This commit was manufactured by cvs2svn to create branch 'poly_meth2'.

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/poly_meth2@4379 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

75 files changed, 15624 insertions, 0 deletions

diff --git a/bytecomp/bytelink.mli b/bytecomp/bytelink.mli
new file mode 100644
index 0000000000..7d73a114ad
--- /dev/null
+++ b/bytecomp/bytelink.mli
@@ -0,0 +1,36 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            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 Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Link .cmo files and produce a bytecode executable. *)
+
+val link: string list -> unit
+
+val check_consistency: string -> Emitcode.compilation_unit -> unit
+
+val extract_crc_interfaces: unit -> (string * Digest.t) list
+
+type error =
+    File_not_found of string
+  | Not_an_object_file of string
+  | Symbol_error of string * Symtable.error
+  | Inconsistent_import of string * string * string
+  | Custom_runtime
+  | File_exists of string
+  | Cannot_open_dll of string
+
+exception Error of error
+
+open Format
+
+val report_error: formatter -> error -> unit
diff --git a/bytecomp/bytepackager.ml b/bytecomp/bytepackager.ml
new file mode 100644
index 0000000000..cf33545ad4
--- /dev/null
+++ b/bytecomp/bytepackager.ml
@@ -0,0 +1,243 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2002 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* "Package" a set of .cmo files into one .cmo file having the
+   original compilation units as sub-modules. *)
+
+open Misc
+open Instruct
+open Opcodes
+open Emitcode
+
+type error =
+    Forward_reference of string * Ident.t
+  | Multiple_definition of string * Ident.t
+  | Not_an_object_file of string
+  | Illegal_renaming of string * string
+  | File_not_found of string
+
+exception Error of error
+
+(* References accumulating informations on the .cmo files *)
+
+let relocs = ref ([] : (reloc_info * int) list)
+let events = ref ([] : debug_event list)
+let primitives = ref ([] : string list)
+let force_link = ref false
+
+(* Record a relocation.  Update its offset, and rename GETGLOBAL and
+   SETGLOBAL relocations that correspond to one of the units being
+   consolidated. *)
+
+let rename_relocation objfile mapping defined base (rel, ofs) =
+  let rel' =
+    match rel with
+      Reloc_getglobal id ->
+        begin try
+          let id' = List.assoc id mapping in
+          if List.mem id defined
+          then Reloc_getglobal id'
+          else raise(Error(Forward_reference(objfile, id)))
+        with Not_found ->
+          rel
+        end
+    | Reloc_setglobal id ->
+        begin try
+          let id' = List.assoc id mapping in
+          if List.mem id defined
+          then raise(Error(Multiple_definition(objfile, id)))
+          else Reloc_setglobal id'
+        with Not_found ->
+          rel
+        end
+    | _ ->
+        rel in
+  relocs := (rel', base + ofs) :: !relocs
+
+(* Record and relocate a debugging event *)
+
+let relocate_debug base ev =
+  ev.ev_pos <- base + ev.ev_pos;
+  events := ev :: !events
+
+(* Read the unit information from a .cmo file. *)
+
+let read_unit_info objfile =
+  let ic = open_in_bin objfile in
+  try
+    let buffer = String.create (String.length Config.cmo_magic_number) in
+    really_input ic buffer 0 (String.length Config.cmo_magic_number);
+    if buffer <> Config.cmo_magic_number then
+      raise(Error(Not_an_object_file objfile));
+    let compunit_pos = input_binary_int ic in
+    seek_in ic compunit_pos;
+    let compunit = (input_value ic : compilation_unit) in
+    if compunit.cu_name
+    <> String.capitalize(Filename.basename(chop_extension_if_any objfile))
+    then raise(Error(Illegal_renaming(objfile, compunit.cu_name)));
+    close_in ic;
+    compunit
+  with x ->
+    close_in ic;
+    raise x
+
+(* Read the bytecode from a .cmo file.
+   Write bytecode to channel [oc].
+   Rename globals as indicated by [mapping] in reloc info.
+   Accumulate relocs, debug info, etc.
+   Return size of bytecode. *)
+
+let rename_append_bytecode oc mapping defined ofs (objfile, compunit) =
+  let ic = open_in_bin objfile in
+  try
+    Bytelink.check_consistency objfile compunit;
+    List.iter
+      (rename_relocation objfile mapping defined ofs)
+      compunit.cu_reloc;
+    primitives := compunit.cu_primitives @ !primitives;
+    if compunit.cu_force_link then force_link := true;
+    seek_in ic compunit.cu_pos;
+    Misc.copy_file_chunk ic oc compunit.cu_codesize;
+    if !Clflags.debug && compunit.cu_debug > 0 then begin
+      seek_in ic compunit.cu_debug;
+      List.iter (relocate_debug ofs) (input_value ic);
+    end;
+    close_in ic;
+    compunit.cu_codesize
+  with x ->
+    close_in ic;
+    raise x
+
+(* Same, for a list of .cmo files.  Return total size of bytecode. *)
+
+let rec rename_append_bytecode_list oc mapping defined ofs = function
+    [] ->
+      ofs
+  | ((objfile, compunit) as obj_unit) :: rem ->
+      let size = rename_append_bytecode oc mapping defined ofs obj_unit in
+      rename_append_bytecode_list
+        oc mapping (Ident.create_persistent compunit.cu_name :: defined)
+        (ofs + size) rem
+
+(* Generate the code that builds the tuple representing the package
+   module:
+     GETGLOBAL M.An
+     PUSHGETGLOBAL M.An-1
+     ...
+     PUSHGETGLOBAL M.A1
+     MAKEBLOCK tag = 0 size = n
+     SETGLOBAL M
+*)
+
+let build_global_target oc target_name mapping ofs =
+  let out_word n =
+    output_byte oc n;
+    output_byte oc (n lsr 8);
+    output_byte oc (n lsr 16);
+    output_byte oc (n lsr 24) in
+  let rec build_global first pos = function
+    [] ->
+      out_word opMAKEBLOCK;             (* pos *)
+      out_word (List.length mapping);   (* pos + 4 *)
+      out_word 0;                       (* pos + 8 *)
+      out_word opSETGLOBAL;             (* pos + 12 *)
+      out_word 0;                       (* pos + 16 *)
+      relocs := (Reloc_setglobal target_name, pos + 16) :: !relocs
+  | (oldname, newname) :: rem ->
+      out_word (if first then opGETGLOBAL else opPUSHGETGLOBAL); (* pos *)
+      out_word 0;                       (* pos + 4 *)
+      relocs := (Reloc_getglobal newname, pos + 4) :: !relocs;
+      build_global false (pos + 8) rem in
+  build_global true ofs (List.rev mapping)
+
+(* Build the .cmo file obtained by packaging the given .cmo files. *)
+
+let package_object_files objfiles targetfile targetname =
+  let units =
+    List.map (fun f -> (f, read_unit_info f)) objfiles in
+  let unit_names =
+    List.map (fun (_, cu) -> cu.cu_name) units in
+  let mapping =
+    List.map
+      (fun name ->
+          (Ident.create_persistent name,
+           Ident.create_persistent(targetname ^ "." ^ name)))
+      unit_names in
+  let oc = open_out_bin targetfile in
+  try
+    output_string oc Config.cmo_magic_number;
+    let pos_depl = pos_out oc in
+    output_binary_int oc 0;
+    let pos_code = pos_out oc in
+    let ofs = rename_append_bytecode_list oc mapping [] 0 units in
+    build_global_target oc (Ident.create_persistent targetname) mapping ofs;
+    let pos_debug = pos_out oc in
+    if !Clflags.debug && !events <> [] then output_value oc (List.rev !events);
+    let pos_final = pos_out oc in
+    let imports =
+      List.filter
+        (fun (name, crc) -> not (List.mem name unit_names))
+        (Bytelink.extract_crc_interfaces()) in
+    let compunit =
+      { cu_name = targetname;
+        cu_pos = pos_code;
+        cu_codesize = pos_debug - pos_code;
+        cu_reloc = List.rev !relocs;
+        cu_imports = (targetname, Env.crc_of_unit targetname) :: imports;
+        cu_primitives = !primitives;
+        cu_force_link = !force_link;
+        cu_debug = if pos_final > pos_debug then pos_debug else 0;
+        cu_debugsize = pos_final - pos_debug } in
+    output_value oc compunit;
+    seek_out oc pos_depl;
+    output_binary_int oc pos_final;
+    close_out oc
+  with x ->
+    close_out oc;
+    raise x
+
+(* The entry point *)
+
+let package_files files targetfile =
+  let objfiles =
+    List.map
+      (fun f ->
+        try find_in_path !Config.load_path f
+        with Not_found -> raise(Error(File_not_found f)))
+      files in
+  let prefix = chop_extension_if_any targetfile in
+  let targetcmi = prefix ^ ".cmi" in
+  let targetname = String.capitalize(Filename.basename prefix) in
+  try
+    Typemod.package_units objfiles targetcmi targetname;
+    package_object_files objfiles targetfile targetname
+  with x ->
+    remove_file targetcmi; remove_file targetfile; raise x
+
+(* Error report *)
+
+open Format
+
+let report_error ppf = function
+    Forward_reference(file, ident) ->
+      fprintf ppf "Forward reference to %s in file %s" (Ident.name ident) file
+  | Multiple_definition(file, ident) ->
+      fprintf ppf "File %s redefines %s" file (Ident.name ident)
+  | Not_an_object_file file ->
+      fprintf ppf "%s is not a bytecode object file" file
+  | Illegal_renaming(file, id) ->
+      fprintf ppf "Wrong file naming: %s@ contains the code for@ %s"
+        file id
+  | File_not_found file ->
+      fprintf ppf "File %s not found" file
diff --git a/bytecomp/bytepackager.mli b/bytecomp/bytepackager.mli
new file mode 100644
index 0000000000..836eb9c637
--- /dev/null
+++ b/bytecomp/bytepackager.mli
@@ -0,0 +1,29 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2002 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* "Package" a set of .cmo files into one .cmo file having the
+   original compilation units as sub-modules. *)
+
+val package_files: string list -> string -> unit
+
+type error =
+    Forward_reference of string * Ident.t
+  | Multiple_definition of string * Ident.t
+  | Not_an_object_file of string
+  | Illegal_renaming of string * string
+  | File_not_found of string
+
+exception Error of error
+
+val report_error: Format.formatter -> error -> unit
diff --git a/bytecomp/dll.ml b/bytecomp/dll.ml
new file mode 100644
index 0000000000..2f600e2141
--- /dev/null
+++ b/bytecomp/dll.ml
@@ -0,0 +1,161 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2001 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Handling of dynamically-linked libraries *)
+
+type dll_handle
+type dll_address
+
+external dll_open: string -> dll_handle = "dynlink_open_lib"
+external dll_close: dll_handle -> unit = "dynlink_close_lib"
+external dll_sym: dll_handle -> string -> dll_address = "dynlink_lookup_symbol"
+         (* returned dll_address may be Val_unit *)
+external add_primitive: dll_address -> int = "dynlink_add_primitive"
+external get_current_dlls: unit -> dll_handle array
+                                           = "dynlink_get_current_libs"
+
+(* Current search path for DLLs *)
+let search_path = ref ([] : string list)
+
+(* DLLs currently opened *)
+let opened_dlls = ref ([] : dll_handle list)
+
+(* File names for those DLLs *)
+let names_of_opened_dlls = ref ([] : string list)
+
+(* Add the given directories to the search path for DLLs. *)
+let add_path dirs =
+  search_path := dirs @ !search_path
+
+(* Extract the name of a DLLs from its external name (xxx.so or -lxxx) *)
+
+let extract_dll_name file =
+  if Filename.check_suffix file Config.ext_dll then
+    Filename.chop_suffix file Config.ext_dll
+  else if String.length file >= 2 && String.sub file 0 2 = "-l" then
+    "dll" ^ String.sub file 2 (String.length file - 2)
+  else
+    file (* will cause error later *)
+
+(* Open a list of DLLs, adding them to opened_dlls.
+   Raise [Failure msg] in case of error. *)
+
+let open_dll name =
+  let name = name ^ Config.ext_dll in
+  let fullname =
+    try
+      let fullname = Misc.find_in_path !search_path name in
+      if Filename.is_implicit fullname then
+        Filename.concat Filename.current_dir_name fullname
+      else fullname
+    with Not_found -> name in
+  if not (List.mem fullname !names_of_opened_dlls) then begin
+    let dll = dll_open fullname in
+    names_of_opened_dlls := fullname :: !names_of_opened_dlls;
+    opened_dlls := dll :: !opened_dlls
+  end
+
+let open_dlls names =
+  List.iter open_dll names
+
+(* Close all DLLs *)
+
+let close_all_dlls () =
+  List.iter dll_close !opened_dlls;
+  opened_dlls := [];
+  names_of_opened_dlls := []
+
+(* Find a primitive in the currently opened DLLs.
+   Raise [Not_found] if not found. *)
+
+let find_primitive prim_name =
+  let rec find = function
+    [] ->
+      raise Not_found
+  | dll :: rem ->
+      let addr = dll_sym dll prim_name in
+      if addr == Obj.magic () then find rem else addr in
+  find !opened_dlls
+
+(* If linking in core (dynlink or toplevel), synchronize the VM
+   table of primitive with the linker's table of primitive
+   by storing the given primitive function at the given position
+   in the VM table of primitives.  *)
+
+let linking_in_core = ref false
+
+let synchronize_primitive num symb =
+  if !linking_in_core then begin
+    let actual_num = add_primitive symb in
+    assert (actual_num = num)
+  end
+
+(* Read the [ld.conf] file and return the corresponding list of directories *)
+
+let ld_conf_contents () =
+  let path = ref [] in
+  begin try
+    let ic = open_in (Filename.concat Config.standard_library "ld.conf") in
+    begin try
+      while true do
+        path := input_line ic :: !path
+      done
+    with End_of_file -> ()
+    end;
+    close_in ic
+  with Sys_error _ -> ()
+  end;
+  List.rev !path
+
+(* Split the CAML_LD_LIBRARY_PATH environment variable and return
+   the corresponding list of directories.  *)
+
+let split str sep =
+  let rec split_rec pos =
+    if pos >= String.length str then [] else begin
+      try
+        let newpos = String.index_from str pos sep in
+        String.sub str pos (newpos - pos) ::
+        split_rec (newpos + 1)
+      with Not_found ->
+        [String.sub str pos (String.length str - pos)]
+    end in
+  split_rec 0
+
+let ld_library_path_contents () =
+  let path_separator =
+    match Sys.os_type with
+    | "Unix" | "Cygwin" -> ':'
+    | "Win32" -> ';'
+    | "MacOS" -> ','
+    | _ -> assert false in
+  try
+    split (Sys.getenv "CAML_LD_LIBRARY_PATH") path_separator
+  with Not_found ->
+    []
+
+let split_dll_path path =
+  split path '\000'
+
+(* Initialization for linking in core (dynlink or toplevel) *)
+
+let init_toplevel dllpath =
+  search_path :=
+    ld_library_path_contents() @
+    split_dll_path dllpath @
+    ld_conf_contents();
+  opened_dlls := Array.to_list (get_current_dlls());
+  names_of_opened_dlls := [];
+  linking_in_core := true
+
diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml
new file mode 100644
index 0000000000..6ab0d63b6f
--- /dev/null
+++ b/bytecomp/lambda.ml
@@ -0,0 +1,337 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            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 Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+open Misc
+open Path
+open Asttypes
+
+type primitive =
+    Pidentity
+  | Pignore
+    (* Globals *)
+  | Pgetglobal of Ident.t
+  | Psetglobal of Ident.t
+  (* Operations on heap blocks *)
+  | Pmakeblock of int * mutable_flag
+  | Pfield of int
+  | Psetfield of int * bool
+  | Pfloatfield of int
+  | Psetfloatfield of int
+  (* External call *)
+  | Pccall of Primitive.description
+  (* Exceptions *)
+  | Praise
+  (* Boolean operations *)
+  | Psequand | Psequor | Pnot
+  (* Integer operations *)
+  | Pnegint | Paddint | Psubint | Pmulint | Pdivint | Pmodint
+  | Pandint | Porint | Pxorint
+  | Plslint | Plsrint | Pasrint
+  | Pintcomp of comparison
+  | Poffsetint of int
+  | Poffsetref of int
+  (* Float operations *)
+  | Pintoffloat | Pfloatofint
+  | Pnegfloat | Pabsfloat
+  | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat
+  | Pfloatcomp of comparison
+  (* String operations *)
+  | Pstringlength | Pstringrefu | Pstringsetu | Pstringrefs | Pstringsets
+  (* Array operations *)
+  | Pmakearray of array_kind
+  | 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
+  (* Bitvect operations *)
+  | Pbittest
+  (* 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 boxed_integer
+  | Pmodbint of boxed_integer
+  | 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 * comparison
+  (* Operations on big arrays *)
+  | Pbigarrayref of int * bigarray_kind * bigarray_layout
+  | Pbigarrayset of int * bigarray_kind * bigarray_layout
+
+and comparison =
+    Ceq | Cneq | Clt | Cgt | Cle | Cge
+
+and array_kind =
+    Pgenarray | Paddrarray | Pintarray | Pfloatarray
+
+and 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
+
+type structured_constant =
+    Const_base of constant
+  | Const_pointer of int
+  | Const_block of int * structured_constant list
+  | Const_float_array of string list
+
+type function_kind = Curried | Tupled
+
+type let_kind = Strict | Alias | StrictOpt | Variable
+
+type shared_code = (int * int) list
+
+type lambda =
+    Lvar of Ident.t
+  | Lconst of structured_constant
+  | Lapply of lambda * lambda list
+  | Lfunction of function_kind * Ident.t list * lambda
+  | Llet of let_kind * Ident.t * lambda * lambda
+  | Lletrec of (Ident.t * lambda) list * lambda
+  | Lprim of primitive * lambda list
+  | Lswitch of lambda * lambda_switch
+  | Lstaticraise of int * lambda list
+  | Lstaticcatch of lambda * (int * Ident.t 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 lambda * lambda * lambda list
+  | Levent of lambda * lambda_event
+  | Lifused of Ident.t * lambda
+
+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: int;
+    lev_kind: lambda_event_kind;
+    lev_repr: int ref option;
+    lev_env: Env.summary }
+
+and lambda_event_kind =
+    Lev_before
+  | Lev_after of Types.type_expr
+  | Lev_function
+
+let const_unit = Const_pointer 0
+
+let lambda_unit = Lconst const_unit
+
+let name_lambda arg fn =
+  match arg with
+    Lvar id -> fn id
+  | _ -> let id = Ident.create "let" in Llet(Strict, id, arg, fn id)
+
+let name_lambda_list args fn =
+  let rec name_list names = function
+    [] -> fn (List.rev names)
+  | (Lvar id as arg) :: rem ->
+      name_list (arg :: names) rem
+  | arg :: rem ->
+      let id = Ident.create "let" in
+      Llet(Strict, id, arg, name_list (Lvar id :: names) rem) in
+  name_list [] args
+
+module IdentSet =
+  Set.Make(struct
+    type t = Ident.t
+    let compare = compare
+  end)
+
+let free_variables l =
+  let fv = ref IdentSet.empty in
+  let rec freevars = function
+    Lvar id ->
+      fv := IdentSet.add id !fv
+  | Lconst sc -> ()
+  | Lapply(fn, args) ->
+      freevars fn; List.iter freevars args
+  | Lfunction(kind, params, body) ->
+      freevars body;
+      List.iter (fun param -> fv := IdentSet.remove param !fv) params
+  | Llet(str, id, arg, body) ->
+      freevars arg; freevars body; fv := IdentSet.remove id !fv
+  | Lletrec(decl, body) ->
+      freevars body;
+      List.iter (fun (id, exp) -> freevars exp) decl;
+      List.iter (fun (id, exp) -> fv := IdentSet.remove id !fv) decl
+  | Lprim(p, args) ->
+      List.iter freevars args
+  | Lswitch(arg, sw) ->
+      freevars arg; 
+      List.iter (fun (key, case) -> freevars case) sw.sw_consts;
+      List.iter (fun (key, case) -> freevars case) sw.sw_blocks;
+      begin match sw.sw_failaction with
+      | None -> ()
+      | Some l -> freevars l
+      end
+  | Lstaticraise (_,args) ->
+      List.iter freevars args
+  | Lstaticcatch(e1, (_,vars), e2) ->
+      freevars e1; freevars e2 ;
+      List.iter (fun id -> fv := IdentSet.remove id !fv) vars        
+  | Ltrywith(e1, exn, e2) ->
+      freevars e1; freevars e2; fv := IdentSet.remove exn !fv
+  | Lifthenelse(e1, e2, e3) ->
+      freevars e1; freevars e2; freevars e3
+  | Lsequence(e1, e2) ->
+      freevars e1; freevars e2
+  | Lwhile(e1, e2) ->
+      freevars e1; freevars e2
+  | Lfor(v, e1, e2, dir, e3) -> 
+      freevars e1; freevars e2; freevars e3; fv := IdentSet.remove v !fv
+  | Lassign(id, e) ->
+      fv := IdentSet.add id !fv; freevars e
+  | Lsend (met, obj, args) ->
+      List.iter freevars (met::obj::args)
+  | Levent (lam, evt) ->
+      freevars lam
+  | Lifused (v, e) ->
+      freevars e
+  in freevars l; !fv
+
+(* 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, 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, id, lam, body) ->
+      Llet (str, 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_path = function
+    Pident id ->
+      if Ident.global id then Lprim(Pgetglobal id, []) else Lvar id
+  | Pdot(p, s, pos) ->
+      Lprim(Pfield pos, [transl_path p])
+  | Papply(p1, p2) ->
+      fatal_error "Lambda.transl_path"
+
+(* 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 bound variables of the lambda-term do not
+   belong to the domain of the substitution.
+   Assumes that the image of the substitution is out of reach
+   of the bound variables of the lambda-term (no capture). *)
+
+let subst_lambda s lam =
+  let rec subst = function
+    Lvar id as l ->
+      begin try Ident.find_same id s with Not_found -> l end
+  | Lconst sc as l -> l
+  | Lapply(fn, args) -> Lapply(subst fn, List.map subst args)
+  | Lfunction(kind, params, body) -> Lfunction(kind, params, subst body)
+  | Llet(str, id, arg, body) -> Llet(str, id, subst arg, subst body)
+  | Lletrec(decl, body) -> Lletrec(List.map subst_decl decl, subst body)
+  | Lprim(p, args) -> Lprim(p, List.map subst args)
+  | Lswitch(arg, sw) ->
+      Lswitch(subst arg,
+              {sw with sw_consts = List.map subst_case sw.sw_consts;
+                       sw_blocks = List.map subst_case sw.sw_blocks;
+                       sw_failaction =
+                         match sw.sw_failaction with
+                         | None -> None
+                         | Some l -> Some (subst l)})
+                   
+  | Lstaticraise (i,args) ->  Lstaticraise (i, List.map subst args)
+  | Lstaticcatch(e1, io, e2) -> Lstaticcatch(subst e1, io, subst e2)
+  | Ltrywith(e1, exn, e2) -> Ltrywith(subst e1, exn, subst e2)
+  | Lifthenelse(e1, e2, e3) -> Lifthenelse(subst e1, subst e2, subst e3)
+  | Lsequence(e1, e2) -> Lsequence(subst e1, subst e2)
+  | Lwhile(e1, e2) -> Lwhile(subst e1, subst e2)
+  | Lfor(v, e1, e2, dir, e3) -> Lfor(v, subst e1, subst e2, dir, subst e3) 
+  | Lassign(id, e) -> Lassign(id, subst e)
+  | Lsend (met, obj, args) -> Lsend (subst met, subst obj, List.map subst args)
+  | Levent (lam, evt) -> Levent (subst lam, evt)
+  | Lifused (v, e) -> Lifused (v, subst e)
+  and subst_decl (id, exp) = (id, subst exp)
+  and subst_case (key, case) = (key, subst case)
+  in subst lam
+
+
+(* To let-bind expressions to variables *)
+
+let bind str var exp body =
+  match exp with
+    Lvar var' when Ident.same var var' -> body
+  | _ -> Llet(str, var, exp, body)
+
+and commute_comparison = function
+| Ceq -> Ceq| Cneq -> Cneq
+| Clt -> Cgt | Cle -> Cge
+| Cgt -> Clt | Cge -> Cle
+
+and negate_comparison = function
+| Ceq -> Cneq| Cneq -> Ceq
+| Clt -> Cge | Cle -> Cgt
+| Cgt -> Cle | Cge -> Clt
+
+
diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli
new file mode 100644
index 0000000000..253aba3238
--- /dev/null
+++ b/bytecomp/lambda.mli
@@ -0,0 +1,199 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            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 Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* The "lambda" intermediate code *)
+
+open Asttypes
+
+type primitive =
+    Pidentity
+  | Pignore
+    (* Globals *)
+  | Pgetglobal of Ident.t
+  | Psetglobal of Ident.t
+  (* Operations on heap blocks *)
+  | Pmakeblock of int * mutable_flag
+  | Pfield of int
+  | Psetfield of int * bool
+  | Pfloatfield of int
+  | Psetfloatfield of int
+  (* External call *)
+  | Pccall of Primitive.description
+  (* Exceptions *)
+  | Praise
+  (* Boolean operations *)
+  | Psequand | Psequor | Pnot
+  (* Integer operations *)
+  | Pnegint | Paddint | Psubint | Pmulint | Pdivint | Pmodint
+  | Pandint | Porint | Pxorint
+  | Plslint | Plsrint | Pasrint
+  | Pintcomp of comparison
+  | Poffsetint of int
+  | Poffsetref of int
+  (* Float operations *)
+  | Pintoffloat | Pfloatofint
+  | Pnegfloat | Pabsfloat
+  | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat
+  | Pfloatcomp of comparison
+  (* String operations *)
+  | Pstringlength | Pstringrefu | Pstringsetu | Pstringrefs | Pstringsets
+  (* Array operations *)
+  | Pmakearray of array_kind
+  | 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
+  (* Bitvect operations *)
+  | Pbittest
+  (* 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 boxed_integer
+  | Pmodbint of boxed_integer
+  | 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 * comparison
+  (* Operations on big arrays *)
+  | Pbigarrayref of int * bigarray_kind * bigarray_layout
+  | Pbigarrayset of int * bigarray_kind * bigarray_layout
+
+and comparison =
+    Ceq | Cneq | Clt | Cgt | Cle | Cge
+
+and array_kind =
+    Pgenarray | Paddrarray | Pintarray | Pfloatarray
+
+and 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
+
+type structured_constant =
+    Const_base of constant
+  | Const_pointer of int
+  | Const_block of int * structured_constant list
+  | Const_float_array of string list
+
+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-effets; 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 shared_code = (int * int) list     (* stack size -> code label *)
+
+type lambda =
+    Lvar of Ident.t
+  | Lconst of structured_constant
+  | Lapply of lambda * lambda list
+  | Lfunction of function_kind * Ident.t list * lambda
+  | Llet of let_kind * Ident.t * lambda * lambda
+  | Lletrec of (Ident.t * lambda) list * lambda
+  | Lprim of primitive * lambda list
+  | Lswitch of lambda * lambda_switch
+  | Lstaticraise of int * lambda list
+  | Lstaticcatch of lambda * (int * Ident.t 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 lambda * lambda * lambda list
+  | Levent of lambda * lambda_event
+  | Lifused of Ident.t * lambda
+
+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: int;
+    lev_kind: lambda_event_kind;
+    lev_repr: int ref option;
+    lev_env: Env.summary }
+
+and lambda_event_kind =
+    Lev_before
+  | Lev_after of Types.type_expr
+  | Lev_function
+
+val const_unit: structured_constant
+val lambda_unit: lambda
+val name_lambda: lambda -> (Ident.t -> lambda) -> lambda
+val name_lambda_list: lambda list -> (lambda list -> lambda) -> lambda
+val is_guarded: lambda -> bool
+val patch_guarded : lambda -> lambda -> lambda
+
+module IdentSet: Set.S with type elt = Ident.t
+val free_variables: lambda -> IdentSet.t
+
+val transl_path: Path.t -> lambda
+val make_sequence: ('a -> lambda) -> 'a list -> lambda
+
+val subst_lambda: lambda Ident.tbl -> lambda -> lambda
+val bind : let_kind -> Ident.t -> lambda -> lambda -> lambda
+
+val commute_comparison : comparison -> comparison
+val negate_comparison : comparison -> comparison
+
+(***********************)
+(* 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 
+
diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml
new file mode 100644
index 0000000000..1684d4104e
--- /dev/null
+++ b/bytecomp/printlambda.ml
@@ -0,0 +1,301 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            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 Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+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 "'%s'" (Char.escaped c)
+  | Const_base(Const_string s) ->
+      fprintf ppf "\"%s\"" (String.escaped s)
+  | Const_base(Const_float s) ->
+      fprintf ppf "%s" s
+  | 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 boxed_integer_name = function
+  | Pnativeint -> "nativeint"
+  | Pint32 -> "int32"
+  | Pint64 -> "int64"
+
+let print_boxed_integer name ppf bi =
+  fprintf ppf "%s_%s" (boxed_integer_name bi) name
+
+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 kind ppf layout =
+  fprintf ppf "Bigarray.%s[%s,%s]"
+    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 primitive ppf = function
+  | Pidentity -> fprintf ppf "id"
+  | Pignore -> fprintf ppf "ignore"
+  | Pgetglobal id -> fprintf ppf "global %a" Ident.print id
+  | Psetglobal id -> fprintf ppf "setglobal %a" Ident.print id
+  | Pmakeblock(tag, Immutable) -> fprintf ppf "makeblock %i" tag
+  | Pmakeblock(tag, Mutable) -> fprintf ppf "makemutable %i" tag
+  | Pfield n -> fprintf ppf "field %i" n
+  | Psetfield(n, ptr) ->
+      let instr = if ptr then "setfield_ptr " else "setfield_imm " in
+      fprintf ppf "%s%i" instr n
+  | Pfloatfield n -> fprintf ppf "floatfield %i" n
+  | Psetfloatfield n -> fprintf ppf "setfloatfield %i" n
+  | Pccall p -> fprintf ppf "%s" p.prim_name
+  | Praise -> fprintf ppf "raise"
+  | Psequand -> fprintf ppf "&&"
+  | Psequor -> fprintf ppf "||"
+  | Pnot -> fprintf ppf "not"
+  | Pnegint -> fprintf ppf "~"
+  | Paddint -> fprintf ppf "+"
+  | Psubint -> fprintf ppf "-"
+  | Pmulint -> fprintf ppf "*"
+  | Pdivint -> fprintf ppf "/"
+  | Pmodint -> fprintf ppf "mod"
+  | 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(Ceq) -> fprintf ppf "=="
+  | Pintcomp(Cneq) -> fprintf ppf "!="
+  | Pintcomp(Clt) -> fprintf ppf "<"
+  | Pintcomp(Cle) -> fprintf ppf "<="
+  | Pintcomp(Cgt) -> fprintf ppf ">"
+  | Pintcomp(Cge) -> fprintf ppf ">="
+  | 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(Ceq) -> fprintf ppf "==."
+  | Pfloatcomp(Cneq) -> fprintf ppf "!=."
+  | Pfloatcomp(Clt) -> fprintf ppf "<."
+  | Pfloatcomp(Cle) -> fprintf ppf "<=."
+  | Pfloatcomp(Cgt) -> fprintf ppf ">."
+  | Pfloatcomp(Cge) -> fprintf ppf ">=."
+  | Pstringlength -> fprintf ppf "string.length"
+  | Pstringrefu -> fprintf ppf "string.unsafe_get"
+  | Pstringsetu -> fprintf ppf "string.unsafe_set"
+  | Pstringrefs -> fprintf ppf "string.get"
+  | Pstringsets -> fprintf ppf "string.set"
+  | Parraylength _ -> fprintf ppf "array.length"
+  | Pmakearray _ -> fprintf ppf "makearray "
+  | Parrayrefu _ -> fprintf ppf "array.unsafe_get"
+  | Parraysetu _ -> fprintf ppf "array.unsafe_set"
+  | Parrayrefs _ -> fprintf ppf "array.get"
+  | Parraysets _ -> fprintf ppf "array.set"
+  | Pisint -> fprintf ppf "isint"
+  | Pisout -> fprintf ppf "isout"
+  | Pbittest -> fprintf ppf "testbit"
+  | 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 bi -> print_boxed_integer "div" ppf bi
+  | Pmodbint bi -> print_boxed_integer "mod" 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, Cneq) -> 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(n, kind, layout) -> print_bigarray "get" kind ppf layout
+  | Pbigarrayset(n, kind, layout) -> print_bigarray "set" kind ppf layout
+
+let rec lam ppf = function
+  | Lvar id ->
+      Ident.print ppf id
+  | Lconst cst ->
+      struct_const ppf cst
+  | Lapply(lfun, largs) ->
+      let lams ppf largs =
+        List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
+      fprintf ppf "@[<2>(apply@ %a%a)@]" lam lfun lams largs
+  | Lfunction(kind, params, body) ->
+      let pr_params ppf params =
+        match kind with
+        | Curried ->
+            List.iter (fun param -> fprintf ppf "@ %a" Ident.print param) params
+        | Tupled ->
+            fprintf ppf " (";
+            let first = ref true in
+            List.iter
+              (fun param ->
+                if !first then first := false else fprintf ppf ",@ ";
+                Ident.print ppf param)
+              params;
+            fprintf ppf ")" in
+      fprintf ppf "@[<2>(function%a@ %a)@]" pr_params params lam body
+  | Llet(str, id, arg, body) ->
+      let rec letbody = function
+        | Llet(str, id, arg, body) ->
+            fprintf ppf "@ @[<2>%a@ %a@]" Ident.print id lam arg;
+            letbody body
+        | expr -> expr in
+      fprintf ppf "@[<2>(let@ @[<hv 1>(@[<2>%a@ %a@]" Ident.print id 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) ->
+      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
+  | 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 -> match vars with
+          | [] -> ()
+          | _ ->
+              List.iter
+                (fun x -> fprintf ppf " %a" Ident.print x)
+                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 (met, obj, largs) ->
+      let args ppf largs =
+        List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
+      fprintf ppf "@[<2>(send@ %a@ %a%a)@]" 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" in
+      fprintf ppf "@[<2>(%s %i@ %a)@]" kind ev.lev_loc 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
+  | Llet(str, id, arg, body) ->
+      fprintf ppf "@[<2>let@ %a@ %a@]@ %a" Ident.print id lam arg sequence body
+  | l ->
+      lam ppf l
+
+let structured_constant = struct_const
+
+let lambda = lam
diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml
new file mode 100644
index 0000000000..94392ffef6
--- /dev/null
+++ b/bytecomp/symtable.ml
@@ -0,0 +1,314 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            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 Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* To assign numbers to globals and primitives *)
+
+open Misc
+open Asttypes
+open Lambda
+open Emitcode
+
+(* Functions for batch linking *)
+
+type error =
+    Undefined_global of string
+  | Unavailable_primitive of string
+  | Wrong_vm of string
+
+exception Error of error
+
+(* Tables for numbering objects *)
+
+type 'a numtable =
+  { num_cnt: int;               (* The next number *)
+    num_tbl: ('a, int) Tbl.t }  (* The table of already numbered objects *)
+
+let empty_numtable = { num_cnt = 0; num_tbl = Tbl.empty }
+
+let find_numtable nt key =
+  Tbl.find key nt.num_tbl
+
+let enter_numtable nt key =
+  let n = !nt.num_cnt in
+  nt := { num_cnt = n + 1; num_tbl = Tbl.add key n !nt.num_tbl };
+  n
+
+let incr_numtable nt =
+  let n = !nt.num_cnt in
+  nt := { num_cnt = n + 1; num_tbl = !nt.num_tbl };
+  n
+
+(* Global variables *)
+
+let global_table = ref(empty_numtable : Ident.t numtable)
+and literal_table = ref([] : (int * structured_constant) list)
+
+let slot_for_getglobal id =
+  try
+    find_numtable !global_table id
+  with Not_found ->
+    raise(Error(Undefined_global(Ident.name id)))
+
+let slot_for_setglobal id =
+  enter_numtable global_table id
+
+let slot_for_literal cst =
+  let n = incr_numtable global_table in
+  literal_table := (n, cst) :: !literal_table;
+  n
+
+(* The C primitives *)
+
+let c_prim_table = ref(empty_numtable : string numtable)
+
+let set_prim_table name =
+  ignore(enter_numtable c_prim_table name)
+
+let num_of_prim name =
+  try
+    find_numtable !c_prim_table name
+  with Not_found ->
+    if !Clflags.custom_runtime then
+      enter_numtable c_prim_table name
+    else begin
+      let symb =
+        try Dll.find_primitive name
+        with Not_found -> raise(Error(Unavailable_primitive name)) in
+      let num = enter_numtable c_prim_table name in
+      Dll.synchronize_primitive num symb;
+      num
+    end
+
+let require_primitive name =
+  if name.[0] <> '%' then ignore(num_of_prim name)
+
+let all_primitives () =
+  let prim = Array.create !c_prim_table.num_cnt "" in
+  Tbl.iter (fun name number -> prim.(number) <- name) !c_prim_table.num_tbl;
+  prim
+
+let output_primitive_names outchan =
+  let prim = all_primitives() in
+  for i = 0 to Array.length prim - 1 do
+    output_string outchan prim.(i); output_char outchan '\000'
+  done
+
+open Printf
+
+let output_primitive_table outchan =
+  let prim = all_primitives() in
+  fprintf outchan "\
+    #ifdef __cplusplus\n\
+    extern \"C\" {\n\
+    #endif\n";
+  for i = 0 to Array.length prim - 1 do
+    fprintf outchan "extern long %s();\n" prim.(i)
+  done;
+  fprintf outchan "typedef long (*primitive)();\n";
+  fprintf outchan "primitive builtin_cprim[] = {\n";
+  for i = 0 to Array.length prim - 1 do
+    fprintf outchan "  %s,\n" prim.(i)
+  done;
+  fprintf outchan "  (primitive) 0 };\n";
+  fprintf outchan "char * names_of_builtin_cprim[] = {\n";
+  for i = 0 to Array.length prim - 1 do
+    fprintf outchan "  \"%s\",\n" prim.(i)
+  done;
+  fprintf outchan "  (char *) 0 };\n";
+  fprintf outchan "\
+    #ifdef __cplusplus\n\
+    }\n\
+    #endif\n"
+
+(* Initialization for batch linking *)
+
+let init () =
+  (* Enter the predefined exceptions *)
+  Array.iter 
+    (fun name -> 
+      let id =
+        try List.assoc name Predef.builtin_values
+        with Not_found -> fatal_error "Symtable.init" in
+      let c = slot_for_setglobal id in
+      let cst = Const_block(0, [Const_base(Const_string name)]) in
+      literal_table := (c, cst) :: !literal_table)
+    Runtimedef.builtin_exceptions;
+  (* Initialize the known C primitives *)
+  if String.length !Clflags.use_prims > 0 then begin
+      let ic = open_in !Clflags.use_prims in
+      try
+        while true do
+          set_prim_table (input_line ic)
+        done
+      with End_of_file -> close_in ic
+         | x -> close_in ic; raise x
+  end else if String.length !Clflags.use_runtime > 0 then begin
+    let primfile = Filename.temp_file "camlprims" "" in
+    try
+      if Sys.command(Printf.sprintf "%s -p > %s"
+                                    !Clflags.use_runtime primfile) <> 0
+      then raise(Error(Wrong_vm !Clflags.use_runtime));
+      let ic = open_in primfile in
+      try
+        while true do
+          set_prim_table (input_line ic)
+        done
+      with End_of_file -> close_in ic; remove_file primfile
+         | x -> close_in ic; raise x
+    with x -> remove_file primfile; raise x
+  end else begin
+    Array.iter set_prim_table Runtimedef.builtin_primitives
+  end
+
+(* Relocate a block of object bytecode *)
+
+(* Must use the unsafe String.set here because the block may be
+   a "fake" string as returned by Meta.static_alloc. *)
+
+let patch_int buff pos n =
+  String.unsafe_set buff pos (Char.unsafe_chr n);
+  String.unsafe_set buff (pos + 1) (Char.unsafe_chr (n asr 8));
+  String.unsafe_set buff (pos + 2) (Char.unsafe_chr (n asr 16));
+  String.unsafe_set buff (pos + 3) (Char.unsafe_chr (n asr 24))
+
+let patch_object buff patchlist = 
+  List.iter
+    (function
+        (Reloc_literal sc, pos) ->
+          patch_int buff pos (slot_for_literal sc)
+      | (Reloc_getglobal id, pos) ->
+          patch_int buff pos (slot_for_getglobal id)
+      | (Reloc_setglobal id, pos) ->
+          patch_int buff pos (slot_for_setglobal id)
+      | (Reloc_primitive name, pos) ->
+          patch_int buff pos (num_of_prim name))
+    patchlist
+
+(* Translate structured constants *)
+
+let rec transl_const = function
+    Const_base(Const_int i) -> Obj.repr i
+  | Const_base(Const_char c) -> Obj.repr c
+  | Const_base(Const_string s) -> Obj.repr s
+  | Const_base(Const_float f) -> Obj.repr(float_of_string f)
+  | Const_pointer i -> Obj.repr i
+  | Const_block(tag, fields) ->
+      let block = Obj.new_block tag (List.length fields) in
+      let pos = ref 0 in
+      List.iter
+        (fun c -> Obj.set_field block !pos (transl_const c); incr pos)
+        fields;
+      block
+  | Const_float_array fields ->
+      Obj.repr(Array.of_list(List.map (fun f -> float_of_string f) fields))
+
+(* Build the initial table of globals *)
+
+let initial_global_table () =
+  let glob = Array.create !global_table.num_cnt (Obj.repr 0) in
+  List.iter
+    (fun (slot, cst) -> glob.(slot) <- transl_const cst)
+    !literal_table;
+  literal_table := [];
+  glob
+
+(* Save the table of globals *)
+
+let output_global_map oc =
+  output_value oc !global_table
+
+(* Functions for toplevel use *)
+
+(* Update the in-core table of globals *)
+
+let update_global_table () =
+  let ng = !global_table.num_cnt in
+  if ng > Array.length(Meta.global_data()) then Meta.realloc_global_data ng;
+  let glob = Meta.global_data() in
+  List.iter
+    (fun (slot, cst) -> glob.(slot) <- transl_const cst)
+    !literal_table;
+  literal_table := []
+
+(* Initialize the linker for toplevel use *)
+
+let init_toplevel () =
+  (* Read back the known global symbols and the known primitives
+     from the executable file *)
+  let ic = open_in_bin Sys.executable_name in
+  begin try
+    Bytesections.read_toc ic;
+    ignore(Bytesections.seek_section ic "SYMB");
+    global_table := (input_value ic : Ident.t numtable);
+    let prims = Bytesections.read_section ic "PRIM" in
+    let pos = ref 0 in
+    while !pos < String.length prims do
+      let i = String.index_from prims !pos '\000' in
+      set_prim_table (String.sub prims !pos (i - !pos));
+      pos := i + 1
+    done
+  with Bytesections.Bad_magic_number | Not_found | Failure _ ->
+    fatal_error "Toplevel bytecode executable is corrupted"
+  end;
+  let dllpath =
+    try Bytesections.read_section ic "DLPT" with Not_found -> "" in
+  close_in ic;
+  (* Initialize the Dll machinery for toplevel use *)
+  Dll.init_toplevel dllpath
+
+(* Find the value of a global identifier *)
+
+let get_global_position id = slot_for_getglobal id
+
+let get_global_value id =
+  (Meta.global_data()).(slot_for_getglobal id)
+let assign_global_value id v =
+  (Meta.global_data()).(slot_for_getglobal id) <- v
+
+(* Save and restore the current state *)
+
+type global_map = Ident.t numtable
+
+let current_state () = !global_table
+
+let restore_state st = global_table := st
+
+let hide_additions st =
+  if st.num_cnt > !global_table.num_cnt then
+    fatal_error "Symtable.hide_additions";
+  global_table :=
+    { num_cnt = !global_table.num_cnt;
+      num_tbl = st.num_tbl }
+
+(* "Filter" the global map according to some predicate.
+   Used to expunge the global map for the toplevel. *)
+
+let filter_global_map p gmap =
+  let newtbl = ref Tbl.empty in
+  Tbl.iter
+    (fun id num -> if p id then newtbl := Tbl.add id num !newtbl)
+    gmap.num_tbl;
+  {num_cnt = gmap.num_cnt; num_tbl = !newtbl}
+
+(* Error report *)
+
+open Format
+
+let report_error ppf = function
+  | Undefined_global s ->
+      fprintf ppf "Reference to undefined global `%s'" s
+  | Unavailable_primitive s ->
+      fprintf ppf "The external function `%s' is not available" s
+  | Wrong_vm s ->
+      fprintf ppf "Cannot find or execute the runtime system %s" s
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
new file mode 100644
index 0000000000..80bd27f510
--- /dev/null
+++ b/bytecomp/translcore.ml
@@ -0,0 +1,847 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            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 Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Translation from typed abstract syntax to lambda terms,
+   for the core language *)
+
+open Misc
+open Asttypes
+open Primitive
+open Path
+open Types
+open Typedtree
+open Typeopt
+open Lambda
+
+type error =
+    Illegal_letrec_pat
+  | Illegal_letrec_expr
+  | Free_super_var
+
+exception Error of Location.t * error
+
+(* 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)
+
+(* Translation of primitives *)
+
+let comparisons_table = create_hashtable 11 [
+  "%equal",
+      (Pccall{prim_name = "equal"; prim_arity = 2; prim_alloc = true;
+              prim_native_name = ""; prim_native_float = false},
+       Pintcomp Ceq,
+       Pfloatcomp Ceq,
+       Pccall{prim_name = "string_equal"; prim_arity = 2; prim_alloc = false;
+              prim_native_name = ""; prim_native_float = false},
+       Pbintcomp(Pnativeint, Ceq),
+       Pbintcomp(Pint32, Ceq),
+       Pbintcomp(Pint64, Ceq));
+  "%notequal",
+      (Pccall{prim_name = "notequal"; prim_arity = 2; prim_alloc = true;
+              prim_native_name = ""; prim_native_float = false},
+       Pintcomp Cneq,
+       Pfloatcomp Cneq,
+       Pccall{prim_name = "string_notequal"; prim_arity = 2;
+              prim_alloc = false; prim_native_name = "";
+              prim_native_float = false},
+       Pbintcomp(Pnativeint, Cneq),
+       Pbintcomp(Pint32, Cneq),
+       Pbintcomp(Pint64, Cneq));
+  "%lessthan",
+      (Pccall{prim_name = "lessthan"; prim_arity = 2; prim_alloc = true;
+              prim_native_name = ""; prim_native_float = false},
+       Pintcomp Clt,
+       Pfloatcomp Clt,
+       Pccall{prim_name = "lessthan"; prim_arity = 2; prim_alloc = false;
+              prim_native_name = ""; prim_native_float = false},
+       Pbintcomp(Pnativeint, Clt),
+       Pbintcomp(Pint32, Clt),
+       Pbintcomp(Pint64, Clt));
+  "%greaterthan",
+      (Pccall{prim_name = "greaterthan"; prim_arity = 2; prim_alloc = true;
+              prim_native_name = ""; prim_native_float = false},
+       Pintcomp Cgt,
+       Pfloatcomp Cgt,
+       Pccall{prim_name = "greaterthan"; prim_arity = 2; prim_alloc = false;
+              prim_native_name = ""; prim_native_float = false},
+       Pbintcomp(Pnativeint, Cgt),
+       Pbintcomp(Pint32, Cgt),
+       Pbintcomp(Pint64, Cgt));
+  "%lessequal",
+      (Pccall{prim_name = "lessequal"; prim_arity = 2; prim_alloc = true;
+              prim_native_name = ""; prim_native_float = false},
+       Pintcomp Cle,
+       Pfloatcomp Cle,
+       Pccall{prim_name = "lessequal"; prim_arity = 2; prim_alloc = false;
+              prim_native_name = ""; prim_native_float = false},
+       Pbintcomp(Pnativeint, Cle),
+       Pbintcomp(Pint32, Cle),
+       Pbintcomp(Pint64, Cle));
+  "%greaterequal",
+      (Pccall{prim_name = "greaterequal"; prim_arity = 2; prim_alloc = true;
+              prim_native_name = ""; prim_native_float = false},
+       Pintcomp Cge,
+       Pfloatcomp Cge,
+       Pccall{prim_name = "greaterequal"; prim_arity = 2; prim_alloc = false;
+              prim_native_name = ""; prim_native_float = false},
+       Pbintcomp(Pnativeint, Cge),
+       Pbintcomp(Pint32, Cge),
+       Pbintcomp(Pint64, Cge))
+]
+
+let primitives_table = create_hashtable 57 [
+  "%identity", Pidentity;
+  "%ignore", Pignore;
+  "%field0", Pfield 0;
+  "%field1", Pfield 1;
+  "%setfield0", Psetfield(0, true);
+  "%makeblock", Pmakeblock(0, Immutable);
+  "%makemutable", Pmakeblock(0, Mutable);
+  "%raise", Praise;
+  "%sequand", Psequand;
+  "%sequor", Psequor;
+  "%boolnot", Pnot;
+  "%negint", Pnegint;
+  "%succint", Poffsetint 1;
+  "%predint", Poffsetint(-1);
+  "%addint", Paddint;
+  "%subint", Psubint;
+  "%mulint", Pmulint;
+  "%divint", Pdivint;
+  "%modint", Pmodint;
+  "%andint", Pandint;
+  "%orint", Porint;
+  "%xorint", Pxorint;
+  "%lslint", Plslint;
+  "%lsrint", Plsrint;
+  "%asrint", Pasrint;
+  "%eq", Pintcomp Ceq;
+  "%noteq", Pintcomp Cneq;
+  "%ltint", Pintcomp Clt;
+  "%leint", Pintcomp Cle;
+  "%gtint", Pintcomp Cgt;
+  "%geint", Pintcomp Cge;
+  "%incr", Poffsetref(1);
+  "%decr", Poffsetref(-1);
+  "%intoffloat", Pintoffloat;
+  "%floatofint", Pfloatofint;
+  "%negfloat", Pnegfloat;
+  "%absfloat", Pabsfloat;
+  "%addfloat", Paddfloat;
+  "%subfloat", Psubfloat;
+  "%mulfloat", Pmulfloat;
+  "%divfloat", Pdivfloat;
+  "%eqfloat", Pfloatcomp Ceq;
+  "%noteqfloat", Pfloatcomp Cneq;
+  "%ltfloat", Pfloatcomp Clt;
+  "%lefloat", Pfloatcomp Cle;
+  "%gtfloat", Pfloatcomp Cgt;
+  "%gefloat", Pfloatcomp Cge;
+  "%string_length", Pstringlength;
+  "%string_safe_get", Pstringrefs;
+  "%string_safe_set", Pstringsets;
+  "%string_unsafe_get", Pstringrefu;
+  "%string_unsafe_set", Pstringsetu;
+  "%array_length", Parraylength Pgenarray;
+  "%array_safe_get", Parrayrefs Pgenarray;
+  "%array_safe_set", Parraysets Pgenarray;
+  "%array_unsafe_get", Parrayrefu Pgenarray;
+  "%array_unsafe_set", Parraysetu Pgenarray;
+  "%obj_size", Parraylength Pgenarray;
+  "%obj_field", Parrayrefu Pgenarray;
+  "%obj_set_field", Parraysetu Pgenarray;
+  "%obj_is_int", Pisint;
+  "%nativeint_of_int", Pbintofint Pnativeint;
+  "%nativeint_to_int", Pintofbint Pnativeint;
+  "%nativeint_neg", Pnegbint Pnativeint;
+  "%nativeint_add", Paddbint Pnativeint;
+  "%nativeint_sub", Psubbint Pnativeint;
+  "%nativeint_mul", Pmulbint Pnativeint;
+  "%nativeint_div", Pdivbint Pnativeint;
+  "%nativeint_mod", Pmodbint Pnativeint;
+  "%nativeint_and", Pandbint Pnativeint;
+  "%nativeint_or",  Porbint Pnativeint;
+  "%nativeint_xor", Pxorbint Pnativeint;
+  "%nativeint_lsl", Plslbint Pnativeint;
+  "%nativeint_lsr", Plsrbint Pnativeint;
+  "%nativeint_asr", Pasrbint Pnativeint;
+  "%int32_of_int", Pbintofint Pint32;
+  "%int32_to_int", Pintofbint Pint32;
+  "%int32_neg", Pnegbint Pint32;
+  "%int32_add", Paddbint Pint32;
+  "%int32_sub", Psubbint Pint32;
+  "%int32_mul", Pmulbint Pint32;
+  "%int32_div", Pdivbint Pint32;
+  "%int32_mod", Pmodbint Pint32;
+  "%int32_and", Pandbint Pint32;
+  "%int32_or",  Porbint Pint32;
+  "%int32_xor", Pxorbint Pint32;
+  "%int32_lsl", Plslbint Pint32;
+  "%int32_lsr", Plsrbint Pint32;
+  "%int32_asr", Pasrbint Pint32;
+  "%int64_of_int", Pbintofint Pint64;
+  "%int64_to_int", Pintofbint Pint64;
+  "%int64_neg", Pnegbint Pint64;
+  "%int64_add", Paddbint Pint64;
+  "%int64_sub", Psubbint Pint64;
+  "%int64_mul", Pmulbint Pint64;
+  "%int64_div", Pdivbint Pint64;
+  "%int64_mod", Pmodbint Pint64;
+  "%int64_and", Pandbint Pint64;
+  "%int64_or",  Porbint Pint64;
+  "%int64_xor", Pxorbint Pint64;
+  "%int64_lsl", Plslbint Pint64;
+  "%int64_lsr", Plsrbint Pint64;
+  "%int64_asr", Pasrbint Pint64;
+  "%nativeint_of_int32", Pcvtbint(Pint32, Pnativeint);
+  "%nativeint_to_int32", Pcvtbint(Pnativeint, Pint32);
+  "%int64_of_int32", Pcvtbint(Pint32, Pint64);
+  "%int64_to_int32", Pcvtbint(Pint64, Pint32);
+  "%int64_of_nativeint", Pcvtbint(Pnativeint, Pint64);
+  "%int64_to_nativeint", Pcvtbint(Pint64, Pnativeint);
+  "%bigarray_ref_1", Pbigarrayref(1, Pbigarray_unknown, Pbigarray_c_layout);
+  "%bigarray_ref_2", Pbigarrayref(2, Pbigarray_unknown, Pbigarray_c_layout);
+  "%bigarray_ref_3", Pbigarrayref(3, Pbigarray_unknown, Pbigarray_c_layout);
+  "%bigarray_set_1", Pbigarrayset(1, Pbigarray_unknown, Pbigarray_c_layout);
+  "%bigarray_set_2", Pbigarrayset(2, Pbigarray_unknown, Pbigarray_c_layout);
+  "%bigarray_set_3", Pbigarrayset(3, Pbigarray_unknown, Pbigarray_c_layout)
+]
+
+let prim_makearray =
+  { prim_name = "make_vect"; prim_arity = 2; prim_alloc = true;
+    prim_native_name = ""; prim_native_float = false }
+
+let prim_obj_dup =
+  { prim_name = "obj_dup"; prim_arity = 1; prim_alloc = true;
+    prim_native_name = ""; prim_native_float = false }
+
+let transl_prim prim args =
+  try
+    let (gencomp, intcomp, floatcomp, stringcomp,
+         nativeintcomp, int32comp, int64comp) =
+      Hashtbl.find comparisons_table prim.prim_name in
+    begin match args with
+      [arg1; {exp_desc = Texp_construct({cstr_tag = Cstr_constant _}, _)}] ->
+        intcomp
+    | [{exp_desc = Texp_construct({cstr_tag = Cstr_constant _}, _)}; arg2] ->
+        intcomp
+    | [arg1; arg2] when has_base_type arg1 Predef.path_int
+                     || has_base_type arg1 Predef.path_char ->
+        intcomp
+    | [arg1; arg2] when has_base_type arg1 Predef.path_float ->
+        floatcomp
+    | [arg1; arg2] when has_base_type arg1 Predef.path_string ->
+        stringcomp
+    | [arg1; arg2] when has_base_type arg1 Predef.path_nativeint ->
+        nativeintcomp
+    | [arg1; arg2] when has_base_type arg1 Predef.path_int32 ->
+        int32comp
+    | [arg1; arg2] when has_base_type arg1 Predef.path_int64 ->
+        int64comp
+    | _ ->
+        gencomp
+    end
+  with Not_found ->
+  try
+    let p = Hashtbl.find primitives_table prim.prim_name in
+    (* Try strength reduction based on the type of the argument *)
+    begin match (p, args) with
+        (Psetfield(n, _), [arg1; arg2]) -> Psetfield(n, maybe_pointer arg2)
+      | (Parraylength Pgenarray, [arg])   -> Parraylength(array_kind arg)
+      | (Parrayrefu Pgenarray, arg1 :: _) -> Parrayrefu(array_kind arg1)
+      | (Parraysetu Pgenarray, arg1 :: _) -> Parraysetu(array_kind arg1)
+      | (Parrayrefs Pgenarray, arg1 :: _) -> Parrayrefs(array_kind arg1)
+      | (Parraysets Pgenarray, arg1 :: _) -> Parraysets(array_kind arg1)
+      | (Pbigarrayref(n, Pbigarray_unknown, _), arg1 :: _) ->
+            let (k, l) = bigarray_kind_and_layout arg1 in
+            Pbigarrayref(n, k, l)
+      | (Pbigarrayset(n, Pbigarray_unknown, _), arg1 :: _) ->
+            let (k, l) = bigarray_kind_and_layout arg1 in
+            Pbigarrayset(n, k, l)
+      | _ -> p
+    end
+  with Not_found ->
+    Pccall prim
+
+
+(* Eta-expand a primitive without knowing the types of its arguments *)
+
+let transl_primitive p =
+  let prim =
+    try
+      let (gencomp, _, _, _, _, _, _) =
+        Hashtbl.find comparisons_table p.prim_name in
+      gencomp
+    with Not_found ->
+    try
+      Hashtbl.find primitives_table p.prim_name
+    with Not_found ->
+      Pccall p in
+  let rec make_params n =
+    if n <= 0 then [] else Ident.create "prim" :: make_params (n-1) in
+  let params = make_params p.prim_arity in
+  Lfunction(Curried, params, Lprim(prim, List.map (fun id -> Lvar id) params))
+
+(* To check the well-formedness of r.h.s. of "let rec" definitions *)
+
+let check_recursive_lambda idlist lam =
+  let rec check_top idlist = function
+      Lfunction(kind, params, body) as funct -> true
+    | Lprim(Pmakeblock(tag, mut), args) ->
+        List.for_all (check idlist) args
+    | Lprim(Pmakearray(Paddrarray|Pintarray), args) ->
+        List.for_all (check idlist) args
+    | Llet(str, id, arg, body) ->
+        check idlist arg && check_top (add_let id arg idlist) body
+    | Lletrec(bindings, body) ->
+        let idlist' = add_letrec bindings idlist in
+        List.for_all (fun (id, arg) -> check idlist' arg) bindings &&
+        check_top idlist' body
+    | Levent (lam, _) -> check_top idlist lam
+    | _ -> false
+
+  and check idlist = function
+      Lvar _ -> true
+    | Lconst cst -> true
+    | Lfunction(kind, params, body) -> true
+    | Llet(str, id, arg, body) ->
+        check idlist arg && check (add_let id arg idlist) body
+    | Lletrec(bindings, body) ->
+        let idlist' = add_letrec bindings idlist in
+        List.for_all (fun (id, arg) -> check idlist' arg) bindings &&
+        check idlist' body
+    | Lprim(Pmakeblock(tag, mut), args) ->
+        List.for_all (check idlist) args
+    | Lprim(Pmakearray(Paddrarray|Pintarray), args) ->
+        List.for_all (check idlist) args
+    | Levent (lam, _) -> check idlist lam
+    | lam ->
+        let fv = free_variables lam in
+        List.for_all (fun id -> not(IdentSet.mem id fv)) idlist
+
+  and add_let id arg idlist =
+    match arg with
+      Lvar id' -> if List.mem id' idlist then id :: idlist else idlist
+    | Llet(_, _, _, body) -> add_let id body idlist
+    | Lletrec(_, body) -> add_let id body idlist
+    | _ -> idlist
+
+  and add_letrec bindings idlist =
+    List.fold_right (fun (id, arg) idl -> add_let id arg idl)
+                    bindings idlist
+
+  in check_top idlist lam
+
+(* 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"
+
+(* To find reasonable names for let-bound and lambda-bound idents *)
+
+let rec name_pattern default = function
+    [] -> Ident.create default
+  | (p, e) :: rem ->
+      match p.pat_desc with
+        Tpat_var id -> id
+      | Tpat_alias(p, id) -> id
+      | _ -> name_pattern default rem
+
+(* Push the default values under the functional abstractions *)
+
+let rec push_defaults loc bindings pat_expr_list partial =
+  match pat_expr_list with
+    [pat, ({exp_desc = Texp_function(pl,partial)} as exp)] ->
+      let pl = push_defaults exp.exp_loc bindings pl partial in
+      [pat, {exp with exp_desc = Texp_function(pl, partial)}]
+  | [pat, ({exp_desc = Texp_let
+             (Default, cases, ({exp_desc = Texp_function _} as e2))} as e1)] ->
+      push_defaults loc (cases :: bindings) [pat, e2] partial
+  | [pat, exp] ->
+      let exp =
+        List.fold_left
+          (fun exp cases ->
+            {exp with exp_desc = Texp_let(Nonrecursive, cases, exp)})
+          exp bindings
+      in
+      [pat, exp]
+  | (pat, exp) :: _ when bindings <> [] ->
+      let param = name_pattern "param" pat_expr_list in
+      let exp =
+        { exp with exp_loc = loc; exp_desc =
+          Texp_match
+            ({exp with exp_type = pat.pat_type; exp_desc =
+              Texp_ident (Path.Pident param,
+                          {val_type = pat.pat_type; val_kind = Val_reg})},
+             pat_expr_list, partial) }
+      in
+      push_defaults loc bindings
+        [{pat with pat_desc = Tpat_var param}, exp] Total
+  | _ ->
+      pat_expr_list
+
+(* Insertion of debugging events *)
+
+let event_before exp lam = match lam with
+| Lstaticraise (_,_) -> lam
+| _ ->
+  if !Clflags.debug
+  then Levent(lam, {lev_loc = exp.exp_loc.Location.loc_start;
+                    lev_kind = Lev_before;
+                    lev_repr = None;
+                    lev_env = Env.summary exp.exp_env})
+  else lam
+
+let event_after exp lam =
+  if !Clflags.debug
+  then Levent(lam, {lev_loc = exp.exp_loc.Location.loc_end;
+                    lev_kind = Lev_after exp.exp_type;
+                    lev_repr = None;
+                    lev_env = Env.summary exp.exp_env})
+  else lam
+
+let event_function exp lam =
+  if !Clflags.debug then
+    let repr = Some (ref 0) in
+    let (info, body) = lam repr in
+    (info,
+     Levent(body, {lev_loc = exp.exp_loc.Location.loc_start;
+                   lev_kind = Lev_function;
+                   lev_repr = repr;
+                   lev_env = Env.summary exp.exp_env}))
+  else
+    lam None
+
+
+let assert_failed loc =
+  Lprim(Praise, [Lprim(Pmakeblock(0, Immutable),
+          [transl_path Predef.path_assert_failure;
+           Lconst(Const_block(0,
+              [Const_base(Const_string !Location.input_name);
+               Const_base(Const_int loc.Location.loc_start);
+               Const_base(Const_int loc.Location.loc_end)]))])])
+;;
+
+(* Translation of expressions *)
+
+let rec transl_exp e =
+  match e.exp_desc with
+    Texp_ident(path, {val_kind = Val_prim p}) ->
+      transl_primitive p
+  | Texp_ident(path, {val_kind = Val_anc _}) ->
+      raise(Error(e.exp_loc, Free_super_var))
+  | Texp_ident(path, {val_kind = Val_reg | Val_self _}) ->
+      transl_path path
+  | Texp_ident _ -> fatal_error "Translcore.transl_exp: bad Texp_ident"
+  | 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 (pat_expr_list, partial) ->
+      let ((kind, params), body) =
+        event_function e
+          (function repr ->
+            let pl = push_defaults e.exp_loc [] pat_expr_list partial in
+            transl_function e.exp_loc !Clflags.native_code repr partial pl)
+      in
+      Lfunction(kind, params, body)
+  | Texp_apply({exp_desc = Texp_ident(path, {val_kind = Val_prim p})}, args)
+    when List.length args = p.prim_arity
+    && List.for_all (fun (arg,_) -> arg <> None) args ->
+      let args = List.map (function Some x, _ -> x | _ -> assert false) args in
+      let prim = transl_prim p args in
+      begin match (prim, args) with
+        (Praise, [arg1]) ->
+          Lprim(Praise, [event_after arg1 (transl_exp arg1)])
+      | (Pccall _, _) ->
+          event_after e (Lprim(prim, transl_list args))
+      | (_, _) ->
+          Lprim(prim, transl_list args)
+      end
+  | Texp_apply(funct, oargs) ->
+      event_after e (transl_apply (transl_exp funct) oargs)
+  | Texp_match({exp_desc = Texp_tuple argl} as arg, pat_expr_list, partial) ->
+      Matching.for_multiple_match e.exp_loc
+        (transl_list argl) (transl_cases pat_expr_list) partial
+  | Texp_match(arg, pat_expr_list, partial) ->
+      Matching.for_function e.exp_loc None
+        (transl_exp arg) (transl_cases pat_expr_list) partial
+  | Texp_try(body, pat_expr_list) ->
+      let id = name_pattern "exn" pat_expr_list in
+      Ltrywith(transl_exp body, id,
+               Matching.for_trywith (Lvar id) (transl_cases pat_expr_list))
+  | Texp_tuple el ->
+      let ll = transl_list el in
+      begin try
+        Lconst(Const_block(0, List.map extract_constant ll))
+      with Not_constant ->
+        Lprim(Pmakeblock(0, Immutable), ll)
+      end
+  | Texp_construct(cstr, args) ->
+      let ll = transl_list args in
+      begin match cstr.cstr_tag with
+        Cstr_constant n ->
+          Lconst(Const_pointer n)
+      | Cstr_block n ->
+          begin try
+            Lconst(Const_block(n, List.map extract_constant ll))
+          with Not_constant ->
+            Lprim(Pmakeblock(n, Immutable), ll)
+          end
+      | Cstr_exception path ->
+          Lprim(Pmakeblock(0, Immutable), transl_path path :: ll)
+      end
+  | Texp_variant(l, arg) ->
+      let tag = Btype.hash_variant l in
+      begin match arg with
+        None -> Lconst(Const_base(Const_int 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),
+                  [Lconst(Const_base(Const_int tag)); lam])
+      end
+  | Texp_record ((lbl1, _) :: _ as lbl_expr_list, opt_init_expr) ->
+      transl_record lbl1.lbl_all lbl1.lbl_repres lbl_expr_list opt_init_expr
+  | Texp_record ([], _) -> fatal_error "Translcore.transl_exp: bad Texp_record"
+  | Texp_field(arg, lbl) ->
+      let access =
+        match lbl.lbl_repres with
+          Record_regular -> Pfield lbl.lbl_pos
+        | Record_float -> Pfloatfield lbl.lbl_pos in
+      Lprim(access, [transl_exp arg])
+  | Texp_setfield(arg, lbl, newval) ->
+      let access =
+        match lbl.lbl_repres with
+          Record_regular -> Psetfield(lbl.lbl_pos, maybe_pointer newval)
+        | Record_float -> Psetfloatfield lbl.lbl_pos in
+      Lprim(access, [transl_exp arg; transl_exp newval])
+  | Texp_array expr_list ->
+      let kind = array_kind e in
+      let len = List.length expr_list in
+      if len <= Config.max_young_wosize then
+        Lprim(Pmakearray kind, transl_list expr_list)
+      else begin
+        let v = Ident.create "makearray" in
+        let rec fill_fields pos = function
+          [] ->
+            Lvar v
+        | arg :: rem ->
+            Lsequence(Lprim(Parraysetu kind,
+                            [Lvar v;
+                             Lconst(Const_base(Const_int pos));
+                             transl_exp arg]),
+                      fill_fields (pos+1) rem) in
+        Llet(Strict, v,
+             Lprim(Pccall prim_makearray,
+                   [Lconst(Const_base(Const_int len));
+                    transl_exp (List.hd expr_list)]),
+             fill_fields 1 (List.tl expr_list))
+      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_when(cond, body) ->
+      event_before cond
+        (Lifthenelse(transl_exp cond, event_before body (transl_exp body),
+                     staticfail))
+  | Texp_send(expr, met) ->
+      let met_id =
+        match met with
+          Tmeth_name nm -> Translobj.meth nm
+        | Tmeth_val id  -> id
+      in
+      event_after e (Lsend(Lvar met_id, transl_exp expr, []))
+  | Texp_new (cl, _) ->
+      Lapply(Lprim(Pfield 0, [transl_path cl]), [lambda_unit])
+  | Texp_instvar(path_self, path) ->
+      Lprim(Parrayrefu Paddrarray, [transl_path path_self; transl_path path])
+  | Texp_setinstvar(path_self, path, expr) ->
+      transl_setinstvar (transl_path path_self) path expr
+  | Texp_override(path_self, modifs) ->
+      let cpy = Ident.create "copy" in
+      Llet(Strict, cpy,
+           Lapply(Translobj.oo_prim "copy", [transl_path path_self]),
+           List.fold_right
+             (fun (path, expr) rem ->
+                Lsequence(transl_setinstvar (Lvar cpy) path expr, rem))
+             modifs
+             (Lvar cpy))
+  | Texp_letmodule(id, modl, body) ->
+      Llet(Strict, id, !transl_module Tcoerce_none None modl, transl_exp body)
+  | Texp_assert (cond) ->
+      if !Clflags.noassert
+      then lambda_unit
+      else Lifthenelse (transl_exp cond, lambda_unit, assert_failed e.exp_loc)
+  | Texp_assertfalse -> assert_failed e.exp_loc
+  | Texp_lazy e ->
+      let fn = Lfunction (Curried, [Ident.create "param"], transl_exp e) in
+      Lprim(Pmakeblock(Obj.lazy_tag, Immutable), [fn])
+
+and transl_list expr_list =
+  List.map transl_exp expr_list
+
+and transl_cases pat_expr_list =
+  List.map
+    (fun (pat, expr) -> (pat, event_before expr (transl_exp expr)))
+    pat_expr_list
+
+and transl_tupled_cases patl_expr_list =
+  List.map (fun (patl, expr) -> (patl, transl_exp expr)) patl_expr_list
+
+and transl_apply lam sargs =
+  let lapply funct args =
+    match funct with
+      Lsend(lmet, lobj, largs) ->
+        Lsend(lmet, lobj, largs @ args)
+    | Levent(Lsend(lmet, lobj, largs), _) ->
+        Lsend(lmet, lobj, largs @ args)
+    | Lapply(lexp, largs) ->
+        Lapply(lexp, largs @ args)
+    | lexp ->
+        Lapply(lexp, args)
+  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 name in
+              defs := (id, lam) :: !defs;
+              Lvar id
+        in
+        let args, args' =
+          if List.for_all (fun (_,opt) -> opt = Optional) 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 "param" in
+        let body =
+          match build_apply handle ((Lvar id_arg, optional)::args') l with
+            Lfunction(Curried, ids, lam) ->
+              Lfunction(Curried, id_arg::ids, lam)
+          | Levent(Lfunction(Curried, ids, lam), _) ->
+              Lfunction(Curried, id_arg::ids, lam)
+          | lam ->
+              Lfunction(Curried, [id_arg], lam)
+        in
+        List.fold_left
+          (fun body (id, lam) -> Llet(Strict, 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 (x,o) -> may_map transl_exp x, o) sargs)
+
+and transl_function loc untuplify_fn repr partial pat_expr_list =
+  match pat_expr_list with
+    [pat, ({exp_desc = Texp_function(pl,partial')} as exp)] ->
+      let param = name_pattern "param" pat_expr_list in
+      let ((_, params), body) =
+        transl_function exp.exp_loc false repr partial' pl in
+      ((Curried, param :: params),
+       Matching.for_function loc None (Lvar param) [pat, body] partial)
+(*
+  | [({pat_desc = Tpat_var id} as pat),
+     ({exp_desc = Texp_let(Nonrecursive, cases,
+                          ({exp_desc = Texp_function _} as e2))} as e1)]
+    when Ident.name id = "*opt*" ->
+      transl_function loc untuplify_fn repr (cases::bindings) partial [pat, e2]
+  | [pat, exp] when bindings <> [] ->
+      let exp =
+        List.fold_left
+          (fun exp cases ->
+            {exp with exp_desc = Texp_let(Nonrecursive, cases, exp)})
+          exp bindings
+      in
+      transl_function loc untuplify_fn repr [] partial [pat, exp]
+  | (pat, exp)::_ when bindings <> [] ->
+      let param = name_pattern "param" pat_expr_list in
+      let exp =
+        { exp with exp_loc = loc; exp_desc =
+          Texp_match
+            ({exp with exp_type = pat.pat_type; exp_desc =
+              Texp_ident (Path.Pident param,
+                          {val_type = pat.pat_type; val_kind = Val_reg})},
+             pat_expr_list, partial) }
+      in
+      transl_function loc untuplify_fn repr bindings Total
+        [{pat with pat_desc = Tpat_var param}, exp]
+*)
+  | ({pat_desc = Tpat_tuple pl}, _) :: _ when untuplify_fn ->
+      begin try
+        let size = List.length pl in
+        let pats_expr_list =
+          List.map
+            (fun (pat, expr) -> (Matching.flatten_pattern size pat, expr))
+            pat_expr_list in
+        let params = List.map (fun p -> Ident.create "param") pl in
+        ((Tupled, params),
+         Matching.for_tupled_function loc params
+           (transl_tupled_cases pats_expr_list) partial)
+      with Matching.Cannot_flatten ->
+        let param = name_pattern "param" pat_expr_list in
+        ((Curried, [param]),
+         Matching.for_function loc repr (Lvar param)
+           (transl_cases pat_expr_list) partial)
+      end
+  | _ ->
+      let param = name_pattern "param" pat_expr_list in
+      ((Curried, [param]),
+       Matching.for_function loc repr (Lvar param)
+         (transl_cases pat_expr_list) partial)
+
+and transl_let rec_flag pat_expr_list body =
+  match rec_flag with
+    Nonrecursive | Default ->
+      let rec transl = function
+        [] ->
+          body
+      | (pat, expr) :: rem ->
+          Matching.for_let pat.pat_loc (transl_exp expr) pat (transl rem)
+      in transl pat_expr_list
+  | Recursive ->
+      let idlist =
+        List.map
+          (fun (pat, expr) ->
+            match pat.pat_desc with
+              Tpat_var id -> id
+            | _ -> raise(Error(pat.pat_loc, Illegal_letrec_pat)))
+        pat_expr_list in
+      let transl_case (pat, expr) id =
+        let lam = transl_exp expr in
+        if not (check_recursive_lambda idlist lam) then
+          raise(Error(expr.exp_loc, Illegal_letrec_expr));
+        (id, lam) in
+      Lletrec(List.map2 transl_case pat_expr_list idlist, body)
+
+and transl_setinstvar self var expr =
+  Lprim(Parraysetu (if maybe_pointer expr then Paddrarray else Pintarray),
+                    [self; transl_path var; transl_exp expr])
+
+and transl_record all_labels repres lbl_expr_list opt_init_expr =
+  (* Determine if there are "enough" new fields *)
+  if 3 + 2 * List.length lbl_expr_list >= Array.length all_labels
+  then begin
+    (* Allocate new record with given fields (and remaining fields
+       taken from init_expr if any *)
+    let lv = Array.create (Array.length all_labels) staticfail in
+    let init_id = Ident.create "init" in
+    begin match opt_init_expr with
+      None -> ()
+    | Some init_expr ->
+        for i = 0 to Array.length all_labels - 1 do
+          let access =
+            match all_labels.(i).lbl_repres with
+              Record_regular -> Pfield i
+            | Record_float -> Pfloatfield i in
+          lv.(i) <- Lprim(access, [Lvar init_id])
+        done
+    end;
+    List.iter
+      (fun (lbl, expr) -> lv.(lbl.lbl_pos) <- transl_exp expr)
+      lbl_expr_list;
+    let ll = Array.to_list lv in
+    let mut =
+      if List.exists (fun (lbl, expr) -> lbl.lbl_mut = Mutable) lbl_expr_list
+      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_float ->
+            Lconst(Const_float_array(List.map extract_float cl))
+      with Not_constant ->
+        match repres with
+          Record_regular -> Lprim(Pmakeblock(0, mut), ll)
+        | Record_float -> Lprim(Pmakearray Pfloatarray, ll) in
+    begin match opt_init_expr with
+      None -> lam
+    | Some init_expr -> Llet(Strict, 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 "newrecord" in
+    let rec update_field (lbl, expr) cont =
+      let upd =
+        match lbl.lbl_repres with
+          Record_regular -> Psetfield(lbl.lbl_pos, maybe_pointer expr)
+        | Record_float -> Psetfloatfield lbl.lbl_pos in
+      Lsequence(Lprim(upd, [Lvar copy_id; transl_exp expr]), cont) in
+    begin match opt_init_expr with
+      None -> assert false
+    | Some init_expr ->
+        Llet(Strict, copy_id,
+             Lprim(Pccall prim_obj_dup, [transl_exp init_expr]),
+             List.fold_right update_field lbl_expr_list (Lvar copy_id))
+    end
+  end
+
+(* Compile an exception definition *)
+
+let transl_exception id path decl =
+  let name =
+    match path with
+      None -> Ident.name id
+    | Some p -> Path.name p in
+  Lprim(Pmakeblock(0, Immutable), [Lconst(Const_base(Const_string name))])
+
+(* Error report *)
+
+open Format
+
+let report_error ppf = function
+  | Illegal_letrec_pat ->
+      fprintf ppf
+        "Only variables are allowed as left-hand side of `let rec'"
+  | Illegal_letrec_expr ->
+      fprintf ppf
+        "This kind of expression is not allowed as right-hand side of `let rec'"
+  | Free_super_var ->
+      fprintf ppf
+        "Ancestor names can only be used to select inherited methods"
diff --git a/bytecomp/typeopt.ml b/bytecomp/typeopt.ml
new file mode 100644
index 0000000000..0dae07a44d
--- /dev/null
+++ b/bytecomp/typeopt.ml
@@ -0,0 +1,132 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1998 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Auxiliaries for type-based optimizations, e.g. array kinds *)
+
+open Misc
+open Asttypes
+open Primitive
+open Path
+open Types
+open Typedtree
+open Lambda
+
+let has_base_type exp base_ty_path =
+  let exp_ty =
+    Ctype.expand_head exp.exp_env (Ctype.correct_levels exp.exp_type) in
+  match Ctype.repr exp_ty with
+    {desc = Tconstr(p, _, _)} -> Path.same p base_ty_path
+  | _ -> false
+
+let maybe_pointer exp =
+  let exp_ty =
+    Ctype.expand_head exp.exp_env (Ctype.correct_levels exp.exp_type) in
+  match (Ctype.repr exp_ty).desc with
+    Tconstr(p, args, abbrev) ->
+      not (Path.same p Predef.path_int) &&
+      not (Path.same p Predef.path_char) &&
+      begin try
+        match Env.find_type p exp.exp_env with
+          {type_kind = Type_variant cstrs} ->
+            List.exists (fun (name, args) -> args <> []) cstrs
+        | _ -> true
+      with Not_found -> true
+        (* This can happen due to e.g. missing -I options,
+           causing some .cmi files to be unavailable.
+           Maybe we should emit a warning. *)
+      end
+  | _ -> true
+
+let array_element_kind env ty =
+  let ty = Ctype.repr (Ctype.expand_head env ty) in
+  match ty.desc with
+    Tvar ->
+      Pgenarray
+  | Tconstr(p, args, abbrev) ->
+      if Path.same p Predef.path_int || Path.same p Predef.path_char then
+        Pintarray
+      else if Path.same p Predef.path_float then
+        Pfloatarray
+      else if Path.same p Predef.path_string
+           || Path.same p Predef.path_array 
+           || Path.same p Predef.path_nativeint
+           || Path.same p Predef.path_int32
+           || Path.same p Predef.path_int64 then
+        Paddrarray
+      else begin
+        try
+          match Env.find_type p env with
+            {type_kind = Type_abstract} ->
+              Pgenarray
+          | {type_kind = Type_variant cstrs}
+            when List.for_all (fun (name, args) -> args = []) cstrs ->
+              Pintarray
+          | {type_kind = _} ->
+              Paddrarray
+        with Not_found ->
+          (* This can happen due to e.g. missing -I options,
+             causing some .cmi files to be unavailable.
+             Maybe we should emit a warning. *)
+          Pgenarray
+      end
+  | _ ->
+      Paddrarray
+
+let array_kind_gen ty env =
+  let array_ty = Ctype.expand_head env (Ctype.correct_levels ty) in
+  match (Ctype.repr array_ty).desc with
+    Tconstr(p, [elt_ty], _) when Path.same p Predef.path_array ->
+      array_element_kind env elt_ty
+  | _ ->
+      (* This can happen with e.g. Obj.field *)
+      Pgenarray
+
+let array_kind exp = array_kind_gen exp.exp_type exp.exp_env
+
+let array_pattern_kind pat = array_kind_gen pat.pat_type pat.pat_env
+
+let bigarray_decode_type ty tbl dfl =
+  match (Ctype.repr ty).desc with
+    Tconstr(Pdot(Pident mod_id, type_name, _), [], _)
+    when Ident.name mod_id = "Bigarray" ->
+      begin try List.assoc type_name tbl with Not_found -> dfl end
+  | _ ->
+      dfl
+
+let kind_table =
+  ["float32_elt", Pbigarray_float32;
+   "float64_elt", Pbigarray_float64;
+   "int8_signed_elt", Pbigarray_sint8;
+   "int8_unsigned_elt", Pbigarray_uint8;
+   "int16_signed_elt", Pbigarray_sint16;
+   "int16_unsigned_elt", Pbigarray_uint16;
+   "int32_elt", Pbigarray_int32;
+   "int64_elt", Pbigarray_int64;
+   "int_elt", Pbigarray_caml_int;
+   "nativeint_elt", Pbigarray_native_int;
+   "complex32_elt", Pbigarray_complex32;
+   "complex64_elt", Pbigarray_complex64]
+
+let layout_table =
+  ["c_layout", Pbigarray_c_layout;
+   "fortran_layout", Pbigarray_fortran_layout]
+
+let bigarray_kind_and_layout exp =
+  let ty = Ctype.repr (Ctype.expand_head exp.exp_env exp.exp_type) in
+  match ty.desc with
+    Tconstr(p, [caml_type; elt_type; layout_type], abbrev) ->
+      (bigarray_decode_type elt_type kind_table Pbigarray_unknown,
+       bigarray_decode_type layout_type layout_table Pbigarray_unknown_layout)
+  | _ ->
+      (Pbigarray_unknown, Pbigarray_unknown_layout)
diff --git a/byterun/alloc.c b/byterun/alloc.c
new file mode 100644
index 0000000000..97d57b9779
--- /dev/null
+++ b/byterun/alloc.c
@@ -0,0 +1,164 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*         Xavier Leroy and Damien Doligez, 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 Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* 1. Allocation functions doing the same work as the macros in the
+      case where [Setup_for_gc] and [Restore_after_gc] are no-ops.
+   2. Convenience functions related to allocation.
+*/
+
+#include <string.h>
+#include "alloc.h"
+#include "custom.h"
+#include "major_gc.h"
+#include "memory.h"
+#include "mlvalues.h"
+#include "stacks.h"
+
+#define Setup_for_gc
+#define Restore_after_gc
+
+CAMLexport value alloc (mlsize_t wosize, tag_t tag)
+{
+  value result;
+  mlsize_t i;
+
+  Assert (tag < 256);
+  Assert (tag != Infix_tag);
+  if (wosize == 0){
+    result = Atom (tag);
+  }else if (wosize <= Max_young_wosize){
+    Alloc_small (result, wosize, tag);
+    if (tag < No_scan_tag){
+      for (i = 0; i < wosize; i++) Field (result, i) = 0;
+    }
+  }else{
+    result = alloc_shr (wosize, tag);
+    if (tag < No_scan_tag) memset (Bp_val (result), 0, Bsize_wsize (wosize));
+    result = check_urgent_gc (result);
+  }
+  return result;
+}
+
+CAMLexport value alloc_small (mlsize_t wosize, tag_t tag)
+{
+  value result;
+
+  Assert (wosize > 0);
+  Assert (wosize <= Max_young_wosize);
+  Assert (tag < 256);
+  Alloc_small (result, wosize, tag);
+  return result;
+}
+
+CAMLexport value alloc_tuple(mlsize_t n)
+{
+  return alloc(n, 0);
+}
+
+CAMLexport value alloc_string (mlsize_t len)
+{
+  value result;
+  mlsize_t offset_index;
+  mlsize_t wosize = (len + sizeof (value)) / sizeof (value);
+
+  if (wosize <= Max_young_wosize) {
+    Alloc_small (result, wosize, String_tag);
+  }else{
+    result = alloc_shr (wosize, String_tag);
+    result = check_urgent_gc (result);
+  }
+  Field (result, wosize - 1) = 0;
+  offset_index = Bsize_wsize (wosize) - 1;
+  Byte (result, offset_index) = offset_index - len;
+  return result;
+}
+
+CAMLexport value alloc_final (mlsize_t len, final_fun fun,
+                              mlsize_t mem, mlsize_t max)
+{
+  return alloc_custom(final_custom_operations(fun),
+                      len * sizeof(value), mem, max);
+}
+
+CAMLexport value copy_string(char const *s)
+{
+  int len;
+  value res;
+
+  len = strlen(s);
+  res = alloc_string(len);
+  memmove(String_val(res), s, len);
+  return res;
+}
+
+CAMLexport value alloc_array(value (*funct)(char const *), char const ** arr)
+{
+  CAMLparam0 ();
+  mlsize_t nbr, n;
+  CAMLlocal2 (v, result);
+
+  nbr = 0;
+  while (arr[nbr] != 0) nbr++;
+  if (nbr == 0) {
+    CAMLreturn (Atom(0));
+  } else {
+    result = alloc (nbr, 0);
+    for (n = 0; n < nbr; n++) {
+      /* The two statements below must be separate because of evaluation
+         order (don't take the address &Field(result, n) before
+         calling funct, which may cause a GC and move result). */
+      v = funct(arr[n]);
+      modify(&Field(result, n), v);
+    }
+    CAMLreturn (result);
+  }
+}
+
+CAMLexport value copy_string_array(char const ** arr)
+{
+  return alloc_array(copy_string, arr);
+}
+
+CAMLexport int convert_flag_list(value list, int *flags)
+{
+  int res;
+  res = 0;
+  while (list != Val_int(0)) {
+    res |= flags[Int_val(Field(list, 0))];
+    list = Field(list, 1);
+  }
+  return res;
+}
+
+/* For compiling let rec over values */
+
+CAMLprim value alloc_dummy(value size)
+{
+  mlsize_t wosize = Int_val(size);
+
+  if (wosize == 0) return Atom(0);
+  return alloc (wosize, 0);
+}
+
+CAMLprim value update_dummy(value dummy, value newval)
+{
+  mlsize_t size, i;
+  size = Wosize_val(newval);
+  Assert (size == Wosize_val(dummy));
+  Tag_val(dummy) = Tag_val(newval);
+  for (i = 0; i < size; i++)
+    modify(&Field(dummy, i), Field(newval, i));
+  return Val_unit;
+}
diff --git a/byterun/backtrace.c b/byterun/backtrace.c
new file mode 100644
index 0000000000..2df3be5108
--- /dev/null
+++ b/byterun/backtrace.c
@@ -0,0 +1,197 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, 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 Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* Stack backtrace for uncaught exceptions */
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <fcntl.h>
+#include "config.h"
+#ifdef HAS_UNISTD
+#include <unistd.h>
+#endif
+#include "mlvalues.h"
+#include "alloc.h"
+#include "io.h"
+#include "instruct.h"
+#include "intext.h"
+#include "exec.h"
+#include "fix_code.h"
+#include "startup.h"
+#include "stacks.h"
+#include "sys.h"
+#include "backtrace.h"
+
+CAMLexport int backtrace_active = 0;
+CAMLexport int backtrace_pos = 0;
+CAMLexport code_t * backtrace_buffer = NULL;
+CAMLexport value backtrace_last_exn = Val_unit;
+#define BACKTRACE_BUFFER_SIZE 1024
+
+/* Location of fields in the Instruct.debug_event record */
+enum { EV_POS = 0,
+       EV_MODULE = 1,
+       EV_CHAR = 2,
+       EV_KIND = 3 };
+
+/* Initialize the backtrace machinery */
+
+void init_backtrace(void)
+{
+  backtrace_active = 1;
+  register_global_root(&backtrace_last_exn);
+  /* Note: lazy initialization of backtrace_buffer in stash_backtrace
+     to simplify the interface with the thread libraries */
+}
+
+/* Store the return addresses contained in the given stack fragment
+   into the backtrace array */
+
+void stash_backtrace(value exn, code_t pc, value * sp)
+{
+  code_t end_code = (code_t) ((char *) start_code + code_size);
+  if (pc != NULL) pc = pc - 1;
+  if (exn != backtrace_last_exn) {
+    backtrace_pos = 0;
+    backtrace_last_exn = exn;
+  }
+  if (backtrace_buffer == NULL) {
+    backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE * sizeof(code_t));
+    if (backtrace_buffer == NULL) return;
+  }
+  if (backtrace_pos >= BACKTRACE_BUFFER_SIZE) return;
+  backtrace_buffer[backtrace_pos++] = pc;
+  for (/*nothing*/; sp < trapsp; sp++) {
+    code_t p = (code_t) *sp;
+    if (p >= start_code && p < end_code) {
+      if (backtrace_pos >= BACKTRACE_BUFFER_SIZE) break;
+      backtrace_buffer[backtrace_pos++] = p;
+    }
+  }
+}
+
+/* Read the debugging info contained in the current bytecode executable.
+   Return a Caml array of Caml lists of debug_event records in "events",
+   or Val_false on failure. */
+
+#ifndef O_BINARY
+#define O_BINARY 0
+#endif
+
+static value read_debug_info(void)
+{
+  CAMLparam0();
+  CAMLlocal1(events);
+  char * exec_name;
+  int fd;
+  struct exec_trailer trail;
+  struct channel * chan;
+  uint32 num_events, orig, i;
+  value evl, l;
+
+  exec_name = caml_exe_name;
+  fd = attempt_open(&exec_name, &trail, 1);
+  if (fd < 0) CAMLreturn(Val_false);
+  read_section_descriptors(fd, &trail);
+  if (seek_optional_section(fd, &trail, "DBUG") == -1) {
+    close(fd);
+    CAMLreturn(Val_false);
+  }
+  chan = open_descriptor_in(fd);
+  num_events = getword(chan);
+  events = alloc(num_events, 0);
+  for (i = 0; i < num_events; i++) {
+    orig = getword(chan);
+    evl = input_val(chan);
+    /* Relocate events in event list */
+    for (l = evl; l != Val_int(0); l = Field(l, 1)) {
+      value ev = Field(l, 0);
+      Field(ev, EV_POS) = Val_long(Long_val(Field(ev, EV_POS)) + orig);
+    }
+    /* Record event list */
+    Store_field(events, i, evl);
+  }
+  close_channel(chan);
+  CAMLreturn(events);
+}
+
+/* Search the event for the given PC.  Return Val_false if not found. */
+
+static value event_for_location(value events, code_t pc)
+{
+  mlsize_t i;
+  value pos, l, ev;
+
+  Assert(pc >= start_code && pc < start_code + code_size);
+  pos = Val_long((char *) pc - (char *) start_code);
+  for (i = 0; i < Wosize_val(events); i++) {
+    for (l = Field(events, i); l != Val_int(0); l = Field(l, 1)) {
+      ev = Field(l, 0);
+      if (Field(ev, EV_POS) == pos /* && Is_block(Field(ev, EV_KIND)) */)
+        return ev;
+    }
+  }
+  return Val_false;
+}
+
+/* Print the location corresponding to the given PC */
+
+static void print_location(value events, int index)
+{
+  code_t pc = backtrace_buffer[index];
+  char * info;
+  value ev;
+
+  if (pc == NULL) {
+    fprintf(stderr, "Raised from a C function\n");
+    return;
+  }
+  ev = event_for_location(events, pc);
+  if (is_instruction(*pc, RAISE)) {
+    /* Ignore compiler-inserted raise */
+    if (ev == Val_false) return;
+    /* Initial raise if index == 0, re-raise otherwise */
+    if (index == 0)
+      info = "Raised at";
+    else
+      info = "Re-raised at";
+  } else {
+    info = "Called from";
+  }
+  if (ev == Val_false) {
+    fprintf(stderr, "%s unknown location\n", info);
+  } else {
+    fprintf(stderr, "%s module %s, character %d\n", info,
+            String_val(Field(ev, EV_MODULE)),
+            Int_val(Field(ev, EV_CHAR)));
+  }
+}
+
+/* Print a backtrace */
+
+CAMLexport void print_exception_backtrace(void)
+{
+  value events;
+  int i;
+
+  events = read_debug_info();
+  if (events == Val_false) {
+    fprintf(stderr,
+            "(Program not linked with -g, cannot print stack backtrace\n");
+    return;
+  }
+  for (i = 0; i < backtrace_pos; i++)
+    print_location(events, i);
+}
diff --git a/byterun/compare.c b/byterun/compare.c
new file mode 100644
index 0000000000..14bec7b4f1
--- /dev/null
+++ b/byterun/compare.c
@@ -0,0 +1,241 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            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 Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+#include <string.h>
+#include <stdlib.h>
+#include "custom.h"
+#include "fail.h"
+#include "memory.h"
+#include "misc.h"
+#include "mlvalues.h"
+
+/* Structural comparison on trees. */
+
+struct compare_item { value * v1, * v2; mlsize_t count; };
+
+#define COMPARE_STACK_INIT_SIZE 256
+#define COMPARE_STACK_MAX_SIZE (1024*1024)
+
+static struct compare_item compare_stack_init[COMPARE_STACK_INIT_SIZE];
+
+static struct compare_item * compare_stack = compare_stack_init;
+static struct compare_item * compare_stack_limit = compare_stack_init
+                                                   + COMPARE_STACK_INIT_SIZE;
+
+/* Free the compare stack if needed */
+static void compare_free_stack(void)
+{
+  if (compare_stack != compare_stack_init) {
+    stat_free(compare_stack);
+    /* Reinitialize the globals for next time around */
+    compare_stack = compare_stack_init;
+    compare_stack_limit = compare_stack + COMPARE_STACK_INIT_SIZE;
+  }
+}
+
+/* Same, then raise Out_of_memory */
+static void compare_stack_overflow(void)
+{
+  compare_free_stack();
+  raise_out_of_memory();
+}
+
+/* Grow the compare stack */
+static struct compare_item * compare_resize_stack(struct compare_item * sp)
+{
+  asize_t newsize = 2 * (compare_stack_limit - compare_stack);
+  asize_t sp_offset = sp - compare_stack;
+  struct compare_item * newstack;
+
+  if (newsize >= COMPARE_STACK_MAX_SIZE) compare_stack_overflow();
+  if (compare_stack == compare_stack_init) {
+    newstack = malloc(sizeof(struct compare_item) * newsize);
+    if (newstack == NULL) compare_stack_overflow();
+    memcpy(newstack, compare_stack_init,
+           sizeof(struct compare_item) * COMPARE_STACK_INIT_SIZE);
+  } else {
+    newstack =
+      realloc(compare_stack, sizeof(struct compare_item) * newsize);
+    if (newstack == NULL) compare_stack_overflow();
+  }
+  compare_stack = newstack;
+  compare_stack_limit = newstack + newsize;
+  return newstack + sp_offset;
+}
+
+/* Structural comparison */
+
+static long compare_val(value v1, value v2)
+{
+  struct compare_item * sp;
+  tag_t t1, t2;
+
+  sp = compare_stack;
+  while (1) {
+    while (Is_block (v1) && Tag_val (v1) == Forward_tag) v1 = Forward_val (v1);
+    while (Is_block (v2) && Tag_val (v2) == Forward_tag) v2 = Forward_val (v2);
+    if (v1 == v2) goto next_item;
+    if (Is_long(v1)) {
+      if (Is_long(v2))
+        return Long_val(v1) - Long_val(v2);
+      else
+        return -1;
+    }
+    if (Is_long(v2)) return 1;
+    /* If one of the objects is outside the heap (but is not an atom),
+       use address comparison. Since both addresses are 2-aligned,
+       shift lsb off to avoid overflow in subtraction. */
+    if ((!Is_atom(v1) && !Is_young(v1) && !Is_in_heap(v1)) ||
+        (!Is_atom(v2) && !Is_young(v2) && !Is_in_heap(v2)))
+      return (v1 >> 1) - (v2 >> 1);
+    t1 = Tag_val(v1);
+    t2 = Tag_val(v2);
+    if (t1 != t2) return (long)t1 - (long)t2;
+    switch(t1) {
+    case String_tag: {
+      mlsize_t len1, len2, len;
+      unsigned char * p1, * p2;
+      len1 = string_length(v1);
+      len2 = string_length(v2);
+      for (len = (len1 <= len2 ? len1 : len2),
+             p1 = (unsigned char *) String_val(v1),
+             p2 = (unsigned char *) String_val(v2);
+           len > 0;
+           len--, p1++, p2++)
+        if (*p1 != *p2) return (long)*p1 - (long)*p2;
+      if (len1 != len2) return len1 - len2;
+      break;
+    }
+    case Double_tag: {
+      double d1 = Double_val(v1);
+      double d2 = Double_val(v2);
+      if (d1 < d2) return -1;
+      if (d1 > d2) return 1;
+      break;
+    }
+    case Double_array_tag: {
+      mlsize_t sz1 = Wosize_val(v1) / Double_wosize;
+      mlsize_t sz2 = Wosize_val(v2) / Double_wosize;
+      mlsize_t i;
+      if (sz1 != sz2) return sz1 - sz2;
+      for (i = 0; i < sz1; i++) {
+        double d1 = Double_field(v1, i);
+        double d2 = Double_field(v2, i);
+        if (d1 < d2) return -1;
+        if (d1 > d2) return 1;
+      }
+      break;
+    }
+    case Abstract_tag:
+      compare_free_stack();
+      invalid_argument("equal: abstract value");
+    case Closure_tag:
+    case Infix_tag:
+      compare_free_stack();
+      invalid_argument("equal: functional value");
+    case Object_tag: {
+      long oid1 = Oid_val(v1);
+      long oid2 = Oid_val(v2);
+      if (oid1 != oid2) return oid1 - oid2;
+      break;
+    }
+    case Custom_tag: {
+      int res = Custom_ops_val(v1)->compare(v1, v2);
+      if (res != 0) return res;
+      break;
+    }
+    default: {
+      mlsize_t sz1 = Wosize_val(v1);
+      mlsize_t sz2 = Wosize_val(v2);
+      /* Compare sizes first for speed */
+      if (sz1 != sz2) return sz1 - sz2;
+      if (sz1 == 0) break;
+      /* Remember that we still have to compare fields 1 ... sz - 1 */
+      if (sz1 > 1) {
+        sp++;
+        if (sp >= compare_stack_limit) sp = compare_resize_stack(sp);
+        sp->v1 = &Field(v1, 1);
+        sp->v2 = &Field(v2, 1);
+        sp->count = sz1 - 1;
+      }
+      /* Continue comparison with first field */
+      v1 = Field(v1, 0);
+      v2 = Field(v2, 0);
+      continue;
+    }
+    }
+  next_item:
+    /* Pop one more item to compare, if any */
+    if (sp == compare_stack) return 0; /* we're done */
+    v1 = *(sp->v1)++;
+    v2 = *(sp->v2)++;
+    if (--(sp->count) == 0) sp--;
+  }
+}
+
+CAMLprim value compare(value v1, value v2)
+{
+  long res = compare_val(v1, v2);
+  /* Free stack if needed */
+  if (compare_stack != compare_stack_init) compare_free_stack();
+  if (res < 0) 
+    return Val_int(-1);
+  else if (res > 0)
+    return Val_int(1);
+  else
+    return Val_int(0);
+}
+
+CAMLprim value equal(value v1, value v2)
+{
+  long res = compare_val(v1, v2);
+  if (compare_stack != compare_stack_init) compare_free_stack();
+  return Val_int(res == 0);
+}
+
+CAMLprim value notequal(value v1, value v2)
+{
+  long res = compare_val(v1, v2);
+  if (compare_stack != compare_stack_init) compare_free_stack();
+  return Val_int(res != 0);
+}
+
+CAMLprim value lessthan(value v1, value v2)
+{
+  long res = compare_val(v1, v2);
+  if (compare_stack != compare_stack_init) compare_free_stack();
+  return Val_int(res < 0);
+}
+
+CAMLprim value lessequal(value v1, value v2)
+{
+  long res = compare_val(v1, v2);
+  if (compare_stack != compare_stack_init) compare_free_stack();
+  return Val_int(res <= 0);
+}
+
+CAMLprim value greaterthan(value v1, value v2)
+{
+  long res = compare_val(v1, v2);
+  if (compare_stack != compare_stack_init) compare_free_stack();
+  return Val_int(res > 0);
+}
+
+CAMLprim value greaterequal(value v1, value v2)
+{
+  long res = compare_val(v1, v2);
+  if (compare_stack != compare_stack_init) compare_free_stack();
+  return Val_int(res >= 0);
+}
diff --git a/byterun/config.h b/byterun/config.h
new file mode 100644
index 0000000000..13276a1972
--- /dev/null
+++ b/byterun/config.h
@@ -0,0 +1,135 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*         Xavier Leroy and Damien Doligez, 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 Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+#ifndef _config_
+#define _config_
+
+
+#if !macintosh
+#include "../config/m.h"
+#include "../config/s.h"
+#else
+#include <m.h>
+#include <s.h>
+#endif
+
+/* Types for signed chars, 16-bit integers, 32-bit integers, 64-bit integers */
+
+typedef signed char schar;
+
+typedef short int16;            /* FIXME -- not true on the Cray T3E */
+typedef unsigned short uint16;  /* FIXME -- not true on the Cray T3E */
+
+#if SIZEOF_INT == 4
+typedef int int32;
+typedef unsigned int uint32;
+#elif SIZEOF_LONG == 4
+typedef long int32;
+typedef unsigned long uint32;
+#elif SIZEOF_SHORT == 4
+typedef short int32;
+typedef unsigned short uint32;
+#endif
+
+#if defined(ARCH_INT64_TYPE) && defined(ARCH_UINT64_TYPE)
+typedef ARCH_INT64_TYPE int64;
+typedef ARCH_UINT64_TYPE uint64;
+#else
+/* Int64.t will not be supported, and operations over it are not defined,
+   but we must define the types int64 and uint64 as 64-bit placeholders. */
+typedef struct { uint32 a, b; } uint64;
+typedef uint64 int64;
+#endif
+
+
+/* Library dependencies */
+
+/* We use threaded code interpretation if the compiler provides labels
+   as first-class values (GCC 2.x).
+   Macintosh 68k also uses threaded code, with the assembly-language
+   bytecode interpreter (THREADED_CODE defined in config/sm-Mac.h).
+*/
+
+#if defined(__GNUC__) && __GNUC__ >= 2 && !defined(DEBUG) && !defined (SHRINKED_GNUC)
+#define THREADED_CODE
+#endif
+
+
+/* Do not change this definition. */
+#define Page_size (1 << Page_log)
+
+/* Memory model parameters */
+
+/* The size of a page for memory management (in bytes) is [1 << Page_log].
+   It must be a multiple of [sizeof (long)]. */
+#define Page_log 12             /* A page is 4 kilobytes. */
+
+/* Initial size of stack (bytes). */
+#define Stack_size (4096 * sizeof(value))
+
+/* Minimum free size of stack (bytes); below that, it is reallocated. */
+#define Stack_threshold (256 * sizeof(value))
+
+/* Default maximum size of the stack (words). */
+#define Max_stack_def (256 * 1024)
+
+
+/* Maximum size of a block allocated in the young generation (words). */
+/* Must be > 4 */
+#define Max_young_wosize 256
+
+
+/* Minimum size of the minor zone (words).
+   This must be at least [Max_young_wosize + 1]. */
+#define Minor_heap_min 4096
+
+/* Maximum size of the minor zone (words).
+   Must be greater than or equal to [Minor_heap_min].
+*/
+#define Minor_heap_max (1 << 28)
+
+/* Default size of the minor zone. (words)  */
+#define Minor_heap_def 32768
+
+
+/* Minimum size increment when growing the heap (words).
+   Must be a multiple of [Page_size / sizeof (value)]. */
+#define Heap_chunk_min (2 * Page_size / sizeof (value))
+
+/* Maximum size of a contiguous piece of the heap (words).
+   Must be greater than or equal to [Heap_chunk_min].
+   Must be greater than or equal to [Bhsize_wosize (Max_wosize)]. */
+#define Heap_chunk_max (Bhsize_wosize (Max_wosize))
+
+/* Default size increment when growing the heap. (words)
+   Must be a multiple of [Page_size / sizeof (value)]. */
+#define Heap_chunk_def (62 * 1024)
+
+/* Default initial size of the major heap (words);
+   same constraints as for Heap_chunk_def. */
+#define Init_heap_def (62 * 1024)
+
+
+/* Default speed setting for the major GC.  The heap will grow until
+   the dead objects and the free list represent this percentage of the
+   total size of live objects. */
+#define Percent_free_def 42
+
+/* Default setting for the compacter: 300%
+   (i.e. trigger the compacter when 3/4 of the heap is free) */
+#define Max_percent_free_def 300
+
+
+#endif /* _config_ */
diff --git a/byterun/extern.c b/byterun/extern.c
new file mode 100644
index 0000000000..c03e1ea955
--- /dev/null
+++ b/byterun/extern.c
@@ -0,0 +1,580 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            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 Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* Structured output */
+
+#include <string.h>
+#include "alloc.h"
+#include "custom.h"
+#include "fail.h"
+#include "gc.h"
+#include "intext.h"
+#include "io.h"
+#include "memory.h"
+#include "misc.h"
+#include "mlvalues.h"
+#include "reverse.h"
+
+/* To keep track of sharing in externed objects */
+
+typedef unsigned long byteoffset_t;
+
+struct extern_obj {
+  byteoffset_t ofs;
+  value obj;
+};
+
+static byteoffset_t initial_ofs = 1; /* Initial value of object offsets */
+static byteoffset_t obj_counter;     /* Number of objects emitted so far */
+static struct extern_obj * extern_table = NULL; /* Table of objects seen */
+static unsigned long extern_table_size;
+static unsigned long extern_table_mask;
+static unsigned int extern_hash_shift;
+/* extern_table_size, extern_table_mask and extern_hash_shift are such that
+      extern_table_size == 1 << (wordsize - extern_hash_shift)
+      extern_table_mask == extern_table_size - 1  */
+
+/* Multiplicative Fibonacci hashing (Knuth vol 3, section 6.4, page 518).
+   HASH_FACTOR is (sqrt(5) - 1) / 2 * 2^wordsize. */
+#ifdef ARCH_SIXTYFOUR
+#define HASH_FACTOR 11400714819323198485UL
+#else
+#define HASH_FACTOR 2654435769UL
+#endif
+#define Hash(v) (((unsigned long)(v) * HASH_FACTOR) >> extern_hash_shift)
+
+/* Allocate a new extern table */
+static void alloc_extern_table(void)
+{
+  asize_t i;
+  extern_table = (struct extern_obj *)
+                 stat_alloc(extern_table_size * sizeof(struct extern_obj));
+  for (i = 0; i < extern_table_size; i++) extern_table[i].ofs = 0;
+}
+
+/* Grow the extern table */
+static void resize_extern_table(void)
+{
+  asize_t oldsize;
+  struct extern_obj * oldtable;
+  value obj;
+  byteoffset_t ofs;
+  asize_t i, h;
+
+  oldsize = extern_table_size;
+  oldtable = extern_table;
+  extern_hash_shift = extern_hash_shift - 1;
+  extern_table_size = 2 * extern_table_size;
+  extern_table_mask = extern_table_size - 1;
+  alloc_extern_table();
+  for (i = 0; i < oldsize; i++) {
+    ofs = oldtable[i].ofs;
+    if (ofs >= initial_ofs) {
+      obj = oldtable[i].obj;
+      h = Hash(obj);
+      while (extern_table[h].ofs > 0) h = (h + 1) & extern_table_mask;
+      extern_table[h].ofs = ofs;
+      extern_table[h].obj = obj;
+    }
+  }
+  stat_free(oldtable);
+}
+
+/* Free the extern table. We keep it around for next call if
+   it's still small (we did not grow it) and the initial offset
+   does not risk overflowing next time. */
+static void free_extern_table(void)
+{
+  if (extern_table_size > INITIAL_EXTERN_TABLE_SIZE ||
+      initial_ofs >= INITIAL_OFFSET_MAX) {
+    stat_free(extern_table);
+    extern_table = NULL;
+  }
+}
+
+/* To buffer the output */
+
+static char * extern_block, * extern_ptr, * extern_limit;
+static int extern_block_malloced;
+
+static void alloc_extern_block(void)
+{
+  extern_block = stat_alloc(INITIAL_EXTERN_BLOCK_SIZE);
+  extern_limit = extern_block + INITIAL_EXTERN_BLOCK_SIZE;
+  extern_ptr = extern_block;
+  extern_block_malloced = 1;
+}
+
+static void resize_extern_block(int required)
+{
+  long curr_pos, size, reqd_size;
+
+  if (! extern_block_malloced) {
+    initial_ofs += obj_counter;
+    free_extern_table();
+    failwith("Marshal.to_buffer: buffer overflow");
+  }
+  curr_pos = extern_ptr - extern_block;
+  size = extern_limit - extern_block;
+  reqd_size = curr_pos + required;
+  while (size <= reqd_size) size *= 2;
+  extern_block = stat_resize(extern_block, size);
+  extern_limit = extern_block + size;
+  extern_ptr = extern_block + curr_pos;
+}
+
+/* Write characters, integers, and blocks in the output buffer */
+
+#define Write(c) \
+  if (extern_ptr >= extern_limit) resize_extern_block(1); \
+  *extern_ptr++ = (c)
+
+static void writeblock(char *data, long int len)
+{
+  if (extern_ptr + len > extern_limit) resize_extern_block(len);
+  memmove(extern_ptr, data, len);
+  extern_ptr += len;
+}
+
+static void writecode8(int code, long int val)
+{
+  if (extern_ptr + 2 > extern_limit) resize_extern_block(2);
+  extern_ptr[0] = code;
+  extern_ptr[1] = val;
+  extern_ptr += 2;
+}
+
+static void writecode16(int code, long int val)
+{
+  if (extern_ptr + 3 > extern_limit) resize_extern_block(3);
+  extern_ptr[0] = code;
+  extern_ptr[1] = val >> 8;
+  extern_ptr[2] = val;
+  extern_ptr += 3;
+}
+
+static void write32(long int val)
+{
+  if (extern_ptr + 4 > extern_limit) resize_extern_block(4);
+  extern_ptr[0] = val >> 24;
+  extern_ptr[1] = val >> 16;
+  extern_ptr[2] = val >> 8;
+  extern_ptr[3] = val;
+  extern_ptr += 4;
+}
+
+static void writecode32(int code, long int val)
+{
+  if (extern_ptr + 5 > extern_limit) resize_extern_block(5);
+  extern_ptr[0] = code;
+  extern_ptr[1] = val >> 24;
+  extern_ptr[2] = val >> 16;
+  extern_ptr[3] = val >> 8;
+  extern_ptr[4] = val;
+  extern_ptr += 5;
+}
+
+#ifdef ARCH_SIXTYFOUR
+static void writecode64(int code, long val)
+{
+  int i;
+  if (extern_ptr + 9 > extern_limit) resize_extern_block(9);
+  *extern_ptr ++ = code;
+  for (i = 64 - 8; i >= 0; i -= 8) *extern_ptr++ = val >> i;
+}
+#endif
+
+/* Marshal the given value in the output buffer */
+
+static unsigned long size_32;  /* Size in words of 32-bit block for struct. */
+static unsigned long size_64;  /* Size in words of 64-bit block for struct. */
+
+static int extern_ignore_sharing; /* Flag to ignore sharing */
+static int extern_closures;     /* Flag to allow externing code pointers */
+
+static void extern_invalid_argument(char *msg)
+{
+  if (extern_block_malloced) stat_free(extern_block);
+  initial_ofs += obj_counter;
+  free_extern_table();
+  invalid_argument(msg);
+}
+
+static void extern_rec(value v)
+{
+ tailcall:
+  if (Is_long(v)) {
+    long n = Long_val(v);
+    if (n >= 0 && n < 0x40) {
+      Write(PREFIX_SMALL_INT + n);
+    } else if (n >= -(1 << 7) && n < (1 << 7)) {
+      writecode8(CODE_INT8, n);
+    } else if (n >= -(1 << 15) && n < (1 << 15)) {
+      writecode16(CODE_INT16, n);
+#ifdef ARCH_SIXTYFOUR
+    } else if (n < -(1L << 31) || n >= (1L << 31)) {
+      writecode64(CODE_INT64, n);
+#endif
+    } else
+      writecode32(CODE_INT32, n);
+    return;
+  }
+  if (Is_young(v) || Is_in_heap(v) || Is_atom(v)) {
+    header_t hd = Hd_val(v);
+    tag_t tag = Tag_hd(hd);
+    mlsize_t sz = Wosize_hd(hd);
+    asize_t h;
+
+    /* Atoms are treated specially for two reasons: they are not allocated
+       in the externed block, and they are automatically shared. */
+    if (sz == 0) {
+      if (tag < 16) {
+        Write(PREFIX_SMALL_BLOCK + tag);
+      } else {
+        writecode32(CODE_BLOCK32, hd);
+      }
+      return;
+    }
+    /* Check if already seen */
+    if (! extern_ignore_sharing && tag != Infix_tag) {
+      if (2 * obj_counter >= extern_table_size) resize_extern_table();
+      h = Hash(v);
+      while (extern_table[h].ofs >= initial_ofs) {
+        if (extern_table[h].obj == v) {
+          byteoffset_t d = obj_counter - (extern_table[h].ofs - initial_ofs);
+          if (d < 0x100) {
+            writecode8(CODE_SHARED8, d);
+          } else if (d < 0x10000) {
+            writecode16(CODE_SHARED16, d);
+          } else {
+            writecode32(CODE_SHARED32, d);
+          }
+          return;
+        }
+        h = (h + 1) & extern_table_mask;
+      }
+      /* Not seen yet. Record the object */
+      extern_table[h].ofs = initial_ofs + obj_counter;
+      extern_table[h].obj = v;
+      obj_counter++;
+    }
+    /* Output the contents of the object */
+    switch(tag) {
+    case String_tag: {
+      mlsize_t len = string_length(v);
+      if (len < 0x20) {
+        Write(PREFIX_SMALL_STRING + len);
+      } else if (len < 0x100) {
+        writecode8(CODE_STRING8, len);
+      } else {
+        writecode32(CODE_STRING32, len);
+      }
+      writeblock(String_val(v), len);
+      size_32 += 1 + (len + 4) / 4;
+      size_64 += 1 + (len + 8) / 8;
+      break;
+    }
+    case Double_tag: {
+      if (sizeof(double) != 8)
+        extern_invalid_argument("output_value: non-standard floats");
+      Write(CODE_DOUBLE_NATIVE);
+      writeblock((char *) v, 8);
+      size_32 += 1 + 2;
+      size_64 += 1 + 1;
+      break;
+    }
+    case Double_array_tag: {
+      mlsize_t nfloats;
+      if (sizeof(double) != 8)
+        extern_invalid_argument("output_value: non-standard floats");
+      nfloats = Wosize_val(v) / Double_wosize;
+      if (nfloats < 0x100) {
+        writecode8(CODE_DOUBLE_ARRAY8_NATIVE, nfloats);
+      } else {
+        writecode32(CODE_DOUBLE_ARRAY32_NATIVE, nfloats);
+      }
+      writeblock((char *) v, Bosize_val(v));
+      size_32 += 1 + nfloats * 2;
+      size_64 += 1 + nfloats;
+      break;
+    }
+    case Abstract_tag:
+      extern_invalid_argument("output_value: abstract value");
+      break;
+    case Infix_tag:
+      writecode32(CODE_INFIXPOINTER, Infix_offset_hd(hd));
+      extern_rec(v - Infix_offset_hd(hd));
+      break;
+    case Forward_tag:
+      v = Forward_val (v);
+      goto tailcall;
+    case Object_tag:
+      extern_invalid_argument("output_value: object value");
+      break;
+    case Custom_tag: {
+      unsigned long sz_32, sz_64;
+      char * ident = Custom_ops_val(v)->identifier;
+      Write(CODE_CUSTOM);
+      writeblock(ident, strlen(ident) + 1);
+      Custom_ops_val(v)->serialize(v, &sz_32, &sz_64);
+      size_32 += 2 + ((sz_32 + 3) >> 2);  /* header + ops + data */
+      size_64 += 2 + ((sz_64 + 7) >> 3);
+      break;
+    }
+    default: {
+      mlsize_t i;
+      if (tag < 16 && sz < 8) {
+        Write(PREFIX_SMALL_BLOCK + tag + (sz << 4));
+      } else {
+        writecode32(CODE_BLOCK32, Whitehd_hd (hd));
+      }
+      size_32 += 1 + sz;
+      size_64 += 1 + sz;
+      for (i = 0; i < sz - 1; i++) extern_rec(Field(v, i));
+      v = Field(v, i);
+      goto tailcall;
+      }
+    }
+    return;
+  }
+  if ((char *) v >= code_area_start && (char *) v < code_area_end) {
+    if (!extern_closures)
+      extern_invalid_argument("output_value: functional value");
+    writecode32(CODE_CODEPOINTER, (char *) v - code_area_start);
+    writeblock((char *) code_checksum(), 16);
+    return;
+  }
+  extern_invalid_argument("output_value: abstract value");
+}
+
+enum { NO_SHARING = 1, CLOSURES = 2 };
+static int extern_flags[] = { NO_SHARING, CLOSURES };
+
+static long extern_value(value v, value flags)
+{
+  long res_len;
+  int fl;
+  /* Parse flag list */
+  fl = convert_flag_list(flags, extern_flags);
+  extern_ignore_sharing = fl & NO_SHARING;
+  extern_closures = fl & CLOSURES;
+  /* Allocate hashtable of objects already seen, if needed */
+  extern_table_size = INITIAL_EXTERN_TABLE_SIZE;
+  extern_table_mask = extern_table_size - 1;
+  extern_hash_shift = 8 * sizeof(value) - INITIAL_EXTERN_TABLE_SIZE_LOG2;
+  if (extern_table == NULL) {
+    alloc_extern_table();
+    initial_ofs = 1;
+  }
+  obj_counter = 0;
+  size_32 = 0;
+  size_64 = 0;
+  /* Write magic number */
+  write32(Intext_magic_number);
+  /* Set aside space for the sizes */
+  extern_ptr += 4*4;
+  /* Marshal the object */
+  extern_rec(v);
+  /* Update initial offset for next call to extern_value(),
+     if we decide to keep the table of shared objects. */
+  initial_ofs += obj_counter;
+  /* Free the table of shared objects (if needed) */
+  free_extern_table();
+  /* Write the sizes */
+#ifdef ARCH_SIXTYFOUR
+  if (size_32 >= (1L << 32) || size_64 >= (1L << 32)) {
+    /* The object is so big its size cannot be written in the header.
+       Besides, some of the block sizes or string lengths or shared offsets
+       it contains may have overflowed the 32 bits used to write them. */
+    failwith("output_value: object too big");
+  }
+#endif
+  res_len = extern_ptr - extern_block;
+  extern_ptr = extern_block + 4;
+  write32(res_len - 5*4);
+  write32(obj_counter);
+  write32(size_32);
+  write32(size_64);
+  /* Result is res_len bytes starting at extern_block */
+  return res_len;
+}
+
+void output_val(struct channel *chan, value v, value flags)
+{
+  long len;
+  char * block;
+
+  if (! channel_binary_mode(chan))
+    failwith("output_value: not a binary channel");
+  alloc_extern_block();
+  len = extern_value(v, flags);
+  /* During really_putblock, concurrent output_val operations can take
+     place (via signal handlers or context switching in systhreads),
+     and extern_block may change.  So, save the pointer in a local variable. */
+  block = extern_block;
+  really_putblock(chan, extern_block, len);
+  stat_free(block);
+}
+
+CAMLprim value output_value(value vchan, value v, value flags)
+{
+  CAMLparam3 (vchan, v, flags);
+  struct channel * channel = Channel(vchan);
+
+  Lock(channel);
+  output_val(channel, v, flags);
+  Unlock(channel);
+  CAMLreturn (Val_unit);
+}
+
+CAMLprim value output_value_to_string(value v, value flags)
+{
+  long len;
+  value res;
+  alloc_extern_block();
+  len = extern_value(v, flags);
+  res = alloc_string(len);
+  memmove(String_val(res), extern_block, len);
+  stat_free(extern_block);
+  return res;
+}
+
+CAMLprim value output_value_to_buffer(value buf, value ofs, value len,
+                                      value v, value flags)
+{
+  long len_res;
+  extern_block = &Byte(buf, Long_val(ofs));
+  extern_limit = extern_block + Long_val(len);
+  extern_ptr = extern_block;
+  extern_block_malloced = 0;
+  len_res = extern_value(v, flags);
+  return Val_long(len_res);
+}
+
+CAMLexport void output_value_to_malloc(value v, value flags,
+                                       /*out*/ char ** buf, /*out*/ long * len)
+{
+  long len_res;
+  alloc_extern_block();
+  len_res = extern_value(v, flags);
+  *buf = extern_block;
+  *len = len_res;
+}
+
+CAMLexport long output_value_to_block(value v, value flags,
+                                      char * buf, long len)
+{
+  long len_res;
+  extern_block = buf;
+  extern_limit = extern_block + len;
+  extern_ptr = extern_block;
+  extern_block_malloced = 0;
+  len_res = extern_value(v, flags);
+  return len_res;
+}
+
+/* Functions for writing user-defined marshallers */
+
+CAMLexport void serialize_int_1(int i)
+{
+  if (extern_ptr + 1 > extern_limit) resize_extern_block(1);
+  extern_ptr[0] = i;
+  extern_ptr += 1;
+}
+
+CAMLexport void serialize_int_2(int i)
+{
+  if (extern_ptr + 2 > extern_limit) resize_extern_block(2);
+  extern_ptr[0] = i >> 8;
+  extern_ptr[1] = i;
+  extern_ptr += 2;
+}
+
+CAMLexport void serialize_int_4(int32 i)
+{
+  if (extern_ptr + 4 > extern_limit) resize_extern_block(4);
+  extern_ptr[0] = i >> 24;
+  extern_ptr[1] = i >> 16;
+  extern_ptr[2] = i >> 8;
+  extern_ptr[3] = i;
+  extern_ptr += 4;
+}
+
+CAMLexport void serialize_int_8(int64 i)
+{
+  serialize_block_8(&i, 1);
+}
+
+CAMLexport void serialize_float_4(float f)
+{
+  serialize_block_4(&f, 1);
+}
+
+CAMLexport void serialize_float_8(double f)
+{
+  serialize_block_8(&f, 1);
+}
+
+CAMLexport void serialize_block_1(void * data, long len)
+{
+  if (extern_ptr + len > extern_limit) resize_extern_block(len);
+  memmove(extern_ptr, data, len);
+  extern_ptr += len;
+}
+
+CAMLexport void serialize_block_2(void * data, long len)
+{
+  unsigned char * p;
+  char * q;
+  if (extern_ptr + 2 * len > extern_limit) resize_extern_block(2 * len);
+#ifndef ARCH_BIG_ENDIAN
+  for (p = data, q = extern_ptr; len > 0; len--, p += 2, q += 2)
+    Reverse_16(q, p);
+  extern_ptr = q;
+#else
+  memmove(extern_ptr, data, len * 2);
+  extern_ptr += len * 2;
+#endif
+}
+
+CAMLexport void serialize_block_4(void * data, long len)
+{
+  unsigned char * p;
+  char * q;
+  if (extern_ptr + 4 * len > extern_limit) resize_extern_block(4 * len);
+#ifndef ARCH_BIG_ENDIAN
+  for (p = data, q = extern_ptr; len > 0; len--, p += 4, q += 4)
+    Reverse_32(q, p);
+  extern_ptr = q;
+#else
+  memmove(extern_ptr, data, len * 4);
+  extern_ptr += len * 4;
+#endif
+}
+
+CAMLexport void serialize_block_8(void * data, long len)
+{
+  unsigned char * p;
+  char * q;
+  if (extern_ptr + 8 * len > extern_limit) resize_extern_block(8 * len);
+#ifndef ARCH_BIG_ENDIAN
+  for (p = data, q = extern_ptr; len > 0; len--, p += 8, q += 8)
+    Reverse_64(q, p);
+  extern_ptr = q;
+#else
+  memmove(extern_ptr, data, len * 8);
+  extern_ptr += len * 8;
+#endif
+}
diff --git a/byterun/finalise.c b/byterun/finalise.c
new file mode 100644
index 0000000000..b2c51d0860
--- /dev/null
+++ b/byterun/finalise.c
@@ -0,0 +1,180 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*          Damien Doligez, 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 Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* Handling of finalised values. */
+
+#include "callback.h"
+#include "fail.h"
+#include "mlvalues.h"
+#include "roots.h"
+#include "signals.h"
+
+struct final {
+  value fun;
+  value val;
+};
+
+static struct final *final_table = NULL;
+static unsigned long old = 0, young = 0, active = 0, size = 0;
+/* [0..old) : finalisable set
+   [old..young) : recent set
+   [young..active) : free space
+   [active..size) : finalising set
+*/
+
+/* Find white finalisable values, darken them, and put them in the
+   finalising set.
+   The recent set is empty.
+*/
+void final_update (void)
+{
+  unsigned long i;
+  unsigned long oldactive = active;
+  
+  Assert (young == old);
+  Assert (young <= active);
+  for (i = 0; i < old; i++){
+    Assert (Is_block (final_table[i].val));
+    Assert (Is_in_heap (final_table[i].val));
+  again:
+    if (Is_white_val (final_table[i].val)){
+      struct final f;
+
+      if (Tag_val (final_table[i].val) == Forward_tag){
+        final_table[i].val = Forward_val (final_table[i].val);
+        goto again;
+      }
+      f = final_table[i];
+      final_table[i] = final_table[--old];
+      final_table[--active] = f;
+      -- i;
+    }
+  }
+  young = old;
+  for (i = active; i < oldactive; i++) darken (final_table[i].val, NULL);
+}
+
+/* Call the finalisation functions for the finalising set.
+   Note that this function must be reentrant.
+*/
+void final_do_calls (void)
+{
+  struct final f;
+  
+  Assert (active <= size);
+  if (active < size){
+    gc_message (0x80, "Calling finalisation functions.\n", 0);
+    while (active < size){
+      f = final_table[active++];
+      callback (f.fun, f.val);
+    }
+    gc_message (0x80, "Done calling finalisation functions.\n", 0);
+  }
+}
+
+/* Call a scanning_action [f] on [x]. */
+#define Call_action(f,x) (*(f)) ((x), &(x))
+
+/* Call [*f] on the closures of the finalisable set and
+   the closures and values of the finalising set.
+   The recent set is empty.
+   This is called by the major GC and the compactor through [darken_all_roots].
+*/
+void final_do_strong_roots (scanning_action f)
+{
+  unsigned long i;
+
+  Assert (old == young);
+  Assert (young <= active);
+  Assert (active <= size);
+  for (i = 0; i < old; i++) Call_action (f, final_table[i].fun);
+  for (i = active; i < size; i++){
+    Call_action (f, final_table[i].fun);
+    Call_action (f, final_table[i].val);
+  }
+}
+
+/* Call [*f] on the values of the finalisable set.
+   The recent set is empty.
+   This is called directly by the compactor.
+*/
+void final_do_weak_roots (scanning_action f)
+{
+  unsigned long i;
+
+  Assert (old == young);
+  for (i = 0; i < old; i++) Call_action (f, final_table[i].val);
+}
+
+/* Call [*f] on the closures and values of the recent set.
+   This is called by the minor GC through [oldify_local_roots].
+*/
+void final_do_young_roots (scanning_action f)
+{
+  unsigned long i;
+  
+  Assert (old <= young);
+  for (i = old; i < young; i++){
+    Call_action (f, final_table[i].fun);
+    Call_action (f, final_table[i].val);
+  }
+}
+
+/* Empty the recent set into the finalisable set.
+   This is called at the end of each minor collection.
+   The minor heap must be empty when this is called.
+*/
+void final_empty_young (void)
+{
+  old = young;
+}
+
+/* Put (f,v) in the recent set. */
+CAMLprim value final_register (value f, value v)
+{
+  if (!(Is_block (v) && (Is_in_heap (v) || Is_young (v)))){
+    invalid_argument ("Gc.finalise");
+  }
+
+  Assert (old <= young);
+  Assert (young <= active);
+  Assert (active <= size);
+  
+  if (young >= active){
+    if (final_table == NULL){
+      unsigned long new_size = 30;
+      final_table = stat_alloc (new_size * sizeof (struct final));
+      Assert (old == 0);
+      Assert (young == 0);
+      active = size = new_size;
+    }else{
+      unsigned long new_size = size * 2;
+      unsigned long i;
+      final_table = stat_resize (final_table, new_size * sizeof (struct final));
+      for (i = size-1; i >= active; i--){
+        final_table[i + new_size - size] = final_table[i];
+      }
+      active += new_size - size;
+      size = new_size;
+    }
+  }
+  Assert (young < active);
+  final_table[young].fun = f;
+  if (Tag_val (v) == Infix_tag) v -= Infix_offset_val (v);
+  final_table[young].val = v;
+  ++ young;
+
+  return Val_unit;
+}
diff --git a/byterun/floats.c b/byterun/floats.c
new file mode 100644
index 0000000000..c1f6ec5af1
--- /dev/null
+++ b/byterun/floats.c
@@ -0,0 +1,395 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            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 Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+#include <math.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include "alloc.h"
+#include "fail.h"
+#include "memory.h"
+#include "mlvalues.h"
+#include "misc.h"
+#include "reverse.h"
+#include "stacks.h"
+
+#ifdef ARCH_ALIGN_DOUBLE
+
+CAMLexport double Double_val(value val)
+{
+  union { value v[2]; double d; } buffer;
+
+  Assert(sizeof(double) == 2 * sizeof(value));
+  buffer.v[0] = Field(val, 0);
+  buffer.v[1] = Field(val, 1);
+  return buffer.d;
+}
+
+CAMLexport void Store_double_val(value val, double dbl)
+{
+  union { value v[2]; double d; } buffer;
+
+  Assert(sizeof(double) == 2 * sizeof(value));
+  buffer.d = dbl;
+  Field(val, 0) = buffer.v[0];
+  Field(val, 1) = buffer.v[1];
+}
+
+#endif
+
+CAMLexport value copy_double(double d)
+{
+  value res;
+
+#define Setup_for_gc
+#define Restore_after_gc
+  Alloc_small(res, Double_wosize, Double_tag);
+#undef Setup_for_gc
+#undef Restore_after_gc
+  Store_double_val(res, d);
+  return res;
+}
+
+CAMLprim value format_float(value fmt, value arg)
+{
+#define MAX_DIGITS 350
+/* Max number of decimal digits in a "natural" (not artificially padded)
+   representation of a float. Can be quite big for %f format.
+   Max exponent for IEEE format is 308 decimal digits.
+   Rounded up for good measure. */
+  char format_buffer[MAX_DIGITS + 20];
+  int prec, i;
+  char * p;
+  char * dest;
+  value res;
+
+  prec = MAX_DIGITS;
+  for (p = String_val(fmt); *p != 0; p++) {
+    if (*p >= '0' && *p <= '9') {
+      i = atoi(p) + MAX_DIGITS;
+      if (i > prec) prec = i;
+      break;
+    }
+  }
+  for( ; *p != 0; p++) {
+    if (*p == '.') {
+      i = atoi(p+1) + MAX_DIGITS;
+      if (i > prec) prec = i;
+      break;
+    }
+  }
+  if (prec < sizeof(format_buffer)) {
+    dest = format_buffer;
+  } else {
+    dest = stat_alloc(prec);
+  }
+  sprintf(dest, String_val(fmt), Double_val(arg));
+  res = copy_string(dest);
+  if (dest != format_buffer) {
+    stat_free(dest);
+  }
+  return res;
+}
+
+CAMLprim value float_of_string(value vs)
+{
+  char parse_buffer[64];
+  char * buf, * src, * dst, * end;
+  mlsize_t len;
+  double d;
+
+  len = string_length(vs);
+  buf = len < sizeof(parse_buffer) ? parse_buffer : stat_alloc(len + 1);
+  src = String_val(vs);
+  dst = buf;
+  while (len--) {
+    char c = *src++;
+    if (c != '_') *dst++ = c;
+  }
+  *dst = 0;
+  d = strtod((const char *) buf, &end);
+  if (buf != parse_buffer) stat_free(buf);
+  if (end != dst) failwith("float_of_string");
+  return copy_double(d);
+}
+
+CAMLprim value int_of_float(value f)
+{
+  return Val_long((long) Double_val(f));
+}
+
+CAMLprim value float_of_int(value n)
+{
+  return copy_double((double) Long_val(n));
+}
+
+CAMLprim value neg_float(value f)
+{
+  return copy_double(- Double_val(f));
+}
+
+CAMLprim value abs_float(value f)
+{
+  return copy_double(fabs(Double_val(f)));
+}
+
+CAMLprim value add_float(value f, value g)
+{
+  return copy_double(Double_val(f) + Double_val(g));
+}
+
+CAMLprim value sub_float(value f, value g)
+{
+  return copy_double(Double_val(f) - Double_val(g));
+}
+
+CAMLprim value mul_float(value f, value g)
+{
+  return copy_double(Double_val(f) * Double_val(g));
+}
+
+CAMLprim value div_float(value f, value g)
+{
+  return copy_double(Double_val(f) / Double_val(g));
+}
+
+CAMLprim value exp_float(value f)
+{
+  return copy_double(exp(Double_val(f)));
+}
+
+CAMLprim value floor_float(value f)
+{
+  return copy_double(floor(Double_val(f)));
+}
+
+CAMLprim value fmod_float(value f1, value f2)
+{
+  return copy_double(fmod(Double_val(f1), Double_val(f2)));
+}
+
+CAMLprim value frexp_float(value f)
+{
+  CAMLparam1 (f);
+  CAMLlocal2 (res, mantissa);
+  int exponent;
+
+  mantissa = copy_double(frexp (Double_val(f), &exponent));
+  res = alloc_tuple(2);
+  Field(res, 0) = mantissa;
+  Field(res, 1) = Val_int(exponent);
+  CAMLreturn (res);
+}
+
+CAMLprim value ldexp_float(value f, value i)
+{
+  return copy_double(ldexp(Double_val(f), Int_val(i)));
+}
+
+CAMLprim value log_float(value f)
+{
+  return copy_double(log(Double_val(f)));
+}
+
+CAMLprim value log10_float(value f)
+{
+  return copy_double(log10(Double_val(f)));
+}
+
+CAMLprim value modf_float(value f)
+{
+#if __SC__
+  _float_eval frem;       /* Problem with Apple's <math.h> */
+#else
+  double frem;
+#endif
+  CAMLparam1 (f);
+  CAMLlocal3 (res, quo, rem);
+
+  quo = copy_double(modf (Double_val(f), &frem));
+  rem = copy_double(frem);
+  res = alloc_tuple(2);
+  Field(res, 0) = quo;
+  Field(res, 1) = rem;
+  CAMLreturn (res);
+}
+
+CAMLprim value sqrt_float(value f)
+{
+  return copy_double(sqrt(Double_val(f)));
+}
+
+CAMLprim value power_float(value f, value g)
+{
+  return copy_double(pow(Double_val(f), Double_val(g)));
+}
+
+CAMLprim value sin_float(value f)
+{
+  return copy_double(sin(Double_val(f)));
+}
+
+CAMLprim value sinh_float(value f)
+{
+  return copy_double(sinh(Double_val(f)));
+}
+
+CAMLprim value cos_float(value f)
+{
+  return copy_double(cos(Double_val(f)));
+}
+
+CAMLprim value cosh_float(value f)
+{
+  return copy_double(cosh(Double_val(f)));
+}
+
+CAMLprim value tan_float(value f)
+{
+  return copy_double(tan(Double_val(f)));
+}
+
+CAMLprim value tanh_float(value f)
+{
+  return copy_double(tanh(Double_val(f)));
+}
+
+CAMLprim value asin_float(value f)
+{
+  return copy_double(asin(Double_val(f)));
+}
+
+CAMLprim value acos_float(value f)
+{
+  return copy_double(acos(Double_val(f)));
+}
+
+CAMLprim value atan_float(value f)
+{
+  return copy_double(atan(Double_val(f)));
+}
+
+CAMLprim value atan2_float(value f, value g)
+{
+  return copy_double(atan2(Double_val(f), Double_val(g)));
+}
+
+CAMLprim value ceil_float(value f)
+{
+  return copy_double(ceil(Double_val(f)));
+}
+
+CAMLprim value eq_float(value f, value g)
+{
+  return Val_bool(Double_val(f) == Double_val(g));
+}
+
+CAMLprim value neq_float(value f, value g)
+{
+  return Val_bool(Double_val(f) != Double_val(g));
+}
+
+CAMLprim value le_float(value f, value g)
+{
+  return Val_bool(Double_val(f) <= Double_val(g));
+}
+
+CAMLprim value lt_float(value f, value g)
+{
+  return Val_bool(Double_val(f) < Double_val(g));
+}
+
+CAMLprim value ge_float(value f, value g)
+{
+  return Val_bool(Double_val(f) >= Double_val(g));
+}
+
+CAMLprim value gt_float(value f, value g)
+{
+  return Val_bool(Double_val(f) > Double_val(g));
+}
+
+CAMLprim value float_of_bytes(value s)
+{
+  value d = copy_double(0.0);
+#ifdef ARCH_BIG_ENDIAN
+  memcpy(String_val(d), String_val(s), 8);
+#else
+  Reverse_64(String_val(d), String_val(s));
+#endif
+  return d;
+}
+
+enum { FP_normal, FP_subnormal, FP_zero, FP_infinite, FP_nan };
+
+CAMLprim value classify_float(value vd)
+{
+#ifdef fpclassify
+  switch (fpclassify(Double_val(vd))) {
+  case FP_NAN:
+    return Val_int(FP_nan);
+  case FP_INFINITE:
+    return Val_int(FP_infinite);
+  case FP_ZERO:
+    return Val_int(FP_zero);
+  case FP_SUBNORMAL:
+    return Val_int(FP_subnormal);
+  default: /* case FP_NORMAL */
+    return Val_int(FP_normal);
+  }
+#else
+  double d = Double_val(vd);
+  uint32 h, l;
+#ifdef ARCH_BIG_ENDIAN
+  h = ((uint32 *) &d)[0];
+  l = ((uint32 *) &d)[1];
+#else
+  l = ((uint32 *) &d)[0];
+  h = ((uint32 *) &d)[1];
+#endif
+  l = l | (h & 0xFFFFF);
+  h = h & 0x7FF00000;
+  if ((h | l) == 0)
+    return Val_int(FP_zero);
+  if (h == 0)
+    return Val_int(FP_subnormal);
+  if (h == 0x7FF00000) {
+    if (l == 0)
+      return Val_int(FP_infinite);
+    else
+      return Val_int(FP_nan);
+  }
+  return Val_int(FP_normal);
+#endif
+}
+
+/* The init_ieee_float function should initialize floating-point hardware
+   so that it behaves as much as possible like the IEEE standard.
+   In particular, return special numbers like Infinity and NaN instead
+   of signalling exceptions.  Currently, everyone is in IEEE mode
+   at program startup, except FreeBSD prior to 4.0R. */
+
+#ifdef __FreeBSD__
+#include <osreldate.h>
+#if (__FreeBSD_version < 400017)
+#include <floatingpoint.h>
+#endif
+#endif
+
+void init_ieee_floats(void)
+{
+#if defined(__FreeBSD__) && (__FreeBSD_version < 400017)
+  fpsetmask(0);
+#endif
+}
diff --git a/byterun/gc_ctrl.c b/byterun/gc_ctrl.c
new file mode 100644
index 0000000000..b8e89c4703
--- /dev/null
+++ b/byterun/gc_ctrl.c
@@ -0,0 +1,423 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*             Damien Doligez, projet Para, 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 Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+#include "alloc.h"
+#include "compact.h"
+#include "custom.h"
+#include "finalise.h"
+#include "gc.h"
+#include "gc_ctrl.h"
+#include "major_gc.h"
+#include "minor_gc.h"
+#include "misc.h"
+#include "mlvalues.h"
+#include "stacks.h"
+
+#ifndef NATIVE_CODE
+extern unsigned long max_stack_size;    /* defined in stacks.c */
+#endif
+
+double stat_minor_words = 0.0,
+       stat_promoted_words = 0.0,
+       stat_major_words = 0.0;
+
+long stat_minor_collections = 0,
+     stat_major_collections = 0,
+     stat_heap_size = 0,              /* bytes */
+     stat_top_heap_size = 0,          /* bytes */
+     stat_compactions = 0;
+
+extern asize_t major_heap_increment;  /* bytes; see major_gc.c */
+extern unsigned long percent_free;    /*        see major_gc.c */
+extern unsigned long percent_max;     /*        see compact.c */
+
+#define Next(hp) ((hp) + Bhsize_hp (hp))
+
+#ifdef DEBUG
+
+/* Check that [v]'s header looks good.  [v] must be a block in the heap. */
+static void check_head (value v)
+{
+  Assert (Is_block (v));
+  Assert (Is_in_heap (v));
+
+  Assert (Wosize_val (v) != 0);
+  Assert (Color_hd (Hd_val (v)) != Caml_blue);
+  Assert (Is_in_heap (v));
+  if (Tag_val (v) == Infix_tag){
+    int offset = Wsize_bsize (Infix_offset_val (v));
+    value trueval = Val_op (&Field (v, -offset));
+    Assert (Tag_val (trueval) == Closure_tag);
+    Assert (Wosize_val (trueval) > offset);
+    Assert (Is_in_heap (&Field (trueval, Wosize_val (trueval) - 1)));
+  }else{
+    Assert (Is_in_heap (&Field (v, Wosize_val (v) - 1)));
+  }
+  if (Tag_val (v) ==  Double_tag){
+    Assert (Wosize_val (v) == Double_wosize);
+  }else if (Tag_val (v) == Double_array_tag){
+    Assert (Wosize_val (v) % Double_wosize == 0);
+  }
+}
+
+static void check_block (char *hp)
+{
+  mlsize_t nfields = Wosize_hp (hp);
+  mlsize_t i;
+  value v = Val_hp (hp);
+  value f;
+  mlsize_t lastbyte;
+  
+  check_head (v);
+  switch (Tag_hp (hp)){
+  case Abstract_tag: break;
+  case String_tag:
+    /* not true when check_urgent_gc is called by alloc or alloc_string:
+       lastbyte = Bosize_val (v) - 1;
+       i = Byte (v, lastbyte);
+       Assert (i >= 0);
+       Assert (i < sizeof (value));
+       Assert (Byte (v, lastbyte - i) == 0);
+    */
+    break;
+  case Double_tag:
+    Assert (Wosize_val (v) == Double_wosize);
+    break;
+  case Double_array_tag:
+    Assert (Wosize_val (v) % Double_wosize == 0);
+    break;
+  case Custom_tag:
+    Assert (!Is_in_heap (Custom_ops_val (v)));
+    break;
+  
+  case Infix_tag:
+    Assert (0);
+    break;
+
+  default:
+    Assert (Tag_hp (hp) < No_scan_tag);
+    for (i = 0; i < Wosize_hp (hp); i++){
+      f = Field (v, i);
+      if (Is_block (f) && Is_in_heap (f)) check_head (f);
+    }
+  }
+}
+
+#endif /* DEBUG */
+
+/* Check the heap structure (if compiled in debug mode) and
+   gather statistics; return the stats if [returnstats] is true,
+   otherwise return [Val_unit].
+*/
+static value heap_stats (int returnstats)
+{
+  CAMLparam0 ();
+  long live_words = 0, live_blocks = 0,
+       free_words = 0, free_blocks = 0, largest_free = 0,
+       fragments = 0, heap_chunks = 0;
+  char *chunk = heap_start, *chunk_end;
+  char *cur_hp, *prev_hp;
+  header_t cur_hd;
+
+#ifdef DEBUG
+  gc_message (-1, "### O'Caml runtime: heap check ###\n", 0);
+#endif
+
+  while (chunk != NULL){
+    ++ heap_chunks;
+    chunk_end = chunk + Chunk_size (chunk);
+    prev_hp = NULL;
+    cur_hp = chunk;
+    while (cur_hp < chunk_end){
+      cur_hd = Hd_hp (cur_hp);
+                                           Assert (Next (cur_hp) <= chunk_end);
+      switch (Color_hd (cur_hd)){
+      case Caml_white:
+        if (Wosize_hd (cur_hd) == 0){
+          ++fragments;
+          Assert (prev_hp == NULL
+                  || Color_hp (prev_hp) != Caml_blue
+                  || cur_hp == gc_sweep_hp);
+        }else{
+          if (gc_phase == Phase_sweep && cur_hp >= gc_sweep_hp){
+            ++ free_blocks;
+            free_words += Whsize_hd (cur_hd);
+            if (Whsize_hd (cur_hd) > largest_free){
+              largest_free = Whsize_hd (cur_hd);
+            }
+          }else{
+            ++ live_blocks;
+            live_words += Whsize_hd (cur_hd);
+#ifdef DEBUG
+            check_block (cur_hp);
+#endif
+          }
+        }
+        break;
+      case Caml_gray: case Caml_black:
+        Assert (Wosize_hd (cur_hd) > 0);
+        ++ live_blocks;
+        live_words += Whsize_hd (cur_hd);
+#ifdef DEBUG
+        check_block (cur_hp);
+#endif
+        break;
+      case Caml_blue:
+        Assert (Wosize_hd (cur_hd) > 0);
+        ++ free_blocks;
+        free_words += Whsize_hd (cur_hd);
+        if (Whsize_hd (cur_hd) > largest_free){
+          largest_free = Whsize_hd (cur_hd);
+        }
+        Assert (prev_hp == NULL
+                || (Color_hp (prev_hp) != Caml_blue && Wosize_hp (prev_hp) > 0)
+                || cur_hp == gc_sweep_hp);
+        Assert (Next (cur_hp) == chunk_end
+                || (Color_hp (Next (cur_hp)) != Caml_blue
+                    && Wosize_hp (Next (cur_hp)) > 0)
+                || Next (cur_hp) == gc_sweep_hp);
+        break;
+      }
+      prev_hp = cur_hp;
+      cur_hp = Next (cur_hp);
+    }                                          Assert (cur_hp == chunk_end);
+    chunk = Chunk_next (chunk);
+  }
+
+  Assert (live_words + free_words + fragments == Wsize_bsize (stat_heap_size));
+
+  if (returnstats){
+    CAMLlocal1 (res);
+
+    /* get a copy of these before allocating anything... */
+    double minwords = stat_minor_words
+                      + (double) Wsize_bsize (young_end - young_ptr);
+    double prowords = stat_promoted_words;
+    double majwords = stat_major_words + (double) allocated_words;
+    long mincoll = stat_minor_collections;
+    long majcoll = stat_major_collections;
+    long heap_words = Wsize_bsize (stat_heap_size);
+    long cpct = stat_compactions;
+
+    res = alloc_tuple (15);
+    Store_field (res, 0, copy_double (minwords));
+    Store_field (res, 1, copy_double (prowords));
+    Store_field (res, 2, copy_double (majwords));
+    Store_field (res, 3, Val_long (mincoll));
+    Store_field (res, 4, Val_long (majcoll));
+    Store_field (res, 5, Val_long (heap_words));
+    Store_field (res, 6, Val_long (heap_chunks));
+    Store_field (res, 7, Val_long (live_words));
+    Store_field (res, 8, Val_long (live_blocks));
+    Store_field (res, 9, Val_long (free_words));
+    Store_field (res, 10, Val_long (free_blocks));
+    Store_field (res, 11, Val_long (largest_free));
+    Store_field (res, 12, Val_long (fragments));
+    Store_field (res, 13, Val_long (cpct));
+    Store_field (res, 14, Val_long (Wsize_bsize (stat_top_heap_size)));
+    CAMLreturn (res);
+  }else{
+    CAMLreturn (Val_unit);
+  }
+}
+
+#ifdef DEBUG
+void heap_check (void)
+{
+  heap_stats (0);
+}
+#endif
+
+CAMLprim value gc_stat(value v)
+{
+  Assert (v == Val_unit);
+  return heap_stats (1);
+}
+
+CAMLprim value gc_counters(value v)
+{
+  CAMLparam0 ();   /* v is ignored */
+  CAMLlocal1 (res);
+
+  /* get a copy of these before allocating anything... */
+  double minwords = stat_minor_words
+                    + (double) Wsize_bsize (young_end - young_ptr);
+  double prowords = stat_promoted_words;
+  double majwords = stat_major_words + (double) allocated_words;
+
+  res = alloc_tuple (3);
+  Store_field (res, 0, copy_double (minwords));
+  Store_field (res, 1, copy_double (prowords));
+  Store_field (res, 2, copy_double (majwords));
+  CAMLreturn (res);
+}
+
+CAMLprim value gc_get(value v)
+{
+  CAMLparam0 ();   /* v is ignored */
+  CAMLlocal1 (res);
+
+  res = alloc_tuple (6);
+  Store_field (res, 0, Wsize_bsize (Val_long (minor_heap_size)));       /* s */
+  Store_field (res, 1, Wsize_bsize (Val_long (major_heap_increment)));  /* i */
+  Store_field (res, 2, Val_long (percent_free));                        /* o */
+  Store_field (res, 3, Val_long (verb_gc));                             /* v */
+  Store_field (res, 4, Val_long (percent_max));                         /* O */
+#ifndef NATIVE_CODE
+  Store_field (res, 5, Val_long (max_stack_size));                      /* l */
+#else
+  Store_field (res, 5, Val_long (0));
+#endif
+  CAMLreturn (res);
+}
+
+#define Max(x,y) ((x) < (y) ? (y) : (x))
+
+static unsigned long norm_pfree (long unsigned int p)
+{
+  return Max (p, 1);
+}
+
+static unsigned long norm_pmax (long unsigned int p)
+{
+  return p;
+}
+
+static long norm_heapincr (long unsigned int i)
+{
+#define Psv (Wsize_bsize (Page_size))
+  i = ((i + Psv - 1) / Psv) * Psv;
+  if (i < Heap_chunk_min) i = Heap_chunk_min;
+  if (i > Heap_chunk_max) i = Heap_chunk_max;
+  return i;
+}
+
+static long norm_minsize (long int s)
+{
+  if (s < Minor_heap_min) s = Minor_heap_min;
+  if (s > Minor_heap_max) s = Minor_heap_max;
+  return s;
+}
+
+CAMLprim value gc_set(value v)
+{
+  unsigned long newpf, newpm;
+  asize_t newheapincr;
+  asize_t newminsize;
+
+  verb_gc = Long_val (Field (v, 3));
+
+#ifndef NATIVE_CODE
+  change_max_stack_size (Long_val (Field (v, 5)));
+#endif
+
+  newpf = norm_pfree (Long_val (Field (v, 2)));
+  if (newpf != percent_free){
+    percent_free = newpf;
+    gc_message (0x20, "New space overhead: %d%%\n", percent_free);
+  }
+
+  newpm = norm_pmax (Long_val (Field (v, 4)));
+  if (newpm != percent_max){
+    percent_max = newpm;
+    gc_message (0x20, "New max overhead: %d%%\n", percent_max);
+  }
+
+  newheapincr = norm_heapincr (Bsize_wsize (Long_val (Field (v, 1))));
+  if (newheapincr != major_heap_increment){
+    major_heap_increment = newheapincr;
+    gc_message (0x20, "New heap increment size: %luk bytes\n",
+                major_heap_increment/1024);
+  }
+
+    /* Minor heap size comes last because it will trigger a minor collection
+       (thus invalidating [v]) and it can raise [Out_of_memory]. */
+  newminsize = norm_minsize (Bsize_wsize (Long_val (Field (v, 0))));
+  if (newminsize != minor_heap_size){
+    gc_message (0x20, "New minor heap size: %luk bytes\n", newminsize/1024);
+    set_minor_heap_size (newminsize);
+  }
+  return Val_unit;
+}
+
+CAMLprim value gc_minor(value v)
+{                                                    Assert (v == Val_unit);
+  minor_collection ();
+  return Val_unit;
+}
+
+CAMLprim value gc_major(value v)
+{                                                    Assert (v == Val_unit);
+  empty_minor_heap ();
+  finish_major_cycle ();
+  final_do_calls ();
+  return Val_unit;
+}
+
+CAMLprim value gc_full_major(value v)
+{                                                    Assert (v == Val_unit);
+  empty_minor_heap ();
+  finish_major_cycle ();
+  final_do_calls ();
+  empty_minor_heap ();
+  finish_major_cycle ();
+  final_do_calls ();
+  return Val_unit;
+}
+
+CAMLprim value gc_major_slice (value v)
+{
+  Assert (Is_long (v));
+  empty_minor_heap ();
+  return Val_long (major_collection_slice (Long_val (v)));
+}
+
+CAMLprim value gc_compaction(value v)
+{                                                    Assert (v == Val_unit);
+  empty_minor_heap ();
+  finish_major_cycle ();
+  finish_major_cycle ();
+  compact_heap ();
+  return Val_unit;
+}
+
+void init_gc (unsigned long minor_size, unsigned long major_size,
+              unsigned long major_incr, unsigned long percent_fr,
+              unsigned long percent_m)
+{
+  unsigned long major_heap_size = Bsize_wsize (norm_heapincr (major_size));
+
+#ifdef DEBUG
+  gc_message (-1, "### O'Caml runtime: debug mode "
+#ifdef CPU_TYPE_STRING
+                               "(" CPU_TYPE_STRING ") "
+#endif
+                                                       "###\n", 0);
+#endif
+
+  set_minor_heap_size (Bsize_wsize (norm_minsize (minor_size)));
+  major_heap_increment = Bsize_wsize (norm_heapincr (major_incr));
+  percent_free = norm_pfree (percent_fr);
+  percent_max = norm_pmax (percent_m);
+  init_major_heap (major_heap_size);
+  gc_message (0x20, "Initial minor heap size: %luk bytes\n",
+              minor_heap_size / 1024);
+  gc_message (0x20, "Initial major heap size: %luk bytes\n",
+              major_heap_size / 1024);
+  gc_message (0x20, "Initial space overhead: %lu%%\n", percent_free);
+  gc_message (0x20, "Initial max overhead: %lu%%\n", percent_max);
+  gc_message (0x20, "Initial heap increment: %luk bytes\n",
+              major_heap_increment / 1024);
+}
diff --git a/byterun/gc_ctrl.h b/byterun/gc_ctrl.h
new file mode 100644
index 0000000000..9140170adc
--- /dev/null
+++ b/byterun/gc_ctrl.h
@@ -0,0 +1,41 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*             Damien Doligez, projet Para, 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 Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+#ifndef _gc_ctrl_
+#define _gc_ctrl_
+
+#include "misc.h"
+
+extern double
+     stat_minor_words,
+     stat_promoted_words,
+     stat_major_words;
+
+extern long
+     stat_minor_collections,
+     stat_major_collections,
+     stat_heap_size,
+     stat_top_heap_size,
+     stat_compactions;
+
+void init_gc (unsigned long, unsigned long, unsigned long,
+              unsigned long, unsigned long);
+
+
+#ifdef DEBUG
+void heap_check (void);
+#endif
+
+#endif /* _gc_ctrl_ */
diff --git a/byterun/hash.c b/byterun/hash.c
new file mode 100644
index 0000000000..24cd96df12
--- /dev/null
+++ b/byterun/hash.c
@@ -0,0 +1,156 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            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 Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* The generic hashing primitive */
+
+#include "mlvalues.h"
+#include "custom.h"
+#include "memory.h"
+
+static unsigned long hash_accu;
+static long hash_univ_limit, hash_univ_count;
+
+static void hash_aux(value obj);
+
+CAMLprim value hash_univ_param(value count, value limit, value obj)
+{
+  hash_univ_limit = Long_val(limit);
+  hash_univ_count = Long_val(count);
+  hash_accu = 0;
+  hash_aux(obj);
+  return Val_long(hash_accu & 0x3FFFFFFF);
+  /* The & has two purposes: ensure that the return value is positive
+     and give the same result on 32 bit and 64 bit architectures. */
+}
+
+#define Alpha 65599
+#define Beta 19
+#define Combine(new)  (hash_accu = hash_accu * Alpha + (new))
+#define Combine_small(new) (hash_accu = hash_accu * Beta + (new))
+
+static void hash_aux(value obj)
+{
+  unsigned char * p;
+  mlsize_t i, j;
+  tag_t tag;
+
+  hash_univ_limit--;
+  if (hash_univ_count < 0 || hash_univ_limit < 0) return;
+
+ again:
+  if (Is_long(obj)) {
+    hash_univ_count--;
+    Combine(Long_val(obj));
+    return;
+  }
+
+  /* Pointers into the heap are well-structured blocks. So are atoms.
+     We can inspect the block contents. */
+
+  Assert (Is_block (obj));  
+  if (Is_atom(obj) || Is_young(obj) || Is_in_heap(obj)) {
+    tag = Tag_val(obj);
+    switch (tag) {
+    case String_tag:
+      hash_univ_count--;
+      i = string_length(obj);
+      for (p = &Byte_u(obj, 0); i > 0; i--, p++)
+        Combine_small(*p);
+      break;
+    case Double_tag:
+      /* For doubles, we inspect their binary representation, LSB first.
+         The results are consistent among all platforms with IEEE floats. */
+      hash_univ_count--;
+#ifdef ARCH_BIG_ENDIAN
+      for (p = &Byte_u(obj, sizeof(double) - 1), i = sizeof(double);
+           i > 0;
+           p--, i--)
+#else
+      for (p = &Byte_u(obj, 0), i = sizeof(double);
+           i > 0;
+           p++, i--)
+#endif
+        Combine_small(*p);
+      break;
+    case Double_array_tag:
+      hash_univ_count--;
+      for (j = 0; j < Bosize_val(obj); j += sizeof(double)) {
+#ifdef ARCH_BIG_ENDIAN
+      for (p = &Byte_u(obj, j + sizeof(double) - 1), i = sizeof(double);
+           i > 0;
+           p--, i--)
+#else
+      for (p = &Byte_u(obj, j), i = sizeof(double);
+           i > 0;
+           p++, i--)
+#endif
+        Combine_small(*p);
+      }
+      break;
+    case Abstract_tag:
+      /* We don't know anything about the contents of the block.
+         Better do nothing. */
+      break;
+    case Infix_tag:
+      hash_aux(obj - Infix_offset_val(obj));
+      break;
+    case Forward_tag:
+      obj = Forward_val (obj);
+      goto again;
+    case Object_tag:
+      hash_univ_count--;
+      Combine(Oid_val(obj));
+      break;
+    case Custom_tag:
+      /* If no hashing function provided, do nothing */
+      if (Custom_ops_val(obj)->hash != NULL) {
+        hash_univ_count--;
+        Combine(Custom_ops_val(obj)->hash(obj));
+      }
+      break;
+    default:
+      hash_univ_count--;
+      Combine_small(tag);
+      i = Wosize_val(obj);
+      while (i != 0) {
+        i--;
+        hash_aux(Field(obj, i));
+      }
+      break;
+    }
+    return;
+  }
+
+  /* Otherwise, obj is a pointer outside the heap, to an object with
+     a priori unknown structure. Use its physical address as hash key. */
+  Combine((long) obj);
+}
+
+/* Hashing variant tags */
+
+CAMLexport value hash_variant(char * tag)
+{
+  value accu;
+  /* Same hashing algorithm as in ../typing/btype.ml, function hash_variant */
+  for (accu = Val_int(0); *tag != 0; tag++) 
+    accu = Val_int(223 * Int_val(accu) + *((unsigned char *) tag));
+#ifdef ARCH_SIXTYFOUR
+  accu = accu & Val_long(0x7FFFFFFFL);
+#endif
+  /* Force sign extension of bit 31 for compatibility between 32 and 64-bit
+     platforms */
+  return (int32) accu;
+}
+
diff --git a/byterun/intern.c b/byterun/intern.c
new file mode 100644
index 0000000000..fa8c3a5427
--- /dev/null
+++ b/byterun/intern.c
@@ -0,0 +1,645 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            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 Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* Structured input, compact format */
+
+#include <string.h>
+#include "alloc.h"
+#include "custom.h"
+#include "fail.h"
+#include "gc.h"
+#include "intext.h"
+#include "io.h"
+#include "memory.h"
+#include "mlvalues.h"
+#include "misc.h"
+#include "reverse.h"
+
+static unsigned char * intern_src;
+/* Reading pointer in block holding input data. */
+
+static unsigned char * intern_input;
+/* Pointer to beginning of block holding input data.
+   Meaningful only if intern_input_malloced = 1. */
+
+static int intern_input_malloced;
+/* 1 if intern_input was allocated by stat_alloc()
+   and needs stat_free() on error, 0 otherwise. */
+
+static header_t * intern_dest;
+/* Writing pointer in destination block */
+
+static header_t * intern_extra_block;
+/* If non-NULL, point to new heap chunk allocated with alloc_for_heap. */
+
+static asize_t obj_counter;
+/* Count how many objects seen so far */
+
+static value * intern_obj_table;
+/* The pointers to objects already seen */
+
+static unsigned int intern_color;
+/* Color to assign to newly created headers */
+
+static header_t intern_header;
+/* Original header of the destination block.
+   Meaningful only if intern_extra_block is NULL. */
+
+static value intern_block;
+/* Point to the heap block allocated as destination block.
+   Meaningful only if intern_extra_block is NULL. */
+
+#define Sign_extend_shift ((sizeof(long) - 1) * 8)
+#define Sign_extend(x) (((long)(x) << Sign_extend_shift) >> Sign_extend_shift)
+
+#define read8u() (*intern_src++)
+#define read8s() Sign_extend(*intern_src++)
+#define read16u() \
+  (intern_src += 2, \
+   (intern_src[-2] << 8) + intern_src[-1])
+#define read16s() \
+  (intern_src += 2, \
+   (Sign_extend(intern_src[-2]) << 8) + intern_src[-1])
+#define read32u() \
+  (intern_src += 4, \
+   (intern_src[-4] << 24) + (intern_src[-3] << 16) + \
+   (intern_src[-2] << 8) + intern_src[-1])
+#define read32s() \
+  (intern_src += 4, \
+   (Sign_extend(intern_src[-4]) << 24) + (intern_src[-3] << 16) + \
+   (intern_src[-2] << 8) + intern_src[-1])
+
+#ifdef ARCH_SIXTYFOUR
+static long read64s(void)
+{
+  long res;
+  int i;
+  res = 0;
+  for (i = 0; i < 8; i++) res = (res << 8) + intern_src[i];
+  intern_src += 8;
+  return res;
+}
+#endif
+
+#define readblock(dest,len) \
+  (memmove((dest), intern_src, (len)), intern_src += (len))
+
+static void intern_cleanup(void)
+{
+  if (intern_input_malloced) stat_free(intern_input);
+  if (intern_obj_table != NULL) stat_free(intern_obj_table);
+  if (intern_extra_block != NULL) {
+    /* free newly allocated heap chunk */
+    free_for_heap(intern_extra_block); 
+  } else if (intern_block != 0) {
+    /* restore original header for heap block, otherwise GC is confused */
+    Hd_val(intern_block) = intern_header;
+  }
+}
+
+static void intern_rec(value *dest)
+{
+  unsigned int code;
+  tag_t tag;
+  mlsize_t size, len, ofs_ind;
+  value v, clos;
+  asize_t ofs;
+  header_t header;
+  char cksum[16];
+  struct custom_operations * ops;
+
+ tailcall:
+  code = read8u();
+  if (code >= PREFIX_SMALL_INT) {
+    if (code >= PREFIX_SMALL_BLOCK) {
+      /* Small block */
+      tag = code & 0xF;
+      size = (code >> 4) & 0x7;
+    read_block:
+      if (size == 0) {
+        v = Atom(tag);
+      } else {
+        v = Val_hp(intern_dest);
+        *dest = v;
+        if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v;
+        dest = (value *) (intern_dest + 1);
+        *intern_dest = Make_header(size, tag, intern_color);
+        intern_dest += 1 + size;
+        for(/*nothing*/; size > 1; size--, dest++)
+          intern_rec(dest);
+        goto tailcall;
+      }
+    } else {
+      /* Small integer */
+      v = Val_int(code & 0x3F);
+    }
+  } else {
+    if (code >= PREFIX_SMALL_STRING) {
+      /* Small string */
+      len = (code & 0x1F);
+    read_string:
+      size = (len + sizeof(value)) / sizeof(value);
+      v = Val_hp(intern_dest);
+      if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v;
+      *intern_dest = Make_header(size, String_tag, intern_color);
+      intern_dest += 1 + size;
+      Field(v, size - 1) = 0;
+      ofs_ind = Bsize_wsize(size) - 1;
+      Byte(v, ofs_ind) = ofs_ind - len;
+      readblock(String_val(v), len);
+    } else {
+      switch(code) {
+      case CODE_INT8:
+        v = Val_long(read8s());
+        break;
+      case CODE_INT16:
+        v = Val_long(read16s());
+        break;
+      case CODE_INT32:
+        v = Val_long(read32s());
+        break;
+      case CODE_INT64:
+#ifdef ARCH_SIXTYFOUR
+        v = Val_long(read64s());
+        break;
+#else
+        intern_cleanup();
+        failwith("input_value: integer too large");
+        break;
+#endif
+      case CODE_SHARED8:
+        ofs = read8u();
+      read_shared:
+        Assert (ofs > 0);
+        Assert (ofs <= obj_counter);
+        Assert (intern_obj_table != NULL); 
+        v = intern_obj_table[obj_counter - ofs];
+        break;
+      case CODE_SHARED16:
+        ofs = read16u();
+        goto read_shared;
+      case CODE_SHARED32:
+        ofs = read32u();
+        goto read_shared;
+      case CODE_BLOCK32:
+        header = (header_t) read32u();
+        tag = Tag_hd(header);
+        size = Wosize_hd(header);
+        goto read_block;
+      case CODE_STRING8:
+        len = read8u();
+        goto read_string;
+      case CODE_STRING32:
+        len = read32u();
+        goto read_string;
+      case CODE_DOUBLE_LITTLE:
+      case CODE_DOUBLE_BIG:
+        if (sizeof(double) != 8) {
+          intern_cleanup();
+          invalid_argument("input_value: non-standard floats");
+        }
+        v = Val_hp(intern_dest);
+        if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v;
+        *intern_dest = Make_header(Double_wosize, Double_tag, intern_color);
+        intern_dest += 1 + Double_wosize;
+        readblock((char *) v, 8);
+        if (code != CODE_DOUBLE_NATIVE) Reverse_64(v, v);
+        break;
+      case CODE_DOUBLE_ARRAY8_LITTLE:
+      case CODE_DOUBLE_ARRAY8_BIG:
+        len = read8u();
+      read_double_array:
+        if (sizeof(double) != 8) {
+          intern_cleanup();
+          invalid_argument("input_value: non-standard floats");
+        }
+        size = len * Double_wosize;
+        v = Val_hp(intern_dest);
+        if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v;
+        *intern_dest = Make_header(size, Double_array_tag, intern_color);
+        intern_dest += 1 + size;
+        readblock((char *) v, len * 8);
+        if (code != CODE_DOUBLE_ARRAY8_NATIVE && 
+            code != CODE_DOUBLE_ARRAY32_NATIVE) {
+          mlsize_t i;
+          for (i = 0; i < len; i++) Reverse_64((value)((double *)v + i),
+                                               (value)((double *)v + i));
+        }
+        break;
+      case CODE_DOUBLE_ARRAY32_LITTLE:
+      case CODE_DOUBLE_ARRAY32_BIG:
+        len = read32u();
+        goto read_double_array;
+      case CODE_CODEPOINTER:
+        ofs = read32u();
+        readblock(cksum, 16);
+        if (memcmp(cksum, code_checksum(), 16) != 0) {
+          intern_cleanup();
+          failwith("input_value: code mismatch");
+        }
+        v = (value) (code_area_start + ofs);
+        break;
+      case CODE_INFIXPOINTER:
+        ofs = read32u();
+        intern_rec(&clos);
+        v = clos + ofs;
+        break;
+      case CODE_CUSTOM:
+        ops = find_custom_operations((char *) intern_src);
+        if (ops == NULL) {
+          intern_cleanup();
+          failwith("input_value: unknown custom block identifier");
+        }
+        while (*intern_src++ != 0) /*nothing*/;  /*skip identifier*/
+        size = ops->deserialize((void *) (intern_dest + 2));
+        size = 1 + (size + sizeof(value) - 1) / sizeof(value);
+        v = Val_hp(intern_dest);
+        if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v;
+        *intern_dest = Make_header(size, Custom_tag, intern_color);
+        Custom_ops_val(v) = ops;
+        intern_dest += 1 + size;
+        break;
+      default:
+        intern_cleanup();
+        failwith("input_value: ill-formed message");
+      }
+    }
+  }
+  *dest = v;
+}
+
+static void intern_alloc(mlsize_t whsize, mlsize_t num_objects)
+{
+  mlsize_t wosize;
+
+  if (whsize == 0) {
+    intern_obj_table = NULL;
+    intern_extra_block = NULL;
+    intern_block = 0;
+    return;
+  }
+  wosize = Wosize_whsize(whsize);
+  if (wosize > Max_wosize) {
+    /* Round desired size up to next page */
+    asize_t request =
+      ((Bsize_wsize(whsize) + Page_size - 1) >> Page_log) << Page_log;
+    intern_extra_block = alloc_for_heap(request);
+    if (intern_extra_block == NULL) raise_out_of_memory();
+    intern_color = allocation_color(intern_extra_block);
+    intern_dest = intern_extra_block;
+  } else {
+    /* this is a specialised version of alloc from alloc.c */
+    if (wosize == 0){
+      intern_block = Atom (String_tag);
+    }else if (wosize <= Max_young_wosize){
+      intern_block = alloc_small (wosize, String_tag);
+    }else{
+      intern_block = alloc_shr (wosize, String_tag);
+      /* do not do the urgent_gc check here because it might darken
+         intern_block into gray and break the Assert 3 lines down */
+    }
+    intern_header = Hd_val(intern_block);
+    intern_color = Color_hd(intern_header);
+    Assert (intern_color == Caml_white || intern_color == Caml_black);
+    intern_dest = (header_t *) Hp_val(intern_block);
+    intern_extra_block = NULL;
+  }
+  obj_counter = 0;
+  if (num_objects > 0)
+    intern_obj_table = (value *) stat_alloc(num_objects * sizeof(value));
+  else
+    intern_obj_table = NULL;
+}
+
+static void intern_add_to_heap(mlsize_t whsize)
+{
+  /* Add new heap chunk to heap if needed */
+  if (intern_extra_block != NULL) {
+    /* If heap chunk not filled totally, build free block at end */
+    asize_t request =
+      ((Bsize_wsize(whsize) + Page_size - 1) >> Page_log) << Page_log;
+    header_t * end_extra_block = intern_extra_block + Wsize_bsize(request);
+    Assert(intern_dest <= end_extra_block);
+    if (intern_dest < end_extra_block)
+      *intern_dest =
+        Make_header(Wosize_whsize(end_extra_block-intern_dest), 0, Caml_white);
+    add_to_heap(intern_extra_block);
+  }
+}
+
+value input_val(struct channel *chan)
+{
+  uint32 magic;
+  mlsize_t block_len, num_objects, size_32, size_64, whsize;
+  char * block;
+  value res;
+
+  if (! channel_binary_mode(chan))
+    failwith("input_value: not a binary channel");
+  magic = getword(chan);
+  if (magic != Intext_magic_number) failwith("input_value: bad object");
+  block_len = getword(chan);
+  num_objects = getword(chan);
+  size_32 = getword(chan);
+  size_64 = getword(chan);
+  /* Read block from channel */
+  block = stat_alloc(block_len);
+  /* During really_getblock, concurrent input_val operations can take
+     place (via signal handlers or context switching in systhreads),
+     and intern_input may change.  So, wait until really_getblock
+     is over before using intern_input and the other global vars. */
+  if (really_getblock(chan, block, block_len) == 0) {
+    stat_free(block);
+    failwith("input_value: truncated object");
+  }
+  intern_input = (unsigned char *) block;
+  intern_input_malloced = 1;
+  intern_src = intern_input;
+  /* Allocate result */
+#ifdef ARCH_SIXTYFOUR
+  whsize = size_64;
+#else
+  whsize = size_32;
+#endif
+  intern_alloc(whsize, num_objects);
+  /* Fill it in */
+  intern_rec(&res);
+  intern_add_to_heap(whsize);
+  /* Free everything */
+  stat_free(intern_input);
+  if (intern_obj_table != NULL) stat_free(intern_obj_table);
+  return res;
+}
+
+CAMLprim value input_value(value vchan)
+{
+  CAMLparam1 (vchan);
+  struct channel * chan = Channel(vchan);
+  CAMLlocal1 (res);
+
+  Lock(chan);
+  res = input_val(chan);
+  Unlock(chan);
+  CAMLreturn (res);
+}
+
+CAMLexport value input_val_from_string(value str, long int ofs)
+{
+  CAMLparam1 (str);
+  mlsize_t num_objects, size_32, size_64, whsize;
+  CAMLlocal1 (obj);
+
+  intern_src = &Byte_u(str, ofs + 2*4);
+  intern_input_malloced = 0;
+  num_objects = read32u();
+  size_32 = read32u();
+  size_64 = read32u();
+  /* Allocate result */
+#ifdef ARCH_SIXTYFOUR
+  whsize = size_64;
+#else
+  whsize = size_32;
+#endif
+  intern_alloc(whsize, num_objects);
+  intern_src = &Byte_u(str, ofs + 5*4); /* If a GC occurred */
+  /* Fill it in */
+  intern_rec(&obj);
+  intern_add_to_heap(whsize);
+  /* Free everything */
+  if (intern_obj_table != NULL) stat_free(intern_obj_table);
+  CAMLreturn (obj);
+}
+
+CAMLprim value input_value_from_string(value str, value ofs)
+{
+  return input_val_from_string(str, Long_val(ofs));
+}
+
+static value input_val_from_block(void)
+{
+  mlsize_t num_objects, size_32, size_64, whsize;
+  value obj;
+
+  num_objects = read32u();
+  size_32 = read32u();
+  size_64 = read32u();
+  /* Allocate result */
+#ifdef ARCH_SIXTYFOUR
+  whsize = size_64;
+#else
+  whsize = size_32;
+#endif
+  intern_alloc(whsize, num_objects);
+  /* Fill it in */
+  intern_rec(&obj);
+  intern_add_to_heap(whsize);
+  /* Free internal data structures */
+  if (intern_obj_table != NULL) stat_free(intern_obj_table);
+  return obj;
+}
+
+CAMLexport value input_value_from_malloc(char * data, long ofs)
+{
+  mlsize_t magic, block_len;
+  value obj;
+
+  intern_input = (unsigned char *) data;
+  intern_src = intern_input + ofs;
+  intern_input_malloced = 1;
+  magic = read32u();
+  if (magic != Intext_magic_number) 
+    failwith("input_value_from_malloc: bad object");
+  block_len = read32u();
+  obj = input_val_from_block();
+  /* Free the input */
+  stat_free(intern_input);
+  return obj;
+}
+
+CAMLexport value input_value_from_block(char * data, long len)
+{
+  mlsize_t magic, block_len;
+  value obj;
+
+  intern_input = (unsigned char *) data;
+  intern_src = intern_input;
+  intern_input_malloced = 0;
+  magic = read32u();
+  if (magic != Intext_magic_number) 
+    failwith("input_value_from_block: bad object");
+  block_len = read32u();
+  if (5*4 + block_len > len)
+    failwith("input_value_from_block: bad block length");
+  obj = input_val_from_block();
+  return obj;
+}
+
+CAMLprim value marshal_data_size(value buff, value ofs)
+{
+  uint32 magic;
+  mlsize_t block_len;
+
+  intern_src = &Byte_u(buff, Long_val(ofs));
+  intern_input_malloced = 0;
+  magic = read32u();
+  if (magic != Intext_magic_number) failwith("Marshal.data_size: bad object");
+  block_len = read32u();
+  return Val_long(block_len);
+}
+
+/* Return an MD5 checksum of the code area */
+
+#ifdef NATIVE_CODE
+
+#include "md5.h"
+
+unsigned char * code_checksum()
+{
+  static unsigned char checksum[16];
+  static int checksum_computed = 0;
+
+  if (! checksum_computed) {
+    struct MD5Context ctx;
+    MD5Init(&ctx);
+    MD5Update(&ctx,
+              (unsigned char *) code_area_start,
+              code_area_end - code_area_start);
+    MD5Final(checksum, &ctx);
+    checksum_computed = 1;
+  }
+  return checksum;
+}
+
+#else
+
+#include "fix_code.h"
+
+unsigned char * code_checksum(void)
+{
+  return code_md5;
+}
+
+#endif
+
+/* Functions for writing user-defined marshallers */
+
+CAMLexport int deserialize_uint_1(void)
+{
+  return read8u();
+}
+
+CAMLexport int deserialize_sint_1(void)
+{
+  return read8s();
+}
+
+CAMLexport int deserialize_uint_2(void)
+{
+  return read16u();
+}
+
+CAMLexport int deserialize_sint_2(void)
+{
+  return read16s();
+}
+
+CAMLexport uint32 deserialize_uint_4(void)
+{
+  return read32u();
+}
+
+CAMLexport int32 deserialize_sint_4(void)
+{
+  return read32s();
+}
+
+CAMLexport uint64 deserialize_uint_8(void)
+{
+  uint64 i;
+  deserialize_block_8(&i, 1);
+  return i;
+}
+
+CAMLexport int64 deserialize_sint_8(void)
+{
+  int64 i;
+  deserialize_block_8(&i, 1);
+  return i;
+}
+
+CAMLexport float deserialize_float_4(void)
+{
+  float f;
+  deserialize_block_4(&f, 1);
+  return f;
+}
+
+CAMLexport double deserialize_float_8(void)
+{
+  double f;
+  deserialize_block_8(&f, 1);
+  return f;
+}
+
+CAMLexport void deserialize_block_1(void * data, long len)
+{
+  memmove(data, intern_src, len);
+  intern_src += len;
+}
+
+CAMLexport void deserialize_block_2(void * data, long len)
+{
+  unsigned char * p, * q;
+#ifndef ARCH_BIG_ENDIAN
+  for (p = intern_src, q = data; len > 0; len--, p += 2, q += 2)
+    Reverse_16(q, p);
+  intern_src = p;
+#else
+  memmove(data, intern_src, len * 2);
+  intern_src += len * 2;
+#endif
+}
+
+CAMLexport void deserialize_block_4(void * data, long len)
+{
+  unsigned char * p, * q;
+#ifndef ARCH_BIG_ENDIAN
+  for (p = intern_src, q = data; len > 0; len--, p += 4, q += 4)
+    Reverse_32(q, p);
+  intern_src = p;
+#else
+  memmove(data, intern_src, len * 4);
+  intern_src += len * 4;
+#endif
+}
+
+CAMLexport void deserialize_block_8(void * data, long len)
+{
+  unsigned char * p, * q;
+#ifndef ARCH_BIG_ENDIAN
+  for (p = intern_src, q = data; len > 0; len--, p += 8, q += 8)
+    Reverse_64(q, p);
+  intern_src = p;
+#else
+  memmove(data, intern_src, len * 8);
+  intern_src += len * 8;
+#endif
+}
+
+CAMLexport void deserialize_error(char * msg)
+{
+  intern_cleanup();
+  failwith(msg);
+}
diff --git a/byterun/ints.c b/byterun/ints.c
new file mode 100644
index 0000000000..e9ad194014
--- /dev/null
+++ b/byterun/ints.c
@@ -0,0 +1,684 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            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 Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+#include <stdio.h>
+#include <string.h>
+#include "alloc.h"
+#include "custom.h"
+#include "fail.h"
+#include "intext.h"
+#include "memory.h"
+#include "misc.h"
+#include "mlvalues.h"
+
+static char * parse_sign_and_base(char * p,
+                                  /*out*/ int * base,
+                                  /*out*/ int * sign)
+{
+  *sign = 1;
+  if (*p == '-') {
+    *sign = -1;
+    p++;
+  }
+  *base = 10;
+  if (*p == '0') {
+    switch (p[1]) {
+    case 'x': case 'X':
+      *base = 16; p += 2; break;
+    case 'o': case 'O':
+      *base = 8; p += 2; break;
+    case 'b': case 'B':
+      *base = 2; p += 2; break;
+    }
+  }
+  return p;
+}
+
+static int parse_digit(char c)
+{
+  if (c >= '0' && c <= '9')
+    return c - '0';
+  else if (c >= 'A' && c <= 'F')
+    return c - 'A' + 10;
+  else if (c >= 'a' && c <= 'f')
+    return c - 'a' + 10;
+  else
+    return -1;
+}
+
+static long parse_long(char * p)
+{
+  unsigned long res;
+  int sign, base, d;
+
+  p = parse_sign_and_base(p, &base, &sign);
+  d = parse_digit(*p);
+  if (d < 0 || d >= base) failwith("int_of_string");
+  for (p++, res = d; /*nothing*/; p++) {
+    char c = *p;
+    if (c == '_') continue;
+    d = parse_digit(c);
+    if (d < 0 || d >= base) break;
+    res = base * res + d;
+  }
+  if (*p != 0) failwith("int_of_string");
+  return sign < 0 ? -((long) res) : (long) res;
+}
+
+CAMLprim value int_of_string(value s)
+{
+  return Val_long(parse_long(String_val(s)));
+}
+
+#define FORMAT_BUFFER_SIZE 32
+
+static char * parse_format(value fmt,
+                           char * suffix,
+                           char format_string[],
+                           char default_format_buffer[])
+{
+  int prec, lastletter;
+  char * p;
+  mlsize_t len, len_suffix;
+
+  /* Copy Caml format fmt to format_string,
+     adding the suffix before the last letter of the format */
+  len = string_length(fmt);
+  len_suffix = strlen(suffix);
+  if (len + len_suffix + 1 >= FORMAT_BUFFER_SIZE)
+    invalid_argument("format_int: format too long");
+  memmove(format_string, String_val(fmt), len);
+  p = format_string + len - 1;
+  lastletter = *p;
+  /* Compress two-letter formats, ignoring the [lnL] annotation */
+  if (p[-1] == 'l' || p[-1] == 'n' || p[-1] == 'L') p--;
+  memmove(p, suffix, len_suffix);  p += len_suffix;
+  *p++ = lastletter;
+  *p = 0;
+  /* Determine space needed for result and allocate it dynamically if needed */
+  prec = 22 + 5; /* 22 digits for 64-bit number in octal + 5 extra */
+  for (p = String_val(fmt); *p != 0; p++) {
+    if (*p >= '0' && *p <= '9') {
+      prec = atoi(p) + 5;
+      break;
+    }
+  }
+  if (prec < FORMAT_BUFFER_SIZE)
+    return default_format_buffer;
+  else
+    return stat_alloc(prec + 1);
+}
+
+CAMLprim value format_int(value fmt, value arg)
+{
+  char format_string[FORMAT_BUFFER_SIZE];
+  char default_format_buffer[FORMAT_BUFFER_SIZE];
+  char * buffer;
+  value res;
+
+  buffer = parse_format(fmt, "l", format_string, default_format_buffer);
+  sprintf(buffer, format_string, Long_val(arg));
+  res = copy_string(buffer);
+  if (buffer != default_format_buffer) stat_free(buffer);
+  return res;
+}
+
+/* 32-bit integers */
+
+static int int32_compare(value v1, value v2)
+{
+  int32 i1 = Int32_val(v1);
+  int32 i2 = Int32_val(v2);
+  return i1 == i2 ? 0 : i1 < i2 ? -1 : 1;
+}
+
+static long int32_hash(value v)
+{
+  return Int32_val(v);
+}
+
+static void int32_serialize(value v, unsigned long * wsize_32,
+                            unsigned long * wsize_64)
+{
+  serialize_int_4(Int32_val(v));
+  *wsize_32 = *wsize_64 = 4;
+}
+
+static unsigned long int32_deserialize(void * dst)
+{
+  *((int32 *) dst) = deserialize_sint_4();
+  return 4;
+}
+
+CAMLexport struct custom_operations int32_ops = {
+  "_i",
+  custom_finalize_default,
+  int32_compare,
+  int32_hash,
+  int32_serialize,
+  int32_deserialize
+};
+
+CAMLexport value copy_int32(int32 i)
+{
+  value res = alloc_custom(&int32_ops, 4, 0, 1);
+  Int32_val(res) = i;
+  return res;
+}
+
+CAMLprim value int32_neg(value v)
+{ return copy_int32(- Int32_val(v)); }
+
+CAMLprim value int32_add(value v1, value v2)
+{ return copy_int32(Int32_val(v1) + Int32_val(v2)); }
+
+CAMLprim value int32_sub(value v1, value v2)
+{ return copy_int32(Int32_val(v1) - Int32_val(v2)); }
+
+CAMLprim value int32_mul(value v1, value v2)
+{ return copy_int32(Int32_val(v1) * Int32_val(v2)); }
+
+CAMLprim value int32_div(value v1, value v2)
+{
+  int32 divisor = Int32_val(v2);
+  if (divisor == 0) raise_zero_divide();
+  return copy_int32(Int32_val(v1) / divisor);
+}
+
+CAMLprim value int32_mod(value v1, value v2)
+{
+  int32 divisor = Int32_val(v2);
+  if (divisor == 0) raise_zero_divide();
+  return copy_int32(Int32_val(v1) % divisor);
+}
+
+CAMLprim value int32_and(value v1, value v2)
+{ return copy_int32(Int32_val(v1) & Int32_val(v2)); }
+
+CAMLprim value int32_or(value v1, value v2)
+{ return copy_int32(Int32_val(v1) | Int32_val(v2)); }
+
+CAMLprim value int32_xor(value v1, value v2)
+{ return copy_int32(Int32_val(v1) ^ Int32_val(v2)); }
+
+CAMLprim value int32_shift_left(value v1, value v2)
+{ return copy_int32(Int32_val(v1) << Int_val(v2)); }
+
+CAMLprim value int32_shift_right(value v1, value v2)
+{ return copy_int32(Int32_val(v1) >> Int_val(v2)); }
+
+CAMLprim value int32_shift_right_unsigned(value v1, value v2)
+{ return copy_int32((uint32)Int32_val(v1) >> Int_val(v2)); }
+
+CAMLprim value int32_of_int(value v)
+{ return copy_int32(Long_val(v)); }
+
+CAMLprim value int32_to_int(value v)
+{ return Val_long(Int32_val(v)); }
+
+CAMLprim value int32_of_float(value v)
+{ return copy_int32((int32)(Double_val(v))); }
+
+CAMLprim value int32_to_float(value v)
+{ return copy_double((double)(Int32_val(v))); }
+
+CAMLprim value int32_format(value fmt, value arg)
+{
+  char format_string[FORMAT_BUFFER_SIZE];
+  char default_format_buffer[FORMAT_BUFFER_SIZE];
+  char * buffer;
+  value res;
+
+  buffer = parse_format(fmt, "", format_string, default_format_buffer);
+  sprintf(buffer, format_string, (long) Int32_val(arg));
+  res = copy_string(buffer);
+  if (buffer != default_format_buffer) stat_free(buffer);
+  return res;
+}
+
+CAMLprim value int32_of_string(value s)
+{
+  return copy_int32(parse_long(String_val(s)));
+}
+
+/* 64-bit integers */
+
+#ifdef ARCH_INT64_TYPE
+
+#ifdef ARCH_ALIGN_INT64
+
+CAMLexport int64 Int64_val(value v)
+{
+  union { int32 i[2]; int64 j; } buffer;
+  buffer.i[0] = ((int32 *) Data_custom_val(v))[0];
+  buffer.i[1] = ((int32 *) Data_custom_val(v))[1];
+  return buffer.j;
+}
+
+CAMLexport void Store_int64(value v, int64 i)
+{
+}
+
+#endif
+
+static int int64_compare(value v1, value v2)
+{
+  int64 i1 = Int64_val(v1);
+  int64 i2 = Int64_val(v2);
+  return i1 == i2 ? 0 : i1 < i2 ? -1 : 1;
+}
+
+static long int64_hash(value v)
+{
+  return (long) Int64_val(v);
+}
+
+static void int64_serialize(value v, unsigned long * wsize_32,
+                            unsigned long * wsize_64)
+{
+  serialize_int_8(Int64_val(v));
+  *wsize_32 = *wsize_64 = 8;
+}
+
+static unsigned long int64_deserialize(void * dst)
+{
+#ifndef ARCH_ALIGN_INT64
+  *((int64 *) dst) = deserialize_sint_8();
+#else
+  union { int32 i[2]; int64 j; } buffer;
+  buffer.j = deserialize_sint_8();
+  ((int32 *) dst)[0] = buffer.i[0];
+  ((int32 *) dst)[1] = buffer.i[1];
+#endif
+  return 8;
+}
+
+CAMLexport struct custom_operations int64_ops = {
+  "_j",
+  custom_finalize_default,
+  int64_compare,
+  int64_hash,
+  int64_serialize,
+  int64_deserialize
+};
+
+CAMLexport value copy_int64(int64 i)
+{
+  value res = alloc_custom(&int64_ops, 8, 0, 1);
+#ifndef ARCH_ALIGN_INT64
+  Int64_val(res) = i;
+#else
+  union { int32 i[2]; int64 j; } buffer;
+  buffer.j = i;
+  ((int32 *) Data_custom_val(res))[0] = buffer.i[0];
+  ((int32 *) Data_custom_val(res))[1] = buffer.i[1];
+#endif
+  return res;
+}
+
+CAMLprim value int64_neg(value v)
+{ return copy_int64(- Int64_val(v)); }
+
+CAMLprim value int64_add(value v1, value v2)
+{ return copy_int64(Int64_val(v1) + Int64_val(v2)); }
+
+CAMLprim value int64_sub(value v1, value v2)
+{ return copy_int64(Int64_val(v1) - Int64_val(v2)); }
+
+CAMLprim value int64_mul(value v1, value v2)
+{ return copy_int64(Int64_val(v1) * Int64_val(v2)); }
+
+CAMLprim value int64_div(value v1, value v2)
+{
+  int64 divisor = Int64_val(v2);
+  if (divisor == 0) raise_zero_divide();
+  return copy_int64(Int64_val(v1) / divisor);
+}
+
+CAMLprim value int64_mod(value v1, value v2)
+{
+  int64 divisor = Int64_val(v2);
+  if (divisor == 0) raise_zero_divide();
+  return copy_int64(Int64_val(v1) % divisor);
+}
+
+CAMLprim value int64_and(value v1, value v2)
+{ return copy_int64(Int64_val(v1) & Int64_val(v2)); }
+
+CAMLprim value int64_or(value v1, value v2)
+{ return copy_int64(Int64_val(v1) | Int64_val(v2)); }
+
+CAMLprim value int64_xor(value v1, value v2)
+{ return copy_int64(Int64_val(v1) ^ Int64_val(v2)); }
+
+CAMLprim value int64_shift_left(value v1, value v2)
+{ return copy_int64(Int64_val(v1) << Int_val(v2)); }
+
+CAMLprim value int64_shift_right(value v1, value v2)
+{ return copy_int64(Int64_val(v1) >> Int_val(v2)); }
+
+CAMLprim value int64_shift_right_unsigned(value v1, value v2)
+{ return copy_int64((uint64)Int64_val(v1) >> Int_val(v2)); }
+
+CAMLprim value int64_of_int(value v)
+{ return copy_int64(Long_val(v)); }
+
+CAMLprim value int64_to_int(value v)
+{ return Val_long((long) Int64_val(v)); }
+
+CAMLprim value int64_of_float(value v)
+{ return copy_int64((int64)(Double_val(v))); }
+
+CAMLprim value int64_to_float(value v)
+{ return copy_double((double)(Int64_val(v))); }
+
+CAMLprim value int64_of_int32(value v)
+{ return copy_int64(Int32_val(v)); }
+
+CAMLprim value int64_to_int32(value v)
+{ return copy_int32((int32) Int64_val(v)); }
+
+CAMLprim value int64_of_nativeint(value v)
+{ return copy_int64(Nativeint_val(v)); }
+
+CAMLprim value int64_to_nativeint(value v)
+{ return copy_nativeint((long) Int64_val(v)); }
+
+CAMLprim value int64_format(value fmt, value arg)
+#ifdef ARCH_INT64_PRINTF_FORMAT
+{
+  char format_string[FORMAT_BUFFER_SIZE];
+  char default_format_buffer[FORMAT_BUFFER_SIZE];
+  char * buffer;
+  value res;
+
+  buffer = parse_format(fmt, ARCH_INT64_PRINTF_FORMAT,
+                        format_string, default_format_buffer);
+  sprintf(buffer, format_string, Int64_val(arg));
+  res = copy_string(buffer);
+  if (buffer != default_format_buffer) stat_free(buffer);
+  return res;
+}
+#else
+{ invalid_argument ("Int64.format is not implemented on this platform"); }
+#endif
+
+CAMLprim value int64_of_string(value s)
+{
+  char * p;
+  uint64 res;
+  int sign, base, d;
+
+  p = parse_sign_and_base(String_val(s), &base, &sign);
+  d = parse_digit(*p);
+  if (d < 0 || d >= base) failwith("int_of_string");
+  for (p++, res = d; /*nothing*/; p++) {
+    char c = *p;
+    if (c == '_') continue;
+    d = parse_digit(c);
+    if (d < 0 || d >= base) break;
+    res = base * res + d;
+  }
+  if (*p != 0) failwith("int_of_string");
+  return copy_int64(sign < 0 ? -((int64) res) : (int64) res);
+}
+
+CAMLprim value int64_bits_of_float(value vd)
+{
+  union { double d; int64 i; } u;
+  u.d = Double_val(vd);
+  return copy_int64(u.i);
+}
+
+CAMLprim value int64_float_of_bits(value vi)
+{
+  union { double d; int64 i; } u;
+  u.i = Int64_val(vi);
+  return copy_double(u.d);
+}
+
+#else
+
+static char int64_error[] =
+  "The type Int64.t is not supported on this platform";
+
+value copy_int64(int64 i)
+{ invalid_argument(int64_error); }
+
+value int64_neg(value v)
+{ invalid_argument(int64_error); }
+
+value int64_add(value v1, value v2)
+{ invalid_argument(int64_error); }
+
+value int64_sub(value v1, value v2)
+{ invalid_argument(int64_error); }
+
+value int64_mul(value v1, value v2)
+{ invalid_argument(int64_error); }
+
+value int64_div(value v1, value v2)
+{ invalid_argument(int64_error); }
+
+value int64_mod(value v1, value v2)
+{ invalid_argument(int64_error); }
+
+value int64_and(value v1, value v2)
+{ invalid_argument(int64_error); }
+
+value int64_or(value v1, value v2)
+{ invalid_argument(int64_error); }
+
+value int64_xor(value v1, value v2)
+{ invalid_argument(int64_error); }
+
+value int64_shift_left(value v1, value v2)
+{ invalid_argument(int64_error); }
+
+value int64_shift_right(value v1, value v2)
+{ invalid_argument(int64_error); }
+
+value int64_shift_right_unsigned(value v1, value v2)
+{ invalid_argument(int64_error); }
+
+value int64_of_int(value v)
+{ invalid_argument(int64_error); }
+
+value int64_to_int(value v)
+{ invalid_argument(int64_error); }
+
+value int64_of_float(value v)
+{ invalid_argument(int64_error); }
+
+value int64_to_float(value v)
+{ invalid_argument(int64_error); }
+
+value int64_of_int32(value v)
+{ invalid_argument(int64_error); }
+
+value int64_to_int32(value v)
+{ invalid_argument(int64_error); }
+
+value int64_of_nativeint(value v)
+{ invalid_argument(int64_error); }
+
+value int64_to_nativeint(value v)
+{ invalid_argument(int64_error); }
+
+value int64_format(value fmt, value arg)
+{ invalid_argument(int64_error); }
+
+value int64_of_string(value s)
+{ invalid_argument(int64_error); }
+
+value int64_bits_of_float(value vd)
+{ invalid_argument(int64_error); }
+
+value int64_float_of_bits(value vi)
+{ invalid_argument(int64_error); }
+
+#endif
+
+/* Native integers */
+
+static int nativeint_compare(value v1, value v2)
+{
+  long i1 = Nativeint_val(v1);
+  long i2 = Nativeint_val(v2);
+  return i1 == i2 ? 0 : i1 < i2 ? -1 : 1;
+}
+
+static long nativeint_hash(value v)
+{
+  return Nativeint_val(v);
+}
+
+static void nativeint_serialize(value v, unsigned long * wsize_32,
+                            unsigned long * wsize_64)
+{
+  long l = Nativeint_val(v);
+#ifdef ARCH_SIXTYFOUR
+  if (l <= 0x7FFFFFFFL && l >= -0x80000000L) {
+    serialize_int_1(1);
+    serialize_int_4((int32) l);
+  } else {
+    serialize_int_1(2);
+    serialize_int_8(l);
+  }
+#else
+  serialize_int_1(1);
+  serialize_int_4(l);
+#endif
+  *wsize_32 = 4;
+  *wsize_64 = 8;
+}
+
+static unsigned long nativeint_deserialize(void * dst)
+{
+  switch (deserialize_uint_1()) {
+  case 1:
+    *((long *) dst) = deserialize_sint_4();
+    break;
+  case 2:
+#ifdef ARCH_SIXTYFOUR
+    *((long *) dst) = deserialize_sint_8();
+#else
+    deserialize_error("input_value: native integer value too large");
+#endif
+    break;
+  default:
+    deserialize_error("input_value: ill-formed native integer");
+  }
+  return sizeof(long);
+}
+
+CAMLexport struct custom_operations nativeint_ops = {
+  "_n",
+  custom_finalize_default,
+  nativeint_compare,
+  nativeint_hash,
+  nativeint_serialize,
+  nativeint_deserialize
+};
+
+CAMLexport value copy_nativeint(long i)
+{
+  value res = alloc_custom(&nativeint_ops, sizeof(long), 0, 1);
+  Nativeint_val(res) = i;
+  return res;
+}
+
+CAMLprim value nativeint_neg(value v)
+{ return copy_nativeint(- Nativeint_val(v)); }
+
+CAMLprim value nativeint_add(value v1, value v2)
+{ return copy_nativeint(Nativeint_val(v1) + Nativeint_val(v2)); }
+
+CAMLprim value nativeint_sub(value v1, value v2)
+{ return copy_nativeint(Nativeint_val(v1) - Nativeint_val(v2)); }
+
+CAMLprim value nativeint_mul(value v1, value v2)
+{ return copy_nativeint(Nativeint_val(v1) * Nativeint_val(v2)); }
+
+CAMLprim value nativeint_div(value v1, value v2)
+{
+  long divisor = Nativeint_val(v2);
+  if (divisor == 0) raise_zero_divide();
+  return copy_nativeint(Nativeint_val(v1) / divisor);
+}
+
+CAMLprim value nativeint_mod(value v1, value v2)
+{
+  long divisor = Nativeint_val(v2);
+  if (divisor == 0) raise_zero_divide();
+  return copy_nativeint(Nativeint_val(v1) % divisor);
+}
+
+CAMLprim value nativeint_and(value v1, value v2)
+{ return copy_nativeint(Nativeint_val(v1) & Nativeint_val(v2)); }
+
+CAMLprim value nativeint_or(value v1, value v2)
+{ return copy_nativeint(Nativeint_val(v1) | Nativeint_val(v2)); }
+
+CAMLprim value nativeint_xor(value v1, value v2)
+{ return copy_nativeint(Nativeint_val(v1) ^ Nativeint_val(v2)); }
+
+CAMLprim value nativeint_shift_left(value v1, value v2)
+{ return copy_nativeint(Nativeint_val(v1) << Int_val(v2)); }
+
+CAMLprim value nativeint_shift_right(value v1, value v2)
+{ return copy_nativeint(Nativeint_val(v1) >> Int_val(v2)); }
+
+CAMLprim value nativeint_shift_right_unsigned(value v1, value v2)
+{ return copy_nativeint((unsigned long)Nativeint_val(v1) >> Int_val(v2)); }
+
+CAMLprim value nativeint_of_int(value v)
+{ return copy_nativeint(Long_val(v)); }
+
+CAMLprim value nativeint_to_int(value v)
+{ return Val_long(Nativeint_val(v)); }
+
+CAMLprim value nativeint_of_float(value v)
+{ return copy_nativeint((long)(Double_val(v))); }
+
+CAMLprim value nativeint_to_float(value v)
+{ return copy_double((double)(Nativeint_val(v))); }
+
+CAMLprim value nativeint_of_int32(value v)
+{ return copy_nativeint(Int32_val(v)); }
+
+CAMLprim value nativeint_to_int32(value v)
+{ return copy_int32(Nativeint_val(v)); }
+
+CAMLprim value nativeint_format(value fmt, value arg)
+{
+  char format_string[FORMAT_BUFFER_SIZE];
+  char default_format_buffer[FORMAT_BUFFER_SIZE];
+  char * buffer;
+  value res;
+
+  buffer = parse_format(fmt, "l", format_string, default_format_buffer);
+  sprintf(buffer, format_string, (long) Nativeint_val(arg));
+  res = copy_string(buffer);
+  if (buffer != default_format_buffer) stat_free(buffer);
+  return res;
+}
+
+CAMLprim value nativeint_of_string(value s)
+{
+  return copy_nativeint(parse_long(String_val(s)));
+}
+
+
diff --git a/byterun/main.c b/byterun/main.c
new file mode 100644
index 0000000000..9afd3f2be6
--- /dev/null
+++ b/byterun/main.c
@@ -0,0 +1,46 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*         Xavier Leroy and Damien Doligez, 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 Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* Main entry point (can be overridden by a user-provided main()
+   function that calls caml_main() later). */
+
+#include "misc.h"
+#include "mlvalues.h"
+#include "sys.h"
+
+extern void caml_main (char **);
+
+#ifdef _WIN32
+extern void expand_command_line (int *, char ***);
+#endif
+
+#if macintosh
+#include "rotatecursor.h"
+#include "signals.h"
+#endif
+
+int main(int argc, char **argv)
+{
+#ifdef _WIN32
+  /* Expand wildcards and diversions in command line */
+  expand_command_line(&argc, &argv);
+#endif
+#if macintosh
+  rotatecursor_options (&something_to_do, 0, NULL);
+#endif /* macintosh */
+  caml_main(argv);
+  sys_exit(Val_int(0));
+  return 0; /* not reached */
+}
diff --git a/byterun/major_gc.c b/byterun/major_gc.c
new file mode 100644
index 0000000000..a7f2fb996b
--- /dev/null
+++ b/byterun/major_gc.c
@@ -0,0 +1,430 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*             Damien Doligez, projet Para, 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 Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+#include <limits.h>
+
+#include "compact.h"
+#include "custom.h"
+#include "config.h"
+#include "fail.h"
+#include "finalise.h"
+#include "freelist.h"
+#include "gc.h"
+#include "gc_ctrl.h"
+#include "major_gc.h"
+#include "misc.h"
+#include "mlvalues.h"
+#include "roots.h"
+#include "weak.h"
+
+unsigned long percent_free;
+long major_heap_increment;
+char *heap_start, *heap_end;
+page_table_entry *page_table;
+asize_t page_low, page_high;
+char *gc_sweep_hp;
+int gc_phase;        /* always Phase_mark, Phase_sweep, or Phase_idle */
+static value *gray_vals;
+value *gray_vals_cur, *gray_vals_end;
+static asize_t gray_vals_size;
+static int heap_is_pure;   /* The heap is pure if the only gray objects
+                              below [markhp] are also in [gray_vals]. */
+unsigned long allocated_words;
+double extra_heap_memory;
+extern char *fl_merge;  /* Defined in freelist.c. */
+
+static char *markhp, *chunk, *limit;
+
+static int gc_subphase;     /* Subphase_main, Subphase_weak, Subphase_final */
+#define Subphase_main 10
+#define Subphase_weak 11
+#define Subphase_final 12
+static value *weak_prev;
+
+static void realloc_gray_vals (void)
+{
+  value *new;
+
+  Assert (gray_vals_cur == gray_vals_end);
+  if (gray_vals_size < stat_heap_size / 128){
+    gc_message (0x08, "Growing gray_vals to %luk bytes\n",
+                (long) gray_vals_size * sizeof (value) / 512);
+    new = (value *) realloc ((char *) gray_vals,
+                             2 * gray_vals_size * sizeof (value));
+    if (new == NULL){
+      gc_message (0x08, "No room for growing gray_vals\n", 0);
+      gray_vals_cur = gray_vals;
+      heap_is_pure = 0;
+    }else{
+      gray_vals = new;
+      gray_vals_cur = gray_vals + gray_vals_size;
+      gray_vals_size *= 2;
+      gray_vals_end = gray_vals + gray_vals_size;
+    }
+  }else{
+    gray_vals_cur = gray_vals + gray_vals_size / 2;
+    heap_is_pure = 0;
+  }
+}
+
+void darken (value v, value *p /* not used */)
+{
+  if (Is_block (v) && Is_in_heap (v)) {
+    if (Tag_val(v) == Infix_tag) v -= Infix_offset_val(v);
+    if (Is_white_val (v)){
+      Hd_val (v) = Grayhd_hd (Hd_val (v));
+      *gray_vals_cur++ = v;
+      if (gray_vals_cur >= gray_vals_end) realloc_gray_vals ();
+    }
+  }
+}
+
+static void start_cycle (void)
+{
+  Assert (gc_phase == Phase_idle);
+  Assert (gray_vals_cur == gray_vals);
+  gc_message (0x01, "Starting new major GC cycle\n", 0);
+  darken_all_roots();
+  gc_phase = Phase_mark;
+  gc_subphase = Subphase_main;
+  markhp = NULL;
+#ifdef DEBUG
+  heap_check ();
+#endif
+}
+
+static void mark_slice (long work)
+{
+  value *gray_vals_ptr;  /* Local copy of gray_vals_cur */
+  value v, child;
+  header_t hd;
+  mlsize_t size, i;
+
+  gc_message (0x40, "Marking %ld words\n", work);
+  gray_vals_ptr = gray_vals_cur;
+  while (work > 0){
+    if (gray_vals_ptr > gray_vals){
+      v = *--gray_vals_ptr;
+      hd = Hd_val(v);
+      Assert (Is_gray_hd (hd));
+      Hd_val (v) = Blackhd_hd (hd);
+      size = Wosize_hd(hd);
+      if (Tag_hd (hd) < No_scan_tag){
+        for (i = 0; i < size; i++){
+          child = Field (v, i);
+        mark_again:
+          if (Is_block (child) && Is_in_heap (child)) {
+            hd = Hd_val(child);
+            if (Tag_hd (hd) == Forward_tag){
+              child = Forward_val (child);
+              Field (v, i) = child;
+              goto mark_again;
+            }
+            if (Tag_hd(hd) == Infix_tag) {
+              child -= Infix_offset_val(child);
+              hd = Hd_val(child);
+            }
+            if (Is_white_hd (hd)){
+              Hd_val (child) = Grayhd_hd (hd);
+              *gray_vals_ptr++ = child;
+              if (gray_vals_ptr >= gray_vals_end) {
+                gray_vals_cur = gray_vals_ptr;
+                realloc_gray_vals ();
+                gray_vals_ptr = gray_vals_cur;
+              }
+            }
+          }
+        }
+      }
+      work -= Whsize_wosize(size);
+    }else if (markhp != NULL){
+      if (markhp == limit){
+        chunk = Chunk_next (chunk);
+        if (chunk == NULL){
+          markhp = NULL;
+        }else{
+          markhp = chunk;
+          limit = chunk + Chunk_size (chunk);
+        }
+      }else{
+        if (Is_gray_val (Val_hp (markhp))){
+          Assert (gray_vals_ptr == gray_vals);
+          *gray_vals_ptr++ = Val_hp (markhp);
+        }
+        markhp += Bhsize_hp (markhp);
+      }
+    }else if (!heap_is_pure){
+      heap_is_pure = 1;
+      chunk = heap_start;
+      markhp = chunk;
+      limit = chunk + Chunk_size (chunk);
+    }else if (gc_subphase == Subphase_main){
+      /* The main marking phase is over.  Start removing weak pointers to
+         dead values. */
+      gc_subphase = Subphase_weak;
+      weak_prev = &weak_list_head;
+    }else if (gc_subphase == Subphase_weak){
+      value cur, curfield;
+      mlsize_t sz, i;
+      header_t hd;
+
+      cur = *weak_prev;
+      if (cur != NULL){
+        hd = Hd_val (cur);
+        if (Color_hd (hd) == Caml_white){
+          /* The whole array is dead, remove it from the list. */
+          *weak_prev = Field (cur, 0);
+        }else{
+          sz = Wosize_hd (hd);
+          for (i = 1; i < sz; i++){
+            curfield = Field (cur, i);
+          weak_again:
+            if (curfield != 0 && Is_block (curfield) && Is_in_heap (curfield)
+                && Is_white_val (curfield)){
+              if (Tag_val (curfield) == Forward_tag){
+                curfield = Forward_val (curfield);
+                Field (cur, i) = curfield;
+                goto weak_again;
+              }
+              Field (cur, i) = 0;
+            }
+          }
+          weak_prev = &Field (cur, 0);
+        }
+        work -= Whsize_hd (hd);
+      }else{
+        Assert (weak_prev == NULL);
+        /* Subphase_weak is done.  Handle finalised values. */
+        gray_vals_cur = gray_vals_ptr;
+        final_update ();
+        gray_vals_ptr = gray_vals_cur;
+        gc_subphase = Subphase_final;
+      }
+    }else{
+      Assert (gc_subphase == Subphase_final);
+      /* Initialise the sweep phase. */
+      gray_vals_cur = gray_vals_ptr;
+      gc_sweep_hp = heap_start;
+      fl_init_merge ();
+      gc_phase = Phase_sweep;
+      chunk = heap_start;
+      gc_sweep_hp = chunk;
+      limit = chunk + Chunk_size (chunk);
+      work = 0;
+    }
+  }
+  gray_vals_cur = gray_vals_ptr;
+}
+
+static void sweep_slice (long work)
+{
+  char *hp;
+  header_t hd;
+
+  gc_message (0x40, "Sweeping %ld words\n", work);
+  while (work > 0){
+    if (gc_sweep_hp < limit){
+      hp = gc_sweep_hp;
+      hd = Hd_hp (hp);
+      work -= Whsize_hd (hd);
+      gc_sweep_hp += Bhsize_hd (hd);
+      switch (Color_hd (hd)){
+      case Caml_white:
+        if (Tag_hd (hd) == Custom_tag){
+          void (*final_fun)(value) = Custom_ops_val(Val_hp(hp))->finalize;
+          if (final_fun != NULL) final_fun(Val_hp(hp));
+        }
+        gc_sweep_hp = fl_merge_block (Bp_hp (hp));
+        break;
+      case Caml_blue:
+        /* Only the blocks of the free-list are blue.  See [freelist.c]. */
+        fl_merge = Bp_hp (hp);
+        break;
+      default:          /* gray or black */
+        Assert (Color_hd (hd) == Caml_black);
+        Hd_hp (hp) = Whitehd_hd (hd);
+        break;
+      }
+      Assert (gc_sweep_hp <= limit);
+    }else{
+      chunk = Chunk_next (chunk);
+      if (chunk == NULL){
+        /* Sweeping is done. */
+        ++ stat_major_collections;
+        work = 0;
+        gc_phase = Phase_idle;
+      }else{
+        gc_sweep_hp = chunk;
+        limit = chunk + Chunk_size (chunk);
+      }
+    }
+  }
+}
+
+/* The main entry point for the GC.  Called after each minor GC.
+   [howmuch] is the amount of work to do, 0 to let the GC compute it.
+   Return the computed amount of work to do.
+ */
+long major_collection_slice (long howmuch)
+{
+  double p;
+  long computed_work;
+  /*
+     Free memory at the start of the GC cycle (garbage + free list) (assumed):
+                 FM = stat_heap_size * percent_free / (100 + percent_free)
+     Garbage at the start of the GC cycle:
+                 G = FM * 2/3
+     Proportion of free memory consumed since the previous slice:
+                 PH = allocated_words / G
+                    = 3 * allocated_words * (100 + percent_free)
+                      / (2 * stat_heap_size * percent_free)
+     Proportion of extra-heap memory consumed since the previous slice:
+                 PE = extra_heap_memory
+     Proportion of total work to do in this slice:
+                 P  = max (PH, PE)
+     Amount of marking work for the GC cycle:
+                 MW = stat_heap_size * 100 / (100 + percent_free)
+     Amount of sweeping work for the GC cycle:
+                 SW = stat_heap_size
+     Amount of marking work for this slice:
+                 MS = P * MW
+                 MS = P * stat_heap_size * 100 / (100 + percent_free)
+     Amount of sweeping work for this slice:
+                 SS = P * SW
+                 SS = P * stat_heap_size
+     This slice will either mark 2*MS words or sweep 2*SS words.
+  */
+
+#define Margin 100  /* Make it a little faster to be on the safe side. */
+
+  if (gc_phase == Phase_idle) start_cycle ();
+
+  p = 1.5 * allocated_words * (100 + percent_free)
+      / stat_heap_size / percent_free;
+  if (p < extra_heap_memory) p = extra_heap_memory;
+
+  gc_message (0x40, "allocated_words = %lu\n", allocated_words);
+  gc_message (0x40, "extra_heap_memory = %luu\n",
+              (unsigned long) (extra_heap_memory * 1000000));
+  gc_message (0x40, "amount of work to do = %luu\n",
+              (unsigned long) (p * 1000000));
+
+  if (gc_phase == Phase_mark){
+    computed_work = (long) (p * stat_heap_size * 100 / (100+percent_free));
+  }else{
+    computed_work = (long) (p * stat_heap_size);
+  }
+  computed_work += Margin;
+  gc_message (0x40, "ordered work = %ld words\n", howmuch);
+  gc_message (0x40, "computed work = %ld words\n", computed_work);
+  if (howmuch == 0) howmuch = computed_work;
+  if (gc_phase == Phase_mark){
+    mark_slice (howmuch);
+    gc_message (0x02, "!", 0);
+  }else{
+    Assert (gc_phase == Phase_sweep);
+    sweep_slice (howmuch);
+    gc_message (0x02, "$", 0);
+  }
+
+  if (gc_phase == Phase_idle) compact_heap_maybe ();
+
+  stat_major_words += allocated_words;
+  allocated_words = 0;
+  extra_heap_memory = 0.0;
+  return computed_work;
+}
+
+/* The minor heap must be empty when this function is called;
+   the minor heap is empty when this function returns.
+*/
+/* This does not call compact_heap_maybe because the estimations of
+   free and live memory are only valid for a cycle done incrementally.
+   Besides, this function is called by compact_heap_maybe.
+*/
+void finish_major_cycle (void)
+{
+  if (gc_phase == Phase_idle) start_cycle ();
+  while (gc_phase == Phase_mark) mark_slice (LONG_MAX);
+  Assert (gc_phase == Phase_sweep);
+  while (gc_phase == Phase_sweep) sweep_slice (LONG_MAX);
+  Assert (gc_phase == Phase_idle);
+  stat_major_words += allocated_words;
+  allocated_words = 0;
+}
+
+asize_t round_heap_chunk_size (asize_t request)
+{                            Assert (major_heap_increment >= Heap_chunk_min);
+  if (request < major_heap_increment){
+                              Assert (major_heap_increment % Page_size == 0);
+    return major_heap_increment;
+  }else if (request <= Heap_chunk_max){
+    return ((request + Page_size - 1) >> Page_log) << Page_log;
+  }else{
+    raise_out_of_memory ();
+    /* not reached */ return 0;
+  }
+}
+
+void init_major_heap (asize_t heap_size)
+{
+  asize_t i;
+  void *block;
+  asize_t page_table_size;
+  page_table_entry *page_table_block;
+
+  stat_heap_size = round_heap_chunk_size (heap_size);
+  stat_top_heap_size = stat_heap_size;
+  Assert (stat_heap_size % Page_size == 0);
+  heap_start = aligned_malloc (stat_heap_size + sizeof (heap_chunk_head),
+                               sizeof (heap_chunk_head), &block);
+  if (heap_start == NULL)
+    fatal_error ("Fatal error: not enough memory for the initial heap.\n");
+  heap_start += sizeof (heap_chunk_head);
+  Assert ((unsigned long) heap_start % Page_size == 0);
+  Chunk_size (heap_start) = stat_heap_size;
+  Chunk_next (heap_start) = NULL;
+  Chunk_block (heap_start) = block;
+  heap_end = heap_start + stat_heap_size;
+  Assert ((unsigned long) heap_end % Page_size == 0);
+
+  page_low = Page (heap_start);
+  page_high = Page (heap_end);
+
+  page_table_size = page_high - page_low;
+  page_table_block =
+    (page_table_entry *) malloc (page_table_size * sizeof (page_table_entry));
+  if (page_table_block == NULL){
+    fatal_error ("Fatal error: not enough memory for the initial heap.\n");
+  }
+  page_table = page_table_block - page_low;
+  for (i = Page (heap_start); i < Page (heap_end); i++){
+    page_table [i] = In_heap;
+  }
+
+  Hd_hp (heap_start) = Make_header (Wosize_bhsize(stat_heap_size),0,Caml_blue);
+  fl_init_merge ();
+  fl_merge_block (Bp_hp (heap_start));
+  gc_phase = Phase_idle;
+  gray_vals_size = 2048;
+  gray_vals = (value *) malloc (gray_vals_size * sizeof (value));
+  if (gray_vals == NULL)
+    fatal_error ("Fatal error: not enough memory for the initial heap.\n");
+  gray_vals_cur = gray_vals;
+  gray_vals_end = gray_vals + gray_vals_size;
+  heap_is_pure = 1;
+  allocated_words = 0;
+  extra_heap_memory = 0.0;
+}
diff --git a/byterun/major_gc.h b/byterun/major_gc.h
new file mode 100644
index 0000000000..ac6b6fa6b9
--- /dev/null
+++ b/byterun/major_gc.h
@@ -0,0 +1,72 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*             Damien Doligez, projet Para, 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 Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+#ifndef _major_gc_
+#define _major_gc_
+
+
+#include "freelist.h"
+#include "misc.h"
+
+typedef struct {
+  void *block;           /* address of the malloced block this chunk live in */
+  asize_t alloc;         /* in bytes, used for compaction */
+  asize_t size;          /* in bytes */
+  char *next;
+} heap_chunk_head;
+
+#define Chunk_size(c) (((heap_chunk_head *) (c)) [-1]).size
+#define Chunk_alloc(c) (((heap_chunk_head *) (c)) [-1]).alloc
+#define Chunk_next(c) (((heap_chunk_head *) (c)) [-1]).next
+#define Chunk_block(c) (((heap_chunk_head *) (c)) [-1]).block
+
+extern int gc_phase;
+extern unsigned long allocated_words;
+extern double extra_heap_memory;
+
+#define Phase_mark 0
+#define Phase_sweep 1
+#define Phase_idle 2
+
+#ifdef __alpha
+typedef int page_table_entry;
+#else
+typedef char page_table_entry;
+#endif
+
+CAMLextern char *heap_start;
+CAMLextern char *heap_end;
+extern unsigned long total_heap_size;
+CAMLextern page_table_entry *page_table;
+extern asize_t page_low, page_high;
+extern char *gc_sweep_hp;
+
+#define In_heap 1
+#define Not_in_heap 0
+#define Page(p) ((unsigned long) (p) >> Page_log)
+#define Is_in_heap(p) \
+  (Assert (Is_block (p)), \
+   (addr)(p) >= (addr)heap_start && (addr)(p) < (addr)heap_end \
+   && page_table [Page (p)])
+
+void init_major_heap (asize_t);
+asize_t round_heap_chunk_size (asize_t);
+void darken (value, value *);
+long major_collection_slice (long);
+void major_collection (void);
+void finish_major_cycle (void);
+
+
+#endif /* _major_gc_ */
diff --git a/byterun/memory.c b/byterun/memory.c
new file mode 100644
index 0000000000..6349887c3c
--- /dev/null
+++ b/byterun/memory.c
@@ -0,0 +1,341 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*             Damien Doligez, projet Para, 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 Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+#include <stdlib.h>
+#include <string.h>
+#include "fail.h"
+#include "freelist.h"
+#include "gc.h"
+#include "gc_ctrl.h"
+#include "major_gc.h"
+#include "memory.h"
+#include "minor_gc.h"
+#include "misc.h"
+#include "mlvalues.h"
+#include "signals.h"
+
+/* Allocate a block of the requested size, to be passed to
+   [add_to_heap] later.
+   [request] must be a multiple of [Page_size].
+   [alloc_for_heap] returns NULL if the request cannot be satisfied.
+   The returned pointer is a hp, but the header must be initialized by
+   the caller.
+*/
+header_t *alloc_for_heap (asize_t request)
+{
+  char *mem;
+  void *block;
+                                              Assert (request % Page_size == 0);
+  mem = aligned_malloc (request + sizeof (heap_chunk_head),
+                        sizeof (heap_chunk_head), &block);
+  if (mem == NULL) return NULL;
+  mem += sizeof (heap_chunk_head);
+  Chunk_size (mem) = request;
+  Chunk_block (mem) = block;
+  return (header_t *) mem;
+}
+
+/* Use this function to free a block allocated with [alloc_for_heap]
+   if you don't add it with [add_to_heap].
+*/
+void free_for_heap (header_t *mem)
+{
+  free (Chunk_block (mem));
+}
+
+/* Take a block of memory as argument, which must be the result of a
+   call to [alloc_for_heap], and insert it into the heap chaining.
+   The contents of the block must be a sequence of valid blocks and
+   fragments: no space between blocks and no trailing garbage.  If
+   some blocks are blue, they must be added to the free list by the
+   caller.  All other blocks must have the color [allocation_color(mem)].
+   The caller must update [allocated_words] if applicable.
+   Return value: 0 if no error; -1 in case of error.
+*/
+int add_to_heap (header_t *mem)
+{
+  asize_t i;
+  char *m = (char *) mem;
+                                     Assert (Chunk_size (m) % Page_size == 0);
+#ifdef DEBUG
+  /* Should check the contents of the block. */
+#endif /* debug */
+
+  /* Extend the page table as needed. */
+  if (Page (m) < page_low){
+    page_table_entry *block, *new_page_table;
+    asize_t new_page_low = Page (m);
+    asize_t new_size = page_high - new_page_low;
+    
+    gc_message (0x08, "Growing page table to %lu entries\n", new_size);
+    block = malloc (new_size * sizeof (page_table_entry));
+    if (block == NULL){
+      gc_message (0x08, "No room for growing page table\n", 0);
+      return -1;
+    }
+    new_page_table = block - new_page_low;
+    for (i = new_page_low; i < page_low; i++) new_page_table [i] = Not_in_heap;
+    for (i = page_low; i < page_high; i++) new_page_table [i] = page_table [i];
+    free (page_table + page_low);
+    page_table = new_page_table;
+    page_low = new_page_low;
+  }
+  if (Page (m + Chunk_size (m)) > page_high){
+    page_table_entry *block, *new_page_table;
+    asize_t new_page_high = Page (m + Chunk_size (m));
+    asize_t new_size = new_page_high - page_low;
+    
+    gc_message (0x08, "Growing page table to %lu entries\n", new_size);
+    block = malloc (new_size * sizeof (page_table_entry));
+    if (block == NULL){
+      gc_message (0x08, "No room for growing page table\n", 0);
+      return -1;
+    }
+    new_page_table = block - page_low;
+    for (i = page_low; i < page_high; i++) new_page_table [i] = page_table [i];
+    for (i = page_high; i < new_page_high; i++){
+      new_page_table [i] = Not_in_heap;
+    }
+    free (page_table + page_low);
+    page_table = new_page_table;
+    page_high = new_page_high;
+  }
+
+  /* Mark the pages as being in the heap. */
+  for (i = Page (m); i < Page (m + Chunk_size (m)); i++){
+    page_table [i] = In_heap;
+  }
+
+  /* Chain this heap block. */
+  {
+    char **last = &heap_start;
+    char *cur = *last;
+
+    while (cur != NULL && cur < m){
+      last = &(Chunk_next (cur));
+      cur = *last;
+    }
+    Chunk_next (m) = cur;
+    *last = m;
+  }
+
+  /* Update the heap bounds as needed. */
+  /* already done:   if (m < heap_start) heap_start = m; */
+  if (m + Chunk_size (m) > heap_end) heap_end = m + Chunk_size (m);
+
+  stat_heap_size += Chunk_size (m);
+  if (stat_heap_size > stat_top_heap_size) stat_top_heap_size = stat_heap_size;
+  return 0;
+}
+
+/* Allocate more memory from malloc for the heap.
+   Return a blue block of at least the requested size (in words).
+   The caller must insert the block into the free list.
+   Return NULL when out of memory.
+*/
+static char *expand_heap (mlsize_t request)
+{
+  header_t *mem;
+  asize_t malloc_request;
+
+  malloc_request = round_heap_chunk_size (Bhsize_wosize (request));
+  gc_message (0x04, "Growing heap to %luk bytes\n",
+              (stat_heap_size + malloc_request) / 1024);
+  mem = alloc_for_heap (malloc_request);
+  if (mem == NULL){
+    gc_message (0x04, "No room for growing heap\n", 0);
+    return NULL;
+  }
+  Assert (Wosize_bhsize (malloc_request) >= request);
+  Hd_hp (mem) = Make_header (Wosize_bhsize (malloc_request), 0, Caml_blue);
+
+  if (add_to_heap (mem) != 0){
+    free (mem);
+    return NULL;
+  }
+  return Bp_hp (mem);
+}
+
+/* Remove the heap chunk [chunk] from the heap and give the memory back
+   to [free].
+*/
+void shrink_heap (char *chunk)
+{
+  char **cp;
+  int i;
+
+  /* Never deallocate the first block, because heap_start is both the
+     first block and the base address for page numbers, and we don't
+     want to shift the page table, it's too messy (see above).
+     It will never happen anyway, because of the way compaction works.
+     (see compact.c)
+  */
+  if (chunk == heap_start) return;
+
+  stat_heap_size -= Chunk_size (chunk);
+  gc_message (0x04, "Shrinking heap to %luk bytes\n", stat_heap_size / 1024);
+
+#ifdef DEBUG
+  {
+    mlsize_t i;
+    for (i = 0; i < Wsize_bsize (Chunk_size (chunk)); i++){
+      ((value *) chunk) [i] = Debug_free_shrink;
+    }
+  }
+#endif
+
+  /* Remove [chunk] from the list of chunks. */
+  cp = &heap_start;
+  while (*cp != chunk) cp = &(Chunk_next (*cp));
+  *cp = Chunk_next (chunk);
+
+  /* Remove the pages of [chunk] from the page table. */
+  for (i = Page (chunk); i < Page (chunk + Chunk_size (chunk)); i++){
+    page_table [i] = Not_in_heap;
+  }
+
+  /* Free the [malloc] block that contains [chunk]. */
+  free (Chunk_block (chunk));
+}
+
+color_t allocation_color (void *hp)
+{
+  if (gc_phase == Phase_mark
+      || (gc_phase == Phase_sweep && (addr)hp >= (addr)gc_sweep_hp)){
+    return Caml_black;
+  }else{
+    Assert (gc_phase == Phase_idle
+            || (gc_phase == Phase_sweep && (addr)hp < (addr)gc_sweep_hp));
+    return Caml_white;
+  }
+}
+
+value alloc_shr (mlsize_t wosize, tag_t tag)
+{
+  char *hp, *new_block;
+
+  if (wosize > Max_wosize) raise_out_of_memory ();
+  hp = fl_allocate (wosize);
+  if (hp == NULL){
+    new_block = expand_heap (wosize);
+    if (new_block == NULL) {
+      if (in_minor_collection)
+        fatal_error ("Fatal error: out of memory.\n");
+      else
+        raise_out_of_memory ();
+    }
+    fl_add_block (new_block);
+    hp = fl_allocate (wosize);
+  }
+
+  Assert (Is_in_heap (Val_hp (hp)));
+
+  /* Inline expansion of allocation_color. */
+  if (gc_phase == Phase_mark
+      || (gc_phase == Phase_sweep && (addr)hp >= (addr)gc_sweep_hp)){
+    Hd_hp (hp) = Make_header (wosize, tag, Caml_black);
+  }else{
+    Assert (gc_phase == Phase_idle
+            || (gc_phase == Phase_sweep && (addr)hp < (addr)gc_sweep_hp));
+    Hd_hp (hp) = Make_header (wosize, tag, Caml_white);
+  }
+  Assert (Hd_hp (hp) == Make_header (wosize, tag, allocation_color (hp)));
+  allocated_words += Whsize_wosize (wosize);
+  if (allocated_words > Wsize_bsize (minor_heap_size)) urge_major_slice ();
+#ifdef DEBUG
+  {
+    unsigned long i;
+    for (i = 0; i < wosize; i++){
+      Field (Val_hp (hp), i) = Debug_uninit_major;
+    }
+  }
+#endif
+  return Val_hp (hp);
+}
+
+/* Use this function to tell the major GC to speed up when you use
+   finalized blocks to automatically deallocate extra-heap stuff.
+   The GC will do at least one cycle every [max] allocated words;
+   [mem] is the number of words allocated this time.
+   Note that only [mem/max] is relevant.  You can use numbers of bytes
+   (or kilobytes, ...) instead of words.  You can change units between
+   calls to [adjust_gc_speed].
+*/
+void adjust_gc_speed (mlsize_t mem, mlsize_t max)
+{
+  if (max == 0) max = 1;
+  if (mem > max) mem = max;
+  extra_heap_memory += (double) mem / (double) max;
+  if (extra_heap_memory > 1.0){
+    extra_heap_memory = 1.0;
+    urge_major_slice ();
+  }
+  if (extra_heap_memory > (double) Wsize_bsize (minor_heap_size)
+                          / 2.0 / (double) stat_heap_size) {
+    urge_major_slice ();
+  }
+}
+
+/* You must use [initialize] to store the initial value in a field of
+   a shared block, unless you are sure the value is not a young block.
+   A block value [v] is a shared block if and only if [Is_in_heap (v)]
+   is true.
+*/
+/* [initialize] never calls the GC, so you may call it while an block is
+   unfinished (i.e. just after a call to [alloc_shr].) */
+void initialize (value *fp, value val)
+{
+  *fp = val;
+  if (Is_block (val) && Is_young (val) && Is_in_heap (fp)){
+    *ref_table_ptr++ = fp;
+    if (ref_table_ptr >= ref_table_limit){
+      realloc_ref_table ();
+    }
+  }
+}
+
+/* You must use [modify] to change a field of an existing shared block,
+   unless you are sure the value being overwritten is not a shared block and
+   the value being written is not a young block. */
+/* [modify] never calls the GC. */
+void modify (value *fp, value val)
+{
+  Modify (fp, val);
+}
+
+void * stat_alloc (asize_t sz)
+{
+  void * result = malloc (sz);
+
+  /* malloc() may return NULL if size is 0 */
+  if (result == NULL && sz != 0) raise_out_of_memory ();
+#ifdef DEBUG
+  memset (result, Debug_uninit_stat, sz);
+#endif
+  return result;
+}
+
+void stat_free (void * blk)
+{
+  free (blk);
+}
+
+void * stat_resize (void * blk, asize_t sz)
+{
+  void * result = realloc (blk, sz);
+
+  if (result == NULL) raise_out_of_memory ();
+  return result;
+}
diff --git a/byterun/minor_gc.c b/byterun/minor_gc.c
new file mode 100644
index 0000000000..e6ecfcd46f
--- /dev/null
+++ b/byterun/minor_gc.c
@@ -0,0 +1,242 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*             Damien Doligez, projet Para, 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 Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+#include <string.h>
+#include "config.h"
+#include "fail.h"
+#include "finalise.h"
+#include "gc.h"
+#include "gc_ctrl.h"
+#include "major_gc.h"
+#include "memory.h"
+#include "minor_gc.h"
+#include "misc.h"
+#include "mlvalues.h"
+#include "roots.h"
+#include "signals.h"
+
+asize_t minor_heap_size;
+char *young_start = NULL, *young_end = NULL;
+char *young_ptr = NULL, *young_limit = NULL;
+static value **ref_table = NULL, **ref_table_end, **ref_table_threshold;
+value **ref_table_ptr = NULL, **ref_table_limit;
+static asize_t ref_table_size, ref_table_reserve;
+int in_minor_collection = 0;
+
+void set_minor_heap_size (asize_t size)
+{
+  char *new_heap;
+  value **new_table;
+
+  Assert (size >= Minor_heap_min);
+  Assert (size <= Minor_heap_max);
+  Assert (size % sizeof (value) == 0);
+  if (young_ptr != young_end) minor_collection ();
+                                           Assert (young_ptr == young_end);
+  new_heap = (char *) stat_alloc (size);
+  if (young_start != NULL){
+    stat_free (young_start);
+  }
+  young_start = new_heap;
+  young_end = new_heap + size;
+  young_limit = young_start;
+  young_ptr = young_end;
+  minor_heap_size = size;
+
+  ref_table_size = minor_heap_size / sizeof (value) / 8;
+  ref_table_reserve = 256;
+  new_table = (value **) stat_alloc ((ref_table_size + ref_table_reserve)
+                                     * sizeof (value *));
+  if (ref_table != NULL) stat_free (ref_table);
+  ref_table = new_table;
+  ref_table_ptr = ref_table;
+  ref_table_threshold = ref_table + ref_table_size;
+  ref_table_limit = ref_table_threshold;
+  ref_table_end = ref_table + ref_table_size + ref_table_reserve;
+}
+
+static value oldify_todo_list = 0;
+
+/* Note that the tests on the tag depend on the fact that Infix_tag,
+   Forward_tag, and No_scan_tag are contiguous. */
+
+void oldify_one (value v, value *p)
+{
+  value result, field0;
+  header_t hd;
+  mlsize_t sz, i;
+  tag_t tag;
+
+ tail_call:
+  if (Is_block (v) && Is_young (v)){
+    Assert (Hp_val (v) >= young_ptr);
+    hd = Hd_val (v);
+    if (hd == 0){         /* If already forwarded */
+      *p = Field (v, 0);  /*  then forward pointer is first field. */
+    }else{
+      tag = Tag_hd (hd);
+      if (tag < Infix_tag){
+        sz = Wosize_hd (hd);
+        result = alloc_shr (sz, tag);
+        *p = result;
+        field0 = Field (v, 0);
+        Hd_val (v) = 0;            /* Set forward flag */
+        Field (v, 0) = result;     /*  and forward pointer. */
+        if (sz > 1){
+          Field (result, 0) = field0;
+          Field (result, 1) = oldify_todo_list;    /* Add this block */
+          oldify_todo_list = v;                    /*  to the "to do" list. */
+	}else{
+          Assert (sz == 1);
+          p = &Field (result, 0);
+	  v = field0;
+          goto tail_call;
+	}
+      }else if (tag >= No_scan_tag){
+        sz = Wosize_hd (hd);
+        result = alloc_shr (sz, tag);
+        for (i = 0; i < sz; i++) Field (result, i) = Field (v, i);
+        Hd_val (v) = 0;            /* Set forward flag */
+        Field (v, 0) = result;     /*  and forward pointer. */
+        *p = result;
+      }else if (tag == Infix_tag){
+        mlsize_t offset = Infix_offset_hd (hd);
+        oldify_one (v - offset, p);   /* This cannot recurse deeper than 1. */
+        *p += offset;
+      }else{
+        Assert (tag == Forward_tag);
+        v = Forward_val (v);          /* Follow the forwarding */
+        goto tail_call;               /*  then oldify. */
+      }
+    }
+  }else{
+    *p = v;
+  }
+}
+
+/* Finish the work that was put off by oldify_one.
+   Note that oldify_one itself is called by oldify_mopup, so we
+   have to be careful to remove the first entry from the list before
+   oldifying its fields. */
+void oldify_mopup (void)
+{
+  value v, new_v, f;
+  mlsize_t i;
+
+  while (oldify_todo_list != 0){
+    v = oldify_todo_list;                /* Get the head. */
+    Assert (Hd_val (v) == 0);            /* It must be forwarded. */
+    new_v = Field (v, 0);                /* Follow forward pointer. */
+    oldify_todo_list = Field (new_v, 1); /* Remove from list. */
+
+    f = Field (new_v, 0);
+    if (Is_block (f) && Is_young (f)){
+      oldify_one (f, &Field (new_v, 0));
+    }
+    for (i = 1; i < Wosize_val (new_v); i++){
+      f = Field (v, i);
+      if (Is_block (f) && Is_young (f)){
+        oldify_one (f, &Field (new_v, i));
+      }else{
+        Field (new_v, i) = f;
+      }
+    }
+  }
+}
+
+/* Make sure the minor heap is empty by performing a minor collection
+   if needed.
+*/
+void empty_minor_heap (void)
+{
+  value **r;
+
+  if (young_ptr != young_end){
+    in_minor_collection = 1;
+    gc_message (0x02, "<", 0);
+    oldify_local_roots();
+    for (r = ref_table; r < ref_table_ptr; r++) oldify_one (**r, *r);
+    oldify_mopup ();
+    if (young_ptr < young_limit) young_ptr = young_limit;
+    stat_minor_words += Wsize_bsize (young_end - young_ptr);
+    young_ptr = young_end;
+    ref_table_ptr = ref_table;
+    ref_table_limit = ref_table_threshold;
+    gc_message (0x02, ">", 0);
+    in_minor_collection = 0;
+  }
+  final_empty_young ();
+#ifdef DEBUG
+  {
+    value *p;
+    for (p = (value *) young_start; p < (value *) young_end; ++p){
+      *p = Debug_free_minor;
+    }
+  }
+#endif
+}
+
+/* Do a minor collection and a slice of major collection, call finalisation
+   functions, etc.
+   Leave the minor heap empty.
+*/
+void minor_collection (void)
+{
+  long prev_alloc_words = allocated_words;
+
+  empty_minor_heap ();
+
+  stat_promoted_words += allocated_words - prev_alloc_words;
+  ++ stat_minor_collections;
+  major_collection_slice (0);
+  force_major_slice = 0;
+
+  final_do_calls ();
+
+  empty_minor_heap ();
+}
+
+value check_urgent_gc (value extra_root)
+{
+  CAMLparam1 (extra_root);
+  if (force_major_slice) minor_collection();
+  CAMLreturn (extra_root);
+}
+
+void realloc_ref_table (void)
+{                                 Assert (ref_table_ptr == ref_table_limit);
+                                  Assert (ref_table_limit <= ref_table_end);
+                            Assert (ref_table_limit >= ref_table_threshold);
+
+  if (ref_table_limit == ref_table_threshold){
+    gc_message (0x08, "ref_table threshold crossed\n", 0);
+    ref_table_limit = ref_table_end;
+    urge_major_slice ();
+  }else{ /* This will almost never happen with the bytecode interpreter. */
+    asize_t sz;
+    asize_t cur_ptr = ref_table_ptr - ref_table;
+                                                  Assert (force_major_slice);
+
+    ref_table_size *= 2;
+    sz = (ref_table_size + ref_table_reserve) * sizeof (value *);
+    gc_message (0x08, "Growing ref_table to %ldk bytes\n", (long) sz / 1024);
+    ref_table = (value **) realloc ((char *) ref_table, sz);
+    if (ref_table == NULL) fatal_error ("Fatal error: ref_table overflow\n");
+    ref_table_end = ref_table + ref_table_size + ref_table_reserve;
+    ref_table_threshold = ref_table + ref_table_size;
+    ref_table_ptr = ref_table + cur_ptr;
+    ref_table_limit = ref_table_end;
+  }
+}
diff --git a/byterun/minor_gc.h b/byterun/minor_gc.h
new file mode 100644
index 0000000000..7e7d894ac1
--- /dev/null
+++ b/byterun/minor_gc.h
@@ -0,0 +1,46 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*             Damien Doligez, projet Para, 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 Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+#ifndef _minor_gc_
+#define _minor_gc_
+
+
+#include "misc.h"
+
+CAMLextern char *young_start, *young_ptr, *young_end, *young_limit;
+CAMLextern value **ref_table_ptr, **ref_table_limit;
+extern asize_t minor_heap_size;
+extern int in_minor_collection;
+
+#define Is_young(val) \
+  (Assert (Is_block (val)), \
+   (addr)(val) < (addr)young_end && (addr)(val) > (addr)young_start)
+
+extern void set_minor_heap_size (asize_t);
+extern void empty_minor_heap (void);
+CAMLextern void minor_collection (void);
+CAMLextern void garbage_collection (void); /* for the native-code system */
+extern void realloc_ref_table (void);
+extern void oldify_one (value, value *);
+extern void oldify_mopup (void);
+
+#define Oldify(p) do{ \
+    value __oldify__v__ = *p; \
+    if (Is_block (__oldify__v__) && Is_young (__oldify__v__)){ \
+      oldify_one (__oldify__v__, (p)); \
+    } \
+  }while(0)
+
+#endif /* _minor_gc_ */
diff --git a/byterun/misc.c b/byterun/misc.c
new file mode 100644
index 0000000000..536bd1b4a8
--- /dev/null
+++ b/byterun/misc.c
@@ -0,0 +1,139 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*         Xavier Leroy and Damien Doligez, 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 Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+#include <stdio.h>
+#include "config.h"
+#include "misc.h"
+#include "memory.h"
+#ifdef HAS_UI
+#include "ui.h"
+#endif
+
+#ifdef DEBUG
+
+int caml_failed_assert (char * expr, char * file, int line)
+{
+  fprintf (stderr, "file %s; line %d ### Assertion failed: %s\n",
+           file, line, expr);
+  fflush (stderr);
+  exit (100);
+  return 1; /* not reached */
+}
+
+#endif
+
+unsigned long verb_gc = 0;
+
+void gc_message (int level, char *msg, unsigned long arg)
+{
+  if (level < 0 || (verb_gc & level) != 0){
+#ifdef HAS_UI
+    ui_print_stderr(msg, (void *) arg);
+#else
+    fprintf (stderr, msg, arg);
+    fflush (stderr);
+#endif
+  }
+}
+
+void fatal_error (char *msg)
+{
+#ifdef HAS_UI
+  ui_print_stderr("%s", msg);
+  ui_exit (2);
+#else
+  fprintf (stderr, "%s", msg);
+  exit(2);
+#endif
+}
+
+void fatal_error_arg (char *fmt, char *arg)
+{
+#ifdef HAS_UI
+  ui_print_stderr(fmt, arg);
+  ui_exit (2);
+#else
+  fprintf (stderr, fmt, arg);
+  exit(2);
+#endif
+}
+
+void fatal_error_arg2 (char *fmt1, char *arg1, char *fmt2, char *arg2)
+{
+#ifdef HAS_UI
+  ui_print_stderr(fmt1, arg1);
+  ui_print_stderr(fmt2, arg2);
+  ui_exit (2);
+#else
+  fprintf (stderr, fmt1, arg1);
+  fprintf (stderr, fmt2, arg2);
+  exit(2);
+#endif
+}
+
+char *aligned_malloc (asize_t size, int modulo, void **block)
+{
+  char *raw_mem;
+  unsigned long aligned_mem;
+                                                  Assert (modulo < Page_size);
+  raw_mem = (char *) malloc (size + Page_size);
+  if (raw_mem == NULL) return NULL;
+  *block = raw_mem;
+  raw_mem += modulo;                /* Address to be aligned */
+  aligned_mem = (((unsigned long) raw_mem / Page_size + 1) * Page_size);
+#ifdef DEBUG
+  {
+    unsigned long *p;
+    unsigned long *p0 = (void *) *block,
+                  *p1 = (void *) (aligned_mem - modulo),
+                  *p2 = (void *) (aligned_mem - modulo + size),
+                  *p3 = (void *) ((char *) *block + size + Page_size);
+
+    for (p = p0; p < p1; p++) *p = Debug_filler_align;
+    for (p = p1; p < p2; p++) *p = Debug_uninit_align;
+    for (p = p2; p < p3; p++) *p = Debug_filler_align;
+  }
+#endif
+  return (char *) (aligned_mem - modulo);
+}
+
+void ext_table_init(struct ext_table * tbl, int init_capa)
+{
+  tbl->size = 0;
+  tbl->capacity = init_capa;
+  tbl->contents = stat_alloc(sizeof(void *) * init_capa);
+}
+
+int ext_table_add(struct ext_table * tbl, void * data)
+{
+  int res;
+  if (tbl->size >= tbl->capacity) {
+    tbl->capacity *= 2;
+    tbl->contents =
+      stat_resize(tbl->contents, sizeof(void *) * tbl->capacity);
+  }
+  res = tbl->size;
+  tbl->contents[res] = data;
+  tbl->size++;
+  return res;
+}
+
+void ext_table_free(struct ext_table * tbl, int free_entries)
+{
+  int i;
+  if (free_entries)
+    for (i = 0; i < tbl->size; i++) stat_free(tbl->contents[i]);
+  stat_free(tbl->contents);
+}
diff --git a/byterun/misc.h b/byterun/misc.h
new file mode 100644
index 0000000000..37bc31a864
--- /dev/null
+++ b/byterun/misc.h
@@ -0,0 +1,137 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*         Xavier Leroy and Damien Doligez, 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 Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* Miscellaneous macros and variables. */
+
+#ifndef _misc_
+#define _misc_
+
+
+#include "config.h"
+
+/* Standard definitions */
+
+#include <stddef.h>
+#include <stdlib.h>
+
+/* Basic types and constants */
+
+typedef size_t asize_t;
+
+#ifndef NULL
+#define NULL 0
+#endif
+
+typedef char * addr;
+
+#ifdef __GNUC__
+/* Works only in GCC 2.5 and later */
+#define Noreturn __attribute ((noreturn))
+#else
+#define Noreturn
+#endif
+
+/* Export control (to mark primitives and to handle Windows DLL) */
+
+#if defined(_WIN32) && defined(_DLL)
+# define CAMLexport __declspec(dllexport)
+# define CAMLprim __declspec(dllexport)
+# if defined(IN_OCAMLRUN)
+#  define CAMLextern __declspec(dllexport) extern
+# else
+#  define CAMLextern __declspec(dllimport) extern
+# endif
+#else
+# define CAMLexport
+# define CAMLprim
+# define CAMLextern extern
+#endif
+
+/* Assertions */
+
+#ifdef DEBUG
+#define CAMLassert(x) ((x) ? 0 : caml_failed_assert ( #x , __FILE__, __LINE__))
+int caml_failed_assert (char *, char *, int) Noreturn;
+#else
+#define CAMLassert(x) 0
+#endif
+
+void fatal_error (char *msg) Noreturn;
+void fatal_error_arg (char *fmt, char *arg) Noreturn;
+void fatal_error_arg2 (char *fmt1, char *arg1, 
+                       char *fmt2, char *arg2) Noreturn;
+
+/* Data structures */
+
+struct ext_table {
+  int size;
+  int capacity;
+  void ** contents;
+};
+
+extern void ext_table_init(struct ext_table * tbl, int init_capa);
+extern int ext_table_add(struct ext_table * tbl, void * data);
+extern void ext_table_free(struct ext_table * tbl, int free_entries);
+
+/* GC flags and messages */
+
+extern unsigned long verb_gc;
+void gc_message (int, char *, unsigned long);
+
+/* Memory routines */
+
+char *aligned_malloc (asize_t, int, void **);
+
+#ifdef DEBUG
+#ifdef ARCH_SIXTYFOUR
+#define Debug_tag(x) (0xD700D7D7D700D6D7ul \
+                      | ((unsigned long) (x) << 16) \
+                      | ((unsigned long) (x) << 48))
+#else
+#define Debug_tag(x) (0xD700D6D7ul | ((unsigned long) (x) << 16))
+#endif /* ARCH_SIXTYFOUR */
+
+/*
+  00 -> free words in minor heap
+  01 -> fields of free list blocks in major heap
+  03 -> heap chunks deallocated by heap shrinking
+  04 -> fields deallocated by obj_truncate
+  10 -> uninitialised fields of minor objects
+  11 -> uninitialised fields of major objects
+  15 -> uninitialised words of aligned_malloc blocks
+  85 -> filler bytes of aligned_malloc
+
+  special case (byte by byte):
+  D7 -> uninitialised words of stat_alloc blocks
+*/
+#define Debug_free_minor     Debug_tag (0x00)
+#define Debug_free_major     Debug_tag (0x01)
+#define Debug_free_shrink    Debug_tag (0x03)
+#define Debug_free_truncate  Debug_tag (0x04)
+#define Debug_uninit_minor   Debug_tag (0x10)
+#define Debug_uninit_major   Debug_tag (0x11)
+#define Debug_uninit_align   Debug_tag (0x15)
+#define Debug_filler_align   Debug_tag (0x85)
+
+#define Debug_uninit_stat    0xD7
+#endif /* DEBUG */
+
+
+#ifndef CAML_AVOID_CONFLICTS
+#define Assert CAMLassert
+#endif
+
+
+#endif /* _misc_ */
diff --git a/byterun/mlvalues.h b/byterun/mlvalues.h
new file mode 100644
index 0000000000..2c3b6a0ac7
--- /dev/null
+++ b/byterun/mlvalues.h
@@ -0,0 +1,297 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*         Xavier Leroy and Damien Doligez, 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 Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+#ifndef _mlvalues_
+#define _mlvalues_
+
+
+#include "config.h"
+#include "misc.h"
+
+/* Definitions
+
+  word: Four bytes on 32 and 16 bit architectures,
+        eight bytes on 64 bit architectures.
+  long: A C long integer.
+  val: The ML representation of something.  A long or a block or a pointer
+       outside the heap.  If it is a block, it is the (encoded) address
+       of an object.  If it is a long, it is encoded as well.
+  block: Something allocated.  It always has a header and some
+          fields or some number of bytes (a multiple of the word size).
+  field: A word-sized val which is part of a block.
+  bp: Pointer to the first byte of a block.  (a char *)
+  op: Pointer to the first field of a block.  (a value *)
+  hp: Pointer to the header of a block.  (a char *)
+  int32: Four bytes on all architectures.
+  int64: Eight bytes on all architectures.
+
+  Remark: A block size is always a multiple of the word size, and at least
+          one word plus the header.
+
+  bosize: Size (in bytes) of the "bytes" part.
+  wosize: Size (in words) of the "fields" part.
+  bhsize: Size (in bytes) of the block with its header.
+  whsize: Size (in words) of the block with its header.
+
+  hd: A header.
+  tag: The value of the tag field of the header.
+  color: The value of the color field of the header.
+         This is for use only by the GC.
+*/
+
+typedef long value;
+typedef unsigned long header_t;
+typedef unsigned long mlsize_t;
+typedef unsigned int tag_t;             /* Actually, an unsigned char */
+typedef unsigned long color_t;
+typedef unsigned long mark_t;
+
+/* Longs vs blocks. */
+#define Is_long(x)   (((x) & 1) != 0)
+#define Is_block(x)  (((x) & 1) == 0)
+
+/* Conversion macro names are always of the form  "to_from". */
+/* Example: Val_long as in "Val from long" or "Val of long". */
+#define Val_long(x)     (((long)(x) << 1) + 1)
+#define Long_val(x)     ((x) >> 1)
+#define Max_long ((1L << (8 * sizeof(value) - 2)) - 1)
+#define Min_long (-(1L << (8 * sizeof(value) - 2)))
+#define Val_int(x) Val_long(x)
+#define Int_val(x) ((int) Long_val(x))
+
+/* Structure of the header:
+
+For 16-bit and 32-bit architectures:
+     +--------+-------+-----+
+     | wosize | color | tag |
+     +--------+-------+-----+
+bits  31    10 9     8 7   0
+
+For 64-bit architectures:
+
+     +--------+-------+-----+
+     | wosize | color | tag |
+     +--------+-------+-----+
+bits  63    10 9     8 7   0
+
+*/
+
+#define Tag_hd(hd) ((tag_t) ((hd) & 0xFF))
+#define Wosize_hd(hd) ((mlsize_t) ((hd) >> 10))
+
+#define Hd_val(val) (((header_t *) (val)) [-1])        /* Also an l-value. */
+#define Hd_op(op) (Hd_val (op))                        /* Also an l-value. */
+#define Hd_bp(bp) (Hd_val (bp))                        /* Also an l-value. */
+#define Hd_hp(hp) (* ((header_t *) (hp)))              /* Also an l-value. */
+#define Hp_val(val) ((char *) (((header_t *) (val)) - 1))
+#define Hp_op(op) (Hp_val (op))
+#define Hp_bp(bp) (Hp_val (bp))
+#define Val_op(op) ((value) (op))
+#define Val_hp(hp) ((value) (((header_t *) (hp)) + 1))
+#define Op_hp(hp) ((value *) Val_hp (hp))
+#define Bp_hp(hp) ((char *) Val_hp (hp))
+
+#define Num_tags (1 << 8)
+#ifdef ARCH_SIXTYFOUR
+#define Max_wosize ((1L << 54) - 1)
+#else
+#define Max_wosize ((1 << 22) - 1)
+#endif
+
+#define Wosize_val(val) (Wosize_hd (Hd_val (val)))
+#define Wosize_op(op) (Wosize_val (op))
+#define Wosize_bp(bp) (Wosize_val (bp))
+#define Wosize_hp(hp) (Wosize_hd (Hd_hp (hp)))
+#define Whsize_wosize(sz) ((sz) + 1)
+#define Wosize_whsize(sz) ((sz) - 1)
+#define Wosize_bhsize(sz) ((sz) / sizeof (value) - 1)
+#define Bsize_wsize(sz) ((sz) * sizeof (value))
+#define Wsize_bsize(sz) ((sz) / sizeof (value))
+#define Bhsize_wosize(sz) (Bsize_wsize (Whsize_wosize (sz)))
+#define Bhsize_bosize(sz) ((sz) + sizeof (header_t))
+#define Bosize_val(val) (Bsize_wsize (Wosize_val (val)))
+#define Bosize_op(op) (Bosize_val (Val_op (op)))
+#define Bosize_bp(bp) (Bosize_val (Val_bp (bp)))
+#define Bosize_hd(hd) (Bsize_wsize (Wosize_hd (hd)))
+#define Whsize_hp(hp) (Whsize_wosize (Wosize_hp (hp)))
+#define Whsize_val(val) (Whsize_hp (Hp_val (val)))
+#define Whsize_bp(bp) (Whsize_val (Val_bp (bp)))
+#define Whsize_hd(hd) (Whsize_wosize (Wosize_hd (hd)))
+#define Bhsize_hp(hp) (Bsize_wsize (Whsize_hp (hp)))
+#define Bhsize_hd(hd) (Bsize_wsize (Whsize_hd (hd)))
+
+#ifdef ARCH_BIG_ENDIAN
+#define Tag_val(val) (((unsigned char *) (val)) [-1])
+                                                 /* Also an l-value. */
+#define Tag_hp(hp) (((unsigned char *) (hp)) [sizeof(value)-1])
+                                                 /* Also an l-value. */
+#else
+#define Tag_val(val) (((unsigned char *) (val)) [-sizeof(value)])
+                                                 /* Also an l-value. */
+#define Tag_hp(hp) (((unsigned char *) (hp)) [0])
+                                                 /* Also an l-value. */
+#endif
+
+/* The lowest tag for blocks containing no value. */
+#define No_scan_tag 251
+
+
+/* 1- If tag < No_scan_tag : a tuple of fields.  */
+
+/* Pointer to the first field. */
+#define Op_val(x) ((value *) (x))
+/* Fields are numbered from 0. */
+#define Field(x, i) (((value *)(x)) [i])           /* Also an l-value. */
+
+typedef int32 opcode_t;
+typedef opcode_t * code_t;
+
+/* NOTE: [Forward_tag] and [Infix_tag] must be just under
+   [No_scan_tag], with [Infix_tag] the lower one.
+   See [oldify_one] in minor_gc.c for more details.
+
+   NOTE: Update stdlib/obj.ml whenever you change the tags.
+ */
+
+/* Forward_tag: forwarding pointer that the GC may silently shortcut.
+   See stdlib/lazy.ml. */
+#define Forward_tag 250
+#define Forward_val(v) Field(v, 0)
+
+/* If tag == Infix_tag : an infix header inside a closure */
+/* Infix_tag must be odd so that the infix header is scanned as an integer */
+/* Infix_tag must be 1 modulo 4 and infix headers can only occur in blocks
+   with tag Closure_tag (see compact.c). */
+
+#define Infix_tag 249
+#define Infix_offset_hd(hd) (Bosize_hd(hd))
+#define Infix_offset_val(v) Infix_offset_hd(Hd_val(v))
+
+/* Another special case: objects */
+#define Object_tag 248
+#define Class_val(val) Field((val), 0)
+#define Oid_val(val) Long_val(Field((val), 1))
+
+/* Special case of tuples of fields: closures */
+#define Closure_tag 247
+#define Code_val(val) (((code_t *) (val)) [0])     /* Also an l-value. */
+
+/* This tag is not special for the runtime, but it must not be used
+   for any constructor.  See stdlib/lazy.ml. */
+#define Lazy_tag 246
+
+/* Another special case: variants */
+CAMLextern value hash_variant(char * tag);
+
+/* 2- If tag >= No_scan_tag : a sequence of bytes. */
+
+/* Pointer to the first byte */
+#define Bp_val(v) ((char *) (v))
+#define Val_bp(p) ((value) (p))
+/* Bytes are numbered from 0. */
+#define Byte(x, i) (((char *) (x)) [i])            /* Also an l-value. */
+#define Byte_u(x, i) (((unsigned char *) (x)) [i]) /* Also an l-value. */
+
+/* Abstract things.  Their contents is not traced by the GC; therefore they
+   must not contain any [value].
+*/
+#define Abstract_tag 251
+
+/* Strings. */
+#define String_tag 252
+#define String_val(x) ((char *) Bp_val(x))
+CAMLextern mlsize_t string_length (value);
+
+/* Floating-point numbers. */
+#define Double_tag 253
+#define Double_wosize ((sizeof(double) / sizeof(value)))
+#ifndef ARCH_ALIGN_DOUBLE
+#define Double_val(v) (* (double *)(v))
+#define Store_double_val(v,d) (* (double *)(v) = (d))
+#else
+CAMLextern double Double_val (value);
+CAMLextern void Store_double_val (value,double);
+#endif
+
+/* Arrays of floating-point numbers. */
+#define Double_array_tag 254
+#define Double_field(v,i) Double_val((value)((double *)(v) + (i)))
+#define Store_double_field(v,i,d) do{ \
+  mlsize_t caml__temp_i = (i); \
+  double caml__temp_d = (d); \
+  Store_double_val((value)((double *) v + caml__temp_i), caml__temp_d); \
+}while(0)
+
+/* Custom blocks.  They contain a pointer to a "method suite"
+   of functions (for finalization, comparison, hashing, etc)
+   followed by raw data.  The contents of custom blocks is not traced by
+   the GC; therefore, they must not contain any [value].
+   See [custom.h] for operations on method suites. */
+#define Custom_tag 255
+#define Data_custom_val(v) ((void *) &Field((v), 1))
+struct custom_operations;       /* defined in [custom.h] */
+
+/* Int32.t, Int64.t and Nativeint.t are represented as custom blocks. */
+
+#define Int32_val(v) (*((int32 *) Data_custom_val(v)))
+#define Nativeint_val(v) (*((long *) Data_custom_val(v)))
+#ifndef ARCH_ALIGN_INT64
+#define Int64_val(v) (*((int64 *) Data_custom_val(v)))
+#else
+CAMLextern int64 Int64_val(value v);
+#endif
+
+/* 3- Atoms are 0-tuples.  They are statically allocated once and for all. */
+
+CAMLextern header_t atom_table[];
+#define Atom(tag) (Val_hp (&(atom_table [(tag)])))
+
+/* Is_atom tests whether a well-formed block is statically allocated
+   outside the heap. For the bytecode system, only zero-sized block (Atoms)
+   fall in this class. For the native-code generator, data
+   emitted by the code generator (as described in the table
+   caml_data_segments) are also atoms. */
+
+#ifndef NATIVE_CODE
+#define Is_atom(v) ((v) >= Atom(0) && (v) <= Atom(255))
+#else
+CAMLextern char * static_data_start, * static_data_end;
+#define Is_atom(v) \
+  ((((char *)(v) >= static_data_start && (char *)(v) < static_data_end) || \
+   ((v) >= Atom(0) && (v) <= Atom(255))))
+#endif
+
+/* Booleans are integers 0 or 1 */
+
+#define Val_bool(x) Val_int((x) != 0)
+#define Bool_val(x) Int_val(x)
+#define Val_false Val_int(0)
+#define Val_true Val_int(1)
+#define Val_not(x) (Val_false + Val_true - (x))
+
+/* The unit value is 0 (tagged) */
+
+#define Val_unit Val_int(0)
+
+/* List constructors */
+#define Val_emptylist Val_int(0)
+#define Tag_cons 0
+
+/* The table of global identifiers */
+
+extern value global_data;
+
+
+#endif /* _mlvalues_ */
diff --git a/byterun/obj.c b/byterun/obj.c
new file mode 100644
index 0000000000..d7ce07f641
--- /dev/null
+++ b/byterun/obj.c
@@ -0,0 +1,132 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            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 Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* Operations on objects */
+
+#include "alloc.h"
+#include "fail.h"
+#include "gc.h"
+#include "major_gc.h"
+#include "memory.h"
+#include "minor_gc.h"
+#include "misc.h"
+#include "mlvalues.h"
+#include "prims.h"
+
+CAMLprim value static_alloc(value size)
+{
+  return (value) stat_alloc((asize_t) Long_val(size));
+}
+
+CAMLprim value static_free(value blk)
+{
+  stat_free((void *) blk);
+  return Val_unit;
+}
+
+CAMLprim value static_resize(value blk, value new_size)
+{
+  return (value) stat_resize((char *) blk, (asize_t) Long_val(new_size));
+}
+
+CAMLprim value obj_is_block(value arg)
+{
+  return Val_bool(Is_block(arg));
+}
+
+CAMLprim value obj_tag(value arg)
+{
+  return Val_int(Tag_val(arg));
+}
+
+CAMLprim value obj_set_tag (value arg, value new_tag)
+{
+  Tag_val (arg) = Int_val (new_tag);
+  return Val_unit;
+}
+
+CAMLprim value obj_block(value tag, value size)
+{
+  value res;
+  mlsize_t sz, i;
+  tag_t tg;
+
+  sz = Long_val(size);
+  tg = Long_val(tag);
+  if (sz == 0) return Atom(tg);
+  res = alloc(sz, tg);
+  for (i = 0; i < sz; i++)
+    Field(res, i) = Val_long(0);
+
+  return res;
+}
+
+CAMLprim value obj_dup(value arg)
+{
+  CAMLparam1 (arg);
+  CAMLlocal1 (res);
+  mlsize_t sz, i;
+  tag_t tg;
+
+  sz = Wosize_val(arg);
+  if (sz == 0) return arg;
+
+  tg = Tag_val(arg);
+  res = alloc(sz, tg);
+  for (i = 0; i < sz; i++)
+    Field(res, i) = Field(arg, i);
+
+  CAMLreturn (res);
+}
+
+/* Shorten the given block to the given size and return void.
+   Raise Invalid_argument if the given size is less than or equal
+   to 0 or greater than the current size.
+
+   algorithm:
+   Change the length field of the header.  Make up a white object
+   with the leftover part of the object: this is needed in the major
+   heap and harmless in the minor heap.
+*/
+CAMLprim value obj_truncate (value v, value newsize)
+{
+  mlsize_t new_wosize = Long_val (newsize);
+  header_t hd = Hd_val (v);
+  tag_t tag = Tag_hd (hd);
+  color_t color = Color_hd (hd);
+  mlsize_t wosize = Wosize_hd (hd);
+  mlsize_t i;
+
+  if (tag == Double_array_tag) new_wosize *= Double_wosize;  /* PR#156 */
+
+  if (new_wosize <= 0 || new_wosize > wosize) 
+    invalid_argument ("Obj.truncate");
+  if (new_wosize == wosize) return Val_unit;
+  /* PR#61: since we're about to lose our references to the elements
+     beyond new_wosize in v, erase them explicitly so that the GC
+     can darken them as appropriate. */
+  if (tag < No_scan_tag) {
+    for (i = new_wosize; i < wosize; i++){
+      modify(&Field(v, i), Val_unit);
+#ifdef DEBUG
+      Field (v, i) = Debug_free_truncate;
+#endif
+    }
+  }
+  Field (v, new_wosize) =
+    Make_header (Wosize_whsize (wosize-new_wosize), 0, Caml_white);
+  Hd_val (v) = Make_header (new_wosize, tag, color);
+  return Val_unit;
+}
diff --git a/byterun/roots.c b/byterun/roots.c
new file mode 100644
index 0000000000..6378ceffb0
--- /dev/null
+++ b/byterun/roots.c
@@ -0,0 +1,111 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*         Xavier Leroy and Damien Doligez, 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 Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* To walk the memory roots for garbage collection */
+
+#include "finalise.h"
+#include "globroots.h"
+#include "major_gc.h"
+#include "memory.h"
+#include "minor_gc.h"
+#include "misc.h"
+#include "mlvalues.h"
+#include "roots.h"
+#include "stacks.h"
+
+CAMLexport struct caml__roots_block *local_roots = NULL;
+
+void (*scan_roots_hook) (scanning_action f) = NULL;
+
+/* FIXME rename to [oldify_young_roots] and synchronise with asmrun/roots.c */
+/* Call [oldify_one] on (at least) all the roots that point to the minor
+   heap. */
+void oldify_local_roots (void)
+{
+  register value * sp;
+  struct global_root * gr;
+  struct caml__roots_block *lr;
+  long i, j;
+
+  /* The stack */
+  for (sp = extern_sp; sp < stack_high; sp++) {
+    oldify_one (*sp, sp);
+  }
+  /* Local C roots */  /* FIXME do the old-frame trick ? */
+  for (lr = local_roots; lr != NULL; lr = lr->next) {
+    for (i = 0; i < lr->ntables; i++){
+      for (j = 0; j < lr->nitems; j++){
+        sp = &(lr->tables[i][j]);
+        oldify_one (*sp, sp);
+      }
+    }
+  }
+  /* Global C roots */
+  for (gr = caml_global_roots.forward[0]; gr != NULL; gr = gr->forward[0]) {
+    oldify_one(*(gr->root), gr->root);
+  }
+  /* Finalised values */
+  final_do_young_roots (&oldify_one);
+  /* Hook */
+  if (scan_roots_hook != NULL) (*scan_roots_hook)(&oldify_one);
+}
+
+/* Call [darken] on all roots */
+
+void darken_all_roots (void)
+{
+  do_roots (darken);
+}
+
+void do_roots (scanning_action f)
+{
+  struct global_root * gr;
+
+  /* Global variables */
+  f(global_data, &global_data);
+
+  /* The stack and the local C roots */
+  do_local_roots(f, extern_sp, stack_high, local_roots);
+
+  /* Global C roots */
+  for (gr = caml_global_roots.forward[0]; gr != NULL; gr = gr->forward[0]) {
+    f(*(gr->root), gr->root);
+  }
+  /* Finalised values */
+  final_do_strong_roots (f);
+  /* Hook */
+  if (scan_roots_hook != NULL) (*scan_roots_hook)(f);
+}
+
+void do_local_roots (scanning_action f, value *stack_low, value *stack_high,
+                     struct caml__roots_block *local_roots)
+{
+  register value * sp;
+  struct caml__roots_block *lr;
+  int i, j;
+
+  for (sp = stack_low; sp < stack_high; sp++) {
+    f (*sp, sp);
+  }
+  for (lr = local_roots; lr != NULL; lr = lr->next) {
+    for (i = 0; i < lr->ntables; i++){
+      for (j = 0; j < lr->nitems; j++){
+        sp = &(lr->tables[i][j]);
+        f (*sp, sp);
+      }
+    }
+  }
+}
+
diff --git a/byterun/startup.c b/byterun/startup.c
new file mode 100644
index 0000000000..9daa3f1dc8
--- /dev/null
+++ b/byterun/startup.c
@@ -0,0 +1,458 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*         Xavier Leroy and Damien Doligez, 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 Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* Start-up code */
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <fcntl.h>
+#include "config.h"
+#ifdef HAS_UNISTD
+#include <unistd.h>
+#endif
+#ifdef _WIN32
+#include <process.h>
+#endif
+#include "alloc.h"
+#include "backtrace.h"
+#include "callback.h"
+#include "custom.h"
+#include "debugger.h"
+#include "dynlink.h"
+#include "exec.h"
+#include "fail.h"
+#include "fix_code.h"
+#include "gc_ctrl.h"
+#include "instrtrace.h"
+#include "interp.h"
+#include "intext.h"
+#include "io.h"
+#include "memory.h"
+#include "minor_gc.h"
+#include "misc.h"
+#include "mlvalues.h"
+#include "osdeps.h"
+#include "prims.h"
+#include "printexc.h"
+#include "reverse.h"
+#include "signals.h"
+#include "stacks.h"
+#include "sys.h"
+#include "startup.h"
+
+#ifndef O_BINARY
+#define O_BINARY 0
+#endif
+
+#ifndef SEEK_END
+#define SEEK_END 2
+#endif
+
+extern int parser_trace;
+
+CAMLexport header_t atom_table[256];
+
+/* Initialize the atom table */
+
+static void init_atoms(void)
+{
+  int i;
+  for(i = 0; i < 256; i++) atom_table[i] = Make_header(0, i, Caml_white);
+}
+
+/* Read the trailer of a bytecode file */
+
+static void fixup_endianness_trailer(uint32 * p)
+{
+#ifndef ARCH_BIG_ENDIAN
+  Reverse_32(p, p);
+#endif
+}
+
+static int read_trailer(int fd, struct exec_trailer *trail)
+{
+  lseek(fd, (long) -TRAILER_SIZE, SEEK_END);
+  if (read(fd, (char *) trail, TRAILER_SIZE) < TRAILER_SIZE)
+    return BAD_BYTECODE;
+  fixup_endianness_trailer(&trail->num_sections);
+  if (strncmp(trail->magic, EXEC_MAGIC, 12) == 0)
+    return 0;
+  else
+    return BAD_BYTECODE;
+}
+
+int attempt_open(char **name, struct exec_trailer *trail,
+                 int do_open_script)
+{
+  char * truename;
+  int fd;
+  int err;
+  char buf [2];
+
+  truename = search_exe_in_path(*name);
+  *name = truename;
+  gc_message(0x100, "Opening bytecode executable %s\n",
+             (unsigned long) truename);
+  fd = open(truename, O_RDONLY | O_BINARY);
+  if (fd == -1) {
+    gc_message(0x100, "Cannot open file\n", 0);
+    return FILE_NOT_FOUND;
+  }
+  if (!do_open_script) {
+    err = read (fd, buf, 2);
+    if (err < 2 || (buf [0] == '#' && buf [1] == '!')) {
+      close(fd);
+      gc_message(0x100, "Rejected #! script\n", 0);
+      return BAD_BYTECODE;
+    }
+  }
+  err = read_trailer(fd, trail);
+  if (err != 0) {
+    close(fd);
+    gc_message(0x100, "Not a bytecode executable\n", 0);
+    return err;
+  }
+  return fd;
+}
+
+/* Read the section descriptors */
+
+void read_section_descriptors(int fd, struct exec_trailer *trail)
+{
+  int toc_size, i;
+
+  toc_size = trail->num_sections * 8;
+  trail->section = stat_alloc(toc_size);
+  lseek(fd, - (long) (TRAILER_SIZE + toc_size), SEEK_END);
+  if (read(fd, (char *) trail->section, toc_size) != toc_size)
+    fatal_error("Fatal error: cannot read section table\n");
+  /* Fixup endianness of lengths */
+  for (i = 0; i < trail->num_sections; i++)
+    fixup_endianness_trailer(&(trail->section[i].len));
+}
+
+/* Position fd at the beginning of the section having the given name.
+   Return the length of the section data in bytes, or -1 if no section
+   found with that name. */
+
+int32 seek_optional_section(int fd, struct exec_trailer *trail, char *name)
+{
+  long ofs;
+  int i;
+
+  ofs = TRAILER_SIZE + trail->num_sections * 8;
+  for (i = trail->num_sections - 1; i >= 0; i--) {
+    ofs += trail->section[i].len;
+    if (strncmp(trail->section[i].name, name, 4) == 0) {
+      lseek(fd, -ofs, SEEK_END);
+      return trail->section[i].len;
+    }
+  }
+  return -1;
+}
+
+/* Position fd at the beginning of the section having the given name.
+   Return the length of the section data in bytes. */
+
+int32 seek_section(int fd, struct exec_trailer *trail, char *name)
+{
+  int32 len = seek_optional_section(fd, trail, name);
+  if (len == -1) 
+    fatal_error_arg("Fatal_error: section `%s' is missing\n", name);
+  return len;
+}
+
+/* Read and return the contents of the section having the given name.
+   Add a terminating 0.  Return NULL if no such section. */
+
+static char * read_section(int fd, struct exec_trailer *trail, char *name)
+{
+  int32 len;
+  char * data;
+
+  len = seek_optional_section(fd, trail, name);
+  if (len == -1) return NULL;
+  data = stat_alloc(len + 1);
+  if (read(fd, data, len) != len)
+    fatal_error_arg("Fatal error: error reading section %s\n", name);
+  data[len] = 0;
+  return data;
+}
+
+/* Invocation of ocamlrun: 4 cases.
+
+   1.  runtime + bytecode
+       user types:  ocamlrun [options] bytecode args...
+       arguments:  ocamlrun [options] bytecode args...
+
+   2.  bytecode script
+       user types:  bytecode args...
+   2a  (kernel 1) arguments:  ocamlrun ./bytecode args...
+   2b  (kernel 2) arguments:  bytecode bytecode args...
+
+   3.  concatenated runtime and bytecode
+       user types:  composite args...
+       arguments:  composite args...
+
+Algorithm:
+  1-  If argument 0 is a valid byte-code file that does not start with #!,
+      then we are in case 3 and we pass the same command line to the
+      Objective Caml program.
+  2-  In all other cases, we parse the command line as:
+        (whatever) [options] bytecode args...
+      and we strip "(whatever) [options]" from the command line.
+
+*/
+
+/* Configuration parameters and flags */
+
+static unsigned long percent_free_init = Percent_free_def;
+static unsigned long max_percent_free_init = Max_percent_free_def;
+static unsigned long minor_heap_init = Minor_heap_def;
+static unsigned long heap_chunk_init = Heap_chunk_def;
+static unsigned long heap_size_init = Init_heap_def;
+static unsigned long max_stack_init = Max_stack_def;
+
+/* Parse options on the command line */
+
+static int parse_command_line(char **argv)
+{
+  int i, j;
+
+  for(i = 1; argv[i] != NULL && argv[i][0] == '-'; i++) {
+    switch(argv[i][1]) {
+#ifdef DEBUG
+    case 't':
+      trace_flag = 1;
+      break;
+#endif
+    case 'v':
+      verb_gc = 0x001+0x004+0x008+0x010+0x020;
+      break;
+    case 'p':
+      for (j = 0; names_of_builtin_cprim[j] != NULL; j++)
+        printf("%s\n", names_of_builtin_cprim[j]);
+      exit(0);
+      break;
+    case 'b':
+      init_backtrace();
+      break;
+    case 'I':
+      if (argv[i + 1] != NULL) {
+        ext_table_add(&shared_libs_path, argv[i + 1]);
+        i++;
+      }
+      break;
+    default:
+      fatal_error_arg("Unknown option %s.\n", argv[i]);
+    }
+  }
+  return i;
+}
+
+/* Parse the CAMLRUNPARAM variable */
+/* The option letter for each runtime option is the first letter of the
+   last word of the ML name of the option (see [stdlib/gc.mli]).
+   Except for l (maximum stack size) and h (initial heap size).
+*/
+
+static void scanmult (char *opt, long unsigned int *var)
+{
+  char mult = ' ';
+  sscanf (opt, "=%lu%c", var, &mult);
+  sscanf (opt, "=0x%lx%c", var, &mult);
+  if (mult == 'k') *var = *var * 1024;
+  if (mult == 'M') *var = *var * 1024 * 1024;
+  if (mult == 'G') *var = *var * 1024 * 1024 * 1024;
+}
+
+static void parse_camlrunparam(void)
+{
+  char *opt = getenv ("OCAMLRUNPARAM");
+
+  if (opt == NULL) opt = getenv ("CAMLRUNPARAM");
+
+  if (opt != NULL){
+    while (*opt != '\0'){
+      switch (*opt++){
+      case 's': scanmult (opt, &minor_heap_init); break;
+      case 'i': scanmult (opt, &heap_chunk_init); break;
+      case 'h': scanmult (opt, &heap_size_init); break;
+      case 'l': scanmult (opt, &max_stack_init); break;
+      case 'o': scanmult (opt, &percent_free_init); break;
+      case 'O': scanmult (opt, &max_percent_free_init); break;
+      case 'v': scanmult (opt, &verb_gc); break;
+      case 'b': init_backtrace(); break;
+      case 'p': parser_trace = 1; break;
+      }
+    }
+  }
+}
+
+extern void init_ieee_floats (void);
+
+#ifdef _WIN32
+extern void caml_signal_thread(void * lpParam);
+#endif
+
+/* Main entry point when loading code from a file */
+
+CAMLexport void caml_main(char **argv)
+{
+  int fd, pos;
+  struct exec_trailer trail;
+  struct channel * chan;
+  value res;
+  char * shared_lib_path, * shared_libs, * req_prims;
+  char * exe_name;
+#ifdef __linux__
+  static char proc_self_exe[256];
+  int retcode;
+#endif
+
+  /* Machine-dependent initialization of the floating-point hardware
+     so that it behaves as much as possible as specified in IEEE */
+  init_ieee_floats();
+  init_custom_operations();
+  ext_table_init(&shared_libs_path, 8);
+  external_raise = NULL;
+  /* Determine options and position of bytecode file */
+#ifdef DEBUG
+  verb_gc = 63;
+#endif
+  parse_camlrunparam();
+  pos = 0;
+  exe_name = argv[0];
+#ifdef __linux__
+  /* Recover executable name from /proc/self/exe, much more reliable */
+  retcode = readlink("/proc/self/exe", proc_self_exe, sizeof(proc_self_exe));
+  if (retcode != -1 && retcode < sizeof(proc_self_exe)) {
+    proc_self_exe[retcode] = 0;
+    exe_name = proc_self_exe;
+  }
+#endif
+  fd = attempt_open(&exe_name, &trail, 0);
+  if (fd < 0) {
+    pos = parse_command_line(argv);
+    if (argv[pos] == 0)
+      fatal_error("No bytecode file specified.\n");
+    exe_name = argv[pos];
+    fd = attempt_open(&exe_name, &trail, 1);
+    switch(fd) {
+    case FILE_NOT_FOUND:
+      fatal_error_arg("Fatal error: cannot find file %s\n", argv[pos]);
+      break;
+    case BAD_BYTECODE:
+      fatal_error_arg(
+        "Fatal error: the file %s is not a bytecode executable file\n",
+        argv[pos]);
+      break;
+    }
+  }
+  /* Read the table of contents (section descriptors) */
+  read_section_descriptors(fd, &trail);
+  /* Initialize the abstract machine */
+  init_gc (minor_heap_init, heap_size_init, heap_chunk_init,
+           percent_free_init, max_percent_free_init);
+  init_stack (max_stack_init);
+  init_atoms();
+  /* Initialize the interpreter */
+  interprete(NULL, 0);
+  /* Initialize the debugger, if needed */
+  debugger_init();
+  /* Load the code */
+  code_size = seek_section(fd, &trail, "CODE");
+  load_code(fd, code_size);
+  /* Build the table of primitives */
+  shared_lib_path = read_section(fd, &trail, "DLPT");
+  shared_libs = read_section(fd, &trail, "DLLS");
+  req_prims = read_section(fd, &trail, "PRIM");
+  if (req_prims == NULL) fatal_error("Fatal error: no PRIM section\n");
+  build_primitive_table(shared_lib_path, shared_libs, req_prims);
+  stat_free(shared_lib_path);
+  stat_free(shared_libs);
+  stat_free(req_prims);
+  /* Load the globals */
+  seek_section(fd, &trail, "DATA");
+  chan = open_descriptor_in(fd);
+  global_data = input_val(chan);
+  close_channel(chan); /* this also closes fd */
+  stat_free(trail.section);
+  /* Ensure that the globals are in the major heap. */
+  oldify_one (global_data, &global_data);
+  oldify_mopup ();
+  /* Initialize system libraries */
+  init_exceptions();
+  sys_init(exe_name, argv + pos);
+#ifdef _WIN32
+  /* Start a thread to handle signals */
+  if (getenv("CAMLSIGPIPE"))
+    _beginthread(caml_signal_thread, 4096, NULL);
+#endif
+  /* Execute the program */
+  debugger(PROGRAM_START);
+  res = interprete(start_code, code_size);
+  if (Is_exception_result(res)) {
+    exn_bucket = Extract_exception(res);
+    if (debugger_in_use) {
+      extern_sp = &exn_bucket; /* The debugger needs the exception value. */
+      debugger(UNCAUGHT_EXC);
+    }
+    fatal_uncaught_exception(exn_bucket);
+  }
+}
+
+/* Main entry point when code is linked in as initialized data */
+
+CAMLexport void caml_startup_code(code_t code, asize_t code_size,
+                                  char *data, char **argv)
+{
+  value res;
+
+  init_ieee_floats();
+#ifdef DEBUG
+  verb_gc = 63;
+#endif
+  parse_camlrunparam();
+  external_raise = NULL;
+  /* Initialize the abstract machine */
+  init_gc (minor_heap_init, heap_size_init, heap_chunk_init,
+           percent_free_init, max_percent_free_init);
+  init_stack (max_stack_init);
+  init_atoms();
+  /* Initialize the interpreter */
+  interprete(NULL, 0);
+  /* Load the code */
+  start_code = code;
+#ifdef THREADED_CODE
+  thread_code(start_code, code_size);
+#endif
+  /* Use the builtin table of primitives */
+  prim_table.size = prim_table.capacity = -1;
+  prim_table.contents = (void **) builtin_cprim;
+  /* Load the globals */
+  global_data = input_val_from_string((value)data, 0);
+  /* Ensure that the globals are in the major heap. */
+  oldify_one (global_data, &global_data);
+  oldify_mopup ();
+  /* Run the code */
+  init_exceptions();
+  sys_init("", argv);
+  res = interprete(start_code, code_size);
+  if (Is_exception_result(res))
+    fatal_uncaught_exception(Extract_exception(res));
+}
+
diff --git a/byterun/sys.c b/byterun/sys.c
new file mode 100644
index 0000000000..cb70ba345a
--- /dev/null
+++ b/byterun/sys.c
@@ -0,0 +1,314 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            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 Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* Basic system calls */
+
+#include <errno.h>
+#include <fcntl.h>
+#include <signal.h>
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <time.h>
+#if !macintosh
+#include <sys/types.h>
+#include <sys/stat.h>
+#endif
+#if !macintosh && !_WIN32
+#include <sys/wait.h>
+#endif
+#if macintosh
+#include "macintosh.h"
+#endif
+#include "config.h"
+#ifdef HAS_UNISTD
+#include <unistd.h>
+#endif
+#ifdef HAS_TIMES
+#include <sys/times.h>
+#endif
+#ifdef HAS_GETTIMEOFDAY
+#include <sys/time.h>
+#endif
+#include "alloc.h"
+#include "debugger.h"
+#include "fail.h"
+#include "instruct.h"
+#include "mlvalues.h"
+#include "signals.h"
+#include "stacks.h"
+#include "sys.h"
+#ifdef HAS_UI
+#include "ui.h"
+#endif
+
+#ifndef _WIN32
+extern int errno;
+#endif
+
+#ifdef HAS_STRERROR
+
+#ifndef _WIN32
+extern char * strerror(int);
+#endif
+
+char * error_message(void)
+{
+  return strerror(errno);
+}
+
+#else
+
+extern int sys_nerr;
+extern char * sys_errlist [];
+
+char * error_message(void)
+{
+  if (errno < 0 || errno >= sys_nerr)
+    return "unknown error";
+  else
+    return sys_errlist[errno];
+}
+
+#endif /* HAS_STRERROR */
+
+#ifndef EAGAIN
+#define EAGAIN (-1)
+#endif
+#ifndef EWOULDBLOCK
+#define EWOULDBLOCK (-1)
+#endif
+
+CAMLexport void sys_error(value arg)
+{
+  CAMLparam1 (arg);
+  char * err;
+  CAMLlocal1 (str);
+  
+  if (errno == EAGAIN || errno == EWOULDBLOCK) {
+    raise_sys_blocked_io();
+  } else {
+    err = error_message();
+    if (arg == NO_ARG) {
+      str = copy_string(err);
+    } else {
+      int err_len = strlen(err);
+      int arg_len = string_length(arg);
+      str = alloc_string(arg_len + 2 + err_len);
+      memmove(&Byte(str, 0), String_val(arg), arg_len);
+      memmove(&Byte(str, arg_len), ": ", 2);
+      memmove(&Byte(str, arg_len + 2), err, err_len);
+    }
+    raise_sys_error(str);
+  }
+}
+
+CAMLprim value sys_exit(value retcode)
+{
+#ifndef NATIVE_CODE
+  debugger(PROGRAM_EXIT);
+#endif
+#ifdef HAS_UI
+  ui_exit(Int_val(retcode));
+#else
+  exit(Int_val(retcode));
+#endif
+  return Val_unit;
+}
+
+#ifndef O_BINARY
+#define O_BINARY 0
+#endif
+#ifndef O_TEXT
+#define O_TEXT 0
+#endif
+#ifndef O_NONBLOCK
+#ifdef O_NDELAY
+#define O_NONBLOCK O_NDELAY
+#else
+#define O_NONBLOCK 0
+#endif
+#endif
+
+static int sys_open_flags[] = {
+  O_RDONLY, O_WRONLY, O_APPEND, O_CREAT, O_TRUNC, O_EXCL,
+  O_BINARY, O_TEXT, O_NONBLOCK
+};
+
+CAMLprim value sys_open(value path, value flags, value perm)
+{
+  int ret;
+  ret = open(String_val(path), convert_flag_list(flags, sys_open_flags)
+#if !macintosh
+             , Int_val(perm)
+#endif
+                                       );
+  if (ret == -1) sys_error(path);
+  return Val_long(ret);
+}
+
+CAMLprim value sys_close(value fd)
+{
+  close(Int_val(fd));
+  return Val_unit;
+}
+
+CAMLprim value sys_file_exists(value name)
+{
+#if macintosh
+  int f;
+  f = open (String_val (name), O_RDONLY);
+  if (f == -1) return (Val_bool (0));
+  close (f);
+  return (Val_bool (1));
+#else
+  struct stat st;
+  return Val_bool(stat(String_val(name), &st) == 0);
+#endif
+}
+
+CAMLprim value sys_remove(value name)
+{
+  int ret;
+  ret = unlink(String_val(name));
+  if (ret != 0) sys_error(name);
+  return Val_unit;
+}
+
+CAMLprim value sys_rename(value oldname, value newname)
+{
+  if (rename(String_val(oldname), String_val(newname)) != 0)
+    sys_error(oldname);
+  return Val_unit;
+}
+
+CAMLprim value sys_chdir(value dirname)
+{
+  if (chdir(String_val(dirname)) != 0) sys_error(dirname);
+  return Val_unit;
+}
+
+CAMLprim value sys_getcwd(value unit)
+{
+  char buff[4096];
+#ifdef HAS_GETCWD
+  if (getcwd(buff, sizeof(buff)) == 0) sys_error(NO_ARG);
+#else
+  if (getwd(buff) == 0) sys_error(NO_ARG);
+#endif /* HAS_GETCWD */
+  return copy_string(buff);
+}
+
+CAMLprim value sys_getenv(value var)
+{
+  char * res;
+
+  res = getenv(String_val(var));
+  if (res == 0) raise_not_found();
+  return copy_string(res);
+}
+
+char * caml_exe_name;
+static char ** caml_main_argv;
+
+CAMLprim value sys_get_argv(value unit)
+{
+  CAMLparam0 ();   /* unit is unused */
+  CAMLlocal3 (exe_name, argv, res);
+  exe_name = copy_string(caml_exe_name);
+  argv = copy_string_array((char const **) caml_main_argv);
+  res = alloc_small(2, 0);
+  Field(res, 0) = exe_name;
+  Field(res, 1) = argv;
+  CAMLreturn(res);
+}
+
+void sys_init(char * exe_name, char **argv)
+{
+  caml_exe_name = exe_name;
+  caml_main_argv = argv;
+}
+
+#if !(defined(WIFEXITED) && defined(WEXITSTATUS))
+/* Assume old-style V7 status word */
+#define WIFEXITED(status) (((status) & 0xFF) == 0)
+#define WEXITSTATUS(status) (((status) >> 8) & 0xFF)
+#endif
+
+#ifdef _WIN32
+extern int win32_system(char * command);
+#endif
+
+CAMLprim value sys_system_command(value command)
+{
+  int status, retcode;
+  
+  enter_blocking_section ();
+#ifndef _WIN32
+  status = system(String_val(command));
+  if (WIFEXITED(status))
+    retcode = WEXITSTATUS(status);
+  else
+    retcode = 255;
+#else
+  status = retcode = win32_system(String_val(command));
+#endif
+  leave_blocking_section ();
+  if (status == -1) sys_error(command);
+  return Val_int(retcode);
+}
+
+CAMLprim value sys_time(value unit)
+{
+#ifdef HAS_TIMES
+#ifndef CLK_TCK
+#ifdef HZ
+#define CLK_TCK HZ
+#else
+#define CLK_TCK 60
+#endif
+#endif
+  struct tms t;
+  times(&t);
+  return copy_double((double)(t.tms_utime + t.tms_stime) / CLK_TCK);
+#else
+  /* clock() is standard ANSI C */
+  return copy_double((double)clock() / CLOCKS_PER_SEC);
+#endif
+}
+
+CAMLprim value sys_random_seed (value unit)
+{
+#ifdef HAS_GETTIMEOFDAY
+  struct timeval tv;
+  gettimeofday(&tv, NULL);
+  return Val_int(tv.tv_sec ^ tv.tv_usec);
+#else
+  return Val_int(time (NULL));
+#endif
+}
+
+CAMLprim value sys_get_config(value unit)
+{
+  CAMLparam0 ();   /* unit is unused */
+  CAMLlocal2 (result, ostype);
+
+  ostype = copy_string(OCAML_OS_TYPE);
+  result = alloc_small (2, 0);
+  Field(result, 0) = ostype;
+  Field(result, 1) = Val_long (8 * sizeof(value));
+  CAMLreturn (result);
+}
+
diff --git a/byterun/sys.h b/byterun/sys.h
new file mode 100644
index 0000000000..6b1ac17344
--- /dev/null
+++ b/byterun/sys.h
@@ -0,0 +1,29 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            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 Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+#ifndef _sys_
+#define _sys_
+
+#include "misc.h"
+
+#define NO_ARG Val_int(0)
+
+CAMLextern void sys_error (value);
+extern void sys_init (char * exe_name, char ** argv);
+CAMLextern value sys_exit (value);
+
+extern char * caml_exe_name;
+
+#endif /* _sys_ */
diff --git a/byterun/weak.c b/byterun/weak.c
new file mode 100644
index 0000000000..846669c117
--- /dev/null
+++ b/byterun/weak.c
@@ -0,0 +1,114 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*             Damien Doligez, projet Para, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1997 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* Operations on weak arrays */
+
+#include <string.h>
+
+#include "alloc.h"
+#include "fail.h"
+#include "memory.h"
+#include "mlvalues.h"
+
+value weak_list_head = 0;
+
+CAMLprim value weak_create (value len)
+{
+  mlsize_t size, i;
+  value res;
+
+  size = Long_val (len) + 1;
+  if (size <= 0 || size > Max_wosize) invalid_argument ("Weak.create");
+  res = alloc_shr (size, Abstract_tag);
+  for (i = 1; i < size; i++) Field (res, i) = 0;
+  Field (res, 0) = weak_list_head;
+  weak_list_head = res;
+  return res;
+}
+
+#define None_val (Val_int(0))
+#define Some_tag 0
+
+CAMLprim value weak_set (value ar, value n, value el)
+{
+  mlsize_t offset = Long_val (n) + 1;
+                                                   Assert (Is_in_heap (ar));
+  if (offset < 1 || offset >= Wosize_val (ar)) invalid_argument ("Weak.set");
+  Field (ar, offset) = 0;
+  if (el != None_val){                        Assert (Wosize_val (el) == 1);
+    Modify (&Field (ar, offset), Field (el, 0));
+  }
+  return Val_unit;
+}
+
+#define Setup_for_gc
+#define Restore_after_gc
+
+CAMLprim value weak_get (value ar, value n)
+{
+  CAMLparam2 (ar, n);
+  mlsize_t offset = Long_val (n) + 1;
+  CAMLlocal2 (res, elt);
+                                                   Assert (Is_in_heap (ar));
+  if (offset < 1 || offset >= Wosize_val (ar)) invalid_argument ("Weak.get");
+  if (Field (ar, offset) == 0){
+    res = None_val;
+  }else{
+    elt = Field (ar, offset);
+    if (gc_phase == Phase_mark) darken (elt, NULL);
+    res = alloc_small (1, Some_tag);
+    Field (res, 0) = elt;
+  }
+  CAMLreturn (res);
+}
+
+#undef Setup_for_gc
+#undef Restore_after_gc
+
+CAMLprim value weak_get_copy (value ar, value n)
+{
+  CAMLparam2 (ar, n);
+  mlsize_t offset = Long_val (n) + 1;
+  CAMLlocal2 (res, elt);
+  value v;  /* Caution: this is NOT a local root. */
+                                                   Assert (Is_in_heap (ar));
+  if (offset < 1 || offset >= Wosize_val (ar)) invalid_argument ("Weak.get");
+
+  v = Field (ar, offset);
+  if (v == 0) CAMLreturn (None_val);
+  elt = alloc (Wosize_val (v), Tag_val (v)); /* The GC may erase or move v. */
+  v = Field (ar, offset);
+  if (v == 0) CAMLreturn (None_val);
+  if (Tag_val (v) < No_scan_tag){
+    mlsize_t i;
+    for (i = 0; i < Wosize_val (v); i++){
+      Modify (&Field (elt, i), Field (v, i));
+    }
+  }else{
+    memmove (Bp_val (elt), Bp_val (v), Bosize_val (v));
+  }
+  res = alloc_small (1, Some_tag);
+  Field (res, 0) = elt;
+
+  CAMLreturn (res);
+}
+
+CAMLprim value weak_check (value ar, value n)
+{
+  mlsize_t offset = Long_val (n) + 1;
+                                                   Assert (Is_in_heap (ar));
+  if (offset < 1 || offset >= Wosize_val (ar)) invalid_argument ("Weak.get");
+  return Val_bool (Field (ar, offset) != 0);
+}
diff --git a/driver/compile.ml b/driver/compile.ml
new file mode 100644
index 0000000000..0699c531cb
--- /dev/null
+++ b/driver/compile.ml
@@ -0,0 +1,105 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2002 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* The batch compiler *)
+
+open Misc
+open Config
+open Format
+open Typedtree
+
+(* Initialize the search path.
+   The current directory is always searched first,
+   then the directories specified with the -I option (in command-line order),
+   then the standard library directory. *)
+
+let init_path () =
+  let dirs =
+    if !Clflags.thread_safe
+    then "+threads" :: !Clflags.include_dirs
+    else !Clflags.include_dirs in
+  let exp_dirs =
+    List.map (expand_directory Config.standard_library) dirs in
+  load_path := "" :: List.rev (Config.standard_library :: exp_dirs);
+  Env.reset_cache()
+
+(* Return the initial environment in which compilation proceeds. *)
+
+let initial_env () =
+  try
+    if !Clflags.nopervasives
+    then Env.initial
+    else Env.open_pers_signature "Pervasives" Env.initial
+  with Not_found ->
+    fatal_error "cannot open pervasives.cmi"
+
+(* Compile a .mli file *)
+
+let interface ppf sourcefile =
+  init_path();
+  let prefixname = chop_extension_if_any sourcefile in
+  let modulename = String.capitalize(Filename.basename prefixname) in
+  let inputfile = Pparse.preprocess sourcefile in
+  try
+    let ast =
+      Pparse.file ppf inputfile Parse.interface ast_intf_magic_number in
+    if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast;
+    let sg = Typemod.transl_signature (initial_env()) ast in
+    if !Clflags.print_types
+      then fprintf std_formatter "%a@." Printtyp.signature sg;
+    Warnings.check_fatal ();
+    Env.save_signature sg modulename (prefixname ^ ".cmi");
+    Pparse.remove_preprocessed inputfile
+  with e ->
+    Pparse.remove_preprocessed_if_ast inputfile;
+    raise e
+
+(* Compile a .ml file *)
+
+let print_if ppf flag printer arg =
+  if !flag then fprintf ppf "%a@." printer arg;
+  arg
+
+let (++) x f = f x
+
+let implementation ppf sourcefile =
+  init_path();
+  let prefixname = chop_extension_if_any sourcefile in
+  let modulename = String.capitalize(Filename.basename prefixname) in
+  let inputfile = Pparse.preprocess sourcefile in
+  let objfile = prefixname ^ ".cmo" in
+  let oc = open_out_bin objfile in
+  let env = initial_env() in
+  try
+    Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number
+    ++ print_if ppf Clflags.dump_parsetree Printast.implementation
+    ++ Typemod.type_implementation sourcefile prefixname modulename env
+    ++ Translmod.transl_implementation modulename
+    ++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda
+    ++ Simplif.simplify_lambda
+    ++ print_if ppf Clflags.dump_lambda Printlambda.lambda
+    ++ Bytegen.compile_implementation modulename
+    ++ print_if ppf Clflags.dump_instr Printinstr.instrlist
+    ++ Emitcode.to_file oc modulename;
+    Warnings.check_fatal ();
+    Pparse.remove_preprocessed inputfile;
+    close_out oc;
+  with x ->
+    close_out oc;
+    remove_file objfile;
+    Pparse.remove_preprocessed_if_ast inputfile;
+    raise x
+
+let c_file name =
+  if Ccomp.compile_file name <> 0 then exit 2
diff --git a/driver/errors.ml b/driver/errors.ml
new file mode 100644
index 0000000000..78f6c00ac4
--- /dev/null
+++ b/driver/errors.ml
@@ -0,0 +1,69 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            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 Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* WARNING: if you change something in this file, you must look at
+   opterrors.ml to see if you need to make the same changes there.
+*)
+
+open Format
+
+(* Report an error *)
+
+let report_error ppf exn =
+  let report ppf = function
+  | Lexer.Error(err, start, stop) ->
+      Location.print ppf {Location.loc_start = start;
+                          Location.loc_end = stop;
+                          Location.loc_ghost = false};
+      Lexer.report_error ppf err
+  | Syntaxerr.Error err ->
+      Syntaxerr.report_error ppf err
+  | Pparse.Error ->
+      fprintf ppf "Preprocessor error"
+  | Env.Error err ->
+      Env.report_error ppf err
+  | Ctype.Tags(l, l') -> fprintf ppf
+      "In this program,@ variant constructors@ `%s and `%s@ \
+       have the same hash value.@ Change one of them." l l'
+  | Typecore.Error(loc, err) ->
+      Location.print ppf loc; Typecore.report_error ppf err
+  | Typetexp.Error(loc, err) ->
+      Location.print ppf loc; Typetexp.report_error ppf err
+  | Typedecl.Error(loc, err) ->
+      Location.print ppf loc; Typedecl.report_error ppf err
+  | Includemod.Error err ->
+      Includemod.report_error ppf err
+  | Typemod.Error(loc, err) ->
+      Location.print ppf loc; Typemod.report_error ppf err
+  | Translcore.Error(loc, err) ->
+      Location.print ppf loc; Translcore.report_error ppf err
+  | Symtable.Error code ->
+      Symtable.report_error ppf code
+  | Bytelink.Error code ->
+      Bytelink.report_error ppf code
+  | Bytelibrarian.Error code ->
+      Bytelibrarian.report_error ppf code
+  | Bytepackager.Error code ->
+      Bytepackager.report_error ppf code
+  | Sys_error msg ->
+      fprintf ppf "I/O error: %s" msg
+  | Typeclass.Error(loc, err) ->
+      Location.print ppf loc; Typeclass.report_error ppf err
+  | Translclass.Error(loc, err) ->
+      Location.print ppf loc; Translclass.report_error ppf err
+  | Warnings.Errors (n) ->
+      fprintf ppf "@.Error: %d error-enabled warnings occurred." n
+  | x -> fprintf ppf "@]"; raise x in
+
+  fprintf ppf "@[%a@]@." report exn
diff --git a/driver/main.ml b/driver/main.ml
new file mode 100644
index 0000000000..d91d48aa48
--- /dev/null
+++ b/driver/main.ml
@@ -0,0 +1,135 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            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 Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+open Config
+open Clflags
+
+let process_interface_file ppf name =
+  Compile.interface ppf name
+
+let process_implementation_file ppf name =
+  Compile.implementation ppf name;
+  objfiles := (Misc.chop_extension_if_any name ^ ".cmo") :: !objfiles
+
+let process_file ppf name =
+  if Filename.check_suffix name ".ml"
+  || Filename.check_suffix name ".mlt" then begin
+    Compile.implementation ppf name;
+    objfiles := (Misc.chop_extension_if_any name ^ ".cmo") :: !objfiles
+  end
+  else if Filename.check_suffix name !Config.interface_suffix then
+    Compile.interface ppf name
+  else if Filename.check_suffix name ".cmo"
+       || Filename.check_suffix name ".cma" then
+    objfiles := name :: !objfiles
+  else if Filename.check_suffix name ext_obj
+       || Filename.check_suffix name ext_lib then
+    ccobjs := name :: !ccobjs
+  else if Filename.check_suffix name ext_dll then
+    dllibs := name :: !dllibs
+  else if Filename.check_suffix name ".c" then begin
+    Compile.c_file name;
+    match Sys.os_type with
+    | "MacOS" -> ccobjs := (name ^ ".o") :: (name ^ ".x") :: !ccobjs
+    | _ ->
+       ccobjs := (Filename.chop_suffix (Filename.basename name) ".c" ^ ext_obj)
+                 :: !ccobjs
+  end
+  else
+    raise(Arg.Bad("don't know what to do with " ^ name))
+
+let print_version_number () =
+  print_string "The Objective Caml compiler, version ";
+  print_string Config.version; print_newline();
+  print_string "Standard library directory: ";
+  print_string Config.standard_library; print_newline();
+  exit 0
+
+let print_standard_library () =
+  print_string Config.standard_library; print_newline(); exit 0
+
+let usage = "Usage: ocamlc <options> <files>\nOptions are:"
+
+(* Error messages to standard error formatter *)
+let anonymous = process_file Format.err_formatter;;
+let impl = process_implementation_file Format.err_formatter;;
+let intf = process_interface_file Format.err_formatter;;
+
+module Options = Main_args.Make_options (struct
+  let set r () = r := true
+  let unset r () = r := false
+  let _a = set make_archive
+  let _c = set compile_only
+  let _cc s = c_compiler := s; c_linker := s
+  let _cclib s = ccobjs := s :: !ccobjs
+  let _ccopt s = ccopts := s :: !ccopts
+  let _custom = set custom_runtime
+  let _dllib s = dllibs := s :: !dllibs
+  let _dllpath s = dllpaths := !dllpaths @ [s]
+  let _g = set debug
+  let _i = set print_types
+  let _I s = include_dirs := s :: !include_dirs
+  let _impl = impl
+  let _intf = intf
+  let _intf_suffix s = Config.interface_suffix := s
+  let _labels = unset classic
+  let _linkall = set link_everything
+  let _make_runtime () =
+    custom_runtime := true; make_runtime := true; link_everything := true
+  let _noassert = set noassert
+  let _nolabels = set classic
+  let _noautolink = set no_auto_link
+  let _o s = exec_name := s; archive_name := s; object_name := s
+  let _output_obj () = output_c_object := true; custom_runtime := true
+  let _pack = set make_package
+  let _pp s = preprocessor := Some s
+  let _rectypes = set recursive_types
+  let _thread = set thread_safe
+  let _unsafe = set fast
+  let _use_prims s = use_prims := s
+  let _use_runtime s = use_runtime := s
+  let _v = print_version_number
+  let _w = (Warnings.parse_options false)
+  let _warn_error = (Warnings.parse_options true)
+  let _where = print_standard_library
+  let _verbose = set verbose
+  let _nopervasives = set nopervasives
+  let _dparsetree = set dump_parsetree
+  let _drawlambda = set dump_rawlambda
+  let _dlambda = set dump_lambda
+  let _dinstr = set dump_instr
+  let anonymous = anonymous
+end)
+
+let main () =
+  try
+    Arg.parse Options.list anonymous usage;
+    if !make_archive then begin
+      Compile.init_path();
+      Bytelibrarian.create_archive (List.rev !objfiles) !archive_name
+    end
+    else if !make_package then begin
+      Compile.init_path();
+      Bytepackager.package_files (List.rev !objfiles) !object_name
+    end
+    else if not !compile_only && !objfiles <> [] then begin
+      Compile.init_path();
+      Bytelink.link (List.rev !objfiles)
+    end;
+    exit 0
+  with x ->
+    Errors.report_error Format.err_formatter x;
+    exit 2
+
+let _ = main ()
diff --git a/driver/main_args.ml b/driver/main_args.ml
new file mode 100644
index 0000000000..33391e3d05
--- /dev/null
+++ b/driver/main_args.ml
@@ -0,0 +1,141 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*             Damien Doligez, projet Para, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1998 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+module Make_options (F :
+   sig
+     val _a : unit -> unit
+     val _c : unit -> unit
+     val _cc : string -> unit
+     val _cclib : string -> unit
+     val _ccopt : string -> unit
+     val _custom : unit -> unit
+     val _dllib : string -> unit
+     val _dllpath : string -> unit
+     val _g : unit -> unit
+     val _i : unit -> unit
+     val _I : string -> unit
+     val _impl : string -> unit
+     val _intf : string -> unit
+     val _intf_suffix : string -> unit
+     val _labels : unit -> unit
+     val _linkall : unit -> unit
+     val _make_runtime : unit -> unit
+     val _noassert : unit -> unit
+     val _noautolink : unit -> unit
+     val _nolabels : unit -> unit
+     val _o : string -> unit
+     val _output_obj : unit -> unit
+     val _pack : unit -> unit
+     val _pp : string -> unit
+     val _rectypes : unit -> unit
+     val _thread : unit -> unit
+     val _unsafe : unit -> unit
+     val _use_prims : string -> unit
+     val _use_runtime : string -> unit
+     val _v : unit -> unit
+     val _verbose : unit -> unit
+     val _w : string -> unit
+     val _warn_error : string -> unit
+     val _where : unit -> unit
+
+     val _nopervasives : unit -> unit
+     val _dparsetree : unit -> unit
+     val _drawlambda : unit -> unit
+     val _dlambda : unit -> unit
+     val _dinstr : unit -> unit
+     val anonymous : string -> unit
+   end) =
+struct
+  let list = [
+    "-a", Arg.Unit F._a, " Build a library";
+    "-c", Arg.Unit F._c, " Compile only (do not link)";
+    "-cc", Arg.String F._cc,
+           "<command>  Use <command> as the C compiler and linker";
+    "-cclib", Arg.String F._cclib, "<opt>  Pass option <opt> to the C linker";
+    "-ccopt", Arg.String F._ccopt,
+           "<opt>  Pass option <opt> to the C compiler and linker";
+    "-custom", Arg.Unit F._custom, " Link in custom mode";
+    "-dllib", Arg.String F._dllib,
+           "<lib>  Use the dynamically-loaded library <lib>";
+    "-dllpath", Arg.String F._dllpath,
+           "<dir>  Add <dir> to the run-time search path for shared libraries";
+    "-g", Arg.Unit F._g, " Save debugging information";
+    "-i", Arg.Unit F._i, " Print the types";
+    "-I", Arg.String F._I,
+           "<dir>  Add <dir> to the list of include directories";
+    "-impl", Arg.String F._impl, "<file>  Compile <file> as a .ml file";
+    "-intf", Arg.String F._intf, "<file>  Compile <file> as a .mli file";
+    "-intf-suffix", Arg.String F._intf_suffix,
+           "<string>  Suffix for interface files (default: .mli)";
+    "-intf_suffix", Arg.String F._intf_suffix,
+           "<string>  (deprecated) same as -intf-suffix";
+    "-labels", Arg.Unit F._labels, " Use commuting label mode";
+    "-linkall", Arg.Unit F._linkall, " Link all modules, even unused ones";
+    "-make-runtime", Arg.Unit F._make_runtime,
+           " Build a runtime system with given C objects and libraries";
+    "-make_runtime", Arg.Unit F._make_runtime,
+           " (deprecated) same as -make-runtime";
+    "-modern", Arg.Unit F._labels, " (deprecated) same as -labels";
+    "-noassert", Arg.Unit F._noassert, " Don't compile assertion checks";
+    "-noautolink", Arg.Unit F._noautolink,
+           " Don't automatically link C libraries specified in .cma files";
+    "-nolabels", Arg.Unit F._nolabels, " Ignore non-optional labels in types";
+    "-o", Arg.String F._o, "<file>  Set output file name to <file>";
+    "-output-obj", Arg.Unit F._output_obj,
+           " Output a C object file instead of an executable";
+    "-pack", Arg.Unit F._pack,
+           " Package the given .cmo files into one .cmo";
+    "-pp", Arg.String F._pp,
+           "<command>  Pipe sources through preprocessor <command>";
+    "-rectypes", Arg.Unit F._rectypes, " Allow arbitrary recursive types";
+    "-thread", Arg.Unit F._thread, " Use thread-safe standard library";
+    "-unsafe", Arg.Unit F._unsafe,
+           " No bounds checking on array and string access";
+    "-use-runtime", Arg.String F._use_runtime,
+           "<file>  Generate bytecode for the given runtime system";
+    "-use_runtime", Arg.String F._use_runtime,
+           "<file>  (deprecated) same as -use-runtime";
+    "-v", Arg.Unit F._v, " Print compiler version number and exit";
+    "-verbose", Arg.Unit F._verbose, " Print calls to external commands";
+    "-w", Arg.String F._w,
+      "<flags>  Enable or disable warnings according to <flags>:\n\
+      \032    A/a enable/disable all warnings\n\
+      \032    C/c enable/disable suspicious comment\n\
+      \032    D/d enable/disable deprecated features\n\
+      \032    F/f enable/disable partially applied function\n\
+      \032    L/l enable/disable labels omitted in application\n\
+      \032    M/m enable/disable overriden method\n\
+      \032    P/p enable/disable partial match\n\
+      \032    S/s enable/disable non-unit statement\n\
+      \032    U/u enable/disable unused match case\n\
+      \032    V/v enable/disable hidden instance variable\n\
+      \032    X/x enable/disable all other warnings\n\
+      \032    default setting is \"Al\" (all warnings but labels enabled)";
+    "-warn-error" , Arg.String F._warn_error,
+      "<flags>  Treat the warnings enabled by <flags> as errors.\n\
+      \032    See option -w for the list of flags.\n\
+      \032    Default setting is \"a\" (warnings are not errors)";
+    "-where", Arg.Unit F._where,
+           " Print location of standard library and exit";
+    "-nopervasives", Arg.Unit F._nopervasives, " (undocumented)";
+    "-dparsetree", Arg.Unit F._dparsetree, " (undocumented)";
+    "-drawlambda", Arg.Unit F._drawlambda, " (undocumented)";
+    "-dlambda", Arg.Unit F._dlambda, " (undocumented)";
+    "-dinstr", Arg.Unit F._dinstr, " (undocumented)";
+    "-use-prims", Arg.String F._use_prims, "<file>  (undocumented)";
+
+    "-", Arg.String F.anonymous,
+           "<file>  Treat <file> as a file name (even if it starts with `-')";
+  ]
+end;;
diff --git a/driver/main_args.mli b/driver/main_args.mli
new file mode 100644
index 0000000000..3f71e245bf
--- /dev/null
+++ b/driver/main_args.mli
@@ -0,0 +1,61 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*             Damien Doligez, projet Para, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1998 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+module Make_options (F :
+    sig
+      val _a : unit -> unit
+      val _c : unit -> unit
+      val _cc : string -> unit
+      val _cclib : string -> unit
+      val _ccopt : string -> unit
+      val _custom : unit -> unit
+      val _dllib : string -> unit
+      val _dllpath : string -> unit
+      val _g : unit -> unit
+      val _i : unit -> unit
+      val _I : string -> unit
+      val _impl : string -> unit
+      val _intf : string -> unit
+      val _intf_suffix : string -> unit
+      val _labels : unit -> unit
+      val _linkall : unit -> unit
+      val _make_runtime : unit -> unit
+      val _noassert : unit -> unit
+      val _noautolink : unit -> unit
+      val _nolabels : unit -> unit
+      val _o : string -> unit
+      val _output_obj : unit -> unit
+      val _pack : unit -> unit
+      val _pp : string -> unit
+      val _rectypes : unit -> unit
+      val _thread : unit -> unit
+      val _unsafe : unit -> unit
+      val _use_prims : string -> unit
+      val _use_runtime : string -> unit
+      val _v : unit -> unit
+      val _verbose : unit -> unit
+      val _w : string -> unit
+      val _warn_error : string -> unit
+      val _where : unit -> unit
+
+      val _nopervasives : unit -> unit
+      val _dparsetree : unit -> unit
+      val _drawlambda : unit -> unit
+      val _dlambda : unit -> unit
+      val _dinstr : unit -> unit
+      val anonymous : string -> unit
+    end) :
+  sig
+    val list : (string * Arg.spec * string) list
+  end
diff --git a/driver/optcompile.ml b/driver/optcompile.ml
new file mode 100644
index 0000000000..b3302a182b
--- /dev/null
+++ b/driver/optcompile.ml
@@ -0,0 +1,100 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2002 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* The batch compiler *)
+
+open Misc
+open Config
+open Format
+open Typedtree
+
+(* Initialize the search path.
+   The current directory is always searched first,
+   then the directories specified with the -I option (in command-line order),
+   then the standard library directory. *)
+
+let init_path () =
+  let dirs =
+    if !Clflags.thread_safe
+    then "+threads" :: !Clflags.include_dirs
+    else !Clflags.include_dirs in
+  let exp_dirs =
+    List.map (expand_directory Config.standard_library) dirs in
+  load_path := "" :: List.rev (Config.standard_library :: exp_dirs);
+  Env.reset_cache()
+
+(* Return the initial environment in which compilation proceeds. *)
+
+let initial_env () =
+  init_path();
+  try
+    if !Clflags.nopervasives
+    then Env.initial
+    else Env.open_pers_signature "Pervasives" Env.initial
+  with Not_found ->
+    fatal_error "cannot open Pervasives.cmi"
+
+(* Compile a .mli file *)
+
+let interface ppf sourcefile =
+  let prefixname = Misc.chop_extension_if_any sourcefile in
+  let modulename = String.capitalize(Filename.basename prefixname) in
+  let inputfile = Pparse.preprocess sourcefile in
+  try
+    let ast =
+      Pparse.file ppf inputfile Parse.interface ast_intf_magic_number in
+    if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast;
+    let sg = Typemod.transl_signature (initial_env()) ast in
+    if !Clflags.print_types then
+      fprintf std_formatter "%a@." Printtyp.signature sg;
+    Warnings.check_fatal ();
+    Env.save_signature sg modulename (prefixname ^ ".cmi");
+    Pparse.remove_preprocessed inputfile
+  with e ->
+    Pparse.remove_preprocessed_if_ast inputfile;
+    raise e
+
+(* Compile a .ml file *)
+
+let print_if ppf flag printer arg =
+  if !flag then fprintf ppf "%a@." printer arg;
+  arg
+
+let (++) x f = f x
+let (+++) (x, y) f = (x, f y)
+
+let implementation ppf sourcefile =
+  let prefixname = Misc.chop_extension_if_any sourcefile in
+  let modulename = String.capitalize(Filename.basename prefixname) in
+  let inputfile = Pparse.preprocess sourcefile in
+  let env = initial_env() in
+  Compilenv.reset modulename;
+  try
+    Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number
+    ++ print_if ppf Clflags.dump_parsetree Printast.implementation
+    ++ Typemod.type_implementation sourcefile prefixname modulename env
+    ++ Translmod.transl_store_implementation modulename
+    +++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda
+    +++ Simplif.simplify_lambda
+    +++ print_if ppf Clflags.dump_lambda Printlambda.lambda
+    ++ Asmgen.compile_implementation prefixname ppf;
+    Compilenv.save_unit_info (prefixname ^ ".cmx");
+    Warnings.check_fatal ();
+    Pparse.remove_preprocessed inputfile
+  with x ->
+    Pparse.remove_preprocessed_if_ast inputfile;
+    raise x
+
+let c_file name =
+  if Ccomp.compile_file name <> 0 then exit 2
diff --git a/driver/opterrors.ml b/driver/opterrors.ml
new file mode 100644
index 0000000000..207e00ff46
--- /dev/null
+++ b/driver/opterrors.ml
@@ -0,0 +1,71 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            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 Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* WARNING: if you change something in this file, you must look at
+   errors.ml to see if you need to make the same changes there.
+*)
+
+open Format
+
+(* Report an error *)
+
+let report_error ppf exn =
+  let report ppf = function
+  | Lexer.Error(err, start, stop) ->
+      Location.print ppf {Location.loc_start = start;
+                          Location.loc_end = stop;
+                          Location.loc_ghost = false};
+      Lexer.report_error ppf err
+  | Syntaxerr.Error err ->
+      Syntaxerr.report_error ppf err
+  | Pparse.Error ->
+      fprintf ppf "Preprocessor error"
+  | Env.Error err ->
+      Env.report_error ppf err
+  | Ctype.Tags(l, l') -> fprintf ppf
+      "In this program,@ variant constructors@ `%s and `%s@ \
+       have the same hash value." l l'
+  | Typecore.Error(loc, err) ->
+      Location.print ppf loc; Typecore.report_error ppf err
+  | Typetexp.Error(loc, err) ->
+      Location.print ppf loc; Typetexp.report_error ppf err
+  | Typedecl.Error(loc, err) ->
+      Location.print ppf loc; Typedecl.report_error ppf err
+  | Includemod.Error err ->
+      Includemod.report_error ppf err
+  | Typemod.Error(loc, err) ->
+      Location.print ppf loc; Typemod.report_error ppf err
+  | Translcore.Error(loc, err) ->
+      Location.print ppf loc; Translcore.report_error ppf err
+  | Compilenv.Error code ->
+      Compilenv.report_error ppf code
+  | Asmgen.Error code ->
+      Asmgen.report_error ppf code
+  | Asmlink.Error code ->
+      Asmlink.report_error ppf code
+  | Asmlibrarian.Error code ->
+      Asmlibrarian.report_error ppf code
+  | Asmpackager.Error code ->
+      Asmpackager.report_error ppf code
+  | Sys_error msg ->
+      fprintf ppf "I/O error: %s" msg
+  | Typeclass.Error(loc, err) ->
+      Location.print ppf loc; Typeclass.report_error ppf err
+  | Translclass.Error(loc, err) ->
+      Location.print ppf loc; Translclass.report_error ppf err
+  | Warnings.Errors (n) ->
+      fprintf ppf "@.Error: %d error-enabled warnings occurred." n
+  | x -> fprintf ppf "@]"; raise x in
+
+  fprintf ppf "@[%a@]@." report exn
diff --git a/driver/optmain.ml b/driver/optmain.ml
new file mode 100644
index 0000000000..b73a42350c
--- /dev/null
+++ b/driver/optmain.ml
@@ -0,0 +1,179 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            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 Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+open Config
+open Clflags
+
+let process_interface_file ppf name =
+  Optcompile.interface ppf name
+
+let process_implementation_file ppf name =
+  Optcompile.implementation ppf name;
+  objfiles := (Misc.chop_extension_if_any name ^ ".cmx") :: !objfiles
+
+let process_file ppf name =
+  if Filename.check_suffix name ".ml"
+  || Filename.check_suffix name ".mlt" then begin
+    Optcompile.implementation ppf name;
+    objfiles := (Misc.chop_extension_if_any name ^ ".cmx") :: !objfiles
+  end
+  else if Filename.check_suffix name !Config.interface_suffix then
+    Optcompile.interface ppf name
+  else if Filename.check_suffix name ".cmx" 
+       || Filename.check_suffix name ".cmxa" then
+    objfiles := name :: !objfiles
+  else if Filename.check_suffix name ext_obj
+       || Filename.check_suffix name ext_lib then
+    ccobjs := name :: !ccobjs
+  else if Filename.check_suffix name ".c" then begin
+    Optcompile.c_file name;
+    ccobjs := (Filename.chop_suffix (Filename.basename name) ".c" ^ ext_obj)
+    :: !ccobjs
+  end
+  else
+    raise(Arg.Bad("don't know what to do with " ^ name))
+
+let print_version_number () =
+  print_string "The Objective Caml native-code compiler, version ";
+  print_string Config.version; print_newline();
+  print_string "Standard library directory: ";
+  print_string Config.standard_library; print_newline();
+  exit 0
+
+let print_standard_library () =
+  print_string Config.standard_library; print_newline(); exit 0
+
+let usage = "Usage: ocamlopt <options> <files>\nOptions are:"
+
+let main () =
+  native_code := true;
+  c_compiler := Config.native_c_compiler;
+  c_linker := Config.native_c_linker;
+  let ppf = Format.err_formatter in
+  try
+    Arg.parse [
+       "-a", Arg.Set make_archive, " Build a library";
+       "-c", Arg.Set compile_only, " Compile only (do not link)";
+       "-cc", Arg.String(fun s -> c_compiler := s; c_linker := s),
+             "<comp>  Use <comp> as the C compiler and linker";
+       "-cclib", Arg.String(fun s -> ccobjs := s :: !ccobjs),
+             "<opt>  Pass option <opt> to the C linker";
+       "-ccopt", Arg.String(fun s -> ccopts := s :: !ccopts),
+             "<opt>  Pass option <opt> to the C compiler and linker";
+       "-compact", Arg.Clear optimize_for_speed,
+             " Optimize code size rather than speed";
+       "-dllpath", Arg.String (fun s -> dllpaths := !dllpaths @ [s]),
+            "<dir>  Add <dir> to the run-time search path for shared libraries";
+       "-i", Arg.Set print_types, " Print the types";
+       "-I", Arg.String(fun dir -> include_dirs := dir :: !include_dirs),
+             "<dir>  Add <dir> to the list of include directories";
+       "-impl", Arg.String (process_implementation_file ppf),
+             "<file>  Compile <file> as a .ml file";
+       "-inline", Arg.Int(fun n -> inline_threshold := n * 8),
+             "<n>  Set aggressiveness of inlining to <n>";
+       "-intf", Arg.String (process_interface_file ppf),
+             "<file>  Compile <file> as a .mli file";
+       "-intf-suffix", Arg.String (fun s -> Config.interface_suffix := s),
+             "<file>  Suffix for interface files (default: .mli)";
+       "-intf_suffix", Arg.String (fun s -> Config.interface_suffix := s),
+             "<file>  (deprecated) same as -intf-suffix";
+       "-labels", Arg.Clear classic, " Use commuting label mode";
+       "-linkall", Arg.Set link_everything,
+             " Link all modules, even unused ones";
+       "-noassert", Arg.Set noassert, " Don't compile assertion checks";
+       "-noautolink", Arg.Set no_auto_link,
+             " Don't automatically link C libraries specified in .cma files";
+       "-nolabels", Arg.Set classic, " Ignore non-optional labels in types";
+       "-o", Arg.String(fun s -> exec_name := s;
+                                 archive_name := s;
+                                 object_name := s),
+             "<file>  Set output file name to <file>";
+       "-output-obj", Arg.Unit(fun () -> output_c_object := true),
+             " Output a C object file instead of an executable";
+       "-p", Arg.Set gprofile,
+             " Compile and link with profiling support for \"gprof\"\n\
+               \t(not supported on all platforms)";
+       "-pack", Arg.Set make_package,
+              " Package the given .cmo files into one .cmo";
+       "-pp", Arg.String(fun s -> preprocessor := Some s),
+             "<command>  Pipe sources through preprocessor <command>";
+       "-rectypes", Arg.Set recursive_types,
+             " Allow arbitrary recursive types";
+       "-S", Arg.Set keep_asm_file, " Keep intermediate assembly file";
+       "-thread", Arg.Set thread_safe, " Use thread-safe standard library";
+       "-unsafe", Arg.Set fast,
+             " No bounds checking on array and string access";
+       "-v", Arg.Unit print_version_number, " Print compiler version number";
+       "-verbose", Arg.Set verbose, " Print calls to external commands";
+       "-w", Arg.String (Warnings.parse_options false),
+             "<flags>  Enable or disable warnings according to <flags>:\n\
+         \032    A/a enable/disable all warnings\n\
+         \032    C/c enable/disable suspicious comment\n\
+         \032    D/d enable/disable deprecated features\n\
+         \032    F/f enable/disable partially applied function\n\
+         \032    L/l enable/disable labels omitted in application\n\
+         \032    M/m enable/disable overriden methods\n\
+         \032    P/p enable/disable partial match\n\
+         \032    S/s enable/disable non-unit statement\n\
+         \032    U/u enable/disable unused match case\n\
+         \032    V/v enable/disable hidden instance variables\n\
+         \032    X/x enable/disable all other warnings\n\
+         \032    default setting is \"Al\" (all warnings but labels enabled)";
+       "-warn-error" , Arg.String (Warnings.parse_options true),
+         "<flags>  Enable or disable fatal warnings according to <flags>\n\
+           \032    (see option -w for the list of flags)\n\
+           \032    default setting is a (all warnings are non-fatal)";
+    "-where", Arg.Unit print_standard_library,
+      " Print location of standard library and exit";
+
+       "-nopervasives", Arg.Set nopervasives, " (undocumented)";
+       "-dparsetree", Arg.Set dump_parsetree, " (undocumented)";
+       "-drawlambda", Arg.Set dump_rawlambda, " (undocumented)";
+       "-dlambda", Arg.Set dump_lambda, " (undocumented)";
+       "-dcmm", Arg.Set dump_cmm, " (undocumented)";
+       "-dsel", Arg.Set dump_selection, " (undocumented)";
+       "-dcombine", Arg.Set dump_combine, " (undocumented)";
+       "-dlive", Arg.Unit(fun () -> dump_live := true;
+                                    Printmach.print_live := true),
+             " (undocumented)";
+       "-dspill", Arg.Set dump_spill, " (undocumented)";
+       "-dsplit", Arg.Set dump_split, " (undocumented)";
+       "-dinterf", Arg.Set dump_interf, " (undocumented)";
+       "-dprefer", Arg.Set dump_prefer, " (undocumented)";
+       "-dalloc", Arg.Set dump_regalloc, " (undocumented)";
+       "-dreload", Arg.Set dump_reload, " (undocumented)";
+       "-dscheduling", Arg.Set dump_scheduling, " (undocumented)";
+       "-dlinear", Arg.Set dump_linear, " (undocumented)";
+       "-dstartup", Arg.Set keep_startup_file, " (undocumented)";
+       "-", Arg.String (process_file ppf),
+            "<file>  Treat <file> as a file name (even if it starts with `-')"
+      ] (process_file ppf) usage;
+    if !make_archive then begin
+      Optcompile.init_path();
+      Asmlibrarian.create_archive (List.rev !objfiles) !archive_name
+    end
+    else if !make_package then begin
+      Optcompile.init_path();
+      Asmpackager.package_files ppf (List.rev !objfiles) !object_name
+    end
+    else if not !compile_only && !objfiles <> [] then begin
+      Optcompile.init_path();
+      Asmlink.link ppf (List.rev !objfiles)
+    end;
+    exit 0
+  with x ->
+    Opterrors.report_error ppf x;
+    exit 2
+
+let _ = main ()
diff --git a/driver/pparse.ml b/driver/pparse.ml
new file mode 100644
index 0000000000..bcec36e7e7
--- /dev/null
+++ b/driver/pparse.ml
@@ -0,0 +1,79 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*        Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt     *)
+(*                                                                     *)
+(*  Copyright 2002 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+open Format
+
+exception Error
+
+(* Optionally preprocess a source file *)
+
+let preprocess sourcefile =
+  match !Clflags.preprocessor with
+    None -> sourcefile
+  | Some pp ->
+      let tmpfile = Filename.temp_file "camlpp" "" in
+      let comm = Printf.sprintf "%s %s > %s" pp sourcefile tmpfile in
+      if Ccomp.command comm <> 0 then begin
+        Misc.remove_file tmpfile;
+        raise Error;
+      end;
+      tmpfile
+
+let remove_preprocessed inputfile =
+  match !Clflags.preprocessor with
+    None -> ()
+  | Some _ -> Misc.remove_file inputfile
+
+let remove_preprocessed_if_ast inputfile =
+  match !Clflags.preprocessor with
+    None -> ()
+  | Some _ ->
+      if inputfile <> !Location.input_name then Misc.remove_file inputfile
+
+(* Parse a file or get a dumped syntax tree in it *)
+
+exception Outdated_version
+
+let file ppf inputfile parse_fun ast_magic =
+  let ic = open_in_bin inputfile in
+  let is_ast_file =
+    try
+      let buffer = String.create (String.length ast_magic) in
+      really_input ic buffer 0 (String.length ast_magic);
+      if buffer = ast_magic then true
+      else if String.sub buffer 0 9 = String.sub ast_magic 0 9 then
+        raise Outdated_version
+      else false
+    with
+      Outdated_version ->
+        Misc.fatal_error "Ocaml and preprocessor have incompatible versions"
+    | _ -> false
+  in
+  let ast =
+    try
+      if is_ast_file then begin
+        if !Clflags.fast then
+          fprintf ppf "@[Warning: %s@]@."
+            "option -unsafe used with a preprocessor returning a syntax tree";
+        Location.input_name := input_value ic;
+        input_value ic
+      end else begin
+        seek_in ic 0;
+        Location.input_name := inputfile;
+        parse_fun (Lexing.from_channel ic)
+      end
+    with x -> close_in ic; raise x
+  in
+  close_in ic;
+  ast
diff --git a/driver/pparse.mli b/driver/pparse.mli
new file mode 100644
index 0000000000..0ed0391360
--- /dev/null
+++ b/driver/pparse.mli
@@ -0,0 +1,22 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*        Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt     *)
+(*                                                                     *)
+(*  Copyright 2002 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+open Format
+
+exception Error
+
+val preprocess : string -> string
+val remove_preprocessed : string -> unit
+val remove_preprocessed_if_ast : string -> unit
+val file : formatter -> string -> (Lexing.lexbuf -> 'a) -> string -> 'a
diff --git a/stdlib/.cvsignore b/stdlib/.cvsignore
new file mode 100644
index 0000000000..5566878302
--- /dev/null
+++ b/stdlib/.cvsignore
@@ -0,0 +1,4 @@
+camlheader
+camlheader_ur
+labelled-*
+caml
diff --git a/stdlib/.depend b/stdlib/.depend
new file mode 100644
index 0000000000..c22ca15c6c
--- /dev/null
+++ b/stdlib/.depend
@@ -0,0 +1,87 @@
+format.cmi: buffer.cmi 
+genlex.cmi: stream.cmi 
+moreLabels.cmi: hashtbl.cmi map.cmi set.cmi 
+parsing.cmi: lexing.cmi obj.cmi 
+printf.cmi: buffer.cmi 
+arg.cmo: array.cmi list.cmi printf.cmi string.cmi sys.cmi arg.cmi 
+arg.cmx: array.cmx list.cmx printf.cmx string.cmx sys.cmx arg.cmi 
+arrayLabels.cmo: array.cmi arrayLabels.cmi 
+arrayLabels.cmx: array.cmx arrayLabels.cmi 
+array.cmo: array.cmi 
+array.cmx: array.cmi 
+buffer.cmo: string.cmi sys.cmi buffer.cmi 
+buffer.cmx: string.cmx sys.cmx buffer.cmi 
+callback.cmo: obj.cmi callback.cmi 
+callback.cmx: obj.cmx callback.cmi 
+char.cmo: char.cmi 
+char.cmx: char.cmi 
+complex.cmo: complex.cmi 
+complex.cmx: complex.cmi 
+digest.cmo: string.cmi digest.cmi 
+digest.cmx: string.cmx digest.cmi 
+filename.cmo: buffer.cmi string.cmi sys.cmi filename.cmi 
+filename.cmx: buffer.cmx string.cmx sys.cmx filename.cmi 
+format.cmo: buffer.cmi obj.cmi printf.cmi string.cmi format.cmi 
+format.cmx: buffer.cmx obj.cmx printf.cmx string.cmx format.cmi 
+gc.cmo: printf.cmi sys.cmi gc.cmi 
+gc.cmx: printf.cmx sys.cmx gc.cmi 
+genlex.cmo: char.cmi hashtbl.cmi list.cmi stream.cmi string.cmi genlex.cmi 
+genlex.cmx: char.cmx hashtbl.cmx list.cmx stream.cmx string.cmx genlex.cmi 
+hashtbl.cmo: array.cmi sys.cmi hashtbl.cmi 
+hashtbl.cmx: array.cmx sys.cmx hashtbl.cmi 
+int32.cmo: int32.cmi 
+int32.cmx: int32.cmi 
+int64.cmo: int32.cmi obj.cmi int64.cmi 
+int64.cmx: int32.cmx obj.cmx int64.cmi 
+lazy.cmo: lazy.cmi 
+lazy.cmx: lazy.cmi 
+lexing.cmo: string.cmi lexing.cmi 
+lexing.cmx: string.cmx lexing.cmi 
+listLabels.cmo: list.cmi listLabels.cmi 
+listLabels.cmx: list.cmx listLabels.cmi 
+list.cmo: array.cmi list.cmi 
+list.cmx: array.cmx list.cmi 
+map.cmo: map.cmi 
+map.cmx: map.cmi 
+marshal.cmo: string.cmi marshal.cmi 
+marshal.cmx: string.cmx marshal.cmi 
+moreLabels.cmo: hashtbl.cmi map.cmi set.cmi moreLabels.cmi 
+moreLabels.cmx: hashtbl.cmx map.cmx set.cmx moreLabels.cmi 
+nativeint.cmo: sys.cmi nativeint.cmi 
+nativeint.cmx: sys.cmx nativeint.cmi 
+obj.cmo: marshal.cmi obj.cmi 
+obj.cmx: marshal.cmx obj.cmi 
+oo.cmo: array.cmi hashtbl.cmi list.cmi map.cmi obj.cmi random.cmi sort.cmi \
+    sys.cmi oo.cmi 
+oo.cmx: array.cmx hashtbl.cmx list.cmx map.cmx obj.cmx random.cmx sort.cmx \
+    sys.cmx oo.cmi 
+parsing.cmo: array.cmi lexing.cmi obj.cmi parsing.cmi 
+parsing.cmx: array.cmx lexing.cmx obj.cmx parsing.cmi 
+pervasives.cmo: pervasives.cmi 
+pervasives.cmx: pervasives.cmi 
+printexc.cmo: obj.cmi printf.cmi string.cmi sys.cmi printexc.cmi 
+printexc.cmx: obj.cmx printf.cmx string.cmx sys.cmx printexc.cmi 
+printf.cmo: buffer.cmi list.cmi obj.cmi string.cmi printf.cmi 
+printf.cmx: buffer.cmx list.cmx obj.cmx string.cmx printf.cmi 
+queue.cmo: queue.cmi 
+queue.cmx: queue.cmi 
+random.cmo: array.cmi char.cmi digest.cmi string.cmi random.cmi 
+random.cmx: array.cmx char.cmx digest.cmx string.cmx random.cmi 
+set.cmo: set.cmi 
+set.cmx: set.cmi 
+sort.cmo: array.cmi sort.cmi 
+sort.cmx: array.cmx sort.cmi 
+stack.cmo: list.cmi stack.cmi 
+stack.cmx: list.cmx stack.cmi 
+stdLabels.cmo: arrayLabels.cmi listLabels.cmi stringLabels.cmi stdLabels.cmi 
+stdLabels.cmx: arrayLabels.cmx listLabels.cmx stringLabels.cmx stdLabels.cmi 
+stream.cmo: list.cmi obj.cmi string.cmi stream.cmi 
+stream.cmx: list.cmx obj.cmx string.cmx stream.cmi 
+stringLabels.cmo: string.cmi stringLabels.cmi 
+stringLabels.cmx: string.cmx stringLabels.cmi 
+string.cmo: char.cmi list.cmi string.cmi 
+string.cmx: char.cmx list.cmx string.cmi 
+sys.cmo: sys.cmi 
+sys.cmx: sys.cmi 
+weak.cmo: obj.cmi weak.cmi 
+weak.cmx: obj.cmx weak.cmi 
diff --git a/stdlib/Makefile b/stdlib/Makefile
new file mode 100644
index 0000000000..724aaabf8f
--- /dev/null
+++ b/stdlib/Makefile
@@ -0,0 +1,155 @@
+#########################################################################
+#                                                                       #
+#                            Objective Caml                             #
+#                                                                       #
+#            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 Library General Public License, with     #
+#   the special exception on linking described in file ../LICENSE.      #
+#                                                                       #
+#########################################################################
+
+# $Id$
+
+include ../config/Makefile
+
+RUNTIME=../boot/ocamlrun
+COMPILER=../ocamlc
+CAMLC=$(RUNTIME) $(COMPILER)
+COMPFLAGS=-g -warn-error A
+OPTCOMPILER=../ocamlopt
+CAMLOPT=$(RUNTIME) $(OPTCOMPILER)
+OPTCOMPFLAGS=-warn-error A
+CAMLDEP=../boot/ocamlrun ../tools/ocamldep
+
+BASIC=pervasives.cmo array.cmo list.cmo char.cmo string.cmo sys.cmo \
+  hashtbl.cmo sort.cmo marshal.cmo obj.cmo \
+  lexing.cmo parsing.cmo \
+  set.cmo map.cmo stack.cmo queue.cmo stream.cmo \
+  buffer.cmo printf.cmo format.cmo arg.cmo printexc.cmo gc.cmo \
+  digest.cmo random.cmo oo.cmo genlex.cmo callback.cmo weak.cmo \
+  lazy.cmo filename.cmo int32.cmo int64.cmo nativeint.cmo complex.cmo
+LABELLED=arrayLabels.ml listLabels.ml stringLabels.ml moreLabels.ml
+
+OBJS=$(BASIC) labelled.cmo stdLabels.cmo
+ALLOBJS=$(BASIC) $(LABELLED:.ml=.cmo) stdLabels.cmo
+
+all: stdlib.cma std_exit.cmo camlheader camlheader_ur
+
+allopt: stdlib.cmxa std_exit.cmx allopt-$(PROFILING)
+
+allopt-noprof:
+
+allopt-prof: stdlib.p.cmxa std_exit.p.cmx
+
+install:
+	cp stdlib.cma std_exit.cmo *.cmi *.mli *.ml camlheader camlheader_ur $(LIBDIR)
+
+installopt: installopt-default installopt-$(PROFILING)
+
+installopt-default:
+	cp stdlib.cmxa stdlib.a std_exit.o *.cmx $(LIBDIR)
+	cd $(LIBDIR); $(RANLIB) stdlib.a
+
+installopt-noprof:
+	rm -f $(LIBDIR)/stdlib.p.cmxa; ln -s stdlib.cmxa $(LIBDIR)/stdlib.p.cmxa
+	rm -f $(LIBDIR)/stdlib.p.a; ln -s stdlib.a $(LIBDIR)/stdlib.p.a
+	rm -f $(LIBDIR)/std_exit.p.cmx; ln -s std_exit.cmx $(LIBDIR)/std_exit.p.cmx
+	rm -f $(LIBDIR)/std_exit.p.o; ln -s std_exit.o $(LIBDIR)/std_exit.p.o
+
+installopt-prof:
+	cp stdlib.p.cmxa stdlib.p.a std_exit.p.cmx std_exit.p.o $(LIBDIR)
+	cd $(LIBDIR); $(RANLIB) stdlib.p.a
+
+stdlib.cma: $(OBJS)
+	$(CAMLC) -a -o stdlib.cma $(ALLOBJS)
+
+stdlib.cmxa: $(OBJS:.cmo=.cmx)
+	$(CAMLOPT) -a -o stdlib.cmxa $(ALLOBJS:.cmo=.cmx)
+
+stdlib.p.cmxa: $(OBJS:.cmo=.p.cmx)
+	$(CAMLOPT) -a -o stdlib.p.cmxa $(ALLOBJS:.cmo=.p.cmx)
+
+camlheader camlheader_ur: header.c ../config/Makefile
+	if $(SHARPBANGSCRIPTS); then \
+          echo '#!$(BINDIR)/ocamlrun' > camlheader && \
+          echo '#!' | tr -d '\012' > camlheader_ur; \
+        else \
+	  $(BYTECC) $(BYTECCCOMPOPTS) $(BYTECCLINKOPTS) -DRUNTIME_NAME='"$(BINDIR)/ocamlrun"' header.c -o tmpheader$(EXE) && \
+          strip tmpheader$(EXE) && \
+	  mv tmpheader$(EXE) camlheader && \
+          cp camlheader camlheader_ur; \
+        fi
+
+clean::
+	rm -f camlheader camlheader_ur
+
+pervasives.cmi: pervasives.mli
+	$(CAMLC) $(COMPFLAGS) -nopervasives -c pervasives.mli
+
+pervasives.cmo: pervasives.ml
+	$(CAMLC) $(COMPFLAGS) -nopervasives -c pervasives.ml
+
+pervasives.cmx: pervasives.ml
+	$(CAMLOPT) $(OPTCOMPFLAGS) -nopervasives -c pervasives.ml
+
+pervasives.p.cmx: pervasives.ml
+	@if test -f pervasives.cmx; then mv pervasives.cmx pervasives.n.cmx; else :; fi
+	@if test -f pervasives.o; then mv pervasives.o pervasives.n.o; else :; fi
+	$(CAMLOPT) $(OPTCOMPFLAGS) -p -nopervasives -c pervasives.ml
+	mv pervasives.cmx pervasives.p.cmx
+	mv pervasives.o pervasives.p.o
+	@if test -f pervasives.n.cmx; then mv pervasives.n.cmx pervasives.cmx; else :; fi
+	@if test -f pervasives.n.o; then mv pervasives.n.o pervasives.o; else :; fi
+
+# oo.cmi must be compiled with -nopervasives for applets
+oo.cmi: oo.mli
+	$(CAMLC) $(COMPFLAGS) -nopervasives -c oo.mli
+
+# labelled modules require the -nolabels flag
+labelled.cmo:
+	$(MAKE) EXTRAFLAGS=-nolabels RUNTIME=$(RUNTIME) COMPILER=$(COMPILER) $(LABELLED:.ml=.cmo)
+	touch $@
+labelled.cmx:
+	$(MAKE) EXTRAFLAGS=-nolabels $(LABELLED:.ml=.cmx)
+	touch $@
+labelled.p.cmx:
+	$(MAKE) EXTRAFLAGS=-nolabels $(LABELLED:.ml=.p.cmx)
+	touch $@
+
+.SUFFIXES: .mli .ml .cmi .cmo .cmx .p.cmx
+
+.mli.cmi:
+	$(CAMLC) $(COMPFLAGS) $(EXTRAFLAGS) -c $<
+
+.ml.cmo:
+	$(CAMLC) $(COMPFLAGS) $(EXTRAFLAGS) -c $<
+
+.ml.cmx:
+	$(CAMLOPT) $(OPTCOMPFLAGS) $(EXTRAFLAGS) -c $<
+
+.ml.p.cmx:
+	@if test -f $*.cmx; then mv $*.cmx $*.n.cmx; else :; fi
+	@if test -f $*.o; then mv $*.o $*.n.o; else :; fi
+	$(CAMLOPT) $(OPTCOMPFLAGS) $(EXTRAFLAGS) -p -c $<
+	mv $*.cmx $*.p.cmx
+	mv $*.o $*.p.o
+	@if test -f $*.n.cmx; then mv $*.n.cmx $*.cmx; else :; fi
+	@if test -f $*.n.o; then mv $*.n.o $*.o; else :; fi
+
+$(ALLOBJS) labelled.cmo std_exit.cmo: pervasives.cmi $(COMPILER)
+$(ALLOBJS:.cmo=.cmx) labelled.cmx std_exit.cmx: pervasives.cmi $(OPTCOMPILER)
+$(ALLOBJS:.cmo=.p.cmx) labelled.p.cmx std_exit.p.cmx: pervasives.cmi $(OPTCOMPILER)
+$(ALLOBJS:.cmo=.cmi) std_exit.cmi: $(COMPILER)
+labelled.cmo labelled.cmx labelled.p.cmx: $(LABELLED) $(LABELLED:.ml=.mli)
+
+clean::
+	rm -f *.cm* *.o *.a
+	rm -f *~
+
+include .depend
+
+depend:
+	$(CAMLDEP) *.mli *.ml > .depend
diff --git a/stdlib/Makefile.Mac b/stdlib/Makefile.Mac
new file mode 100644
index 0000000000..45bd2326c9
--- /dev/null
+++ b/stdlib/Makefile.Mac
@@ -0,0 +1,73 @@
+#########################################################################
+#                                                                       #
+#                            Objective Caml                             #
+#                                                                       #
+#            Damien Doligez, projet Para, 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 Library General Public License, with     #
+#   the special exception on linking described in file ../LICENSE.      #
+#                                                                       #
+#########################################################################
+
+# $Id$
+
+RUNTIME = ::boot:ocamlrun
+COMPILER = ::ocamlc
+CAMLC = {RUNTIME} {COMPILER}
+CAMLDEP = ::boot:ocamlrun ::tools:ocamldep
+
+OBJS = pervasives.cmo array.cmo list.cmo char.cmo string.cmo sys.cmo ¶
+  hashtbl.cmo sort.cmo marshal.cmo obj.cmo ¶
+  lexing.cmo parsing.cmo ¶
+  set.cmo map.cmo stack.cmo queue.cmo stream.cmo ¶
+  buffer.cmo printf.cmo format.cmo arg.cmo printexc.cmo gc.cmo ¶
+  digest.cmo random.cmo oo.cmo genlex.cmo callback.cmo weak.cmo ¶
+  lazy.cmo filename.cmo int32.cmo int64.cmo nativeint.cmo complex.cmo
+
+all Ä stdlib.cma std_exit.cmo camlheader camlheader_ur
+
+install Ä
+    duplicate -y stdlib.cma std_exit.cmo Å.cmi Å.mli camlheader camlheader_ur ¶
+              "{LIBDIR}"
+
+stdlib.cma Ä {OBJS}
+    {CAMLC} -a -o stdlib.cma {OBJS}
+
+camlheader Ä
+    begin
+      quote -n "ocamlrun"; echo ' "{command}" {"Parameters"}'
+      echo 'exit {status}'
+      echo
+    end > camlheader
+
+camlheader_ur Ä
+    echo -n ' ' > camlheader_ur
+
+clean ÄÄ
+    delete -i camlheader camlheader_ur
+
+pervasives.cmi Ä pervasives.mli
+    {CAMLC} {COMPFLAGS} -nopervasives -c pervasives.mli
+
+pervasives.cmo Ä pervasives.ml
+    {CAMLC} {COMPFLAGS} -nopervasives -c pervasives.ml
+
+# oo.cmi must be compiled with -nopervasives for applets
+oo.cmi Ä oo.mli
+    {CAMLC} {COMPFLAGS} -nopervasives -c oo.mli
+
+.cmi Ä .mli
+    {CAMLC} {COMPFLAGS} -c {default}.mli
+
+.cmo Ä .ml
+    {CAMLC} {COMPFLAGS} -c {default}.ml
+
+{OBJS} std_exit.cmo Ä pervasives.cmi
+
+clean ÄÄ
+    delete -i Å.cm[aio] || set status 0
+
+depend Ä
+    {CAMLDEP} Å.mli Å.ml > Makefile.Mac.depend
diff --git a/stdlib/Makefile.nt b/stdlib/Makefile.nt
new file mode 100644
index 0000000000..c16e0657f5
--- /dev/null
+++ b/stdlib/Makefile.nt
@@ -0,0 +1,108 @@
+#########################################################################
+#                                                                       #
+#                            Objective Caml                             #
+#                                                                       #
+#            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 Library General Public License, with     #
+#   the special exception on linking described in file ../LICENSE.      #
+#                                                                       #
+#########################################################################
+
+# $Id$
+
+!include ..\config\Makefile.nt
+
+RUNTIME=..\boot\ocamlrun
+COMPILER=..\ocamlc
+CAMLC=$(RUNTIME) $(COMPILER)
+OPTCOMPILER=..\ocamlopt
+CAMLOPT=$(RUNTIME) $(OPTCOMPILER)
+CAMLDEP=..\boot\ocamlrun ..\tools\ocamldep
+
+BASIC=pervasives.cmo array.cmo list.cmo char.cmo string.cmo sys.cmo \
+  hashtbl.cmo sort.cmo marshal.cmo obj.cmo \
+  lexing.cmo parsing.cmo \
+  set.cmo map.cmo stack.cmo queue.cmo stream.cmo \
+  buffer.cmo printf.cmo format.cmo arg.cmo printexc.cmo gc.cmo \
+  digest.cmo random.cmo oo.cmo genlex.cmo callback.cmo weak.cmo \
+  lazy.cmo filename.cmo int32.cmo int64.cmo nativeint.cmo complex.cmo
+LABELLED=arrayLabels.ml listLabels.ml stringLabels.ml moreLabels.ml
+
+OBJS=$(BASIC) labelled.cmo stdLabels.cmo
+ALLOBJS=$(BASIC) $(LABELLED:.ml=.cmo) stdLabels.cmo
+
+all: stdlib.cma std_exit.cmo camlheader camlheader_ur
+
+allopt: stdlib.cmxa std_exit.cmx
+
+install:
+	cp stdlib.cma std_exit.cmo *.cmi *.mli *.ml camlheader camlheader_ur $(LIBDIR)
+
+installopt:
+	cp stdlib.cmxa stdlib.lib std_exit.obj *.cmx $(LIBDIR)
+
+stdlib.cma: $(OBJS)
+	$(CAMLC) -a -o stdlib.cma $(ALLOBJS)
+
+stdlib.cmxa: $(OBJS:.cmo=.cmx)
+	$(CAMLOPT) -a -o stdlib.cmxa $(ALLOBJS:.cmo=.cmx)
+
+camlheader camlheader_ur: headernt.c ..\config\Makefile.nt
+	$(BYTECC) $(BYTECCCOMPOPTS) $(BYTECCLINKOPTS) -o camlheader. headernt.c
+	cp camlheader camlheader_ur
+
+clean::
+	rm -f camlheader camlheader_ur
+
+pervasives.cmi: pervasives.mli
+	$(CAMLC) $(COMPFLAGS) -nopervasives -c pervasives.mli
+
+pervasives.cmo: pervasives.ml
+	$(CAMLC) $(COMPFLAGS) -nopervasives -c pervasives.ml
+
+pervasives.cmx: pervasives.ml
+	$(CAMLOPT) $(COMPFLAGS) -nopervasives -c pervasives.ml
+
+# oo.cmi must be compiled with -nopervasives for applets
+oo.cmi: oo.mli
+	$(CAMLC) $(COMPFLAGS) -nopervasives -c oo.mli
+
+# labelled modules require the -nolabels flag
+labelled.cmo:
+	$(MAKEREC) EXTRAFLAGS=-nolabels RUNTIME=$(RUNTIME) COMPILER=$(COMPILER) $(LABELLED:.ml=.cmo)
+	touch $@
+labelled.cmx:
+	$(MAKEREC) EXTRAFLAGS=-nolabels $(LABELLED:.ml=.cmx)
+	touch $@
+labelled.p.cmx:
+	$(MAKEREC) EXTRAFLAGS=-nolabels $(LABELLED:.ml=.p.cmx)
+	touch $@
+
+# generic rules
+.SUFFIXES: .mli .ml .cmi .cmo .cmx
+
+.mli.cmi:
+	$(CAMLC) $(COMPFLAGS) $(EXTRAFLAGS) -c $<
+
+.ml.cmo:
+	$(CAMLC) $(COMPFLAGS) $(EXTRAFLAGS) -c $<
+
+.ml.cmx:
+	$(CAMLOPT) $(COMPFLAGS) $(EXTRAFLAGS) -c $<
+
+$(ALLOBJS) labelled.cmo std_exit.cmo: pervasives.cmi $(COMPILER)
+$(ALLOBJS:.cmo=.cmx) labelled.cmx std_exit.cmx: pervasives.cmi $(OPTCOMPILER)
+$(ALLOBJS:.cmo=.cmi) std_exit.cmi: $(COMPILER)
+labelled.cmo labelled.cmx: $(LABELLED) $(LABELLED:.ml=.mli)
+
+clean::
+	rm -f *.cm* *.obj *.lib
+	rm -f *~
+
+!include .depend
+
+depend: beforedepend
+	$(CAMLDEP) *.mli *.ml > .depend
diff --git a/stdlib/arg.mli b/stdlib/arg.mli
new file mode 100644
index 0000000000..a4be84d58f
--- /dev/null
+++ b/stdlib/arg.mli
@@ -0,0 +1,93 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*             Damien Doligez, projet Para, 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 Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** Parsing of command line arguments.
+
+   This module provides a general mechanism for extracting options and
+   arguments from the command line to the program.
+
+   Syntax of command lines:
+    A keyword is a character string starting with a [-].
+    An option is a keyword alone or followed by an argument.
+    The types of keywords are: [Unit], [Set], [Clear], [String],
+    [Int], [Float], and [Rest].  [Unit], [Set] and [Clear] keywords take
+    no argument.  [String], [Int], and [Float] keywords take the following
+    word on the command line as an argument.  A [Rest] keyword takes the
+    remaining of the command line as (string) arguments.
+    Arguments not preceded by a keyword are called anonymous arguments.
+
+   Examples ([cmd] is assumed to be the command name):
+-   [cmd -flag           ](a unit option)
+-   [cmd -int 1          ](an int option with argument [1])
+-   [cmd -string foobar  ](a string option with argument ["foobar"])
+-   [cmd -float 12.34    ](a float option with argument [12.34])
+-   [cmd a b c           ](three anonymous arguments: ["a"], ["b"], and ["c"])
+-   [cmd a b -- c d      ](two anonymous arguments and a rest option with
+                           two arguments)
+*)
+
+type spec =
+    Unit of (unit -> unit)     (** Call the function with unit argument *)
+  | Set of bool ref            (** Set the reference to true *)
+  | Clear of bool ref          (** Set the reference to false *)
+  | String of (string -> unit) (** Call the function with a string argument *)
+  | Int of (int -> unit)       (** Call the function with an int argument *)
+  | Float of (float -> unit)   (** Call the function with a float argument *)
+  | Rest of (string -> unit)   (** Stop interpreting keywords and call the 
+                                   function with each remaining argument *)
+
+(** The concrete type describing the behavior associated
+   with a keyword. *)
+
+val parse :
+  (string * spec * string) list -> (string -> unit) -> string -> unit
+(** [Arg.parse speclist anonfun usage_msg] parses the command line.
+    [speclist] is a list of triples [(key, spec, doc)].
+    [key] is the option keyword, it must start with a ['-'] character.
+    [spec] gives the option type and the function to call when this option
+    is found on the command line.
+    [doc] is a one-line description of this option.
+    [anonfun] is called on anonymous arguments.
+    The functions in [spec] and [anonfun] are called in the same order
+    as their arguments appear on the command line.
+
+    If an error occurs, [Arg.parse] exits the program, after printing
+    an error message as follows:
+-   The reason for the error: unknown option, invalid or missing argument, etc.
+-   [usage_msg]
+-   The list of options, each followed by the corresponding [doc] string.
+
+    For the user to be able to specify anonymous arguments starting with a
+    [-], include for example [("-", String anonfun, doc)] in [speclist].
+
+    By default, [parse] recognizes two unit options, [-help] and [--help],
+    which will display [usage_msg] and the list of options, and exit
+    the program.  You can override this behaviour by specifying your
+    own [-help] and [--help] options in [speclist].
+*)
+
+exception Bad of string
+(** Functions in [spec] or [anonfun] can raise [Arg.Bad] with an error
+   message to reject invalid arguments. *)
+
+val usage : (string * spec * string) list -> string -> unit
+(** [Arg.usage speclist usage_msg] prints an error message including
+    the list of valid options.  This is the same message that
+    {!Arg.parse} prints in case of error.
+    [speclist] and [usage_msg] are the same as for [Arg.parse]. *)
+
+val current : int ref
+(** Position (in {!Sys.argv}) of the argument being processed.  You can
+    change this value, e.g. to force {!Arg.parse} to skip some arguments.*)
diff --git a/stdlib/array.mli b/stdlib/array.mli
new file mode 100644
index 0000000000..2a4d3628a6
--- /dev/null
+++ b/stdlib/array.mli
@@ -0,0 +1,198 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            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 Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** Array operations. *)
+
+external length : 'a array -> int = "%array_length"
+(** Return the length (number of elements) of the given array. *)
+
+external get : 'a array -> int -> 'a = "%array_safe_get"
+(** [Array.get a n] returns the element number [n] of array [a].
+   The first element has number 0.
+   The last element has number [Array.length a - 1].
+
+   Raise [Invalid_argument "Array.get"]  if [n] is outside the range
+   0 to [(Array.length a - 1)].
+   You can also write [a.(n)] instead of [Array.get a n]. *)
+
+external set : 'a array -> int -> 'a -> unit = "%array_safe_set"
+(** [Array.set a n x] modifies array [a] in place, replacing
+   element number [n] with [x].
+
+   Raise [Invalid_argument "Array.set"] if [n] is outside the range
+   0 to [Array.length a - 1].
+   You can also write [a.(n) <- x] instead of [Array.set a n x]. *)
+        
+external make : int -> 'a -> 'a array = "make_vect"
+(** [Array.make n x] returns a fresh array of length [n],
+   initialized with [x].
+   All the elements of this new array are initially
+   physically equal to [x] (in the sense of the [==] predicate).
+   Consequently, if [x] is mutable, it is shared among all elements
+   of the array, and modifying [x] through one of the array entries
+   will modify all other entries at the same time.
+
+   Raise [Invalid_argument] if [n < 0] or [n > Sys.max_array_length].
+   If the value of [x] is a floating-point number, then the maximum
+   size is only [Sys.max_array_length / 2].*)
+
+external create : int -> 'a -> 'a array = "make_vect"
+(** @deprecated [Array.create] is an alias for {!Array.make}. *)
+
+val init : int -> (int -> 'a) -> 'a array
+(** [Array.init n f] returns a fresh array of length [n],
+   with element number [i] initialized to the result of [f i].
+   In other terms, [Array.init n f] tabulates the results of [f]
+   applied to the integers [0] to [n-1].
+
+   Raise [Invalid_argument] if [n < 0] or [n > Sys.max_array_length].
+   If the return type of [f] is [float], then the maximum
+   size is only [Sys.max_array_length / 2].*)
+
+val make_matrix : int -> int -> 'a -> 'a array array
+(** [Array.make_matrix dimx dimy e] returns a two-dimensional array
+   (an array of arrays) with first dimension [dimx] and
+   second dimension [dimy]. All the elements of this new matrix
+   are initially physically equal to [e].
+   The element ([x,y]) of a matrix [m] is accessed
+   with the notation [m.(x).(y)].
+
+   Raise [Invalid_argument] if [dimx] or [dimy] is negative or
+   greater than [Sys.max_array_length].
+   If the value of [e] is a floating-point number, then the maximum
+   size is only [Sys.max_array_length / 2]. *)
+
+val create_matrix : int -> int -> 'a -> 'a array array
+(** @deprecated [Array.create_matrix] is an alias for {!Array.make_matrix}. *)
+
+val append : 'a array -> 'a array -> 'a array
+(** [Array.append v1 v2] returns a fresh array containing the
+   concatenation of the arrays [v1] and [v2]. *)
+
+val concat : 'a array list -> 'a array
+(** Same as [Array.append], but concatenates a list of arrays. *)
+
+val sub : 'a array -> int -> int -> 'a array
+(** [Array.sub a start len] returns a fresh array of length [len],
+   containing the elements number [start] to [start + len - 1]
+   of array [a].
+
+   Raise [Invalid_argument "Array.sub"] if [start] and [len] do not
+   designate a valid subarray of [a]; that is, if
+   [start < 0], or [len < 0], or [start + len > Array.length a]. *)
+
+val copy : 'a array -> 'a array
+(** [Array.copy a] returns a copy of [a], that is, a fresh array
+   containing the same elements as [a]. *)
+
+val fill : 'a array -> int -> int -> 'a -> unit
+(** [Array.fill a ofs len x] modifies the array [a] in place,
+   storing [x] in elements number [ofs] to [ofs + len - 1].
+
+   Raise [Invalid_argument "Array.fill"] if [ofs] and [len] do not
+   designate a valid subarray of [a]. *)
+
+val blit : 'a array -> int -> 'a array -> int -> int -> unit
+(** [Array.blit v1 o1 v2 o2 len] copies [len] elements
+   from array [v1], starting at element number [o1], to array [v2],
+   starting at element number [o2]. It works correctly even if
+   [v1] and [v2] are the same array, and the source and
+   destination chunks overlap.
+
+   Raise [Invalid_argument "Array.blit"] if [o1] and [len] do not
+   designate a valid subarray of [v1], or if [o2] and [len] do not
+   designate a valid subarray of [v2]. *)
+
+val to_list : 'a array -> 'a list
+(** [Array.to_list a] returns the list of all the elements of [a]. *)
+
+val of_list : 'a list -> 'a array
+(** [Array.of_list l] returns a fresh array containing the elements
+   of [l]. *)
+
+val iter : ('a -> unit) -> 'a array -> unit
+(** [Array.iter f a] applies function [f] in turn to all
+   the elements of [a].  It is equivalent to
+   [f a.(0); f a.(1); ...; f a.(Array.length a - 1); ()]. *)
+
+val map : ('a -> 'b) -> 'a array -> 'b array
+(** [Array.map f a] applies function [f] to all the elements of [a],
+   and builds an array with the results returned by [f]:
+   [[| f a.(0); f a.(1); ...; f a.(Array.length a - 1) |]]. *)
+
+val iteri : (int -> 'a -> unit) -> 'a array -> unit
+(** Same as {!Array.iter}, but the
+   function is applied to the index of the element as first argument,
+   and the element itself as second argument. *)
+
+val mapi : (int -> 'a -> 'b) -> 'a array -> 'b array
+(** Same as {!Array.map}, but the
+   function is applied to the index of the element as first argument,
+   and the element itself as second argument. *)
+
+val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b array -> 'a
+(** [Array.fold_left f x a] computes
+   [f (... (f (f x a.(0)) a.(1)) ...) a.(n-1)],
+   where [n] is the length of the array [a]. *)
+
+val fold_right : ('b -> 'a -> 'a) -> 'b array -> 'a -> 'a
+(** [Array.fold_right f a x] computes
+   [f a.(0) (f a.(1) ( ... (f a.(n-1) x) ...))],
+   where [n] is the length of the array [a]. *)
+
+
+(** {6 Sorting} *)
+
+
+val sort : ('a -> 'a -> int) -> 'a array -> unit
+(** Sort an array in increasing order according to a comparison
+   function.  The comparison function must return 0 if its arguments
+   compare as equal, a positive integer if the first is greater,
+   and a negative integer if the first is smaller (see below for a
+   complete specification).  For example, {!Pervasives.compare} is
+   a suitable comparison function.  After calling [Array.sort], the
+   array is sorted in place in increasing order.
+   [Array.sort] is guaranteed to run in constant heap space
+   and (at most) logarithmic stack space.
+
+   The current implementation uses Heap Sort.  It runs in constant
+   stack space.
+
+   Specification of the comparison function:
+   Let [a] be the array and [cmp] the comparison function.  The following
+   must be true for all x, y, z in a :
+-   [cmp x y] > 0 if and only if [cmp y x] < 0
+-   if [cmp x y] >= 0 and [cmp y z] >= 0 then [cmp x z] >= 0
+
+   When [Array.sort] returns, [a] contains the same elements as before,
+   reordered in such a way that for all i and j valid indices of [a] :
+-   [cmp a.(i) a.(j)] >= 0 if and only if i >= j
+*)
+
+val stable_sort : ('a -> 'a -> int) -> 'a array -> unit
+(** Same as {!Array.sort}, but the sorting algorithm is stable (i.e.
+   elements that compare equal are kept in their original order) and
+   not guaranteed to run in constant heap space.
+
+   The current implementation uses Merge Sort. It uses [n/2]
+   words of heap space, where [n] is the length of the array.
+   It is usually faster than the current implementation of {!Array.sort}.
+*)
+
+(**/**)
+(** {6 Undocumented functions} *)
+
+external unsafe_get : 'a array -> int -> 'a = "%array_unsafe_get"
+external unsafe_set : 'a array -> int -> 'a -> unit = "%array_unsafe_set"
diff --git a/stdlib/complex.ml b/stdlib/complex.ml
new file mode 100644
index 0000000000..05d8910b06
--- /dev/null
+++ b/stdlib/complex.ml
@@ -0,0 +1,81 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2002 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Complex numbers *)
+
+type t = { re: float; im: float }
+
+let zero = { re = 0.0; im = 0.0 }
+let one = { re = 1.0; im = 0.0 }
+let i = { re = 0.0; im = 1.0 }
+
+let add x y = { re = x.re +. y.re; im = x.im +. y.im }
+
+let sub x y = { re = x.re -. y.re; im = x.im -. y.im }
+
+let neg x = { re = -. x.re; im = -. x.im }
+
+let conj x = { re = x.re; im = -. x.im }
+
+let mul x y = { re = x.re *. y.re -. x.im *. y.im;
+                im = x.re *. y.im +. x.im *. y.re }
+
+let inv x =
+  (* Watch out for overflow in computing re^2 + im^2 *)
+  if abs_float x.re >= abs_float x.im then begin
+    let q = x.im /. x.re in
+    let d = 1.0 +. q *. q in
+    { re = (1.0 /. d) /. x.re; im = -. (q /. d) /. x.re }
+  end else begin
+    let q = x.re /. x.im in
+    let d = 1.0 +. q *. q in
+    { re = (q /. d) /. x.im; im = (-1.0 /. d) /. x.im }
+  end
+
+let div x y = mul x (inv y)
+
+let norm2 x = x.re *. x.re +. x.im *. x.im
+
+let norm x =
+  (* Watch out for overflow in computing re^2 + im^2 *)
+  let r = abs_float x.re and i = abs_float x.im in
+  if r = 0.0 && i = 0.0 then 0.0
+  else if r >= i then
+    let q = i /. r in r *. sqrt(1.0 +. q *. q)
+  else
+    let q = r /. i in i *. sqrt(1.0 +. q *. q)
+
+let arg x = atan2 x.im x.re
+
+let polar n a = { re = cos a *. n; im = sin a *. n }
+
+let sqrt x =
+  (* Avoid cancellation in computing norm x + x.re 
+     when x.re < 0 and x.im is small *)
+  if x.re >= 0.0 then begin
+    let r = sqrt(0.5 *. norm x +. 0.5 *. x.re) in
+    { re = r; im = if r = 0.0 then 0.0 else 0.5 *. x.im /. r }
+  end else begin
+    let s = sqrt(0.5 *. norm x -. 0.5 *. x.re) in
+    { re = if s = 0.0 then 0.0 else 0.5 *. abs_float x.im /. s;
+      im = if x.im >= 0.0 then s else -. s }
+  end
+
+let exp x =
+  let e = exp x.re in { re = e *. cos x.im; im = e *. sin x.im }
+
+let log x = { re = log (norm x); im = atan2 x.im x.re }
+
+let pow x y = exp (mul y (log x))
diff --git a/stdlib/complex.mli b/stdlib/complex.mli
new file mode 100644
index 0000000000..72e974a2f7
--- /dev/null
+++ b/stdlib/complex.mli
@@ -0,0 +1,85 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2002 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** Complex numbers.
+
+    This module provides arithmetic operations on complex numbers.
+    Complex numbers are represented by their real and imaginary parts
+    (cartesian representation).  Each part is represented by a
+    double-precision floating-point number (type [float]).   *)
+
+type t = { re: float; im: float }
+(** The type of complex numbers.  [re] is the real part and [im] the
+    imaginary part. *)
+
+val zero: t
+(** The complex number [0]. *)
+
+val one: t
+(** The complex number [1]. *)
+
+val i: t
+(** The complex number [i]. *)
+
+val neg: t -> t
+(** Unary negation. *)
+
+val conj: t -> t
+(** Conjugate: given the complex [x + i.y], returns [x - i.y]. *)
+
+val add: t -> t -> t
+(** Addition *)
+
+val sub: t -> t -> t
+(** Subtraction *)
+
+val mul: t -> t -> t
+(** Multiplication *)
+
+val inv: t -> t
+(** Multiplicative inverse ([1/z]). *)
+
+val div: t -> t -> t
+(** Division *)
+
+val sqrt: t -> t
+(** Square root.  The result always lies within the semispace [real >= 0].
+    This function has a discontinuity along the negative real axis. *)
+
+val norm2: t -> float
+(** Norm squared: given [x + i.y], returns [x^2 + y^2]. *)
+
+val norm: t -> float
+(** Norm: given [x + i.y], returns [sqrt(x^2 + y^2)]. *)
+
+val arg: t -> float
+(** Argument.  The argument of a complex number is the angle
+    in the complex plane between the positive real axis and a line
+    passing through zero and the number.  This angle ranges from
+    [-pi] to [pi].  This function has a discontinuity along the
+    negative real axis. *)
+
+val polar: float -> float -> t
+(** [polar norm arg] returns the complex having norm [norm] 
+    and argument [arg]. *)
+
+val exp: t -> t
+(** Exponentiation.  [exp z] returns [e] to the [z] power. *)
+
+val log: t -> t
+(** Natural logarithm (in base [e]). *)
+
+val pow: t -> t -> t
+(** Power function.  [pow z1 z2] returns [z1] to the [z2] power. *)
diff --git a/stdlib/format.mli b/stdlib/format.mli
new file mode 100644
index 0000000000..9d9c84c617
--- /dev/null
+++ b/stdlib/format.mli
@@ -0,0 +1,510 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Pierre Weis, 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 Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** Pretty printing.
+
+   This module implements a pretty-printing facility to format text
+   within ``pretty-printing boxes''. The pretty-printer breaks lines
+   at specified break hints, and indents lines according to the box
+   structure.
+
+   Warning: the material output by the following functions is delayed
+   in the pretty-printer queue in order to compute the proper line
+   breaking. Hence, you should not mix calls to the printing functions
+   of the basic I/O system with calls to the functions of this module:
+   this could result in some strange output seemingly unrelated with
+   the evaluation order of printing commands.
+
+   You may consider this module as providing an extension to the
+   [printf] facility to provide automatic line breaking. The addition of
+   pretty-printing annotations to your regular [printf] formats gives you
+   fancy indentation and line breaks.
+   Pretty-printing annotations are described below in the documentation of
+   the function {!Format.fprintf}.
+
+   You may also use the explicit box management and printing functions
+   provided by this module. This style is more basic but more verbose
+   than the [fprintf] concise formats.
+
+   For instance, the sequence 
+   [open_box (); print_string "x ="; print_space (); print_int 1; close_box ()]
+   that prints [x = 1] within a pretty-printing box, can be
+   abbreviated as [printf "@[%s@ %i@]" "x =" 1], or even shorter
+   [printf "@[x =@ %i@]" 1].
+
+   Rule of thumb for casual users of this library:
+-   use simple boxes (as obtained by [open_box 0]);
+-   use simple break hints (as obtained by [print_cut ()] that outputs a
+   simple break hint, or by [print_space ()] that outputs a space
+   indicating a break hint);
+-   once a box is opened, display its material with basic printing
+   functions (e. g. [print_int] and [print_string]);
+-   when the material for a box has been printed, call [close_box ()] to
+   close the box;
+-   at the end of your routine, evaluate [print_newline ()] to close
+   all remaining boxes and flush the pretty-printer.
+
+   The behaviour of pretty-printing commands is unspecified
+   if there is no opened pretty-printing box. Each box opened via
+   one of the [open_] functions below must be closed using [close_box]
+   for proper formatting. Otherwise, some of the material printed in the
+   boxes may not be output, or may be formatted incorrectly.
+
+   In case of interactive use, the system closes all opened boxes and
+   flushes all pending text (as with the [print_newline] function)
+   after each phrase. Each phrase is therefore executed in the initial
+   state of the pretty-printer.
+*)
+
+
+(** {6 Boxes} *)
+
+val open_box : int -> unit
+(** [open_box d] opens a new pretty-printing box
+   with offset [d].
+   This box is the general purpose pretty-printing box.
+   Material in this box is displayed ``horizontal or vertical'':
+   break hints inside the box may lead to a new line, if there
+   is no more room on the line to print the remainder of the box,
+   or if a new line may lead to a new indentation
+   (demonstrating the indentation of the box).
+   When a new line is printed in the box, [d] is added to the
+   current indentation. *)
+
+val close_box : unit -> unit
+(** Close the most recently opened pretty-printing box. *)
+
+(** {6 Formatting functions} *)
+
+val print_string : string -> unit
+(** [print_string str] prints [str] in the current box. *)
+
+val print_as : int -> string -> unit
+(** [print_as len str] prints [str] in the
+   current box. The pretty-printer formats [str] as if
+   it were of length [len]. *)
+
+val print_int : int -> unit
+(** Print an integer in the current box. *)
+
+val print_float : float -> unit
+(** Print a floating point number in the current box. *)
+
+val print_char : char -> unit
+(** Print a character in the current box. *)
+
+val print_bool : bool -> unit
+(** Print a boolean in the current box. *)
+
+
+(** {6 Break hints} *)
+
+val print_space : unit -> unit
+(** [print_space ()] is used to separate items (typically to print
+   a space between two words). 
+   It indicates that the line may be split at this
+   point. It either prints one space or splits the line.
+   It is equivalent to [print_break 1 0]. *)
+
+val print_cut : unit -> unit
+(** [print_cut ()] is used to mark a good break position.
+   It indicates that the line may be split at this 
+   point. It either prints nothing or splits the line.
+   This allows line splitting at the current
+   point, without printing spaces or adding indentation.
+   It is equivalent to [print_break 0 0]. *)
+
+val print_break : int -> int -> unit
+(** Insert a break hint in a pretty-printing box.
+   [print_break nspaces offset] indicates that the line may
+   be split (a newline character is printed) at this point,
+   if the contents of the current box does not fit on the
+   current line. 
+   If the line is split at that point, [offset] is added to
+   the current indentation. If the line is not split,
+   [nspaces] spaces are printed. *)
+
+val print_flush : unit -> unit
+(** Flush the pretty printer: all opened boxes are closed,
+   and all pending text is displayed. *)
+
+val print_newline : unit -> unit
+(** Equivalent to [print_flush] followed by a new line. *)
+
+val force_newline : unit -> unit
+(** Force a newline in the current box. Not the normal way of
+   pretty-printing, you should prefer break hints. *)
+
+val print_if_newline : unit -> unit
+(** Execute the next formatting command if the preceding line
+   has just been split. Otherwise, ignore the next formatting
+   command. *)
+
+
+(** {6 Margin} *)
+
+val set_margin : int -> unit
+(** [set_margin d] sets the value of the right margin
+   to [d] (in characters): this value is used to detect line
+   overflows that leads to split lines.
+   Nothing happens if [d] is smaller than 2 or
+   bigger than 999999999. *)
+
+val get_margin : unit -> int
+(** Return the position of the right margin. *)
+
+
+(** {6 Maximum indentation limit} *)
+
+val set_max_indent : int -> unit
+(** [set_max_indent d] sets the value of the maximum
+   indentation limit to [d] (in characters):
+   once this limit is reached, boxes are rejected to the left,
+   if they do not fit on the current line.
+   Nothing happens if [d] is smaller than 2 or
+   bigger than 999999999. *)
+
+val get_max_indent : unit -> int
+(** Return the value of the maximum indentation limit (in characters). *)
+
+
+(** {6 Formatting depth: maximum number of boxes allowed before ellipsis} *)
+
+val set_max_boxes : int -> unit
+(** [set_max_boxes max] sets the maximum number
+   of boxes simultaneously opened.
+   Material inside boxes nested deeper is printed as an
+   ellipsis (more precisely as the text returned by
+   [get_ellipsis_text ()]).
+   Nothing happens if [max] is not greater than 1. *)
+
+val get_max_boxes : unit -> int
+(** Return the maximum number of boxes allowed before ellipsis. *)
+
+val over_max_boxes : unit -> bool
+(** Test if the maximum number of boxes allowed have already been opened. *)
+
+
+(** {6 Advanced formatting} *)
+
+val open_hbox : unit -> unit
+(** [open_hbox ()] opens a new pretty-printing box.
+   This box is ``horizontal'': the line is not split in this box
+   (new lines may still occur inside boxes nested deeper). *)
+
+val open_vbox : int -> unit
+(** [open_vbox d] opens a new pretty-printing box
+   with offset [d].
+   This box is ``vertical'': every break hint inside this
+   box leads to a new line.
+   When a new line is printed in the box, [d] is added to the
+   current indentation. *)
+
+val open_hvbox : int -> unit
+(** [open_hvbox d] opens a new pretty-printing box
+   with offset [d].
+   This box is ``horizontal-vertical'': it behaves as an
+   ``horizontal'' box if it fits on a single line,
+   otherwise it behaves as a ``vertical'' box.
+   When a new line is printed in the box, [d] is added to the
+   current indentation. *)
+
+val open_hovbox : int -> unit
+(** [open_hovbox d] opens a new pretty-printing box
+   with offset [d].
+   This box is ``horizontal or vertical'': break hints
+   inside this box may lead to a new line, if there is no more room
+   on the line to print the remainder of the box.
+   When a new line is printed in the box, [d] is added to the
+   current indentation. *)
+
+
+(** {6 Tabulations} *)
+
+val open_tbox : unit -> unit
+(** Open a tabulation box. *)
+
+val close_tbox : unit -> unit
+(** Close the most recently opened tabulation box. *)
+
+val print_tbreak : int -> int -> unit
+(** Break hint in a tabulation box.
+   [print_tbreak spaces offset] moves the insertion point to
+   the next tabulation ([spaces] being added to this position).
+   Nothing occurs if insertion point is already on a
+   tabulation mark.
+   If there is no next tabulation on the line, then a newline
+   is printed and the insertion point moves to the first
+   tabulation of the box.
+   If a new line is printed, [offset] is added to the current
+   indentation. *)
+
+val set_tab : unit -> unit
+(** Set a tabulation mark at the current insertion point. *)
+
+val print_tab : unit -> unit
+(** [print_tab ()] is equivalent to [print_tbreak (0,0)]. *)
+
+
+(** {6 Ellipsis} *)
+
+val set_ellipsis_text : string -> unit
+(** Set the text of the ellipsis printed when too many boxes
+   are opened (a single dot, [.], by default). *)
+
+val get_ellipsis_text : unit -> string
+(** Return the text of the ellipsis. *)
+
+
+(** {6 Redirecting formatter output} *)
+
+val set_formatter_out_channel : out_channel -> unit
+(** Redirect the pretty-printer output to the given channel. *)
+
+
+(** {6 Changing the meaning of printing material} *)
+
+val set_formatter_output_functions :
+  (string -> int -> int -> unit) -> (unit -> unit) -> unit
+(** [set_formatter_output_functions out flush] redirects the
+   pretty-printer output to the functions [out] and [flush].
+   The [out] function performs the pretty-printer output.
+   It is called with a string [s], a start position [p],
+   and a number of characters [n]; it is supposed to output
+   characters [p] to [p + n - 1] of [s]. The [flush] function is
+   called whenever the pretty-printer is flushed using
+   [print_flush] or [print_newline]. *)
+
+val get_formatter_output_functions :
+  unit -> (string -> int -> int -> unit) * (unit -> unit)
+(** Return the current output functions of the pretty-printer. *)
+
+
+(** {6 Changing the meaning of pretty printing (indentation, line breaking, and printing material)} *)
+
+val set_all_formatter_output_functions :
+  out:(string -> int -> int -> unit) -> flush:(unit -> unit) ->
+    newline:(unit -> unit) -> spaces:(int -> unit) -> unit
+(** [set_all_formatter_output_functions out flush outnewline outspace]
+   redirects the pretty-printer output to the functions
+   [out] and [flush] as described in
+   [set_formatter_output_functions]. In addition, the pretty-printer
+   function that outputs a newline is set to the function [outnewline]
+   and the function that outputs indentation spaces is set to the
+   function [outspace].
+   This way, you can change the meaning of indentation (which
+   can be something else than just printing a space character) and
+   the meaning of new lines opening (which can be connected to
+   any other action needed by the application at hand).
+   The two functions [outspace] and [outnewline] are normally
+   connected to [out] and [flush]: respective default values for
+   [outspace] and [outnewline] are [out (String.make n ' ') 0 n]
+   and [out "\n" 0 1]. *)
+
+val get_all_formatter_output_functions :
+  unit ->
+    (string -> int -> int -> unit) * (unit -> unit) * (unit -> unit) *
+      (int -> unit)
+(** Return the current output functions of the pretty-printer,
+   including line breaking and indentation functions. *)
+
+
+(** {6 Multiple formatted output} *)
+
+type formatter
+(** Abstract data type corresponding to a pretty-printer and
+   all its machinery.
+   Defining new pretty-printers permits the output of
+   material in parallel on several channels.
+   Parameters of a pretty-printer are local to this pretty-printer:
+   margin, maximum indentation limit, maximum number of boxes
+   simultaneously opened, ellipsis, and so on, are specific to
+   each pretty-printer and may be fixed independently.
+   Given an output channel [oc], a new formatter writing to
+   that channel is obtained by calling [formatter_of_out_channel oc].
+   Alternatively, the [make_formatter] function allocates a new
+   formatter with explicit output and flushing functions
+   (convenient to output material to strings for instance). *)
+
+val formatter_of_out_channel : out_channel -> formatter
+(** [formatter_of_out_channel oc] returns a new formatter that
+   writes to the corresponding channel [oc]. *)
+
+val std_formatter : formatter
+(** The standard formatter used by the formatting functions
+   above. It is defined as [formatter_of_out_channel stdout]. *)
+
+val err_formatter : formatter
+(** A formatter to use with formatting functions below for
+   output to standard error. It is defined as
+  [formatter_of_out_channel stderr]. *)
+
+val formatter_of_buffer : Buffer.t -> formatter
+(** [formatter_of_buffer b] returns a new formatter writing to
+   buffer [b]. As usual, the formatter has to be flushed at
+   the end of pretty printing, using [pp_print_flush] or
+   [pp_print_newline], to display all the pending material. *)
+
+val stdbuf : Buffer.t
+(** The string buffer in which [str_formatter] writes. *)
+
+val str_formatter : formatter
+(** A formatter to use with formatting functions below for
+   output to the [stdbuf] string buffer.
+   [str_formatter] is defined as 
+   [formatter_of_buffer stdbuf]. *)
+
+val flush_str_formatter : unit -> string
+(** Returns the material printed with [str_formatter], flushes
+   the formatter and reset the corresponding buffer. *)
+
+val make_formatter :
+  (string -> int -> int -> unit) -> (unit -> unit) -> formatter
+(** [make_formatter out flush] returns a new formatter that
+   writes according to the output function [out], and the flushing
+   function [flush]. Hence, a formatter to the out channel [oc]
+   is returned by [make_formatter (output oc) (fun () -> flush oc)]. *)
+
+
+(** {6 Basic functions to use with formatters} *)
+
+val pp_open_hbox : formatter -> unit -> unit
+val pp_open_vbox : formatter -> int -> unit
+val pp_open_hvbox : formatter -> int -> unit
+val pp_open_hovbox : formatter -> int -> unit
+val pp_open_box : formatter -> int -> unit
+val pp_close_box : formatter -> unit -> unit
+val pp_print_string : formatter -> string -> unit
+val pp_print_as : formatter -> int -> string -> unit
+val pp_print_int : formatter -> int -> unit
+val pp_print_float : formatter -> float -> unit
+val pp_print_char : formatter -> char -> unit
+val pp_print_bool : formatter -> bool -> unit
+val pp_print_break : formatter -> int -> int -> unit
+val pp_print_cut : formatter -> unit -> unit
+val pp_print_space : formatter -> unit -> unit
+val pp_force_newline : formatter -> unit -> unit
+val pp_print_flush : formatter -> unit -> unit
+val pp_print_newline : formatter -> unit -> unit
+val pp_print_if_newline : formatter -> unit -> unit
+val pp_open_tbox : formatter -> unit -> unit
+val pp_close_tbox : formatter -> unit -> unit
+val pp_print_tbreak : formatter -> int -> int -> unit
+val pp_set_tab : formatter -> unit -> unit
+val pp_print_tab : formatter -> unit -> unit
+val pp_set_margin : formatter -> int -> unit
+val pp_get_margin : formatter -> unit -> int
+val pp_set_max_indent : formatter -> int -> unit
+val pp_get_max_indent : formatter -> unit -> int
+val pp_set_max_boxes : formatter -> int -> unit
+val pp_get_max_boxes : formatter -> unit -> int
+val pp_over_max_boxes : formatter -> unit -> bool
+val pp_set_ellipsis_text : formatter -> string -> unit
+val pp_get_ellipsis_text : formatter -> unit -> string
+val pp_set_formatter_out_channel : formatter -> out_channel -> unit
+val pp_set_formatter_output_functions :
+  formatter -> (string -> int -> int -> unit) -> (unit -> unit) -> unit
+val pp_get_formatter_output_functions :
+  formatter -> unit -> (string -> int -> int -> unit) * (unit -> unit)
+val pp_set_all_formatter_output_functions :
+  formatter -> out:(string -> int -> int -> unit) -> flush:(unit -> unit) ->
+    newline:(unit -> unit) -> spaces:(int -> unit) -> unit
+val pp_get_all_formatter_output_functions :
+  formatter -> unit ->
+    (string -> int -> int -> unit) * (unit -> unit) * (unit -> unit) *
+      (int -> unit)
+(** These functions are the basic ones: usual functions
+   operating on the standard formatter are defined via partial
+   evaluation of these primitives. For instance,
+   [print_string] is equal to [pp_print_string std_formatter]. *)
+
+
+(** {6 [printf] like functions for pretty-printing.} *)
+
+val fprintf : formatter -> ('a, formatter, unit) format -> 'a
+(** [fprintf ff format arg1 ... argN] formats the arguments
+   [arg1] to [argN] according to the format string [format],
+   and outputs the resulting string on the formatter [ff].
+   The format is a character string which contains three types of
+   objects: plain characters and conversion specifications as
+   specified in the [printf] module, and pretty-printing
+   indications.
+   The pretty-printing indication characters are introduced by
+   a [@] character, and their meanings are:
+   - [@\[]: open a pretty-printing box. The type and offset of the
+     box may be optionally specified with the following syntax:
+     the [<] character, followed by an optional box type indication,
+     then an optional integer offset, and the closing [>] character. 
+     Box type is one of [h], [v], [hv], [b], or [hov],
+     which stand respectively for an horizontal box, a vertical box,
+     an ``horizontal-vertical'' box, or an ``horizontal or
+     vertical'' box ([b] standing for an ``horizontal or
+     vertical'' box demonstrating indentation and [hov] standing
+     for a regular``horizontal or vertical'' box).
+     For instance, [@\[<hov 2>] opens an ``horizontal or vertical''
+     box with indentation 2 as obtained with [open_hovbox 2].
+     For more details about boxes, see the various box opening
+     functions [open_*box].
+   - [@\]]: close the most recently opened pretty-printing box.
+   - [@,]: output a good break as with [print_cut ()].
+   - [@ ]: output a space, as with [print_space ()].
+   - [@\n]: force a newline, as with [force_newline ()].
+   - [@;]: output a good break as with [print_break]. The
+     [nspaces] and [offset] parameters of the break may be
+     optionally specified with the following syntax: 
+     the [<] character, followed by an integer [nspaces] value,
+     then an integer offset, and a closing [>] character. 
+   - [@?]: flush the pretty printer as with [print_flush ()].
+   - [@.]: flush the pretty printer and output a new line, as with
+     [print_newline ()].
+   - [@<n>]: print the following item as if it were of length [n].
+     Hence, [printf "@<0>%s" arg] is equivalent to [print_as 0 arg].
+     If [@<n>] is not followed by a conversion specification,
+     then the following character of the format is printed as if
+     it were of length [n].
+   - [@@]: print a plain [@] character.
+   
+   Example: [printf "@[%s@ %d@]" "x =" 1] is equivalent to 
+   [open_box (); print_string "x ="; print_space (); print_int 1; close_box ()].
+   It prints [x = 1] within a pretty-printing box. *)
+
+val printf : ('a, formatter, unit) format -> 'a
+(** Same as [fprintf] above, but output on [std_formatter]. *)
+
+val eprintf : ('a, formatter, unit) format -> 'a
+(** Same as [fprintf] above, but output on [err_formatter]. *)
+
+val sprintf : ('a, unit, string) format -> 'a
+(** Same as [printf] above, but instead of printing on a formatter,
+   return a string containing the result of formatting the arguments.
+   Note that the pretty-printer queue is flushed at the end of each
+   call to [sprintf].
+   In case of multiple and related calls to [sprintf] to output material on a
+   string, you should consider using [fprintf] with a
+   formatter writing to a buffer: flushing the buffer at the
+   end of pretty-printing returns the desired string. You can use the
+   predefined formatter [str_formatter] and call [flush_str_formatter
+   ()] to get the result. *)
+
+val bprintf : Buffer.t -> ('a, formatter, unit) format -> 'a
+(** Same as [sprintf] above, but instead of printing on a string,
+   writes into the given extensible buffer.
+   As for [sprintf], the pretty-printer queue is flushed at the end of each
+   call to [bprintf].
+   In case of multiple and related calls to [bprintf] to output material on the
+   same buffer [b], you should consider using [fprintf] with a
+   formatter writing to the buffer [b] (as obtained by
+   [formatter_of_buffer b]), otherwise the repeated flushes of the
+   pretty-printer queue would result in badly formatted output. *)
diff --git a/stdlib/gc.ml b/stdlib/gc.ml
new file mode 100644
index 0000000000..b2d89cce5e
--- /dev/null
+++ b/stdlib/gc.ml
@@ -0,0 +1,99 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Damien Doligez, projet Para, 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 Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+type stat = {
+  minor_words : float;
+  promoted_words : float;
+  major_words : float;
+  minor_collections : int;
+  major_collections : int;
+  heap_words : int;
+  heap_chunks : int;
+  live_words : int;
+  live_blocks : int;
+  free_words : int;
+  free_blocks : int;
+  largest_free : int;
+  fragments : int;
+  compactions : int;
+  top_heap_words : int;
+};;
+
+type control = {
+  mutable minor_heap_size : int;
+  mutable major_heap_increment : int;
+  mutable space_overhead : int;
+  mutable verbose : int;
+  mutable max_overhead : int;
+  mutable stack_limit : int;
+};;
+
+external stat : unit -> stat = "gc_stat";;
+external counters : unit -> (float * float * float) = "gc_counters";;
+external get : unit -> control = "gc_get";;
+external set : control -> unit = "gc_set";;
+external minor : unit -> unit = "gc_minor";;
+external major_slice : int -> int = "gc_major_slice";;
+external major : unit -> unit = "gc_major";;
+external full_major : unit -> unit = "gc_full_major";;
+external compact : unit -> unit = "gc_compaction";;
+
+open Printf;;
+
+let print_stat c =
+  let st = stat () in
+  fprintf c "minor_words: %.0f\n" st.minor_words;
+  fprintf c "promoted_words: %.0f\n" st.promoted_words;
+  fprintf c "major_words: %.0f\n" st.major_words;
+  fprintf c "minor_collections: %d\n" st.minor_collections;
+  fprintf c "major_collections: %d\n" st.major_collections;
+  fprintf c "heap_words: %d\n" st.heap_words;
+  fprintf c "heap_chunks: %d\n" st.heap_chunks;
+  fprintf c "top_heap_words: %d\n" st.top_heap_words;
+  fprintf c "live_words: %d\n" st.live_words;
+  fprintf c "live_blocks: %d\n" st.live_blocks;
+  fprintf c "free_words: %d\n" st.free_words;
+  fprintf c "free_blocks: %d\n" st.free_blocks;
+  fprintf c "largest_free: %d\n" st.largest_free;
+  fprintf c "fragments: %d\n" st.fragments;
+  fprintf c "compactions: %d\n" st.compactions;
+;;
+
+let allocated_bytes () =
+  let (mi, pro, ma) = counters () in
+  (mi +. ma -. pro) *. float_of_int (Sys.word_size / 8)
+;;
+
+external finalise : ('a -> unit) -> 'a -> unit = "final_register";;
+
+
+type alarm = bool ref;;
+type alarm_rec = {active : alarm; f : unit -> unit};;
+
+let rec call_alarm arec =
+  if !(arec.active) then begin
+    finalise call_alarm arec;
+    arec.f ();
+  end;
+;;
+
+let create_alarm f =
+  let a = ref true in
+  let arec = { active = ref true; f = f } in
+  finalise call_alarm arec;
+  a
+;;
+
+let delete_alarm a = a := false;;
diff --git a/stdlib/gc.mli b/stdlib/gc.mli
new file mode 100644
index 0000000000..b1d34d8eb3
--- /dev/null
+++ b/stdlib/gc.mli
@@ -0,0 +1,245 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*             Damien Doligez, projet Para, 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 Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** Memory management control and statistics; finalised values. *)
+
+type stat =
+  { minor_words : float; 
+    (** Number of words allocated in the minor heap since
+       the program was started.  This number is accurate in
+       byte-code programs, but only an approximation in programs
+       compiled to native code. *)
+
+    promoted_words : float;
+    (** Number of words allocated in the minor heap that
+       survived a minor collection and were moved to the major heap
+       since the program was started. *)
+
+    major_words : float;
+    (** Number of words allocated in the major heap, including
+       the promoted words, since the program was started. *)
+
+    minor_collections : int;
+    (** Number of minor collections since the program was started. *)
+
+    major_collections : int;
+    (** Number of major collection cycles completed since the program
+        was started. *)
+
+    heap_words : int;
+    (** Total size of the major heap, in words. *)
+
+    heap_chunks : int;
+    (** Number of contiguous pieces of memory that make up the major heap. *)
+
+    live_words : int;
+    (** Number of words of live data in the major heap, including the header
+       words. *)
+
+    live_blocks : int;
+    (** Number of live blocks in the major heap. *)
+
+    free_words : int;
+    (** Number of words in the free list. *)
+
+    free_blocks : int;
+    (** Number of blocks in the free list. *)
+
+    largest_free : int;
+    (** Size (in words) of the largest block in the free list. *)
+
+    fragments : int;
+    (** Number of wasted words due to fragmentation.  These are
+       1-words free blocks placed between two live blocks.  They
+       are not available for allocation. *)
+
+    compactions : int;
+    (** Number of heap compactions since the program was started. *)
+
+    top_heap_words : int;
+    (** Maximum size reached by the major heap, in words. *)
+}
+(** The memory management counters are returned in a [stat] record.
+
+   The total amount of memory allocated by the program since it was started
+   is (in words) [minor_words + major_words - promoted_words].  Multiply by
+   the word size (4 on a 32-bit machine, 8 on a 64-bit machine) to get
+   the number of bytes.
+*)
+
+type control =
+  { mutable minor_heap_size : int;
+    (** The size (in words) of the minor heap.  Changing
+       this parameter will trigger a minor collection.  Default: 32k. *)
+
+    mutable major_heap_increment : int;
+    (** The minimum number of words to add to the
+       major heap when increasing it.  Default: 62k. *)
+
+    mutable space_overhead : int;
+    (** The major GC speed is computed from this parameter.
+       This is the memory that will be "wasted" because the GC does not
+       immediatly collect unreachable blocks.  It is expressed as a
+       percentage of the memory used for live data.
+       The GC will work more (use more CPU time and collect
+       blocks more eagerly) if [space_overhead] is smaller.
+       The computation of the GC speed assumes that the amount
+       of live data is constant.  Default: 42. *)
+
+    mutable verbose : int;
+    (** This value controls the GC messages on standard error output.
+       It is a sum of some of the following flags, to print messages
+       on the corresponding events:
+       - [0x01] Start of major GC cycle.
+       - [0x02] Minor collection and major GC slice.
+       - [0x04] Growing and shrinking of the heap.
+       - [0x08] Resizing of stacks and memory manager tables.
+       - [0x10] Heap compaction.
+       - [0x20] Change of GC parameters.
+       - [0x40] Computation of major GC slice size.
+       - [0x80] Calling of finalisation functions.
+       - [0x100] Bytecode executable search at start-up.
+       Default: 0. *)
+
+    mutable max_overhead : int;
+    (** Heap compaction is triggered when the estimated amount
+       of free memory is more than [max_overhead] percent of the amount
+       of live data.  If [max_overhead] is set to 0, heap
+       compaction is triggered at the end of each major GC cycle
+       (this setting is intended for testing purposes only).
+       If [max_overhead >= 1000000], compaction is never triggered.
+       Default: 300. *)
+
+    mutable stack_limit : int;
+    (** The maximum size of the stack (in words).  This is only
+       relevant to the byte-code runtime, as the native code runtime
+       uses the operating system's stack.  Default: 256k. *) 
+}
+(** The GC parameters are given as a [control] record. *)
+
+external stat : unit -> stat = "gc_stat"
+(** Return the current values of the memory management counters in a
+   [stat] record. *)
+
+external counters : unit -> float * float * float = "gc_counters"
+(** Return [(minor_words, promoted_words, major_words)].  Much faster
+   than [stat]. *)
+
+external get : unit -> control = "gc_get"
+(** Return the current values of the GC parameters in a [control] record. *)
+
+external set : control -> unit = "gc_set"
+(** [set r] changes the GC parameters according to the [control] record [r].
+   The normal usage is: [Gc.set { (Gc.get()) with Gc.verbose = 0x00d }] *)
+
+external minor : unit -> unit = "gc_minor"
+(** Trigger a minor collection. *)
+
+external major_slice : int -> int = "gc_major_slice";;
+(** Do a minor collection and a slice of major collection.  The argument
+    is the size of the slice, 0 to use the automatically-computed
+    slice size.  In all cases, the result is the computed slice size. *)
+
+external major : unit -> unit = "gc_major"
+(** Do a minor collection and finish the current major collection cycle. *)
+
+external full_major : unit -> unit = "gc_full_major"
+(** Do a minor collection, finish the current major collection cycle,
+   and perform a complete new cycle.  This will collect all currently
+   unreachable blocks. *)
+
+external compact : unit -> unit = "gc_compaction"
+(** Perform a full major collection and compact the heap.  Note that heap
+   compaction is a lengthy operation. *)
+
+val print_stat : out_channel -> unit
+(** Print the current values of the memory management counters (in
+   human-readable form) into the channel argument. *)
+
+val allocated_bytes : unit -> float
+(** Return the total number of bytes allocated since the program was
+   started.  It is returned as a [float] to avoid overflow problems
+   with [int] on 32-bit machines. *)
+
+val finalise : ('a -> unit) -> 'a -> unit
+(** [finalise f v] registers [f] as a finalisation function for [v].
+   [v] must be heap-allocated.  [f] will be called with [v] as
+   argument at some point between the first time [v] becomes unreachable
+   and the time [v] is collected by the GC.  Several functions can
+   be registered for the same value, or even several instances of the
+   same function.  Each instance will be called once (or never,
+   if the program terminates before [v] becomes unreachable).
+   
+  
+   A number of pitfalls are associated with finalised values:
+   finalisation functions are called asynchronously, sometimes
+   even during the execution of other finalisation functions.
+   In a multithreaded program, finalisation functions are called
+   from any thread, thus they must not acquire any mutex.
+
+
+   Anything reachable from the closure of finalisation functions
+   is considered reachable, so the following code will not work
+   as expected:
+   - [ let v = ... in Gc.finalise (fun x -> ...) v ]
+
+   Instead you should write:
+   - [ let f = fun x -> ... ;; let v = ... in Gc.finalise f v ]
+     
+
+   The [f] function can use all features of O'Caml, including
+   assignments that make the value reachable again.  It can also
+   loop forever (in this case, the other
+   finalisation functions will be called during the execution of f).
+   It can call [finalise] on [v] or other values to register other
+   functions or even itself.  It can raise an exception; in this case
+   the exception will interrupt whatever the program was doing when
+   the function was called.
+
+   
+   [finalise] will raise [Invalid_argument] if [v] is not
+   heap-allocated.  Some examples of values that are not
+   heap-allocated are integers, constant constructors, booleans,
+   the empty array, the empty list, the unit value.  The exact list
+   of what is heap-allocated or not is implementation-dependent.
+   Some constant values can be heap-allocated but never deallocated
+   during the lifetime of the program, for example a list of integer
+   constants; this is also implementation-dependent.
+   You should also be aware that compiler optimisations may duplicate
+   some immutable values, for example floating-point numbers when
+   stored into arrays, so they can be finalised and collected while
+   another copy is still in use by the program.
+
+   
+   The results of calling {!String.make}, {!String.create},
+   {!Array.make}, and {!Pervasives.ref} are guaranteed to be
+   heap-allocated and non-constant
+   except when the length argument is [0].
+*)
+
+type alarm
+(** An alarm is a piece of data that calls a user function at the end of
+   each major GC cycle.  The following functions are provided to create
+   and delete alarms. *)
+
+val create_alarm : (unit -> unit) -> alarm
+(** [create_alarm f] will arrange for [f] to be called at the end of each
+   major GC cycle, starting with the current cycle or the next one.
+   A value of type [alarm] is returned that you can
+   use to call [delete_alarm]. *)
+
+val delete_alarm : alarm -> unit
+(** [delete_alarm a] will stop the calls to the function associated
+   to [a].  Calling [delete_alarm a] again has no effect. *)
diff --git a/stdlib/hashtbl.ml b/stdlib/hashtbl.ml
new file mode 100644
index 0000000000..81545a7266
--- /dev/null
+++ b/stdlib/hashtbl.ml
@@ -0,0 +1,273 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            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 Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Hash tables *)
+
+external hash_param : int -> int -> 'a -> int = "hash_univ_param" "noalloc"
+
+let hash x = hash_param 10 100 x
+
+(* We do dynamic hashing, and resize the table and rehash the elements
+   when buckets become too long. *)
+
+type ('a, 'b) t =
+  { mutable size: int;                        (* number of elements *)
+    mutable data: ('a, 'b) bucketlist array } (* the buckets *)
+
+and ('a, 'b) bucketlist =
+    Empty
+  | Cons of 'a * 'b * ('a, 'b) bucketlist
+
+let create initial_size =
+  let s = min (max 1 initial_size) Sys.max_array_length in
+  { size = 0; data = Array.make s Empty }
+
+let clear h =
+  for i = 0 to Array.length h.data - 1 do
+    h.data.(i) <- Empty
+  done;
+  h.size <- 0
+
+let copy h =
+  { size = h.size;
+    data = Array.copy h.data }
+
+let resize hashfun tbl =
+  let odata = tbl.data in
+  let osize = Array.length odata in
+  let nsize = min (2 * osize + 1) Sys.max_array_length in
+  if nsize <> osize then begin
+    let ndata = Array.create nsize Empty in
+    let rec insert_bucket = function
+        Empty -> ()
+      | Cons(key, data, rest) ->
+          insert_bucket rest; (* preserve original order of elements *)
+          let nidx = (hashfun key) mod nsize in
+          ndata.(nidx) <- Cons(key, data, ndata.(nidx)) in
+    for i = 0 to osize - 1 do
+      insert_bucket odata.(i)
+    done;
+    tbl.data <- ndata;
+  end
+
+let add h key info =
+  let i = (hash key) mod (Array.length h.data) in
+  let bucket = Cons(key, info, h.data.(i)) in
+  h.data.(i) <- bucket;
+  h.size <- succ h.size;
+  if h.size > Array.length h.data lsl 1 then resize hash h
+
+let remove h key =
+  let rec remove_bucket = function
+      Empty ->
+        Empty
+    | Cons(k, i, next) ->
+        if k = key
+        then begin h.size <- pred h.size; next end
+        else Cons(k, i, remove_bucket next) in
+  let i = (hash key) mod (Array.length h.data) in
+  h.data.(i) <- remove_bucket h.data.(i)
+
+let rec find_rec key = function
+    Empty ->
+      raise Not_found
+  | Cons(k, d, rest) ->
+      if key = k then d else find_rec key rest
+
+let find h key =
+  match h.data.((hash key) mod (Array.length h.data)) with
+    Empty -> raise Not_found
+  | Cons(k1, d1, rest1) ->
+      if key = k1 then d1 else
+      match rest1 with
+        Empty -> raise Not_found
+      | Cons(k2, d2, rest2) ->
+          if key = k2 then d2 else
+          match rest2 with
+            Empty -> raise Not_found
+          | Cons(k3, d3, rest3) ->
+              if key = k3 then d3 else find_rec key rest3
+
+let find_all h key =
+  let rec find_in_bucket = function
+    Empty ->
+      []
+  | Cons(k, d, rest) ->
+      if k = key then d :: find_in_bucket rest else find_in_bucket rest in
+  find_in_bucket h.data.((hash key) mod (Array.length h.data))
+
+let replace h key info =
+  let rec replace_bucket = function
+      Empty ->
+        raise Not_found
+    | Cons(k, i, next) ->
+        if k = key
+        then Cons(k, info, next)
+        else Cons(k, i, replace_bucket next) in
+  let i = (hash key) mod (Array.length h.data) in
+  let l = h.data.(i) in
+  try
+    h.data.(i) <- replace_bucket l
+  with Not_found ->
+    h.data.(i) <- Cons(key, info, l);
+    h.size <- succ h.size;
+    if h.size > Array.length h.data lsl 1 then resize hash h
+
+let mem h key =
+  let rec mem_in_bucket = function
+  | Empty ->
+      false
+  | Cons(k, d, rest) ->
+      k = key || mem_in_bucket rest in
+  mem_in_bucket h.data.((hash key) mod (Array.length h.data))
+
+let iter f h =
+  let rec do_bucket = function
+      Empty ->
+        ()
+    | Cons(k, d, rest) ->
+        f k d; do_bucket rest in
+  let d = h.data in
+  for i = 0 to Array.length d - 1 do
+    do_bucket d.(i)
+  done
+
+let fold f h init =
+  let rec do_bucket b accu =
+    match b with
+      Empty ->
+        accu
+    | Cons(k, d, rest) ->
+        do_bucket rest (f k d accu) in
+  let d = h.data in
+  let accu = ref init in
+  for i = 0 to Array.length d - 1 do
+    accu := do_bucket d.(i) !accu
+  done;
+  !accu
+
+(* Functorial interface *)
+
+module type HashedType =
+  sig
+    type t
+    val equal: t -> t -> bool
+    val hash: t -> int
+  end
+
+module type S =
+  sig
+    type key
+    type 'a t
+    val create: int -> 'a t
+    val clear: 'a t -> unit
+    val copy: 'a t -> 'a t
+    val add: 'a t -> key -> 'a -> unit
+    val remove: 'a t -> key -> unit
+    val find: 'a t -> key -> 'a
+    val find_all: 'a t -> key -> 'a list
+    val replace : 'a t -> key -> 'a -> unit
+    val mem : 'a t -> key -> bool
+    val iter: (key -> 'a -> unit) -> 'a t -> unit
+    val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+  end
+
+module Make(H: HashedType): (S with type key = H.t) =
+  struct
+    type key = H.t
+    type 'a hashtbl = (key, 'a) t
+    type 'a t = 'a hashtbl
+    let create = create
+    let clear = clear
+    let copy = copy
+
+    let safehash key = (H.hash key) land max_int
+
+    let add h key info =
+      let i = (safehash key) mod (Array.length h.data) in
+      let bucket = Cons(key, info, h.data.(i)) in
+      h.data.(i) <- bucket;
+      h.size <- succ h.size;
+      if h.size > Array.length h.data lsl 1 then resize safehash h
+
+    let remove h key =
+      let rec remove_bucket = function
+          Empty ->
+            Empty
+        | Cons(k, i, next) ->
+            if H.equal k key
+            then begin h.size <- pred h.size; next end
+            else Cons(k, i, remove_bucket next) in
+      let i = (safehash key) mod (Array.length h.data) in
+      h.data.(i) <- remove_bucket h.data.(i)
+
+    let rec find_rec key = function
+        Empty ->
+          raise Not_found
+      | Cons(k, d, rest) ->
+          if H.equal key k then d else find_rec key rest
+
+    let find h key =
+      match h.data.((safehash key) mod (Array.length h.data)) with
+        Empty -> raise Not_found
+      | Cons(k1, d1, rest1) ->
+          if H.equal key k1 then d1 else
+          match rest1 with
+            Empty -> raise Not_found
+          | Cons(k2, d2, rest2) ->
+              if H.equal key k2 then d2 else
+              match rest2 with
+                Empty -> raise Not_found
+              | Cons(k3, d3, rest3) ->
+                  if H.equal key k3 then d3 else find_rec key rest3
+
+    let find_all h key =
+      let rec find_in_bucket = function
+        Empty ->
+          []
+      | Cons(k, d, rest) ->
+          if H.equal k key
+          then d :: find_in_bucket rest
+          else find_in_bucket rest in
+      find_in_bucket h.data.((safehash key) mod (Array.length h.data))
+
+    let replace h key info =
+      let rec replace_bucket = function
+          Empty ->
+            raise Not_found
+        | Cons(k, i, next) ->
+            if H.equal k key
+            then Cons(k, info, next)
+            else Cons(k, i, replace_bucket next) in
+      let i = (safehash key) mod (Array.length h.data) in
+      let l = h.data.(i) in
+      try
+        h.data.(i) <- replace_bucket l
+      with Not_found ->
+        h.data.(i) <- Cons(key, info, l);
+        h.size <- succ h.size;
+        if h.size > Array.length h.data lsl 1 then resize safehash h
+
+    let mem h key =
+      let rec mem_in_bucket = function
+      | Empty ->
+          false
+      | Cons(k, d, rest) ->
+          H.equal k key || mem_in_bucket rest in
+      mem_in_bucket h.data.((safehash key) mod (Array.length h.data))
+
+    let iter = iter
+    let fold = fold
+  end
diff --git a/stdlib/hashtbl.mli b/stdlib/hashtbl.mli
new file mode 100644
index 0000000000..a5eb7d97ee
--- /dev/null
+++ b/stdlib/hashtbl.mli
@@ -0,0 +1,163 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            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 Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** Hash tables and hash functions.
+
+   Hash tables are hashed association tables, with in-place modification. 
+*)
+
+
+(** {6 Generic interface} *)
+
+
+type ('a, 'b) t
+(** The type of hash tables from type ['a] to type ['b]. *)
+
+val create : int -> ('a, 'b) t
+(** [Hashtbl.create n] creates a new, empty hash table, with
+   initial size [n].  For best results, [n] should be on the
+   order of the expected number of elements that will be in
+   the table.  The table grows as needed, so [n] is just an
+   initial guess. *)
+
+val clear : ('a, 'b) t -> unit
+(** Empty a hash table. *)
+
+val add : ('a, 'b) t -> 'a -> 'b -> unit
+(** [Hashtbl.add tbl x y] adds a binding of [x] to [y] in table [tbl].
+   Previous bindings for [x] are not removed, but simply
+   hidden. That is, after performing {!Hashtbl.remove}[ tbl x],
+   the previous binding for [x], if any, is restored.
+   (Same behavior as with association lists.) *)
+
+val copy : ('a, 'b) t -> ('a, 'b) t
+(** Return a copy of the given hashtable. *)
+
+val find : ('a, 'b) t -> 'a -> 'b
+(** [Hashtbl.find tbl x] returns the current binding of [x] in [tbl],
+   or raises [Not_found] if no such binding exists. *)
+
+val find_all : ('a, 'b) t -> 'a -> 'b list
+(** [Hashtbl.find_all tbl x] returns the list of all data
+   associated with [x] in [tbl].
+   The current binding is returned first, then the previous
+   bindings, in reverse order of introduction in the table. *)
+
+val mem : ('a, 'b) t -> 'a -> bool
+(** [Hashtbl.mem tbl x] checks if [x] is bound in [tbl]. *)
+
+val remove : ('a, 'b) t -> 'a -> unit
+(** [Hashtbl.remove tbl x] removes the current binding of [x] in [tbl],
+   restoring the previous binding if it exists.
+   It does nothing if [x] is not bound in [tbl]. *)
+
+val replace : ('a, 'b) t -> 'a -> 'b -> unit
+(** [Hashtbl.replace tbl x y] replaces the current binding of [x]
+   in [tbl] by a binding of [x] to [y].  If [x] is unbound in [tbl],
+   a binding of [x] to [y] is added to [tbl].
+   This is functionally equivalent to {!Hashtbl.remove}[ tbl x]
+   followed by {!Hashtbl.add}[ tbl x y]. *)
+
+val iter : ('a -> 'b -> unit) -> ('a, 'b) t -> unit
+(** [Hashtbl.iter f tbl] applies [f] to all bindings in table [tbl].
+   [f] receives the key as first argument, and the associated value
+   as second argument. The order in which the bindings are passed to
+   [f] is unspecified. Each binding is presented exactly once
+   to [f]. *)
+
+val fold : ('a -> 'b -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c
+(** [Hashtbl.fold f tbl init] computes
+   [(f kN dN ... (f k1 d1 init)...)],
+   where [k1 ... kN] are the keys of all bindings in [tbl],
+   and [d1 ... dN] are the associated values.
+   The order in which the bindings are passed to
+   [f] is unspecified. Each binding is presented exactly once
+   to [f]. *)
+
+
+(** {6 Functorial interface} *)
+
+
+module type HashedType =
+  sig
+    type t
+      (** The type of the hashtable keys. *)
+    val equal : t -> t -> bool
+      (** The equality predicate used to compare keys. *)
+    val hash : t -> int
+      (** A hashing function on keys. It must be such that if two keys are
+          equal according to [equal], then they have identical hash values
+          as computed by [hash].
+          Examples: suitable ([equal], [hash]) pairs for arbitrary key
+          types include
+          ([(=)], {!Hashtbl.hash}) for comparing objects by structure, and
+          ([(==)], {!Hashtbl.hash}) for comparing objects by addresses
+          (e.g. for mutable or cyclic keys). *)
+   end
+(** The input signature of the functor {!Hashtbl.Make}. *)
+
+module type S =
+  sig
+    type key
+    type 'a t
+    val create : int -> 'a t
+    val clear : 'a t -> unit
+    val copy : 'a t -> 'a t
+    val add : 'a t -> key -> 'a -> unit
+    val remove : 'a t -> key -> unit
+    val find : 'a t -> key -> 'a
+    val find_all : 'a t -> key -> 'a list
+    val replace : 'a t -> key -> 'a -> unit
+    val mem : 'a t -> key -> bool
+    val iter : (key -> 'a -> unit) -> 'a t -> unit
+    val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+  end
+(** The output signature of the functor {!Hashtbl.Make}. *)
+
+module Make (H : HashedType) : S with type key = H.t
+(** Functor building an implementation of the hashtable structure.
+    The functor [Hashtbl.Make] returns a structure containing
+    a type [key] of keys and a type ['a t] of hash tables
+    associating data of type ['a] to keys of type [key].
+    The operations perform similarly to those of the generic
+    interface, but use the hashing and equality functions
+    specified in the functor argument [H] instead of generic
+    equality and hashing. *)
+
+
+(** {6 The polymorphic hash primitive} *)
+
+
+val hash : 'a -> int
+(** [Hashtbl.hash x] associates a positive integer to any value of
+   any type. It is guaranteed that
+   if [x = y], then [hash x = hash y]. 
+   Moreover, [hash] always terminates, even on cyclic
+   structures. *)
+
+external hash_param : int -> int -> 'a -> int = "hash_univ_param" "noalloc"
+(** [Hashtbl.hash_param n m x] computes a hash value for [x], with the
+   same properties as for [hash]. The two extra parameters [n] and
+   [m] give more precise control over hashing. Hashing performs a
+   depth-first, right-to-left traversal of the structure [x], stopping
+   after [n] meaningful nodes were encountered, or [m] nodes,
+   meaningful or not, were encountered. Meaningful nodes are: integers;
+   floating-point numbers; strings; characters; booleans; and constant
+   constructors. Larger values of [m] and [n] means that more
+   nodes are taken into account to compute the final hash
+   value, and therefore collisions are less likely to happen.
+   However, hashing takes longer. The parameters [m] and [n]
+   govern the tradeoff between accuracy and speed. *)
+
diff --git a/stdlib/lazy.ml b/stdlib/lazy.ml
new file mode 100644
index 0000000000..10aa40d2d2
--- /dev/null
+++ b/stdlib/lazy.ml
@@ -0,0 +1,93 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Damien Doligez, projet Para, INRIA Rocquencourt          *)
+(*                                                                     *)
+(*  Copyright 1997 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Module [Lazy]: deferred computations *)
+
+
+(*
+   WARNING: some purple magic is going on here.  Do not take this file
+   as an example of how to program in Objective Caml.
+*)
+
+
+(* We make use of two special tags provided by the runtime:
+   [lazy_tag] and [forward_tag].
+
+   A value of type ['a Lazy.t] can be one of three things:
+   1. A block of size 1 with tag [lazy_tag].  Its field is a closure of
+      type [unit -> 'a] that computes the value.
+   2. A block of size 1 with tag [forward_tag].  Its field is the value
+      of type ['a] that was computed.
+   3. Anything else.  This has type ['a] and is the value that was computed.
+   Exceptions are stored in format (1).
+   The GC will magically change things from (2) to (3) according to its
+   fancy.
+
+   We have to use the built-in type constructor [lazy_t] to
+   let the compiler implement the special typing and compilation
+   rules for the [lazy] keyword.
+*)
+
+type 'a t = 'a lazy_t;;
+exception Undefined;;
+
+let raise_undefined = Obj.repr (fun () -> raise Undefined);;
+
+let force (l : 'arg t) =
+  let x = Obj.repr l in
+  if Obj.is_int x then (Obj.obj x : 'arg)
+  else if Obj.tag x = Obj.forward_tag then (Obj.obj (Obj.field x 0) : 'arg)
+  else if Obj.tag x <> Obj.lazy_tag then (Obj.obj x : 'arg)
+  else begin
+    let closure = (Obj.obj (Obj.field x 0) : unit -> 'arg) in
+    Obj.set_field x 0 raise_undefined;
+    try
+      let result = closure () in
+      Obj.set_field x 0 (Obj.repr result);  (* do set_field BEFORE set_tag *)
+      Obj.set_tag x (Obj.forward_tag);
+      result
+    with e ->
+      Obj.set_field x 0 (Obj.repr (fun () -> raise e));
+      raise e;
+  end
+;;
+
+let force_val (l : 'arg t) =
+  let x = Obj.repr l in
+  if Obj.is_int x then (Obj.obj x : 'arg)
+  else if Obj.tag x = Obj.forward_tag then (Obj.obj (Obj.field x 0) : 'arg)
+  else if Obj.tag x <> Obj.lazy_tag then (Obj.obj x : 'arg)
+  else begin
+    let closure = (Obj.obj (Obj.field x 0) : unit -> 'arg) in
+    Obj.set_field x 0 raise_undefined;
+    let result = closure () in
+    Obj.set_field x 0 (Obj.repr result);  (* do set_field BEFORE set_tag *)
+    Obj.set_tag x (Obj.forward_tag);
+    result
+  end
+;;
+
+let lazy_from_fun (f : unit -> 'arg) =
+  let x = Obj.new_block Obj.lazy_tag 1 in
+  Obj.set_field x 0 (Obj.repr f);
+  (Obj.obj x : 'arg t)
+;;
+
+let lazy_from_val (v : 'arg) = (Obj.magic v : 'arg t);;
+
+let lazy_is_val (l : 'arg t) =
+  let x = Obj.repr l in
+  Obj.is_int x || Obj.tag x <> Obj.lazy_tag
+;;
diff --git a/stdlib/lazy.mli b/stdlib/lazy.mli
new file mode 100644
index 0000000000..10d69432d2
--- /dev/null
+++ b/stdlib/lazy.mli
@@ -0,0 +1,64 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Damien Doligez, projet Para, INRIA Rocquencourt          *)
+(*                                                                     *)
+(*  Copyright 1997 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** Deferred computations. *)
+
+type 'a t = 'a lazy_t;;
+(** A value of type ['a Lazy.t] is a deferred computation, called
+   a suspension, that has a result of type ['a].  The special
+   expression syntax [lazy (expr)] makes a suspension of the
+   computation of [expr], without computing [expr] itself yet.
+   "Forcing" the suspension will then compute [expr] and return its
+   result.
+
+   Note: [lazy_t] is the built-in type constructor used by the compiler
+   for the [lazy] keyword.  You should not use it directly.  Always use
+   [Lazy.t] instead.
+*)
+
+
+exception Undefined;;
+
+val force : 'a t -> 'a;;
+(** [force x] forces the suspension [x] and returns its result.
+   If [x] has already been forced, [Lazy.force x] returns the
+   same value again without recomputing it.  If it raised an exception,
+   the same exception is raised again.
+   Raise [Undefined] if the forcing of [x] tries to force [x] itself
+   recursively.
+*)
+
+val force_val : 'a t -> 'a;;
+(** [force_val x] forces the suspension [x] and returns its
+    result.  If [x] has already been forced, [force_val x]
+    returns the same value again without recomputing it.
+    Raise [Undefined] if the forcing of [x] tries to force [x] itself
+    recursively.
+    If the computation of [x] raises an exception, it is unspecified
+    whether [force_val x] raises the same exception or [Undefined].
+*)
+
+val lazy_from_fun : (unit -> 'a) -> 'a t;;
+(** [lazy_from_fun f] is the same as [lazy (f ())] but slightly more
+    efficient. *)
+
+val lazy_from_val : 'a -> 'a t;;
+(** [lazy_from_val v] returns an already-forced suspension of [v]
+    This is for special purposes only and should not be confused with
+    [lazy (v)]. *)
+
+val lazy_is_val : 'a t -> bool;;
+(** [lazy_is_val x] returns [true] if [x] has already been forced and
+    did not raise an exception. *)
diff --git a/stdlib/list.mli b/stdlib/list.mli
new file mode 100644
index 0000000000..bb64f3b02d
--- /dev/null
+++ b/stdlib/list.mli
@@ -0,0 +1,260 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            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 Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** List operations.
+
+   Some functions are flagged as not tail-recursive.  A tail-recursive
+   function uses constant stack space, while a non-tail-recursive function
+   uses stack space proportional to the length of its list argument, which
+   can be a problem with very long lists.  When the function takes several
+   list arguments, an approximate formula giving stack usage (in some
+   unspecified constant unit) is shown in parentheses.
+
+   The above considerations can usually be ignored if your lists are not
+   longer than about 10000 elements.
+*)
+
+val length : 'a list -> int
+(** Return the length (number of elements) of the given list. *)
+
+val hd : 'a list -> 'a
+(** Return the first element of the given list. Raise
+   [Failure "hd"] if the list is empty. *)
+
+val tl : 'a list -> 'a list
+(** Return the given list without its first element. Raise
+   [Failure "tl"] if the list is empty. *)
+
+val nth : 'a list -> int -> 'a
+(** Return the n-th element of the given list.
+   The first element (head of the list) is at position 0.
+   Raise [Failure "nth"] if the list is too short. *)
+
+val rev : 'a list -> 'a list
+(** List reversal. *)
+
+val append : 'a list -> 'a list -> 'a list
+(** Catenate two lists.  Same function as the infix operator [@].
+   Not tail-recursive (length of the first argument).  The [@]
+   operator is not tail-recursive either. *)
+
+val rev_append : 'a list -> 'a list -> 'a list
+(** [List.rev_append l1 l2] reverses [l1] and concatenates it to [l2].
+   This is equivalent to {!List.rev}[ l1 @ l2], but [rev_append] is
+   tail-recursive and more efficient. *)
+
+val concat : 'a list list -> 'a list
+(** Concatenate a list of lists.  Not tail-recursive
+   (length of the argument + length of the longest sub-list). *)
+
+val flatten : 'a list list -> 'a list
+(** Flatten a list of lists.  Not tail-recursive
+   (length of the argument + length of the longest sub-list). *)
+
+
+(** {6 Iterators} *)
+
+
+val iter : ('a -> unit) -> 'a list -> unit
+(** [List.iter f [a1; ...; an]] applies function [f] in turn to
+   [a1; ...; an]. It is equivalent to
+   [begin f a1; f a2; ...; f an; () end]. *)
+
+val map : ('a -> 'b) -> 'a list -> 'b list
+(** [List.map f [a1; ...; an]] applies function [f] to [a1, ..., an],
+   and builds the list [[f a1; ...; f an]]
+   with the results returned by [f].  Not tail-recursive. *)
+
+val rev_map : ('a -> 'b) -> 'a list -> 'b list
+(** [List.rev_map f l] gives the same result as
+   {!List.rev}[ (]{!List.map}[ f l)], but is tail-recursive and
+   more efficient. *)
+
+val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a
+(** [List.fold_left f a [b1; ...; bn]] is
+   [f (... (f (f a b1) b2) ...) bn]. *)
+
+val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b
+(** [List.fold_right f [a1; ...; an] b] is
+   [f a1 (f a2 (... (f an b) ...))].  Not tail-recursive. *)
+
+
+(** {6 Iterators on two lists} *)
+
+
+val iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit
+(** [List.iter2 f [a1; ...; an] [b1; ...; bn]] calls in turn
+   [f a1 b1; ...; f an bn].
+   Raise [Invalid_argument] if the two lists have
+   different lengths. *)
+
+val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
+(** [List.map2 f [a1; ...; an] [b1; ...; bn]] is
+   [[f a1 b1; ...; f an bn]].
+   Raise [Invalid_argument] if the two lists have
+   different lengths.  Not tail-recursive. *)
+
+val rev_map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
+(** [List.rev_map2 f l] gives the same result as
+   {!List.rev}[ (]{!List.map2}[ f l)], but is tail-recursive and
+   more efficient. *)
+
+val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a
+(** [List.fold_left2 f a [b1; ...; bn] [c1; ...; cn]] is
+   [f (... (f (f a b1 c1) b2 c2) ...) bn cn].
+   Raise [Invalid_argument] if the two lists have
+   different lengths. *)
+
+val fold_right2 : ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c
+(** [List.fold_right2 f [a1; ...; an] [b1; ...; bn] c] is
+   [f a1 b1 (f a2 b2 (... (f an bn c) ...))].
+   Raise [Invalid_argument] if the two lists have
+   different lengths.  Not tail-recursive. *)
+
+
+(** {6 List scanning} *)
+
+
+val for_all : ('a -> bool) -> 'a list -> bool
+(** [for_all p [a1; ...; an]] checks if all elements of the list
+   satisfy the predicate [p]. That is, it returns
+   [(p a1) && (p a2) && ... && (p an)]. *)
+
+val exists : ('a -> bool) -> 'a list -> bool
+(** [exists p [a1; ...; an]] checks if at least one element of
+   the list satisfies the predicate [p]. That is, it returns
+   [(p a1) || (p a2) || ... || (p an)]. *)
+
+val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
+(** Same as {!List.for_all}, but for a two-argument predicate.
+   Raise [Invalid_argument] if the two lists have
+   different lengths. *)
+
+val exists2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
+(** Same as {!List.exists}, but for a two-argument predicate.
+   Raise [Invalid_argument] if the two lists have
+   different lengths. *)
+
+val mem : 'a -> 'a list -> bool
+(** [mem a l] is true if and only if [a] is equal
+   to an element of [l]. *)
+
+val memq : 'a -> 'a list -> bool
+(** Same as {!List.mem}, but uses physical equality instead of structural
+   equality to compare list elements. *)
+
+
+(** {6 List searching} *)
+
+
+val find : ('a -> bool) -> 'a list -> 'a
+(** [find p l] returns the first element of the list [l]
+   that satisfies the predicate [p].
+   Raise [Not_found] if there is no value that satisfies [p] in the
+   list [l]. *)
+
+val filter : ('a -> bool) -> 'a list -> 'a list
+(** [filter p l] returns all the elements of the list [l]
+   that satisfy the predicate [p].  The order of the elements
+   in the input list is preserved.  *)
+
+val find_all : ('a -> bool) -> 'a list -> 'a list
+(** [find_all] is another name for {!List.filter}. *)
+
+val partition : ('a -> bool) -> 'a list -> 'a list * 'a list
+(** [partition p l] returns a pair of lists [(l1, l2)], where
+   [l1] is the list of all the elements of [l] that
+   satisfy the predicate [p], and [l2] is the list of all the
+   elements of [l] that do not satisfy [p].
+   The order of the elements in the input list is preserved. *)
+
+
+(** {6 Association lists} *)
+
+
+val assoc : 'a -> ('a * 'b) list -> 'b
+(** [assoc a l] returns the value associated with key [a] in the list of
+   pairs [l]. That is,
+   [assoc a [ ...; (a,b); ...] = b]
+   if [(a,b)] is the leftmost binding of [a] in list [l].
+   Raise [Not_found] if there is no value associated with [a] in the
+   list [l]. *)
+
+val assq : 'a -> ('a * 'b) list -> 'b
+(** Same as {!List.assoc}, but uses physical equality instead of structural
+   equality to compare keys. *)
+
+val mem_assoc : 'a -> ('a * 'b) list -> bool
+(** Same as {!List.assoc}, but simply return true if a binding exists,
+   and false if no bindings exist for the given key. *)
+
+val mem_assq : 'a -> ('a * 'b) list -> bool
+(** Same as {!List.mem_assoc}, but uses physical equality instead of
+   structural equality to compare keys. *)
+
+val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list
+(** [remove_assoc a l] returns the list of
+   pairs [l] without the first pair with key [a], if any.
+   Not tail-recursive. *)
+
+val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list
+(** Same as {!List.remove_assoc}, but uses physical equality instead
+   of structural equality to compare keys.  Not tail-recursive. *)
+
+
+(** {6 Lists of pairs} *)
+
+
+val split : ('a * 'b) list -> 'a list * 'b list
+(** Transform a list of pairs into a pair of lists:
+   [split [(a1,b1); ...; (an,bn)]] is [([a1; ...; an], [b1; ...; bn])].
+   Not tail-recursive.
+*)
+
+val combine : 'a list -> 'b list -> ('a * 'b) list
+(** Transform a pair of lists into a list of pairs:
+   [combine [a1; ...; an] [b1; ...; bn]] is
+   [[(a1,b1); ...; (an,bn)]].
+   Raise [Invalid_argument] if the two lists
+   have different lengths.  Not tail-recursive. *)
+
+
+(** {6 Sorting} *)
+
+
+val sort : ('a -> 'a -> int) -> 'a list -> 'a list
+(** Sort a list in increasing order according to a comparison
+   function.  The comparison function must return 0 if it arguments
+   compare as equal, a positive integer if the first is greater,
+   and a negative integer if the first is smaller (see Array.sort for
+   a complete specification).  For example,
+   {!Pervasives.compare} is a suitable comparison function.
+   The resulting list is sorted in increasing order.
+   [List.sort] is guaranteed to run in constant heap space
+   (in addition to the size of the result list) and logarithmic
+   stack space.
+   
+   The current implementation uses Merge Sort. It runs in constant
+   heap space and logarithmic stack space.
+*)
+
+val stable_sort : ('a -> 'a -> int) -> 'a list -> 'a list
+(** Same as {!List.sort}, but the sorting algorithm is guaranteed to
+   be stable (i.e. elements that compare equal are kept in their
+   original order) .
+   
+   The current implementation uses Merge Sort. It runs in constant
+   heap space and logarithmic stack space.
+*)
diff --git a/stdlib/obj.ml b/stdlib/obj.ml
new file mode 100644
index 0000000000..42df136f7a
--- /dev/null
+++ b/stdlib/obj.ml
@@ -0,0 +1,52 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            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 Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Operations on internal representations of values *)
+
+type t
+
+external repr : 'a -> t = "%identity"
+external obj : t -> 'a = "%identity"
+external magic : 'a -> 'b = "%identity"
+external is_block : t -> bool = "obj_is_block"
+external is_int : t -> bool = "%obj_is_int"
+external tag : t -> int = "obj_tag"
+external set_tag : t -> int -> unit = "obj_set_tag"
+external size : t -> int = "%obj_size"
+external field : t -> int -> t = "%obj_field"
+external set_field : t -> int -> t -> unit = "%obj_set_field"
+external new_block : int -> int -> t = "obj_block"
+external dup : t -> t = "obj_dup"
+external truncate : t -> int -> unit = "obj_truncate"
+
+let marshal (obj : t) =
+  Marshal.to_string obj []
+let unmarshal str pos =
+  (Marshal.from_string str pos, pos + Marshal.total_size str pos)
+
+let lazy_tag = 246
+let closure_tag = 247
+let object_tag = 248
+let infix_tag = 249
+let forward_tag = 250
+
+let no_scan_tag = 251
+
+let abstract_tag = 251
+let string_tag = 252
+let double_tag = 253
+let double_array_tag = 254
+let custom_tag = 255
+let final_tag = custom_tag
diff --git a/stdlib/obj.mli b/stdlib/obj.mli
new file mode 100644
index 0000000000..68670f51d9
--- /dev/null
+++ b/stdlib/obj.mli
@@ -0,0 +1,55 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            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 Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** Operations on internal representations of values.
+
+   Not for the casual user. 
+*)
+
+type t
+
+external repr : 'a -> t = "%identity"
+external obj : t -> 'a = "%identity"
+external magic : 'a -> 'b = "%identity"
+external is_block : t -> bool = "obj_is_block"
+external is_int : t -> bool = "%obj_is_int"
+external tag : t -> int = "obj_tag"
+external set_tag : t -> int -> unit = "obj_set_tag"
+external size : t -> int = "%obj_size"
+external truncate : t -> int -> unit = "obj_truncate"
+external field : t -> int -> t = "%obj_field"
+external set_field : t -> int -> t -> unit = "%obj_set_field"
+external new_block : int -> int -> t = "obj_block"
+external dup : t -> t = "obj_dup"
+
+val lazy_tag : int
+val closure_tag : int
+val object_tag : int
+val infix_tag : int
+val forward_tag : int
+val no_scan_tag : int
+val abstract_tag : int
+val string_tag : int
+val double_tag : int
+val double_array_tag : int
+val custom_tag : int
+val final_tag : int  (* DEPRECATED *)
+
+(** The following two functions are deprecated.  Use module {!Marshal}
+    instead. *)
+
+val marshal : t -> string
+val unmarshal : string -> int -> t * int
+
diff --git a/stdlib/oo.ml b/stdlib/oo.ml
new file mode 100644
index 0000000000..d5f4f96b9d
--- /dev/null
+++ b/stdlib/oo.ml
@@ -0,0 +1,452 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*         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 Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+open Obj
+
+(**** Object representation ****)
+
+let last_id = ref 0
+let new_id () =
+  let id = !last_id in incr last_id; id
+
+let set_id o id =
+  let id0 = !id in
+  Array.unsafe_set (Obj.magic o : int array) 1 id0;
+  id := id0 + 1
+
+(**** Object copy ****)
+
+let copy o =
+  let o = (Obj.obj (Obj.dup (Obj.repr o))) in
+  set_id o last_id;
+  o
+
+(**** Compression options ****)
+(* Parameters *)
+type params = {
+    mutable compact_table : bool;
+    mutable copy_parent : bool;
+    mutable clean_when_copying : bool;
+    mutable retry_count : int;
+    mutable bucket_small_size : int
+  } 
+
+let params = {
+  compact_table = true;
+  copy_parent = true;
+  clean_when_copying = true;
+  retry_count = 3;
+  bucket_small_size = 16
+} 
+
+(**** Parameters ****)
+
+let step = Sys.word_size / 16
+let first_bucket = 0
+let bucket_size = 32                    (* Must be 256 or less *)
+let initial_object_size = 2
+
+(**** Index ****)
+
+type label = int
+
+let label_count = ref 0
+
+let next label =
+  incr label_count;
+  let label = label + step in
+  if label mod (step * bucket_size) = 0 then
+    label + step * (65536 - bucket_size)
+  else
+    label
+
+let decode label =
+  (label / 65536 / step, (label mod (step * bucket_size)) / step)
+
+(**** Items ****)
+
+type item
+
+let dummy_item = (magic () : item)
+
+(**** Buckets ****)
+
+type bucket = item array
+
+let version = ref 0
+
+let set_bucket_version (bucket : bucket) =
+  bucket.(bucket_size) <- (magic !version : item)
+
+let bucket_version bucket =
+  (magic bucket.(bucket_size) : int)
+
+let bucket_list = ref []
+
+let empty_bucket = [| |]
+
+let new_bucket () =
+  let bucket = Array.create (bucket_size + 1) dummy_item in
+  set_bucket_version bucket;
+  bucket_list := bucket :: !bucket_list;
+  bucket
+
+let copy_bucket bucket =
+  let bucket = Array.copy bucket in
+  set_bucket_version bucket;
+  bucket.(bucket_size) <- (magic !version : item);
+  bucket_list := bucket :: !bucket_list;
+  bucket
+
+(**** Make a clean bucket ****)
+
+let new_filled_bucket pos methods =
+  let bucket = new_bucket () in
+  List.iter
+    (fun (lab, met) ->
+       let (buck, elem) = decode lab in
+       if buck = pos then
+         bucket.(elem) <- (magic met : item))
+    (List.rev methods);
+  bucket
+
+(**** Bucket merging ****)
+
+let small_buckets = ref (Array.create 10 [| |])
+let small_bucket_count = ref 0
+
+let insert_bucket bucket =
+  let length = Array.length !small_buckets in
+  if !small_bucket_count >= length then begin
+    let new_array = Array.create (2 * length) [| |] in
+    Array.blit !small_buckets 0 new_array 0 length;
+    small_buckets := new_array
+  end;
+  !small_buckets.(!small_bucket_count) <- bucket;
+  incr small_bucket_count
+
+let remove_bucket n =
+  !small_buckets.(n) <- !small_buckets.(!small_bucket_count - 1);
+  decr small_bucket_count
+
+let bucket_used b =
+  let n = ref 0 in
+  for i = 0 to bucket_size - 1 do
+    if b.(i) != dummy_item then incr n
+  done;
+  !n
+
+let small_bucket b = bucket_used b <= params.bucket_small_size
+
+exception Failed
+
+let rec except e =
+  function
+    [] -> []
+  | e'::l -> if e == e' then l else e'::(except e l)
+
+let merge_buckets b1 b2 =
+  for i = 0 to bucket_size - 1 do
+    if
+      (b2.(i) != dummy_item) && (b1.(i) != dummy_item) && (b2.(i) != b1.(i))
+    then
+      raise Failed
+  done;
+  for i = 0 to bucket_size - 1 do
+    if b2.(i) != dummy_item then
+      b1.(i) <- b2.(i)
+  done;
+  bucket_list := except b2 !bucket_list;
+  b1
+
+let rec choose bucket i =
+  if (i > 0) && (!small_bucket_count > 0) then begin
+    let n = Random.int !small_bucket_count in
+    if not (small_bucket !small_buckets.(n)) then begin
+      remove_bucket n; choose bucket i
+    end else
+      try
+        merge_buckets !small_buckets.(n) bucket
+      with Failed ->
+        choose bucket (i - 1)
+  end else begin
+    insert_bucket bucket;
+    bucket
+  end
+
+let compact b =
+  if
+    (b != empty_bucket) && (bucket_version b = !version) && (small_bucket b)
+  then
+    choose b params.retry_count
+  else
+    b
+
+let compact_buckets buckets =
+  for i = first_bucket to Array.length buckets - 1 do
+    buckets.(i) <- compact buckets.(i)
+  done
+
+(**** Labels ****)
+
+let first_label = first_bucket * 65536 * step
+
+let last_label = ref first_label
+let methods = Hashtbl.create 101
+
+let new_label () =
+  let label = !last_label in
+  last_label := next !last_label;
+  label
+
+let new_method met =
+  try
+    Hashtbl.find methods met
+  with Not_found ->
+    let label = new_label () in
+    Hashtbl.add methods met label;
+    label
+
+let new_anonymous_method =
+  new_label
+
+(**** Types ****)
+
+type obj = t array
+
+(**** Sparse array ****)
+
+module Vars = Map.Make(struct type t = string let compare = compare end)
+type vars = int Vars.t
+
+module Meths = Map.Make(struct type t = string let compare = compare end)
+type meths = label Meths.t
+module Labs = Map.Make(struct type t = label let compare = compare end)
+type labs = bool Labs.t
+
+(* The compiler assumes that the first field of this structure is [size]. *)
+type table =
+ { mutable size: int;
+   mutable buckets: bucket array;
+   mutable methods_by_name: meths;
+   mutable methods_by_label: labs;
+   mutable previous_states:
+     (meths * labs * (label * item) list * vars *
+      label list * string list) list;
+   mutable hidden_meths: (label * item) list;
+   mutable vars: vars;
+   mutable initializers: (obj -> unit) list }
+
+let table_count = ref 0
+
+let new_table () =
+  incr table_count;
+  { buckets = [| |];
+    methods_by_name = Meths.empty;
+    methods_by_label = Labs.empty;
+    previous_states = [];
+    hidden_meths = [];
+    vars = Vars.empty;
+    initializers = [];
+    size = initial_object_size }
+
+let resize array new_size =
+  let old_size = Array.length array.buckets in
+  if new_size > old_size then begin
+    let new_buck = Array.create new_size empty_bucket in
+    Array.blit array.buckets 0 new_buck 0 old_size;
+    array.buckets <- new_buck
+ end
+
+let put array label element =
+  let (buck, elem) = decode label in
+  resize array (buck + 1);
+  let bucket = ref (array.buckets.(buck)) in
+  if !bucket == empty_bucket then begin
+    bucket := new_bucket ();
+    array.buckets.(buck) <- !bucket
+  end;
+  !bucket.(elem) <- element
+
+(**** Classes ****)
+
+let method_count = ref 0
+let inst_var_count = ref 0
+
+type t
+type meth = item
+
+let get_method_label table name =
+  try
+    Meths.find name table.methods_by_name
+  with Not_found ->
+    let label = new_anonymous_method () in
+    table.methods_by_name <- Meths.add name label table.methods_by_name;
+    table.methods_by_label <- Labs.add label true table.methods_by_label;
+    label
+
+let set_method table label element =
+  incr method_count;
+  if Labs.find label table.methods_by_label then
+    put table label element
+  else
+    table.hidden_meths <- (label, element) :: table.hidden_meths
+
+let get_method table label =
+  try List.assoc label table.hidden_meths with Not_found ->
+  let (buck, elem) = decode label in
+  table.buckets.(buck).(elem)
+
+let narrow table vars virt_meths concr_meths =
+  let virt_meth_labs = List.map (get_method_label table) virt_meths in
+  let concr_meth_labs = List.map (get_method_label table) concr_meths in
+  table.previous_states <-
+     (table.methods_by_name, table.methods_by_label, table.hidden_meths,
+      table.vars, virt_meth_labs, vars)
+     :: table.previous_states;
+  table.vars <- Vars.empty;
+  let by_name = ref Meths.empty in
+  let by_label = ref Labs.empty in
+  List.iter2
+    (fun met label ->
+       by_name := Meths.add met label !by_name;
+       by_label :=
+          Labs.add label
+            (try Labs.find label table.methods_by_label with Not_found -> true)
+            !by_label)
+    concr_meths concr_meth_labs;
+  List.iter2
+    (fun met label ->
+       by_name := Meths.add met label !by_name;
+       by_label := Labs.add label false !by_label)
+    virt_meths virt_meth_labs;
+  table.methods_by_name <- !by_name;
+  table.methods_by_label <- !by_label;
+  table.hidden_meths <-
+     List.fold_right
+       (fun ((lab, _) as met) hm ->
+          if List.mem lab virt_meth_labs then hm else met::hm)
+       table.hidden_meths
+       []
+
+let widen table =
+  let (by_name, by_label, saved_hidden_meths, saved_vars, virt_meths, vars) =
+    List.hd table.previous_states
+  in
+  table.previous_states <- List.tl table.previous_states;
+  table.vars <-
+     List.fold_left
+       (fun s v -> Vars.add v (Vars.find v table.vars) s)
+       saved_vars vars;
+  table.methods_by_name <- by_name;
+  table.methods_by_label <- by_label;
+  table.hidden_meths <-
+     List.fold_right
+       (fun ((lab, _) as met) hm ->
+          if List.mem lab virt_meths then hm else met::hm)
+       table.hidden_meths
+       saved_hidden_meths
+
+let new_slot table =
+  let index = table.size in
+  table.size <- index + 1;
+  index
+
+let new_variable table name =
+  let index = new_slot table in
+  table.vars <- Vars.add name index table.vars;
+  index
+
+let get_variable table name =
+  Vars.find name table.vars
+
+let add_initializer table f =
+  table.initializers <- f::table.initializers
+
+let create_table public_methods =
+  let table = new_table () in
+  List.iter
+    (function met ->
+       let lab = new_method met in
+       table.methods_by_name  <- Meths.add met lab table.methods_by_name;
+       table.methods_by_label <- Labs.add lab true table.methods_by_label)
+    public_methods;
+  table
+
+let init_class table =
+  inst_var_count := !inst_var_count + table.size - 1;
+  if params.compact_table then
+    compact_buckets table.buckets;
+  table.initializers <- List.rev table.initializers
+
+(**** Objects ****)
+
+let create_object table =
+  (* XXX Appel de [obj_block] *)
+  let obj = Obj.new_block Obj.object_tag table.size in
+  (* XXX Appel de [modify] *)
+  Obj.set_field obj 0 (Obj.repr table.buckets);
+  set_id obj last_id;
+  (Obj.obj obj)
+
+let rec iter_f obj =
+  function
+    []   -> ()
+  | f::l -> f obj; iter_f obj l
+
+let run_initializers obj table =
+  let inits = table.initializers in
+  if inits <> [] then
+    iter_f obj inits
+
+let send obj lab =
+  let (buck, elem) = decode lab in
+  (magic obj : (obj -> t) array array array).(0).(buck).(elem) obj
+
+(**** Statistics ****)
+
+type stats =
+  { classes: int; labels: int; methods: int; inst_vars: int; buckets: int;
+    distrib : int array; small_bucket_count: int; small_bucket_max: int }
+
+let distrib () =
+  let d = Array.create 32 0 in
+  List.iter
+    (function b ->
+       let n = bucket_used b in
+       d.(n - 1) <- d.(n - 1) + 1)
+    !bucket_list;
+  d
+
+let stats () =
+  { classes = !table_count; labels = !label_count;
+    methods = !method_count; inst_vars = !inst_var_count;
+    buckets = List.length !bucket_list; distrib = distrib ();
+    small_bucket_count = !small_bucket_count;
+    small_bucket_max = Array.length !small_buckets  }
+
+let sort_buck lst =
+  List.map snd
+    (Sort.list (fun (n, _) (n', _) -> n <= n')
+       (List.map (function b -> (bucket_used b, b)) lst))
+
+let show_buckets () =
+  List.iter
+    (function b ->
+       for i = 0 to bucket_size - 1 do
+         print_char (if b.(i) == dummy_item then '.' else '*')
+       done;
+       print_newline ())
+    (sort_buck !bucket_list)
diff --git a/stdlib/pervasives.ml b/stdlib/pervasives.ml
new file mode 100644
index 0000000000..a13c925f3c
--- /dev/null
+++ b/stdlib/pervasives.ml
@@ -0,0 +1,403 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            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 Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* type 'a option = None | Some of 'a *)
+
+(* Exceptions *)
+
+external raise : exn -> 'a = "%raise"
+
+let failwith s = raise(Failure s)
+let invalid_arg s = raise(Invalid_argument s)
+
+exception Exit
+
+(* Comparisons *)
+
+external (=) : 'a -> 'a -> bool = "%equal"
+external (<>) : 'a -> 'a -> bool = "%notequal"
+external (<) : 'a -> 'a -> bool = "%lessthan"
+external (>) : 'a -> 'a -> bool = "%greaterthan"
+external (<=) : 'a -> 'a -> bool = "%lessequal"
+external (>=) : 'a -> 'a -> bool = "%greaterequal"
+external compare: 'a -> 'a -> int = "compare"
+
+let min x y = if x <= y then x else y
+let max x y = if x >= y then x else y
+
+external (==) : 'a -> 'a -> bool = "%eq"
+external (!=) : 'a -> 'a -> bool = "%noteq"
+
+(* Boolean operations *)
+
+external not : bool -> bool = "%boolnot"
+external (&) : bool -> bool -> bool = "%sequand"
+external (&&) : bool -> bool -> bool = "%sequand"
+external (or) : bool -> bool -> bool = "%sequor"
+external (||) : bool -> bool -> bool = "%sequor"
+
+(* Integer operations *)
+
+external (~-) : int -> int = "%negint"
+external succ : int -> int = "%succint"
+external pred : int -> int = "%predint"
+external (+) : int -> int -> int = "%addint"
+external (-) : int -> int -> int = "%subint"
+external ( * ) : int -> int -> int = "%mulint"
+external (/) : int -> int -> int = "%divint"
+external (mod) : int -> int -> int = "%modint"
+
+let abs x = if x >= 0 then x else -x
+
+external (land) : int -> int -> int = "%andint"
+external (lor) : int -> int -> int = "%orint"
+external (lxor) : int -> int -> int = "%xorint"
+
+let lnot x = x lxor (-1)
+
+external (lsl) : int -> int -> int = "%lslint"
+external (lsr) : int -> int -> int = "%lsrint"
+external (asr) : int -> int -> int = "%asrint"
+
+let min_int = 1 lsl (if 1 lsl 31 = 0 then 30 else 62)
+let max_int = min_int - 1
+
+(* Floating-point operations *)
+
+external (~-.) : float -> float = "%negfloat"
+external (+.) : float -> float -> float = "%addfloat"
+external (-.) : float -> float -> float = "%subfloat"
+external ( *. ) : float -> float -> float = "%mulfloat"
+external (/.) : float -> float -> float = "%divfloat"
+external ( ** ) : float -> float -> float = "power_float" "pow" "float"
+external exp : float -> float = "exp_float" "exp" "float"
+external acos : float -> float = "acos_float" "acos" "float"
+external asin : float -> float = "asin_float" "asin" "float"
+external atan : float -> float = "atan_float" "atan" "float"
+external atan2 : float -> float -> float = "atan2_float" "atan2" "float"
+external cos : float -> float = "cos_float" "cos" "float"
+external cosh : float -> float = "cosh_float" "cosh" "float"
+external log : float -> float = "log_float" "log" "float"
+external log10 : float -> float = "log10_float" "log10" "float"
+external sin : float -> float = "sin_float" "sin" "float"
+external sinh : float -> float = "sinh_float" "sinh" "float"
+external sqrt : float -> float = "sqrt_float" "sqrt" "float"
+external tan : float -> float = "tan_float" "tan" "float"
+external tanh : float -> float = "tanh_float" "tanh" "float"
+external ceil : float -> float = "ceil_float" "ceil" "float"
+external floor : float -> float = "floor_float" "floor" "float"
+external abs_float : float -> float = "%absfloat"
+external mod_float : float -> float -> float = "fmod_float" "fmod" "float"
+external frexp : float -> float * int = "frexp_float"
+external ldexp : float -> int -> float = "ldexp_float"
+external modf : float -> float * float = "modf_float"
+external float : int -> float = "%floatofint"
+external float_of_int : int -> float = "%floatofint"
+external truncate : float -> int = "%intoffloat"
+external int_of_float : float -> int = "%intoffloat"
+external float_of_bytes : string -> float = "float_of_bytes"
+let infinity =
+  float_of_bytes "\127\240\000\000\000\000\000\000"
+              (* 0x7F F0 00 00 00 00 00 00 *)
+let neg_infinity =
+  float_of_bytes "\255\240\000\000\000\000\000\000"
+              (* 0xFF F0 00 00 00 00 00 00 *)
+let nan =
+  float_of_bytes "\127\240\000\000\000\000\000\001"
+              (* 0x7F F0 00 00 00 00 00 01 *)
+let max_float =
+  float_of_bytes "\127\239\255\255\255\255\255\255"
+              (* 0x7f ef ff ff ff ff ff ff *)
+let min_float =
+  float_of_bytes "\000\016\000\000\000\000\000\000"
+              (* 0x00 10 00 00 00 00 00 00 *)
+let epsilon_float =
+  float_of_bytes "\060\176\000\000\000\000\000\000"
+              (* 0x3c b0 00 00 00 00 00 00 *)
+type fpclass =
+    FP_normal
+  | FP_subnormal
+  | FP_zero
+  | FP_infinite
+  | FP_nan
+external classify_float: float -> fpclass = "classify_float"
+
+(* String operations -- more in module String *)
+
+external string_length : string -> int = "%string_length"
+external string_create: int -> string = "create_string"
+external string_blit : string -> int -> string -> int -> int -> unit
+                     = "blit_string" "noalloc"
+
+let (^) s1 s2 =
+  let l1 = string_length s1 and l2 = string_length s2 in
+  let s = string_create (l1 + l2) in
+  string_blit s1 0 s 0 l1;
+  string_blit s2 0 s l1 l2;
+  s
+
+(* Character operations -- more in module Char *)
+
+external int_of_char : char -> int = "%identity"
+external unsafe_char_of_int : int -> char = "%identity"
+let char_of_int n =
+  if n < 0 or n > 255 then invalid_arg "char_of_int" else unsafe_char_of_int n
+
+(* Unit operations *)
+
+external ignore : 'a -> unit = "%ignore"
+
+(* Pair operations *)
+
+external fst : 'a * 'b -> 'a = "%field0"
+external snd : 'a * 'b -> 'b = "%field1"
+
+(* String conversion functions *)
+
+external format_int: string -> int -> string = "format_int"
+external format_float: string -> float -> string = "format_float"
+
+let string_of_bool b =
+  if b then "true" else "false"
+let bool_of_string = function
+  | "true" -> true
+  | "false" -> false
+  | _ -> invalid_arg "bool_of_string"
+
+let string_of_int n =
+  format_int "%d" n
+
+external int_of_string : string -> int = "int_of_string"
+
+module String = struct
+  external get : string -> int -> char = "%string_safe_get"
+end
+
+let string_of_float f =
+  let s = format_float "%.12g" f in
+  let l = string_length s in
+  let rec loop i =
+    if i >= l then s ^ "." else
+    if s.[i] = '.' || s.[i] = 'e' then s
+    else loop (i+1)
+  in
+  loop 0
+;;
+
+external float_of_string : string -> float = "float_of_string"
+
+(* List operations -- more in module List *)
+
+let rec (@) l1 l2 =
+  match l1 with
+    [] -> l2
+  | hd :: tl -> hd :: (tl @ l2)
+
+(* I/O operations *)
+
+type in_channel
+type out_channel
+
+external open_descriptor_out: int -> out_channel = "caml_open_descriptor_out"
+external open_descriptor_in: int -> in_channel = "caml_open_descriptor_in"
+
+let stdin = open_descriptor_in 0
+let stdout = open_descriptor_out 1
+let stderr = open_descriptor_out 2
+
+(* General output functions *)
+
+type open_flag =
+    Open_rdonly | Open_wronly | Open_append
+  | Open_creat | Open_trunc | Open_excl
+  | Open_binary | Open_text | Open_nonblock
+
+external open_desc: string -> open_flag list -> int -> int = "sys_open"
+
+let open_out_gen mode perm name =
+  open_descriptor_out(open_desc name mode perm)
+
+let open_out name =
+  open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_text] 0o666 name
+
+let open_out_bin name =
+  open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] 0o666 name
+
+external flush : out_channel -> unit = "caml_flush"
+
+external out_channels_list : unit -> out_channel list 
+                           = "caml_out_channels_list"
+
+let flush_all () = 
+  let rec iter = function
+      [] -> ()
+    | a::l -> flush a; iter l
+  in iter (out_channels_list ())
+
+external unsafe_output : out_channel -> string -> int -> int -> unit
+                       = "caml_output"
+
+external output_char : out_channel -> char -> unit = "caml_output_char"
+
+let output_string oc s =
+  unsafe_output oc s 0 (string_length s)
+
+let output oc s ofs len =
+  if ofs < 0 || len < 0 || ofs + len > string_length s
+  then invalid_arg "output"
+  else unsafe_output oc s ofs len
+
+external output_byte : out_channel -> int -> unit = "caml_output_char"
+external output_binary_int : out_channel -> int -> unit = "caml_output_int"
+
+external marshal_to_channel : out_channel -> 'a -> unit list -> unit
+     = "output_value"
+let output_value chan v = marshal_to_channel chan v []
+
+external seek_out : out_channel -> int -> unit = "caml_seek_out"
+external pos_out : out_channel -> int = "caml_pos_out"
+external out_channel_length : out_channel -> int = "caml_channel_size"
+external close_out_channel : out_channel -> unit = "caml_close_channel"
+let close_out oc = flush oc; close_out_channel oc
+external set_binary_mode_out : out_channel -> bool -> unit
+                             = "caml_set_binary_mode"
+
+(* General input functions *)
+
+let open_in_gen mode perm name =
+  open_descriptor_in(open_desc name mode perm)
+
+let open_in name =
+  open_in_gen [Open_rdonly; Open_text] 0 name
+
+let open_in_bin name =
+  open_in_gen [Open_rdonly; Open_binary] 0 name
+
+external input_char : in_channel -> char = "caml_input_char"
+
+external unsafe_input : in_channel -> string -> int -> int -> int 
+                      = "caml_input"
+
+let input ic s ofs len =
+  if ofs < 0 || len < 0 || ofs + len > string_length s
+  then invalid_arg "input"
+  else unsafe_input ic s ofs len
+
+let rec unsafe_really_input ic s ofs len =
+  if len <= 0 then () else begin
+    let r = unsafe_input ic s ofs len in
+    if r = 0
+    then raise End_of_file
+    else unsafe_really_input ic s (ofs+r) (len-r)
+  end
+
+let really_input ic s ofs len =
+  if ofs < 0 || len < 0 || ofs + len > string_length s
+  then invalid_arg "really_input"
+  else unsafe_really_input ic s ofs len
+
+external input_scan_line : in_channel -> int = "caml_input_scan_line"
+
+let input_line chan =
+  let rec build_result buf pos = function
+    [] -> buf
+  | hd :: tl ->
+      let len = string_length hd in
+      string_blit hd 0 buf (pos - len) len;
+      build_result buf (pos - len) tl in
+  let rec scan accu len =
+    let n = input_scan_line chan in
+    if n = 0 then begin                   (* n = 0: we are at EOF *)
+      match accu with
+        [] -> raise End_of_file
+      | _  -> build_result (string_create len) len accu
+    end else if n > 0 then begin          (* n > 0: newline found in buffer *)
+      let res = string_create (n-1) in
+      ignore (unsafe_input chan res 0 (n-1));
+      ignore (input_char chan);           (* skip the newline *)
+      match accu with
+        [] -> res
+      |  _ -> let len = len + n - 1 in 
+              build_result (string_create len) len (res :: accu)
+    end else begin                        (* n < 0: newline not found *)
+      let beg = string_create (-n) in
+      ignore(unsafe_input chan beg 0 (-n));
+      scan (beg :: accu) (len - n)
+    end
+  in scan [] 0
+
+external input_byte : in_channel -> int = "caml_input_char"
+external input_binary_int : in_channel -> int = "caml_input_int"
+external input_value : in_channel -> 'a = "input_value"
+external seek_in : in_channel -> int -> unit = "caml_seek_in"
+external pos_in : in_channel -> int = "caml_pos_in"
+external in_channel_length : in_channel -> int = "caml_channel_size"
+external close_in : in_channel -> unit = "caml_close_channel"
+external set_binary_mode_in : in_channel -> bool -> unit
+                            = "caml_set_binary_mode"
+
+(* Output functions on standard output *)
+
+let print_char c = output_char stdout c
+let print_string s = output_string stdout s
+let print_int i = output_string stdout (string_of_int i)
+let print_float f = output_string stdout (string_of_float f)
+let print_endline s = output_string stdout s; output_char stdout '\n'
+let print_newline () = output_char stdout '\n'; flush stdout
+
+(* Output functions on standard error *)
+
+let prerr_char c = output_char stderr c
+let prerr_string s = output_string stderr s
+let prerr_int i = output_string stderr (string_of_int i)
+let prerr_float f = output_string stderr (string_of_float f)
+let prerr_endline s =
+  output_string stderr s; output_char stderr '\n'; flush stderr
+let prerr_newline () = output_char stderr '\n'; flush stderr
+
+(* Input functions on standard input *)
+
+let read_line () = flush stdout; input_line stdin
+let read_int () = int_of_string(read_line())
+let read_float () = float_of_string(read_line())
+
+(* References *)
+
+type 'a ref = { mutable contents: 'a }
+external ref: 'a -> 'a ref = "%makemutable"
+external (!): 'a ref -> 'a = "%field0"
+external (:=): 'a ref -> 'a -> unit = "%setfield0"
+external incr: int ref -> unit = "%incr"
+external decr: int ref -> unit = "%decr"
+
+(* Miscellaneous *)
+
+external sys_exit : int -> 'a = "sys_exit"
+
+let exit_function = ref flush_all
+
+let at_exit f =
+  let g = !exit_function in
+  exit_function := (fun () -> f(); g())
+
+let do_at_exit () = (!exit_function) ()
+
+let exit retcode =
+  do_at_exit ();
+  sys_exit retcode
+
+external register_named_value: string -> 'a -> unit = "register_named_value"
+
+let _ = register_named_value "Pervasives.do_at_exit" do_at_exit
diff --git a/stdlib/pervasives.mli b/stdlib/pervasives.mli
new file mode 100644
index 0000000000..ddcebc3eb0
--- /dev/null
+++ b/stdlib/pervasives.mli
@@ -0,0 +1,862 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            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 Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** The initially opened module.
+
+   This module provides the built-in types (numbers, booleans,
+   strings, exceptions, references, lists, arrays, input-output channels, ...)
+   and the basic operations over these types.
+
+   This module is automatically opened at the beginning of each compilation.
+   All components of this module can therefore be referred by their short
+   name, without prefixing them by [Pervasives].
+*)
+
+(** {6 Predefined types} 
+These are predefined types :
+{[ type int]}    The type of integer numbers.
+{[ type char]}   The type of characters.
+{[ type string]} The type of character strings.
+{[ type float]}  The type of floating-point numbers.
+{[ type bool]}   The type of booleans (truth values).
+{[ type unit = ()]} The type of the unit value.
+{[ type exn]}    The type of exception values.
+{[ type 'a array]}  The type of arrays whose elements have type ['a].
+{[ type 'a list = [] | :: of 'a * 'a list]}
+                 The type of lists whose elements have type ['a].
+{[type 'a option = None | Some of 'a]}
+                 The type of optional values. 
+{[type ('a, 'b, 'c) format]}
+                 The type of format strings. ['a] is the type of the parameters
+                 of the format, ['c] is the result type for the [printf]-style
+                 function, and ['b] is the type of the first argument given to
+                 [%a] and [%t] printing functions (see module {!Printf}).
+*)
+
+(** {6 Exceptions} *)
+
+external raise : exn -> 'a = "%raise"
+(** Raise the given exception value *)
+        
+(** These are predefined exceptions :
+{[exception Match_failure of (string * int * int)]}
+   Exception raised when none of the cases of a pattern-matching
+   apply. The arguments are the location of the pattern-matching
+   in the source code (file name, position of first character,
+   position of last character).
+
+{[exception Assert_failure of (string * int * int)]}
+   Exception raised when an assertion fails.  The arguments are
+   the location of the pattern-matching in the source code
+   (file name, position of first character, position of last
+   character).
+
+{[exception Invalid_argument of string]}
+   Exception raised by library functions to signal that the given
+   arguments do not make sense.
+
+{[exception Failure of string]}
+   Exception raised by library functions to signal that they are
+   undefined on the given arguments. 
+
+{[exception Not_found]}
+   Exception raised by search functions when the desired object
+   could not be found.
+
+{[exception Out_of_memory]}
+   Exception raised by the garbage collector
+   when there is insufficient memory to complete the computation.
+
+{[exception Stack_overflow]}
+   Exception raised by the bytecode interpreter when the evaluation
+   stack reaches its maximal size. This often indicates infinite
+   or excessively deep recursion in the user's program.
+
+{[exception Sys_error of string]}
+   Exception raised by the input/output functions to report
+   an operating system error.
+
+{[exception End_of_file]}
+   Exception raised by input functions to signal that the
+   end of file has been reached.
+
+{[exception Division_by_zero]}
+   Exception raised by division and remainder operations
+   when their second argument is null.
+
+{[exception Sys_blocked_io]}
+   A special case of [Sys_error] raised when no I/O is possible
+   on a non-blocking I/O channel.
+
+*)
+
+exception Exit
+(** The [Exit] exception is not raised by any library function.  It is
+    provided for use in your programs.*)
+
+val invalid_arg : string -> 'a
+(** Raise exception [Invalid_argument] with the given string. *)
+
+val failwith : string -> 'a
+(** Raise exception [Failure] with the given string. *)
+
+
+(** {6 Comparisons} *)
+
+
+external ( = ) : 'a -> 'a -> bool = "%equal"
+(** [e1 = e2] tests for structural equality of [e1] and [e2].
+   Mutable structures (e.g. references and arrays) are equal
+   if and only if their current contents are structurally equal,
+   even if the two mutable objects are not the same physical object.
+   Equality between functional values raises [Invalid_argument].
+   Equality between cyclic data structures may not terminate. *)
+
+external ( <> ) : 'a -> 'a -> bool = "%notequal"
+(** Negation of {!Pervasives.(=)}. *)
+
+
+external ( < ) : 'a -> 'a -> bool = "%lessthan"
+(** See {!Pervasives.(>=)}. *)
+
+external ( > ) : 'a -> 'a -> bool = "%greaterthan"
+(** See {!Pervasives.(>=)}. *)
+
+external ( <= ) : 'a -> 'a -> bool = "%lessequal"
+(** See {!Pervasives.(>=)}. *)
+
+external ( >= ) : 'a -> 'a -> bool = "%greaterequal"
+(** Structural ordering functions. These functions coincide with
+   the usual orderings over integers, characters, strings
+   and floating-point numbers, and extend them to a
+   total ordering over all types.
+   The ordering is compatible with [(=)]. As in the case
+   of [(=)], mutable structures are compared by contents.
+   Comparison between functional values raises [Invalid_argument].
+   Comparison between cyclic structures may not terminate. *)
+
+external compare : 'a -> 'a -> int = "compare"
+(** [compare x y] returns [0] if [x=y], a negative integer if
+   [x<y], and a positive integer if [x>y]. The same restrictions
+   as for [=] apply. [compare] can be used as the comparison function
+   required by the {!Set} and {!Map} modules. *)
+
+val min : 'a -> 'a -> 'a
+(** Return the smaller of the two arguments. *)
+
+val max : 'a -> 'a -> 'a
+(** Return the greater of the two arguments. *)
+
+external ( == ) : 'a -> 'a -> bool = "%eq"
+(** [e1 == e2] tests for physical equality of [e1] and [e2].
+   On integers and characters, it is the same as structural
+   equality. On mutable structures, [e1 == e2] is true if and only if
+   physical modification of [e1] also affects [e2].
+   On non-mutable structures, the behavior of [(==)] is
+   implementation-dependent, except that [e1 == e2] implies
+   [e1 = e2]. *)
+
+external ( != ) : 'a -> 'a -> bool = "%noteq"
+(** Negation of {!Pervasives.(==)}. *)
+
+
+(** {6 Boolean operations} *)
+
+
+external not : bool -> bool = "%boolnot"
+(** The boolean negation. *)
+
+external ( && ) : bool -> bool -> bool = "%sequand"
+(** The boolean ``and''. Evaluation is sequential, left-to-right:
+   in [e1 && e2], [e1] is evaluated first, and if it returns [false],
+   [e2] is not evaluated at all. *)
+
+external ( & ) : bool -> bool -> bool = "%sequand"
+(** @deprecated {!Pervasives.(&&)} should be used instead. *)
+
+external ( || ) : bool -> bool -> bool = "%sequor"
+(** See {!Pervasives.or}.*)
+
+external ( or ) : bool -> bool -> bool = "%sequor"
+(** The boolean ``or''. Evaluation is sequential, left-to-right:
+   in [e1 || e2], [e1] is evaluated first, and if it returns [true],
+   [e2] is not evaluated at all. *)
+
+
+(** {6 Integer arithmetic} *)
+
+(** Integers are 31 bits wide (or 63 bits on 64-bit processors).
+   All operations are taken modulo 2{^31} (or 2{^63}).
+   They do not fail on overflow. *)
+
+external ( ~- ) : int -> int = "%negint"
+(** Unary negation. You can also write [-e] instead of [~-e]. *)
+
+external succ : int -> int = "%succint"
+(** [succ x] is [x+1]. *)
+
+external pred : int -> int = "%predint"
+(** [pred x] is [x-1]. *)
+
+external ( + ) : int -> int -> int = "%addint"
+(** Integer addition. *)
+
+external ( - ) : int -> int -> int = "%subint"
+(** Integer subtraction. *)
+
+external ( * ) : int -> int -> int = "%mulint"
+(** Integer multiplication. *)
+
+external ( / ) : int -> int -> int = "%divint"
+(** Integer division.
+   Raise [Division_by_zero] if the second argument is 0.
+   Integer division rounds the real quotient of its arguments towards zero.
+   More precisely, if [x >= 0] and [y > 0], [x / y] is the greatest integer
+   less than or equal to the real quotient of [x] by [y].  Moreover,
+   [(-x) / y = x / (-y) = -(x / y)].  *)
+
+external ( mod ) : int -> int -> int = "%modint"
+(** Integer remainder.  If [y] is not zero, the result
+   of [x mod y] satisfies the following properties:
+   [x = (x / y) * y + x mod y] and
+   [abs(x mod y) < abs(y)].
+   If [y = 0], [x mod y] raises [Division_by_zero].
+   Notice that [x mod y] is negative if [x < 0]. *)
+
+val abs : int -> int
+(** Return the absolute value of the argument. *)
+
+val max_int : int
+(** The greatest representable integer. *)
+
+val min_int : int
+(** The smallest representable integer. *)
+
+
+
+(** {7 Bitwise operations} *)
+
+
+external ( land ) : int -> int -> int = "%andint"
+(** Bitwise logical and. *)
+
+external ( lor ) : int -> int -> int = "%orint"
+(** Bitwise logical or. *)
+
+external ( lxor ) : int -> int -> int = "%xorint"
+(** Bitwise logical exclusive or. *)
+
+val lnot : int -> int
+(** Bitwise logical negation. *)
+
+external ( lsl ) : int -> int -> int = "%lslint"
+(** [n lsl m] shifts [n] to the left by [m] bits.
+   The result is unspecified if [m < 0] or [m >= bitsize],
+   where [bitsize] is [32] on a 32-bit platform and
+   [64] on a 64-bit platform. *)
+
+external ( lsr ) : int -> int -> int = "%lsrint"
+(** [n lsr m] shifts [n] to the right by [m] bits.
+   This is a logical shift: zeroes are inserted regardless of
+   the sign of [n].
+   The result is unspecified if [m < 0] or [m >= bitsize]. *)
+
+external ( asr ) : int -> int -> int = "%asrint"
+(** [n asr m] shifts [n] to the right by [m] bits.
+   This is an arithmetic shift: the sign bit of [n] is replicated.
+   The result is unspecified if [m < 0] or [m >= bitsize]. *)
+    
+
+(** {6 Floating-point arithmetic}
+
+   Caml's floating-point numbers follow the
+   IEEE 754 standard, using double precision (64 bits) numbers.
+   Floating-point operations never raise an exception on overflow,
+   underflow, division by zero, etc.  Instead, special IEEE numbers
+   are returned as appropriate, such as [infinity] for [1.0 /. 0.0],
+   [neg_infinity] for [-1.0 /. 0.0], and [nan] (``not a number'')
+   for [0.0 /. 0.0].  These special numbers then propagate through
+   floating-point computations as expected: for instance,
+   [1.0 /. infinity] is [0.0], and any operation with [nan] as 
+   argument returns [nan] as result. 
+*)
+
+external ( ~-. ) : float -> float = "%negfloat"
+(** Unary negation. You can also write [-.e] instead of [~-.e]. *)
+
+external ( +. ) : float -> float -> float = "%addfloat"
+(** Floating-point addition *)
+
+external ( -. ) : float -> float -> float = "%subfloat"
+(** Floating-point subtraction *)
+
+external ( *. ) : float -> float -> float = "%mulfloat"
+(** Floating-point multiplication *)
+
+external ( /. ) : float -> float -> float = "%divfloat"
+(** Floating-point division. *)
+
+external ( ** ) : float -> float -> float = "power_float" "pow" "float"
+(** Exponentiation *)
+
+external sqrt : float -> float = "sqrt_float" "sqrt" "float"
+(** Square root *)
+
+external exp : float -> float = "exp_float" "exp" "float"
+(** Exponential. *)
+
+external log : float -> float = "log_float" "log" "float"
+(** Natural logarithm. *)
+
+external log10 : float -> float = "log10_float" "log10" "float"
+(** Base 10 logarithm. *)
+
+external cos : float -> float = "cos_float" "cos" "float"
+(** See {!Pervasives.atan2}. *)
+
+external sin : float -> float = "sin_float" "sin" "float"
+(** See {!Pervasives.atan2}. *)
+
+external tan : float -> float = "tan_float" "tan" "float"
+(** See {!Pervasives.atan2}. *)
+
+external acos : float -> float = "acos_float" "acos" "float"
+(** See {!Pervasives.atan2}. *)
+
+external asin : float -> float = "asin_float" "asin" "float"
+(** See {!Pervasives.atan2}. *)
+
+external atan : float -> float = "atan_float" "atan" "float"
+(** See {!Pervasives.atan2}. *)
+
+external atan2 : float -> float -> float = "atan2_float" "atan2" "float"
+(** The usual trigonometric functions. *)
+
+external cosh : float -> float = "cosh_float" "cosh" "float"
+(** See {!Pervasives.tanh}. *)
+
+external sinh : float -> float = "sinh_float" "sinh" "float"
+(** See {!Pervasives.tanh}. *)
+
+external tanh : float -> float = "tanh_float" "tanh" "float"
+(** The usual hyperbolic trigonometric functions. *)
+
+external ceil : float -> float = "ceil_float" "ceil" "float"
+(** See {!Pervasives.floor}. *)
+
+external floor : float -> float = "floor_float" "floor" "float"
+(** Round the given float to an integer value.
+   [floor f] returns the greatest integer value less than or
+   equal to [f].
+   [ceil f] returns the least integer value greater than or
+   equal to [f]. *)
+
+external abs_float : float -> float = "%absfloat"
+(** Return the absolute value of the argument. *)
+
+external mod_float : float -> float -> float = "fmod_float" "fmod" "float"
+(** [mod_float a b] returns the remainder of [a] with respect to
+   [b].  The returned value is [a -. n *. b], where [n]
+   is the quotient [a /. b] rounded towards zero to an integer. *)
+
+external frexp : float -> float * int = "frexp_float"
+(** [frexp f] returns the pair of the significant
+   and the exponent of [f].  When [f] is zero, the
+   significant [x] and the exponent [n] of [f] are equal to
+   zero.  When [f] is non-zero, they are defined by
+   [f = x *. 2 ** n] and [0.5 <= x < 1.0]. *)
+
+external ldexp : float -> int -> float = "ldexp_float"
+(** [ldexp x n] returns [x *. 2 ** n]. *)
+
+external modf : float -> float * float = "modf_float"
+(** [modf f] returns the pair of the fractional and integral
+   part of [f]. *)
+
+external float : int -> float = "%floatofint"
+(** Same as {!Pervasives.float_of_int}. *)
+
+external float_of_int : int -> float = "%floatofint"
+(** Convert an integer to floating-point. *)
+
+external truncate : float -> int = "%intoffloat"
+(** Same as {!Pervasives.int_of_float}. *)
+
+external int_of_float : float -> int = "%intoffloat"
+(** Truncate the given floating-point number to an integer.
+   The result is unspecified if it falls outside the
+   range of representable integers. *)
+
+val infinity : float
+(** Positive infinity. *)
+
+val neg_infinity : float
+(** Negative infinity. *)
+
+val nan : float
+(** A special floating-point value denoting the result of an
+   undefined operation such as [0.0 /. 0.0].  Stands for
+   ``not a number''. *)
+
+val max_float : float
+(** The largest positive finite value of type [float]. *)
+
+val min_float : float
+(** The smallest positive, non-zero, non-denormalized value of type [float]. *)
+
+val epsilon_float : float
+(** The smallest positive float [x] such that [1.0 +. x <> 1.0]. *)
+
+type fpclass =
+    FP_normal           (** Normal number, none of the below *)
+  | FP_subnormal        (** Number very close to 0.0, has reduced precision *)
+  | FP_zero             (** Number is 0.0 or -0.0 *)
+  | FP_infinite         (** Number is positive or negative infinity *)
+  | FP_nan              (** Not a number: result of an undefined operation *)
+(** The five classes of floating-point numbers, as determined by
+   the {!Pervasives.classify_float} function. *)
+
+external classify_float : float -> fpclass = "classify_float"
+(** Return the class of the given floating-point number:
+   normal, subnormal, zero, infinite, or not a number. *)
+
+
+(** {6 String operations}
+
+   More string operations are provided in module {!String}.
+*)
+
+val ( ^ ) : string -> string -> string
+(** String concatenation. *)
+
+
+(** {6 Character operations}
+
+   More character operations are provided in module {!Char}.
+*)
+
+external int_of_char : char -> int = "%identity"
+(** Return the ASCII code of the argument. *)
+
+val char_of_int : int -> char
+(** Return the character with the given ASCII code.
+   Raise [Invalid_argument "char_of_int"] if the argument is
+   outside the range 0--255. *)
+
+
+(** {6 Unit operations} *)
+
+external ignore : 'a -> unit = "%ignore"
+(** Discard the value of its argument and return [()].
+   For instance, [ignore(f x)] discards the result of
+   the side-effecting function [f].  It is equivalent to
+   [f x; ()], except that the latter may generate a
+   compiler warning; writing [ignore(f x)] instead
+   avoids the warning. *)
+
+
+(** {6 String conversion functions} *)
+
+val string_of_bool : bool -> string
+(** Return the string representation of a boolean. *)
+
+val bool_of_string : string -> bool
+(** Convert the given string to a boolean.
+   Raise [Invalid_argument "bool_of_string"] if the string is not
+   ["true"] or ["false"]. *)
+
+val string_of_int : int -> string
+(** Return the string representation of an integer, in decimal. *)
+
+external int_of_string : string -> int = "int_of_string"
+(** Convert the given string to an integer.
+   The string is read in decimal (by default) or in hexadecimal,
+   octal or binary if the string begins with [0x], [0o] or [0b]
+   respectively.
+   Raise [Failure "int_of_string"] if the given string is not
+   a valid representation of an integer. *)
+
+val string_of_float : float -> string
+(** Return the string representation of a floating-point number. *)
+
+external float_of_string : string -> float = "float_of_string"
+(** Convert the given string to a float.  Raise [Failure "float_of_string"]
+   if the given string is not a valid representation of a float. *)
+
+
+
+(** {6 Pair operations} *)
+
+external fst : 'a * 'b -> 'a = "%field0"
+(** Return the first component of a pair. *)
+
+external snd : 'a * 'b -> 'b = "%field1"
+(** Return the second component of a pair. *)
+
+
+(** {6 List operations}
+
+   More list operations are provided in module {!List}. 
+*)
+
+val ( @ ) : 'a list -> 'a list -> 'a list
+(** List concatenation. *)
+
+
+(** {6 Input/output} *)
+
+type in_channel
+(** The type of input channel. *)
+
+type out_channel
+(** The type of output channel. *)
+
+val stdin : in_channel
+(** The standard input for the process. *)
+
+val stdout : out_channel
+(** The standard output for the process. *)
+
+val stderr : out_channel
+(** The standard error ouput for the process. *)
+
+
+(** {7 Output functions on standard output} *)
+
+val print_char : char -> unit
+(** Print a character on standard output. *)
+
+val print_string : string -> unit
+(** Print a string on standard output. *)
+
+val print_int : int -> unit
+(** Print an integer, in decimal, on standard output. *)
+
+val print_float : float -> unit
+(** Print a floating-point number, in decimal, on standard output. *)
+
+val print_endline : string -> unit
+(** Print a string, followed by a newline character, on
+   standard output. *)
+
+val print_newline : unit -> unit
+(** Print a newline character on standard output, and flush
+   standard output. This can be used to simulate line
+   buffering of standard output. *)
+
+
+(** {7 Output functions on standard error} *)
+
+val prerr_char : char -> unit
+(** Print a character on standard error. *)
+
+val prerr_string : string -> unit
+(** Print a string on standard error. *)
+
+val prerr_int : int -> unit
+(** Print an integer, in decimal, on standard error. *)
+
+val prerr_float : float -> unit
+(** Print a floating-point number, in decimal, on standard error. *)
+
+val prerr_endline : string -> unit
+(** Print a string, followed by a newline character on standard error
+   and flush standard error. *)
+
+val prerr_newline : unit -> unit
+(** Print a newline character on standard error, and flush
+   standard error. *)
+
+
+(** {7 Input functions on standard input} *)
+
+val read_line : unit -> string
+(** Flush standard output, then read characters from standard input
+   until a newline character is encountered. Return the string of
+   all characters read, without the newline character at the end. *)
+
+val read_int : unit -> int
+(** Flush standard output, then read one line from standard input
+   and convert it to an integer. Raise [Failure "int_of_string"]
+   if the line read is not a valid representation of an integer. *)
+
+val read_float : unit -> float
+(** Flush standard output, then read one line from standard input
+   and convert it to a floating-point number.
+   The result is unspecified if the line read is not a valid
+   representation of a floating-point number. *)
+
+(** {7 General output functions} *)
+
+
+type open_flag =
+    Open_rdonly      (** open for reading. *)
+  | Open_wronly      (** open for writing. *)
+  | Open_append      (** open for appending. always write at end of file (needs [Open_wronly]. *)
+  | Open_creat       (** create the file if it does not exist. *)
+  | Open_trunc       (** empty the file if it already exists. *)
+  | Open_excl        (** fail if the file already exists. *)
+  | Open_binary      (** open in binary mode (no conversion). *)
+  | Open_text        (** open in text mode (may perform conversions). *)
+  | Open_nonblock    (** open in non-blocking mode. *)
+(** Opening modes for {!Pervasives.open_out_gen} and {!Pervasives.open_in_gen}. *)
+           
+val open_out : string -> out_channel
+(** Open the named file for writing, and return a new output channel
+   on that file, positionned at the beginning of the file. The
+   file is truncated to zero length if it already exists. It
+   is created if it does not already exists.
+   Raise [Sys_error] if the file could not be opened. *)
+
+val open_out_bin : string -> out_channel
+(** Same as {!Pervasives.open_out}, but the file is opened in binary mode,
+   so that no translation takes place during writes. On operating
+   systems that do not distinguish between text mode and binary
+   mode, this function behaves like {!Pervasives.open_out}. *)
+
+val open_out_gen : open_flag list -> int -> string -> out_channel
+(** Open the named file for writing, as above. The extra argument [mode]
+   specify the opening mode. The extra argument [perm] specifies
+   the file permissions, in case the file must be created.
+   {!Pervasives.open_out} and {!Pervasives.open_out_bin} are special
+   cases of this function. *)
+
+val flush : out_channel -> unit
+(** Flush the buffer associated with the given output channel, 
+   performing all pending writes on that channel.
+   Interactive programs must be careful about flushing standard
+   output and standard error at the right time. *)
+
+val flush_all : unit -> unit
+(** Flush all opened output channels. *)
+
+val output_char : out_channel -> char -> unit
+(** Write the character on the given output channel. *)
+
+val output_string : out_channel -> string -> unit
+(** Write the string on the given output channel. *)
+
+val output : out_channel -> string -> int -> int -> unit
+(** Write [len] characters from string [buf], starting at offset
+   [pos], to the given output channel.
+   Raise [Invalid_argument "output"] if [pos] and [len] do not
+   designate a valid substring of [buf]. *)
+
+val output_byte : out_channel -> int -> unit
+(** Write one 8-bit integer (as the single character with that code)
+   on the given output channel. The given integer is taken modulo
+   256. *)
+
+val output_binary_int : out_channel -> int -> unit
+(** Write one integer in binary format on the given output channel.
+   The only reliable way to read it back is through the
+   {!Pervasives.input_binary_int} function. The format is compatible across
+   all machines for a given version of Objective Caml. *)
+
+val output_value : out_channel -> 'a -> unit
+(** Write the representation of a structured value of any type
+   to a channel. Circularities and sharing inside the value
+   are detected and preserved. The object can be read back,
+   by the function {!Pervasives.input_value}. See the description of module
+   {!Marshal} for more information. {!Pervasives.output_value} is equivalent
+   to {!Marshal.to_channel} with an empty list of flags. *)
+
+val seek_out : out_channel -> int -> unit
+(** [seek_out chan pos] sets the current writing position to [pos]
+   for channel [chan]. This works only for regular files. On
+   files of other kinds (such as terminals, pipes and sockets),
+   the behavior is unspecified. *)
+
+val pos_out : out_channel -> int
+(** Return the current writing position for the given channel. *)
+
+val out_channel_length : out_channel -> int
+(** Return the total length (number of characters) of the
+   given channel.  This works only for regular files. On files of
+   other kinds, the result is meaningless. *)
+
+val close_out : out_channel -> unit
+(** Close the given channel, flushing all buffered write operations.
+   A [Sys_error] exception is raised if any of the functions above
+   is called on a closed channel. *)
+
+val set_binary_mode_out : out_channel -> bool -> unit
+(** [set_binary_mode_out oc true] sets the channel [oc] to binary
+   mode: no translations take place during output.
+   [set_binary_mode_out oc false] sets the channel [oc] to text
+   mode: depending on the operating system, some translations
+   may take place during output.  For instance, under Windows,
+   end-of-lines will be translated from [\n] to [\r\n].
+   This function has no effect under operating systems that
+   do not distinguish between text mode and binary mode. *)
+
+
+(** {7 General input functions} *)
+
+val open_in : string -> in_channel
+(** Open the named file for reading, and return a new input channel
+   on that file, positionned at the beginning of the file.
+   Raise [Sys_error] if the file could not be opened. *)
+
+val open_in_bin : string -> in_channel
+(** Same as {!Pervasives.open_in}, but the file is opened in binary mode,
+   so that no translation takes place during reads. On operating
+   systems that do not distinguish between text mode and binary
+   mode, this function behaves like {!Pervasives.open_in}. *)
+
+val open_in_gen : open_flag list -> int -> string -> in_channel
+(** Open the named file for reading, as above. The extra arguments
+   [mode] and [perm] specify the opening mode and file permissions.
+   {!Pervasives.open_in} and {!Pervasives.open_in_bin} are special
+   cases of this function. *)
+
+val input_char : in_channel -> char
+(** Read one character from the given input channel.
+   Raise [End_of_file] if there are no more characters to read. *)
+
+val input_line : in_channel -> string
+(** Read characters from the given input channel, until a
+   newline character is encountered. Return the string of
+   all characters read, without the newline character at the end.
+   Raise [End_of_file] if the end of the file is reached
+   at the beginning of line. *)
+
+val input : in_channel -> string -> int -> int -> int
+(** Read up to [len] characters from the given channel,
+   storing them in string [buf], starting at character number [pos].
+   It returns the actual number of characters read, between 0 and
+   [len] (inclusive).
+   A return value of 0 means that the end of file was reached.
+   A return value between 0 and [len] exclusive means that
+   not all requested [len] characters were read, either because
+   no more characters were available at that time, or because
+   the implementation found it convenient to do a partial read;
+   [input] must be called again to read the remaining characters,
+   if desired.  (See also {!Pervasives.really_input} for reading
+   exactly [len] characters.)
+   Exception [Invalid_argument "input"] is raised if [pos] and [len]
+   do not designate a valid substring of [buf]. *)          
+
+val really_input : in_channel -> string -> int -> int -> unit
+(** Read [len] characters from the given channel, storing them in
+   string [buf], starting at character number [pos].
+   Raise [End_of_file] if the end of file is reached before [len]
+   characters have been read.
+   Raise [Invalid_argument "really_input"] if
+   [pos] and [len] do not designate a valid substring of [buf]. *)
+
+val input_byte : in_channel -> int
+(** Same as {!Pervasives.input_char}, but return the 8-bit integer representing
+   the character.
+   Raise [End_of_file] if an end of file was reached. *)
+
+val input_binary_int : in_channel -> int
+(** Read an integer encoded in binary format from the given input
+   channel. See {!Pervasives.output_binary_int}.
+   Raise [End_of_file] if an end of file was reached while reading the
+   integer. *)
+
+val input_value : in_channel -> 'a
+(** Read the representation of a structured value, as produced
+   by {!Pervasives.output_value}, and return the corresponding value.
+   This function is identical to {!Marshal.from_channel};
+   see the description of module {!Marshal} for more information,
+   in particular concerning the lack of type safety. *)
+
+val seek_in : in_channel -> int -> unit
+(** [seek_in chan pos] sets the current reading position to [pos]
+   for channel [chan]. This works only for regular files. On
+   files of other kinds, the behavior is unspecified. *)
+
+val pos_in : in_channel -> int
+(** Return the current reading position for the given channel. *)
+
+val in_channel_length : in_channel -> int
+(** Return the total length (number of characters) of the
+   given channel. This works only for regular files. On files of
+   other kinds, the result is meaningless. *)
+
+val close_in : in_channel -> unit
+(** Close the given channel.  A [Sys_error] exception is raised
+   if any of the functions above is called on a closed channel. *)
+
+val set_binary_mode_in : in_channel -> bool -> unit
+(** [set_binary_mode_in ic true] sets the channel [ic] to binary
+   mode: no translations take place during input.
+   [set_binary_mode_out ic false] sets the channel [ic] to text
+   mode: depending on the operating system, some translations
+   may take place during input.  For instance, under Windows,
+   end-of-lines will be translated from [\r\n] to [\n].
+   This function has no effect under operating systems that
+   do not distinguish between text mode and binary mode. *)
+
+
+(** {6 References} *)
+
+
+type 'a ref = { mutable contents : 'a }
+(** The type of references (mutable indirection cells) containing
+   a value of type ['a]. *)
+
+external ref : 'a -> 'a ref = "%makemutable"
+(** Return a fresh reference containing the given value. *)
+
+external ( ! ) : 'a ref -> 'a = "%field0"
+(** [!r] returns the current contents of reference [r].
+   Equivalent to [fun r -> r.contents]. *)
+
+external ( := ) : 'a ref -> 'a -> unit = "%setfield0"
+(** [r := a] stores the value of [a] in reference [r].
+   Equivalent to [fun r v -> r.contents <- v]. *)
+
+external incr : int ref -> unit = "%incr"
+(** Increment the integer contained in the given reference.
+   Equivalent to [fun r -> r := succ !r]. *)
+
+external decr : int ref -> unit = "%decr"
+(** Decrement the integer contained in the given reference.
+   Equivalent to [fun r -> r := pred !r]. *)
+
+
+(** {6 Program termination} *)
+
+
+val exit : int -> 'a
+(** Flush all pending writes on {!Pervasives.stdout} and
+   {!Pervasives.stderr},
+   and terminate the process, returning the given status code
+   to the operating system (usually 0 to indicate no errors,
+   and a small positive integer to indicate failure.) 
+   An implicit [exit 0] is performed each time a program
+   terminates normally (but not if it terminates because of
+   an uncaught exception). *)
+
+val at_exit : (unit -> unit) -> unit
+(** Register the given function to be called at program
+   termination time. The functions registered with [at_exit]
+   will be called when the program executes {!Pervasives.exit}. 
+   They will not be called if the program
+   terminates because of an uncaught exception.
+   The functions are called in ``last in, first out'' order:
+   the function most recently added with [at_exit] is called first. *)
+
+
+(**/**)
+
+(** {6 For system use only, not for the casual user} *)
+
+val unsafe_really_input : in_channel -> string -> int -> int -> unit
+
+val do_at_exit : unit -> unit
diff --git a/stdlib/random.ml b/stdlib/random.ml
new file mode 100644
index 0000000000..35d19ff0c3
--- /dev/null
+++ b/stdlib/random.ml
@@ -0,0 +1,197 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*              Damien Doligez, projet Para, 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 Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* "Linear feedback shift register" random number generator. *)
+(* References: Robert Sedgewick, "Algorithms", Addison-Wesley *)
+
+(* The PRNG is a linear feedback shift register.
+   It is seeded by a MD5-based PRNG.
+*)
+
+(* This is the state you get with [init 27182818] on a 32-bit machine. *)
+let state = [|
+  561073064; 1051173471; 764306064; 9858203; 1023641486; 615350359;
+  552627506; 486882977; 147054819; 951240904; 869261341; 71648846; 848741663;
+  337696531; 66770770; 473370118; 998499212; 477485839; 814302728; 281896889;
+  206134737; 796925167; 762624501; 971004788; 878960411; 233350272;
+  965168955; 933858406; 572927557; 708896334; 32881167; 462134267; 868098973;
+  768795410; 567327260; 4136554; 268309077; 804670393; 854580894; 781847598;
+  310632349; 22990936; 187230644; 714526560; 146577263; 979459837; 514922558;
+  414383108; 21528564; 896816596; 33747835; 180326017; 414576093; 124177607;
+  440266690
+|]
+
+let index = ref 0
+
+(* Returns 30 random bits as an integer 0 <= x < 1073741824 *)
+let bits () =
+  index := (!index + 1) mod 55;
+  let newval =
+    state.((!index + 24) mod 55) + state.(!index) in
+  state.(!index) <- newval;
+  newval land 0x3FFFFFFF
+
+(* Returns a float 0 <= x < 1 with at most 90 bits of precision. *)
+let rawfloat () =
+  let scale = 1073741824.0
+  and r0 = float (bits ())
+  and r1 = float (bits ())
+  and r2 = float (bits ())
+  in ((r0 /. scale +. r1) /. scale +. r2) /. scale
+
+let rec intaux n =
+  let r = bits () in
+  if r >= n then intaux n else r
+let int bound =
+  if bound > 0x3FFFFFFF || bound <= 0
+  then invalid_arg "Random.int"
+  else (intaux (0x3FFFFFFF / bound * bound)) mod bound
+
+let float bound = rawfloat () *. bound
+
+let bool () = (bits () land 1 = 0);;
+
+(* Simple initialisation.  The seed is an integer. *)
+let init seed =
+  let mdg i =
+    let d = Digest.string (string_of_int i ^ string_of_int seed) in
+    (Char.code d.[0] + (Char.code d.[1] lsl 8) + (Char.code d.[2] lsl 16))
+    lxor (Char.code d.[3] lsl 22)
+  in
+  for i = 0 to 54 do
+    state.(i) <- (mdg i)
+  done;
+  index := 0
+
+(* Full initialisation.  The seed is an array of integers. *)
+let full_init seed =
+  init 27182818;
+  for i = 0 to Array.length (seed) - 1 do
+    let j = i mod 55 in
+    state.(j) <- state.(j) + seed.(i)
+  done
+
+(* Low-entropy system-dependent initialisation. *)
+
+external random_seed: unit -> int = "sys_random_seed";;
+
+let self_init () = init (random_seed());;
+
+
+(* Manipulating the current state. *)
+
+type state = { st : int array; idx : int };;
+
+let get_state () = { st = Array.copy state; idx = !index };;
+
+let set_state s =
+  Array.blit s.st 0 state 0 55;
+  index := s.idx;
+;;
+
+(********************
+
+(* Test functions.  Not included in the library.
+   The [chisquare] function should be called with n > 10r.
+   It returns a triple (low, actual, high).
+   If low <= actual <= high, the [g] function passed the test,
+   otherwise it failed.
+
+  Some results:
+
+Random.init 27182818; chisquare Random.int 100000 1000;;
+Random.init 27182818; chisquare Random.int 100000 100;;
+Random.init 27182818; chisquare Random.int 100000 5000;;
+Random.init 27182818; chisquare Random.int 1000000 1000;;
+Random.init 27182818; chisquare Random.int 100000 1024;;
+Random.init 299792643; chisquare Random.int 100000 1024;;
+Random.init 14142136; chisquare Random.int 100000 1024;;
+Random.init 27182818; init_diff 1024; chisquare diff 100000 1024;;
+Random.init 27182818; init_diff 100; chisquare diff 100000 100;;
+Random.init 27182818; init_diff2 1024; chisquare diff2 100000 1024;;
+Random.init 27182818; init_diff2 100; chisquare diff2 100000 100;;
+Random.init 14142136; init_diff2 100; chisquare diff2 100000 100;;
+Random.init 299792643; init_diff2 100; chisquare diff2 100000 100;;
+- : float * float * float = 936.754446797, 948.8, 1063.2455532
+#- : float * float * float = 80, 80.076, 120
+#- : float * float * float = 4858.57864376, 4767.5, 5141.42135624 *********
+#- : float * float * float = 936.754446797, 951.2, 1063.2455532
+#- : float * float * float = 960, 1028.31104, 1088
+#- : float * float * float = 960, 1012.64384, 1088
+#- : float * float * float = 960, 970.25024, 1088
+#- : float * float * float = 960, 982.29248, 1088
+#- : float * float * float = 80, 110.418, 120
+#- : float * float * float = 960, 1022.76096, 1088
+#- : float * float * float = 80, 96.894, 120
+#- : float * float * float = 80, 83.864, 120
+#- : float * float * float = 80, 89.956, 120
+
+*)
+
+(* Return the sum of the squares of v[i0,i1[ *)
+let rec sumsq v i0 i1 =
+  if i0 >= i1 then 0.0
+  else if i1 = i0 + 1 then float v.(i0) *. float v.(i0)
+  else sumsq v i0 ((i0+i1)/2) +. sumsq v ((i0+i1)/2) i1
+;;
+
+let chisquare g n r =
+  if n <= 10 * r then invalid_arg "chisquare";
+  let f = Array.make r 0 in
+  for i = 1 to n do
+    let t = g r in
+    f.(t) <- f.(t) + 1
+  done;
+  let t = sumsq f 0 r
+  and r = float r
+  and n = float n in
+  let sr = 2.0 *. sqrt r in
+  (r -. sr,   (r *. t /. n) -. n,   r +. sr)
+;;
+
+(* This is to test for linear dependencies between successive random numbers.
+*)
+let st = ref 0;;
+let init_diff r = st := Random.int r;;
+let diff r =
+  let x1 = !st
+  and x2 = Random.int r
+  in
+  st := x2;
+  if x1 >= x2 then
+    x1 - x2
+  else
+    r + x1 - x2
+;;
+
+let st1 = ref 0
+and st2 = ref 0
+;;
+
+(* This is to test for quadratic dependencies between successive random
+   numbers.
+*)
+let init_diff2 r = st1 := Random.int r; st2 := Random.int r;;
+let diff2 r =
+  let x1 = !st1
+  and x2 = !st2
+  and x3 = Random.int r
+  in
+  st1 := x2;
+  st2 := x3;
+  (x3 - x2 - x2 + x1 + 2*r) mod r
+;;
+
+********************)
diff --git a/stdlib/random.mli b/stdlib/random.mli
new file mode 100644
index 0000000000..32854a659a
--- /dev/null
+++ b/stdlib/random.mli
@@ -0,0 +1,57 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*              Damien Doligez, projet Para, 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 Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** Pseudo-random number generator (PRNG). *)
+
+val init : int -> unit
+(** Initialize the generator, using the argument as a seed.
+     The same seed will always yield the same sequence of numbers. *)
+
+val full_init : int array -> unit
+(** Same as {!Random.init} but takes more data as seed. *)
+
+val self_init : unit -> unit
+(** Initialize the generator with a more-or-less random seed chosen
+   in a system-dependent way. *)
+
+val bits : unit -> int
+(** Return 30 random bits in a nonnegative integer. *)
+
+val int : int -> int
+(** [Random.int bound] returns a random integer between 0 (inclusive)
+     and [bound] (exclusive).  [bound] must be more than 0 and less
+     than 2{^30}. *)
+
+val float : float -> float
+(** [Random.float bound] returns a random floating-point number
+   between 0 (inclusive) and [bound] (exclusive).  If [bound] is
+   negative, the result is negative.  If [bound] is 0, the result
+   is 0. *)
+
+val bool : unit -> bool
+(** [Random.bool ()] returns [true] or [false] with probability 0.5 each. *)
+
+type state
+(** Values of this type are used to store the current state of the
+   generator. *)
+
+val get_state : unit -> state
+(** Returns the current state of the generator.  This is useful for
+   checkpointing computations that use the PRNG. *)
+
+val set_state : state -> unit
+(** Resets the state of the generator to some previous state returned by
+   {!Random.get_state}. *)
+
diff --git a/stdlib/sys.ml b/stdlib/sys.ml
new file mode 100644
index 0000000000..9da1b6c483
--- /dev/null
+++ b/stdlib/sys.ml
@@ -0,0 +1,81 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            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 Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* System interface *)
+
+external get_config: unit -> string * int = "sys_get_config"
+external get_argv: unit -> string * string array = "sys_get_argv"
+
+let (executable_name, argv) = get_argv()
+let (os_type, word_size) = get_config()
+let max_array_length = (1 lsl (word_size - 10)) - 1;;
+let max_string_length = word_size / 8 * max_array_length - 1;;
+
+external file_exists: string -> bool = "sys_file_exists"
+external remove: string -> unit = "sys_remove"
+external rename : string -> string -> unit = "sys_rename"
+external getenv: string -> string = "sys_getenv"
+external command: string -> int = "sys_system_command"
+external time: unit -> float = "sys_time"
+external chdir: string -> unit = "sys_chdir"
+external getcwd: unit -> string = "sys_getcwd"
+
+let interactive = ref false
+
+type signal_behavior =
+    Signal_default
+  | Signal_ignore
+  | Signal_handle of (int -> unit)
+
+external signal: int -> signal_behavior -> signal_behavior
+        = "install_signal_handler"
+
+let set_signal sig_num sig_beh = ignore(signal sig_num sig_beh)
+
+let sigabrt = -1
+let sigalrm = -2
+let sigfpe = -3
+let sighup = -4
+let sigill = -5
+let sigint = -6
+let sigkill = -7
+let sigpipe = -8
+let sigquit = -9
+let sigsegv = -10
+let sigterm = -11
+let sigusr1 = -12
+let sigusr2 = -13
+let sigchld = -14
+let sigcont = -15
+let sigstop = -16
+let sigtstp = -17
+let sigttin = -18
+let sigttou = -19
+let sigvtalrm = -20
+let sigprof = -21
+
+exception Break
+
+let catch_break on =
+  if on then
+    set_signal sigint (Signal_handle(fun _ -> raise Break))
+  else
+    set_signal sigint Signal_default
+
+
+(* OCaml version numbers and strings, moved from utils/config.mlp.
+   Must be in the format described in sys.mli. *)
+
+let ocaml_version = "3.04+6 (2002-02-05)"
diff --git a/stdlib/sys.mli b/stdlib/sys.mli
new file mode 100644
index 0000000000..f733c3ef15
--- /dev/null
+++ b/stdlib/sys.mli
@@ -0,0 +1,182 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            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 Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** System interface. *)
+
+val argv : string array
+(** The command line arguments given to the process.
+   The first element is the command name used to invoke the program.
+   The following elements are the command-line arguments
+   given to the program. *)
+
+val executable_name : string
+(** The name of the file containing the executable currently running. *)
+
+external file_exists : string -> bool = "sys_file_exists"
+(** Test if a file with the given name exists. *)
+
+external remove : string -> unit = "sys_remove"
+(** Remove the given file name from the file system. *)
+
+external rename : string -> string -> unit = "sys_rename"
+(** Rename a file. The first argument is the old name and the
+   second is the new name. *)
+
+external getenv : string -> string = "sys_getenv"
+(** Return the value associated to a variable in the process
+   environment. Raise [Not_found] if the variable is unbound. *)
+
+external command : string -> int = "sys_system_command"
+(** Execute the given shell command and return its exit code. *)
+
+external time : unit -> float = "sys_time"
+(** Return the processor time, in seconds, used by the program
+   since the beginning of execution. *)
+
+external chdir : string -> unit = "sys_chdir"
+(** Change the current working directory of the process. *)
+
+external getcwd : unit -> string = "sys_getcwd"
+(** Return the current working directory of the process. *)
+
+val interactive : bool ref
+(** This reference is initially set to [false] in standalone
+   programs and to [true] if the code is being executed under
+   the interactive toplevel system [ocaml]. *)
+
+val os_type : string
+(** Operating system currently executing the Caml program.
+   One of ["Unix"], ["Win32"], ["Cygwin"] or ["MacOS"]. *)
+
+val word_size : int
+(** Size of one word on the machine currently executing the Caml
+   program, in bits: 32 or 64. *)
+
+val max_string_length : int
+(** Maximum length of a string. *)
+
+val max_array_length : int
+(** Maximum length of an array. *)
+
+
+(** {6 Signal handling} *)
+
+
+type signal_behavior =
+    Signal_default
+  | Signal_ignore 
+  | Signal_handle of (int -> unit)
+(** What to do when receiving a signal:
+   - [Signal_default]: take the default behavior
+     (usually: abort the program)
+   - [Signal_ignore]: ignore the signal
+   - [Signal_handle f]: call function [f], giving it the signal
+   number as argument. *)
+
+external signal :
+  int -> signal_behavior -> signal_behavior = "install_signal_handler"
+(** Set the behavior of the system on receipt of a given signal.
+   The first argument is the signal number.  Return the behavior
+   previously associated with the signal. *)
+
+val set_signal : int -> signal_behavior -> unit
+(** Same as {!Sys.signal} but return value is ignored. *)
+
+
+(** {7 Signal numbers for the standard POSIX signals.} *) 
+
+val sigabrt : int
+(** Abnormal termination *)
+
+val sigalrm : int
+(** Timeout *)
+
+val sigfpe : int
+(** Arithmetic exception *)
+
+val sighup : int
+(** Hangup on controlling terminal *)
+
+val sigill : int
+(** Invalid hardware instruction *)
+
+val sigint : int
+(** Interactive interrupt (ctrl-C) *)
+
+val sigkill : int
+(** Termination (cannot be ignored) *)
+
+val sigpipe : int
+(** Broken pipe *)
+
+val sigquit : int
+(** Interactive termination *)
+
+val sigsegv : int
+(** Invalid memory reference *)
+
+val sigterm : int
+(** Termination *)
+
+val sigusr1 : int
+(** Application-defined signal 1 *)
+
+val sigusr2 : int
+(** Application-defined signal 2 *)
+
+val sigchld : int
+(** Child process terminated *)
+
+val sigcont : int
+(** Continue *)
+
+val sigstop : int
+(** Stop *)
+
+val sigtstp : int
+(** Interactive stop *)
+
+val sigttin : int
+(** Terminal read from background process *)
+
+val sigttou : int
+(** Terminal write from background process *)
+
+val sigvtalrm : int
+(** Timeout in virtual time *)
+
+val sigprof : int
+(** Profiling interrupt *)
+
+
+exception Break
+(** Exception raised on interactive interrupt if {!Sys.catch_break}
+   is on. *)
+
+
+val catch_break : bool -> unit
+(** [catch_break] governs whether interactive interrupt (ctrl-C)
+   terminates the program or raises the [Break] exception. 
+   Call [catch_break true] to enable raising [Break],
+   and [catch_break false] to let the system
+   terminate the program on user interrupt. *)
+
+
+val ocaml_version : string;;
+(** [ocaml_version] is the version of Objective Caml.
+    It is a string of the form ["major.minor[additional-info] (date)"]
+    Where major and minor are integers, date is in standard format
+    (i.e. YYYY-MM-DD), and [additional-info] is a string that may be
+    empty and does not start with a digit. *)
diff --git a/stdlib/weak.ml b/stdlib/weak.ml
new file mode 100644
index 0000000000..e22e18ce3e
--- /dev/null
+++ b/stdlib/weak.ml
@@ -0,0 +1,235 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Damien Doligez, projet Para, INRIA Rocquencourt          *)
+(*                                                                     *)
+(*  Copyright 1997 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+
+(** Weak array operations *)
+
+type 'a t;;
+
+external create: int -> 'a t = "weak_create";;
+
+let length x = Obj.size(Obj.repr x) - 1;;
+
+external set : 'a t -> int -> 'a option -> unit = "weak_set";;
+external get: 'a t -> int -> 'a option = "weak_get";;
+external get_copy: 'a t -> int -> 'a option = "weak_get_copy";;
+external check: 'a t -> int -> bool = "weak_check";;
+
+let fill ar ofs len x =
+  if ofs < 0 || len < 0 || ofs + len > length ar
+  then raise (Invalid_argument "Weak.fill")
+  else begin
+    for i = ofs to (ofs + len - 1) do
+      set ar i x
+    done
+  end
+;;
+
+let blit ar1 of1 ar2 of2 len =
+  if of1 < 0 || of1 + len > length ar1 || of2 < 0 || of2 + len > length ar2
+  then raise (Invalid_argument "Weak.blit")
+  else begin
+    if of2 > of1 then begin
+      for i = 0 to len - 1 do
+        set ar2 (of2 + i) (get ar1 (of1 + i))
+      done
+    end else begin
+      for i = len - 1 downto 0 do
+        set ar2 (of2 + i) (get ar1 (of1 + i))
+      done
+    end
+  end
+;;
+
+
+(** Weak hash tables *)
+
+module type S = sig
+  type data
+  type t
+  val create : int -> t
+  val clear : t -> unit
+  val merge : t -> data -> data
+  val add : t -> data -> unit
+  val remove : t -> data -> unit
+  val find : t -> data -> data
+  val find_all : t -> data -> data list
+  val mem : t -> data -> bool
+  val iter : (data -> unit) -> t -> unit
+  val fold : (data -> 'a -> 'a) -> t -> 'a -> 'a
+  val count : t -> int
+  val stats : t -> int * int * int * int * int * int
+end;;
+
+module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct
+
+  type 'a weak_t = 'a t;;
+  let weak_create = create;;
+  let emptybucket = weak_create 0;;
+
+  type data = H.t;;
+
+  type t = {
+    mutable table : data weak_t array;
+    mutable totsize : int;             (* sum of the bucket sizes *)
+    mutable limit : int;               (* max ratio totsize/table length *)
+  };;
+
+  let get_index t d = (H.hash d land max_int) mod (Array.length t.table);;
+
+  let create sz =
+    let sz = if sz < 7 then 7 else sz in
+    let sz = if sz > Sys.max_array_length then Sys.max_array_length else sz in
+    {
+      table = Array.create sz emptybucket;
+      totsize = 0;
+      limit = 3;
+    };;
+
+  let clear t =
+    for i = 0 to Array.length t.table - 1 do
+      t.table.(i) <- emptybucket;
+    done;
+    t.totsize <- 0;
+    t.limit <- 3;
+  ;;
+
+  let fold f t init =
+    let rec fold_bucket i b accu =
+      if i >= length b then accu else
+      match get b i with
+      | Some v -> fold_bucket (i+1) b (f v accu)
+      | None -> fold_bucket (i+1) b accu
+    in
+    Array.fold_right (fold_bucket 0) t.table init
+  ;;
+
+  let iter f t = fold (fun d () -> ()) t ();;
+
+  let count t =
+    let rec count_bucket i b accu =
+      if i >= length b then accu else
+      count_bucket (i+1) b (accu + (if check b i then 1 else 0))
+    in
+    Array.fold_right (count_bucket 0) t.table 0
+  ;;
+
+  let next_sz n = min (3*n/2 + 3) (Sys.max_array_length - 1);;
+
+  let rec resize t =
+    let oldlen = Array.length t.table in
+    let newlen = next_sz oldlen in
+    if newlen > oldlen then begin
+      let newt = create newlen in
+      newt.limit <- t.limit + 100;          (* prevent resizing of newt *)
+      fold (fun d () -> add newt d) t ();
+   (* assert Array.length newt.table = newlen; *)
+      t.table <- newt.table;
+      t.limit <- t.limit + 2;
+    end
+
+  and add_aux t d index =
+    let bucket = t.table.(index) in
+    let sz = length bucket in
+    let rec loop i =
+      if i >= sz then begin
+        let newsz = min (sz + 3) (Sys.max_array_length - 1) in
+        if newsz <= sz then failwith "Weak.Make : hash bucket cannot grow more";
+        let newbucket = weak_create newsz in
+        blit bucket 0 newbucket 0 sz;
+        set newbucket i (Some d);
+        t.table.(index) <- newbucket;
+        t.totsize <- t.totsize + (newsz - sz);
+        if t.totsize > t.limit * Array.length t.table then resize t;
+      end else begin
+        if check bucket i
+        then loop (i+1)
+        else set bucket i (Some d)
+      end
+    in
+    loop 0;
+
+  and add t d = add_aux t d (get_index t d)
+  ;;
+
+  let find_or t d ifnotfound =
+    let index = get_index t d in
+    let bucket = t.table.(index) in
+    let sz = length bucket in
+    let rec loop i =
+      if i >= sz then ifnotfound index
+      else begin
+        match get_copy bucket i with
+        | Some v when H.equal v d
+           -> begin match get bucket i with
+              | Some v -> v
+              | None -> loop (i+1)
+              end
+        | _ -> loop (i+1)
+      end
+    in
+    loop 0
+  ;;
+
+  let merge t d = find_or t d (fun index -> add_aux t d index; d);;
+
+  let find t d = find_or t d (fun index -> raise Not_found);;
+
+  let find_shadow t d iffound ifnotfound =
+    let index = get_index t d in
+    let bucket = t.table.(index) in
+    let sz = length bucket in
+    let rec loop i =
+      if i >= sz then ifnotfound else begin
+        match get_copy bucket i with
+        | Some v when H.equal v d -> iffound bucket i
+        | _ -> loop (i+1)
+      end
+    in
+    loop 0
+  ;;
+
+  let remove t d = find_shadow t d (fun w i -> set w i None) ();;
+
+  let mem t d = find_shadow t d (fun w i -> true) false;;
+
+  let find_all t d =
+    let index = get_index t d in
+    let bucket = t.table.(index) in
+    let sz = length bucket in
+    let rec loop i accu =
+      if i >= sz then accu
+      else begin
+        match get_copy bucket i with
+        | Some v when H.equal v d
+           -> begin match get bucket i with
+              | Some v -> loop (i+1) (v::accu)
+              | None -> loop (i+1) accu
+              end
+        | _ -> loop (i+1) accu
+      end
+    in
+    loop 0 []
+  ;;
+
+  let stats t =
+    let len = Array.length t.table in
+    let lens = Array.map length t.table in
+    Array.sort compare lens;
+    let totlen = Array.fold_left ( + ) 0 lens in
+    (len, count t, totlen, lens.(0), lens.(len/2), lens.(len-1))
+  ;;
+
+end;;
diff --git a/stdlib/weak.mli b/stdlib/weak.mli
new file mode 100644
index 0000000000..21666f33cb
--- /dev/null
+++ b/stdlib/weak.mli
@@ -0,0 +1,147 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Damien Doligez, projet Para, INRIA Rocquencourt          *)
+(*                                                                     *)
+(*  Copyright 1997 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the GNU Library General Public License, with    *)
+(*  the special exception on linking described in file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** Arrays of weak pointers and hash tables of weak pointers. *)
+
+
+(** {6 Low-level functions} *)
+
+type 'a t
+(** The type of arrays of weak pointers (weak arrays).  A weak
+   pointer is a value that the garbage collector may erase at
+   any time.
+   A weak pointer is said to be full if it points to a value,
+   empty if the value was erased by the GC.*)
+
+
+val create : int -> 'a t
+(** [Weak.create n] returns a new weak array of length [n].
+   All the pointers are initially empty.  Raise [Invalid_argument]
+   if [n] is negative or greater than {!Sys.max_array_length}[-1].*)
+
+val length : 'a t -> int
+(** [Weak.length ar] returns the length (number of elements) of
+   [ar].*)
+
+val set : 'a t -> int -> 'a option -> unit
+(** [Weak.set ar n (Some el)] sets the [n]th cell of [ar] to be a
+   (full) pointer to [el]; [Weak.set ar n None] sets the [n]th
+   cell of [ar] to empty.
+   Raise [Invalid_argument "Weak.set"] if [n] is not in the range
+   0 to {!Weak.length}[ a - 1].*)
+
+val get : 'a t -> int -> 'a option
+(** [Weak.get ar n] returns None if the [n]th cell of [ar] is
+   empty, [Some x] (where [x] is the value) if it is full.
+   Raise [Invalid_argument "Weak.get"] if [n] is not in the range
+   0 to {!Weak.length}[ a - 1].*)
+
+val get_copy : 'a t -> int -> 'a option
+(** [Weak.get_copy ar n] returns None if the [n]th cell of [ar] is
+   empty, [Some x] (where [x] is a (shallow) copy of the value) if
+   it is full.
+   In addition to pitfalls with mutable values, the interesting
+   difference with [get] is that [get_copy] does not prevent
+   the incremental GC from erasing the value in its current cycle
+   ([get] may delay the erasure to the next GC cycle).
+   Raise [Invalid_argument "Weak.get"] if [n] is not in the range
+   0 to {!Weak.length}[ a - 1].*)
+
+
+val check : 'a t -> int -> bool
+(** [Weak.check ar n] returns [true] if the [n]th cell of [ar] is
+   full, [false] if it is empty.  Note that even if [Weak.check ar n]
+   returns [true], a subsequent {!Weak.get}[ ar n] can return [None].*)
+
+val fill : 'a t -> int -> int -> 'a option -> unit
+(** [Weak.fill ar ofs len el] sets to [el] all pointers of [ar] from
+   [ofs] to [ofs + len - 1].  Raise [Invalid_argument "Weak.fill"]
+   if [ofs] and [len] do not designate a valid subarray of [a].*)
+
+val blit : 'a t -> int -> 'a t -> int -> int -> unit
+(** [Weak.blit ar1 off1 ar2 off2 len] copies [len] weak pointers
+   from [ar1] (starting at [off1]) to [ar2] (starting at [off2]).
+   It works correctly even if [ar1] and [ar2] are the same.
+   Raise [Invalid_argument "Weak.blit"] if [off1] and [len] do
+   not designate a valid subarray of [ar1], or if [off2] and [len]
+   do not designate a valid subarray of [ar2].*)
+
+
+(** {6 Weak hash tables} *)
+
+(** A weak hash table is a hashed set of values.  Each value may
+    magically disappear from the set when it is not used by the
+    rest of the program any more.  This is normally used to share
+    data structures without inducing memory leaks.
+    Weak hash tables are defined on values from a {!Hashtbl.HashedType}
+    module; the [equal] relation and [hash] function are taken from that
+    module.  We will say that [v] is an instance of [x] if [equal x v]
+    is [true].
+
+    The [equal] relation must be able to work on a shallow copy of
+    the values and give the same result as with the value itself.
+    *)
+
+module type S = sig
+  type data
+    (** The type of the elements stored in the table. *)
+  type t
+    (** The type of tables that contain elements of type [data]. *)
+  val create : int -> t
+    (** [create n] creates a new empty weak hash table, of initial
+        size [n].  The table will grow as needed. *)
+  val clear : t -> unit
+    (** Remove all elements from the table. *)
+  val merge : t -> data -> data
+    (** [merge t x] returns an instance of [x] found in [t] if any,
+        or else adds [x] to [t] and return [x]. *)
+  val add : t -> data -> unit
+    (** [add t x] adds [x] to [t].  If there is already an instance
+        of [x] in [t], it is unspecified which one will be
+        returned by subsequent calls to [find] and [merge]. *)
+  val remove : t -> data -> unit
+    (** [remove t x] removes from [t] one instance of [x].  Does
+        nothing if there is no instance of [x] in [t]. *)
+  val find : t -> data -> data
+    (** [find t x] returns an instance of [x] found in [t].
+        Raise [Not_found] if there is no such element. *)
+  val find_all : t -> data -> data list
+    (** [find_all t x] returns a list of all the instances of [x]
+        found in [t]. *)
+  val mem : t -> data -> bool
+    (** [mem t x] returns [true] if there is at least one instance
+        of [x] in [t], false otherwise. *)
+  val iter : (data -> unit) -> t -> unit
+    (** [iter f t] calls [f] on each element of [t], in some unspecified
+        order.  It is not specified what happens if [f] tries to change
+        [t] itself. *)
+  val fold : (data -> 'a -> 'a) -> t -> 'a -> 'a
+    (** [fold f t init] computes [(f d1 (... (f dN init)))] where
+        [d1 ... dN] are the elements of [t] in some unspecified order.
+        It is not specified what happens if [f] tries to change [t]
+        itself. *)
+  val count : t -> int
+    (** Count the number of elements in the table.  [count t] gives the
+        same result as [fold (fun _ n -> n+1) t 0] but does not delay the
+        deallocation of the dead elements. *)
+  val stats : t -> int * int * int * int * int * int
+    (** Return statistics on the table.  The numbers are, in order:
+        table length, number of entries, sum of bucket lengths,
+        smallest bucket length, median bucket length, biggest bucket length. *)
+end;;
+(** The output signature of the functor {!Weak.Make}. *)
+
+module Make (H : Hashtbl.HashedType) : S with type data = H.t;;
+(** Functor building an implementation of the weak hash table structure. *)