From e6c3b75a4761c74f0ca31beea90138481ab88a06 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Sat, 24 Aug 2013 00:48:50 -0700
Subject: [PATCH 01/60] COMPILER: delay var assignement

---
 compiler/Makefile       |  4 +--
 compiler/generate.ml    | 78 +++++++++++++++++------------------------
 compiler/javascript.ml  | 18 +++++-----
 compiler/javascript.mli | 18 +++++-----
 compiler/js_output.ml   | 23 +++++++-----
 5 files changed, 67 insertions(+), 74 deletions(-)

diff --git a/compiler/Makefile b/compiler/Makefile
index c01e293a4b..b582cf3bf8 100644
--- a/compiler/Makefile
+++ b/compiler/Makefile
@@ -8,8 +8,8 @@ lib: compiler.cma compiler.cmxa compiler.cmxs
 PACKAGES=findlib,str,unix
 
 OBJS=pretty_print.cmx util.cmx dgraph.cmx \
-     javascript.cmx js_output.cmx js_simpl.cmx \
-     instr.cmx code.cmx primitive.cmx subst.cmx pure_fun.cmx deadcode.cmx \
+     code.cmx javascript.cmx js_output.cmx js_simpl.cmx \
+     instr.cmx primitive.cmx subst.cmx pure_fun.cmx deadcode.cmx \
      flow.cmx inline.cmx \
      tailcall.cmx freevars.cmx phisimpl.cmx \
      linker.cmx generate.cmx parse_bytecode.cmx driver.cmx
diff --git a/compiler/generate.ml b/compiler/generate.ml
index 564074a14f..29a6898697 100644
--- a/compiler/generate.ml
+++ b/compiler/generate.ml
@@ -85,21 +85,10 @@ end
 
 let add_names = Hashtbl.create 101
 
-let var x = J.EVar (Var.to_string x)
+let var x = J.EVar (J.V x)
 let int n = J.ENum (float n)
 let one = int 1
 let zero = int 0
-let addr pc =
-  if not !compact then
-    Format.sprintf "f%d" pc
-  else begin
-    try
-      Hashtbl.find add_names pc
-    with Not_found ->
-      let x = Var.to_string (Var.fresh ()) in
-      Hashtbl.replace add_names pc x;
-      x
-  end
 let bool e = J.ECond (e, one, zero)
 let boolnot e = J.ECond (e, zero, one)
 let val_float f = f (*J.EArr [Some (J.ENum 253.); Some f]*)
@@ -113,7 +102,7 @@ let rec constant x =
   match x with
     String s ->
       Primitive.mark_used "MlString";
-      J.ENew (J.EVar ("MlString"), Some [J.EStr (s, `Bytes)])
+      J.ENew (J.EVar (J.S "MlString"), Some [J.EStr (s, `Bytes)])
   | Float f ->
       float_const f
   | Float_array a ->
@@ -174,7 +163,7 @@ let flush_queue expr_queue prop l =
   let instrs =
     List.map (fun (x, (_, ce)) ->
                 J.Variable_statement
-                  [Var.to_string x, Some ce]) instrs
+                  [J.V x, Some ce]) instrs
   in
   (List.rev_append instrs l, expr_queue)
 
@@ -363,7 +352,7 @@ let parallel_renaming ctx params args continuation queue =
            0 -> assert false
          | 1 -> enqueue queue px y cx
          | _ -> *)
-         flush_queue queue px [J.Variable_statement [Var.to_string y, Some cx]]
+         flush_queue queue px [J.Variable_statement [J.V y, Some cx]]
        in
        st @ continuation queue)
     continuation l queue
@@ -377,7 +366,7 @@ let get_apply_fun n =
     Util.IntMap.find n !apply_funs
   with Not_found ->
     Primitive.mark_used "caml_call_gen";
-    let x = Var.fresh () in
+    let x = J.V (Var.fresh ()) in
     apply_funs := Util.IntMap.add n x !apply_funs;
     x
 
@@ -386,21 +375,21 @@ let generate_apply_funs cont =
   apply_funs := Util.IntMap.empty;
   Util.IntMap.fold
     (fun n x cont ->
-       let f = Var.to_string (Var.fresh ()) in
+       let f = J.V (Var.fresh ()) in
        let params =
-         Array.to_list (Array.init n (fun _ -> Var.to_string (Var.fresh ())))
+         Array.to_list (Array.init n (fun _ -> J.V (Var.fresh ())))
        in
        let f' = J.EVar f in
        let params' = List.map (fun x -> J.EVar x) params in
        J.Function_declaration
-         (Var.to_string x, f :: params,
+         (x, f :: params,
           [J.Statement
              (J.Return_statement
                 (Some
                    (J.ECond (J.EBin (J.EqEq, J.EDot (f', "length"),
                                      J.ENum (float n)),
                              J.ECall (f', params'),
-                             J.ECall (J.EVar "caml_call_gen",
+                             J.ECall (J.EVar (J.S "caml_call_gen"),
                                       [f'; J.EArr (List.map (fun x -> Some x) params')])))))],
           None) ::
        cont)
@@ -516,11 +505,11 @@ let register_tern_prim name f =
 
 let register_un_math_prim name prim =
   register_un_prim name `Pure
-    (fun cx -> J.ECall (J.EDot (J.EVar "Math", prim), [cx]))
+    (fun cx -> J.ECall (J.EDot (J.EVar (J.S "Math"), prim), [cx]))
 
 let register_bin_math_prim name prim =
   register_bin_prim name `Pure
-    (fun cx cy -> J.ECall (J.EDot (J.EVar "Math", prim), [cx; cy]))
+    (fun cx cy -> J.ECall (J.EDot (J.EVar (J.S "Math"), prim), [cx; cy]))
 
 let _ =
   Code.add_reserved_name "Math";
@@ -609,7 +598,7 @@ let _ =
   register_un_prim "caml_js_to_string" `Mutable
     (fun cx ->
        Primitive.mark_used "MlString";
-       J.ENew (J.EVar "MlWrappedString", Some [cx]));
+       J.ENew (J.EVar (J.S "MlWrappedString"), Some [cx]));
   register_tern_prim "caml_js_set"
     (fun cx cy cz -> J.EBin (J.Eq, J.EAccess (cx, cy), cz));
   register_bin_prim "caml_js_get" `Mutable
@@ -650,12 +639,12 @@ let rec collect_closures ctx l =
       let vars = VarSet.remove x all_vars in
       let fun_name =
         if not (VarSet.is_empty vars) && VarSet.mem x all_vars then
-          Some (Var.to_string x)
+          Some (J.V x)
         else
           None
       in
       let cl =
-        J.EFun ((fun_name, List.map Var.to_string args,
+        J.EFun ((fun_name, List.map (fun v -> J.V v) args,
                  compile_closure ctx cont), Some pc)
       in
       let (l', rem') = collect_closures ctx rem in
@@ -688,7 +677,7 @@ and translate_expr ctx queue x e =
           (x :: l) ([], mutator_p, queue)
       in
       let y = get_apply_fun (List.length l) in
-      (J.ECall (J.EVar (Var.to_string y), args),
+      (J.ECall (J.EVar y, args),
        prop, queue)
   | Block (tag, a) ->
       let (contents, prop, queue) =
@@ -711,16 +700,16 @@ and translate_expr ctx queue x e =
         all_vars
         >> VarSet.remove x
         >> VarSet.elements
-        >> List.map Var.to_string
+        >> List.map (fun v -> J.V v)
       in
       let fun_name =
         if vars <> [] && VarSet.mem x all_vars then
-          Some (Var.to_string x)
+          Some (J.V x)
         else
           None
       in
       let cl =
-        J.EFun ((fun_name, List.map Var.to_string args,
+        J.EFun ((fun_name, List.map (fun v -> J.V v) args,
                  compile_closure ctx cont), Some pc)
       in
       let cl =
@@ -745,10 +734,10 @@ and translate_expr ctx queue x e =
            or_p mutable_p (or_p px py), queue)
       | Extern "caml_js_var", [Pc (String nm)] ->
           Code.add_reserved_name nm;  (*XXX HACK *)
-          (J.EVar nm, const_p, queue)
+          (J.EVar (J.S nm), const_p, queue)
       | Extern "caml_js_const", [Pc (String nm)] ->
           Code.add_reserved_name nm;  (*XXX HACK *)
-          (J.EVar nm, const_p, queue)
+          (J.EVar (J.S nm), const_p, queue)
       | Extern "caml_js_opt_call", Pv f :: Pv o :: l ->
           let ((pf, cf), queue) = access_queue queue f in
           let ((po, co), queue) = access_queue queue o in
@@ -850,7 +839,7 @@ and translate_expr ctx queue x e =
                      (cx :: args, or_p prop prop', queue))
                   l ([], prim_kind, queue)
               in
-              (J.ECall (J.EVar name, args), prop, queue)
+              (J.ECall (J.EVar (J.S name), args), prop, queue)
           end
       | Not, [Pv x] ->
           let ((px, cx), queue) = access_queue queue x in
@@ -900,7 +889,7 @@ and translate_closures ctx expr_queue l =
       let vars =
         vars
         >> VarSet.elements
-        >> List.map Var.to_string
+        >> List.map (fun v -> J.V v)
       in
       let cl =
         if vars = [] then cl else
@@ -914,7 +903,7 @@ and translate_closures ctx expr_queue l =
           0 -> flush_queue expr_queue flush_p [J.Expression_statement (cl, None)]
         | 1 -> enqueue expr_queue flush_p x cl
         | _ -> flush_queue expr_queue flush_p
-                 [J.Variable_statement [Var.to_string x, Some cl]]
+                 [J.Variable_statement [J.V x, Some cl]]
       in
       let (st', expr_queue) = translate_closures ctx expr_queue rem in
       (st @ st', expr_queue)
@@ -927,10 +916,10 @@ and translate_closures ctx expr_queue l =
       let vars =
         VarSet.diff vars names
         >> VarSet.elements
-        >> List.map Var.to_string
+        >> List.map (fun v -> J.V v)
       in
       let defs =
-        List.map (fun (x, _, cl) -> (Var.to_string x, Some cl)) l in
+        List.map (fun (x, _, cl) -> (J.V x, Some cl)) l in
       let statement =
         if vars = [] then
           J.Variable_statement defs
@@ -938,18 +927,18 @@ and translate_closures ctx expr_queue l =
           let tbl = Var.fresh () in
           let arr =
             J.EArr
-              (List.map (fun (x, _, _) -> Some (J.EVar (Var.to_string x))) l)
+              (List.map (fun (x, _, _) -> Some (J.EVar (J.V x))) l)
           in
           let assgn =
             List.fold_left
               (fun (l, n) (x, _, _) ->
-                 ((Var.to_string x,
-                   Some (J.EAccess (J.EVar (Var.to_string tbl), int n))) :: l,
+                 ((J.V x,
+                   Some (J.EAccess (J.EVar (J.V tbl), int n))) :: l,
                   n + 1))
               ([], 0) l
           in
           J.Variable_statement
-            ((Var.to_string tbl,
+            ((J.V tbl,
               Some
                 (J.ECall
                    (J.EFun ((None, vars,
@@ -984,7 +973,7 @@ and translate_instr ctx expr_queue pc instr =
                                                    (ce, Some pc)]
             | 1 -> enqueue expr_queue prop x ce
             | _ -> flush_queue expr_queue prop
-                     [J.Variable_statement [Var.to_string x, Some ce]]
+                     [J.Variable_statement [J.V x, Some ce]]
             end
         | Set_field (x, n, y) ->
             let ((px, cx), expr_queue) = access_queue expr_queue x in
@@ -1398,7 +1387,7 @@ and compile_exn_handling ctx queue (pc, args) handler continuation =
                    0 -> assert false
                  | 1 -> enqueue queue px y cx
                  | _ -> flush_queue queue px
-                          [J.Variable_statement [Var.to_string y, Some cx]]
+                          [J.Variable_statement [J.V y, Some cx]]
                in
                st @ loop continuation old args params queue
               end
@@ -1444,7 +1433,7 @@ and compile_branch_selection pc interm =
   try
     let (pc, (x, i)) = AddrMap.find pc interm in
     if debug () then Format.eprintf "@ %a=%d;" Code.Var.print x i;
-    J.Variable_statement [Var.to_string x, Some (int i)] ::
+    J.Variable_statement [J.V x, Some (int i)] ::
     compile_branch_selection pc interm
   with Not_found ->
     []
@@ -1482,7 +1471,7 @@ let compile_program standalone ctx pc =
     let f = J.EFun ((None, [], generate_apply_funs res), None) in
     [J.Statement (J.Expression_statement ((J.ECall (f, [])), Some pc))]
   else
-    let f = J.EFun ((None, [Var.to_string (Var.fresh ())],
+    let f = J.EFun ((None, [J.V (Var.fresh ())],
                      generate_apply_funs res), None) in
     [J.Statement (J.Expression_statement (f, Some pc))]
 
@@ -1511,4 +1500,3 @@ let f ch ?(standalone=true) ?linkall ((pc, blocks, _) as p) dl live_vars =
   let res = Js_output.program ch p dl in
   if times () then Format.eprintf "  code gen.: %a@." Util.Timer.print t';
   res
-
diff --git a/compiler/javascript.ml b/compiler/javascript.ml
index dfa23b4661..0d76aca1d5 100644
--- a/compiler/javascript.ml
+++ b/compiler/javascript.ml
@@ -67,7 +67,7 @@ and expression =
   | EAccess of expression * expression
   | EDot of expression * identifier
   | ENew of expression * arguments option
-  | EVar of identifier
+  | EVar of ident
   | EFun of function_expression * node_pc
   | EStr of string * [`Bytes (*| `Utf8*)]
   | EArr of array_litteral
@@ -113,11 +113,7 @@ and block = statement_list
 
 and statement_list = statement list
 
-and variable_statement = variable_declaration_list
-
-and variable_declaration_list = variable_declaration list
-
-and variable_declaration = identifier * initialiser option
+and variable_declaration = ident * initialiser option
 
 and case_clause = expression * statement_list
 
@@ -130,12 +126,12 @@ and initialiser = expression
 (* A.5 Functions and programs *)
 
 and function_declaration =
-  identifier * formal_parameter_list * function_body * node_pc
+  ident * formal_parameter_list * function_body * node_pc
 
 and function_expression =
-  identifier option * formal_parameter_list * function_body
+  ident option * formal_parameter_list * function_body
 
-and formal_parameter_list = identifier list
+and formal_parameter_list = ident list
 
 and function_body = source_elements
 
@@ -148,3 +144,7 @@ and source_element =
   | Function_declaration of function_declaration
 
 and identifier = string
+
+and ident =
+  | S of identifier
+  | V of Code.Var.t
diff --git a/compiler/javascript.mli b/compiler/javascript.mli
index ef7dbf55f1..cec9a5678b 100644
--- a/compiler/javascript.mli
+++ b/compiler/javascript.mli
@@ -67,7 +67,7 @@ and expression =
   | EAccess of expression * expression
   | EDot of expression * identifier
   | ENew of expression * arguments option
-  | EVar of identifier
+  | EVar of ident
   | EFun of function_expression * node_pc
   | EStr of string * [`Bytes (*| `Utf8*)]
   | EArr of array_litteral
@@ -113,11 +113,7 @@ and block = statement_list
 
 and statement_list = statement list
 
-and variable_statement = variable_declaration_list
-
-and variable_declaration_list = variable_declaration list
-
-and variable_declaration = identifier * initialiser option
+and variable_declaration = ident * initialiser option
 
 and case_clause = expression * statement_list
 
@@ -130,12 +126,12 @@ and initialiser = expression
 (* A.5 Functions and programs *)
 
 and function_declaration =
-  identifier * formal_parameter_list * function_body * node_pc
+  ident * formal_parameter_list * function_body * node_pc
 
 and function_expression =
-  identifier option * formal_parameter_list * function_body
+  ident option * formal_parameter_list * function_body
 
-and formal_parameter_list = identifier list
+and formal_parameter_list = ident list
 
 and function_body = source_elements
 
@@ -148,3 +144,7 @@ and source_element =
   | Function_declaration of function_declaration
 
 and identifier = string
+
+and ident =
+  | S of identifier
+  | V of Code.Var.t
diff --git a/compiler/js_output.ml b/compiler/js_output.ml
index 44ba74475b..79083e7b91 100644
--- a/compiler/js_output.ml
+++ b/compiler/js_output.ml
@@ -51,16 +51,21 @@ let output_debug_info f pc =
       | None -> ())
     | _, _ -> ()
 
+
+let ident = function
+  | S s -> s
+  | V v -> Code.Var.to_string v
+
 let opt_identifier f i =
   match i with
     None   -> ()
-  | Some i -> PP.space f; PP.string f i
+  | Some i -> PP.space f; PP.string f (ident i)
 
 let rec formal_parameter_list f l =
   match l with
     []     -> ()
-  | [i]    -> PP.string f i
-  | i :: r -> PP.string f i; PP.string f ","; PP.break f;
+  | [i]    -> PP.string f (ident i)
+  | i :: r -> PP.string f (ident i); PP.string f ","; PP.break f;
               formal_parameter_list f r
 
 (*
@@ -217,7 +222,7 @@ let string_escape s =
 let rec expression l f e =
   match e with
     EVar v ->
-      PP.string f v
+      PP.string f (ident v)
   | ESeq (e1, e2) ->
       if l > 0 then begin PP.start_group f 1; PP.string f "(" end;
       expression 0 f e1;
@@ -490,10 +495,10 @@ and arguments f l =
 and variable_declaration f (i, init) =
   match init with
     None   ->
-      PP.string f i
+      PP.string f (ident i)
   | Some e ->
       PP.start_group f 1;
-      PP.string f i; PP.string f "="; PP.break f; expression 1 f e;
+      PP.string f (ident i); PP.string f "="; PP.break f; expression 1 f e;
       PP.end_group f
 
 and variable_declaration_list f l =
@@ -520,14 +525,14 @@ and statement f s =
           PP.start_group f 1;
           PP.string f "var";
           PP.space f;
-          PP.string f i;
+          PP.string f (ident i);
           PP.string f ";";
           PP.end_group f
       | [(i, Some e)] ->
           PP.start_group f 1;
           PP.string f "var";
           PP.space f;
-          PP.string f i;
+          PP.string f (ident i);
           PP.string f "=";
           PP.genbreak f "" 1;
           PP.start_group f 0;
@@ -857,7 +862,7 @@ and source_element f se =
       PP.start_group f 0;
       PP.string f "function";
       PP.space f;
-      PP.string f i;
+      PP.string f (ident i);
       PP.end_group f;
       PP.break f;
       PP.start_group f 1;

From 0add49fcc4121c868477a7c7c19a661c2fa4c4d1 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Fri, 23 Aug 2013 23:53:46 -0700
Subject: [PATCH 02/60] COMPILER: cleanning

Some more cleaning

more cleaning
---
 compiler/.depend        | 10 +++++-----
 compiler/code.ml        | 27 ++++++++++-----------------
 compiler/code.mli       |  7 ++++++-
 compiler/generate.ml    | 28 ++++++++++------------------
 compiler/javascript.ml  | 22 +++++++---------------
 compiler/javascript.mli | 24 ++++++++----------------
 compiler/js_output.ml   |  2 +-
 compiler/js_simpl.ml    | 17 +++++++++--------
 8 files changed, 56 insertions(+), 81 deletions(-)

diff --git a/compiler/.depend b/compiler/.depend
index b2de2f58f6..848136070b 100644
--- a/compiler/.depend
+++ b/compiler/.depend
@@ -26,10 +26,10 @@ inline.cmo : util.cmi deadcode.cmi code.cmi inline.cmi
 inline.cmx : util.cmx deadcode.cmx code.cmx inline.cmi
 instr.cmo : instr.cmi
 instr.cmx : instr.cmi
-javascript.cmo : javascript.cmi
-javascript.cmx : javascript.cmi
-js_output.cmo : pretty_print.cmi javascript.cmi js_output.cmi
-js_output.cmx : pretty_print.cmx javascript.cmx js_output.cmi
+javascript.cmo : code.cmi javascript.cmi
+javascript.cmx : code.cmx javascript.cmi
+js_output.cmo : pretty_print.cmi javascript.cmi code.cmi js_output.cmi
+js_output.cmx : pretty_print.cmx javascript.cmx code.cmx js_output.cmi
 js_rename.cmo : util.cmi javascript.cmi
 js_rename.cmx : util.cmx javascript.cmx
 js_simpl.cmo : javascript.cmi js_simpl.cmi
@@ -68,7 +68,7 @@ freevars.cmi : util.cmi code.cmi
 generate.cmi : pretty_print.cmi parse_bytecode.cmi code.cmi
 inline.cmi : code.cmi
 instr.cmi :
-javascript.cmi :
+javascript.cmi : code.cmi
 js_output.cmi : pretty_print.cmi parse_bytecode.cmi javascript.cmi
 js_simpl.cmi : javascript.cmi
 linker.cmi : pretty_print.cmi
diff --git a/compiler/code.ml b/compiler/code.ml
index 602ac4dfe8..ad809faee8 100644
--- a/compiler/code.ml
+++ b/compiler/code.ml
@@ -21,9 +21,9 @@
 (*FIX: this should probably be somewhere else... *)
 module VarPrinter = struct
   let names = Hashtbl.create 107
-  let name v nm = Hashtbl.add names v nm
+  let name'' v nm = Hashtbl.add names v nm
   let propagate_name v v' =
-    try name v' (Hashtbl.find names v) with Not_found -> ()
+    try name'' v' (Hashtbl.find names v) with Not_found -> ()
   let name v nm =
     let is_alpha c = (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') in
     let is_num c = (c >= '0' && c <= '9') in
@@ -37,7 +37,7 @@ module VarPrinter = struct
       for i = 0 to String.length nm - 1 do
         if nm.[i] = '_' then incr c
       done;
-      if !c < String.length nm then name v nm
+      if !c < String.length nm then name'' v nm
     end
 
   let reserved = Hashtbl.create 107
@@ -99,8 +99,6 @@ module VarPrinter = struct
   let _ = reset ()
 end
 
-let string_of_ident = VarPrinter.format_ident
-
 let add_reserved_name = VarPrinter.add_reserved
 
 module Var : sig
@@ -136,18 +134,6 @@ end = struct
 
   type stream = int
 
-  let c = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_$"
-
-  let rec format_var x =
-    let char x = String.make 1 (c.[x]) in
-    if x < 65 then
-       char (x - 1)
-    else
-      format_var (x / 64) ^ char (x mod 64)
-
-(*
-  let to_string (x, i) = "o$" ^ format_var i(*format_var x ^ Format.sprintf "%d" i*)
-*)
   let to_string (x, i) = VarPrinter.to_string i
 
   let print f x = Format.fprintf f "%s" (to_string x)
@@ -173,6 +159,13 @@ end = struct
   let dummy = (-1 , -1)
 end
 
+module Label = struct
+  type t = int
+  let zero = 0
+  let succ t = succ t
+  let to_string t = VarPrinter.format_ident t
+end
+
 module VarSet = Set.Make (Var)
 module VarMap = Map.Make (Var)
 module VarTbl = struct
diff --git a/compiler/code.mli b/compiler/code.mli
index 892f2126fa..f1c28d59a5 100644
--- a/compiler/code.mli
+++ b/compiler/code.mli
@@ -41,7 +41,12 @@ module Var : sig
   val reset : unit -> unit
 end
 
-val string_of_ident : int -> string
+module Label : sig
+  type t
+  val zero : t
+  val succ : t -> t
+  val to_string : t -> string
+end
 
 module VarSet : Set.S with type elt = Var.t
 module VarMap : Map.S with type key = Var.t
diff --git a/compiler/generate.ml b/compiler/generate.ml
index 29a6898697..b465b8edef 100644
--- a/compiler/generate.ml
+++ b/compiler/generate.ml
@@ -68,19 +68,12 @@ let list_group f l =
 
 module Ctx = struct
   type t =
-    { var_stream : Var.stream;
-      mutable blocks : block AddrMap.t;
+    { mutable blocks : block AddrMap.t;
       live : int array;
       mutated_vars : VarSet.t AddrMap.t }
 
-  let fresh_var ctx =
-    let (x, stream) = Var.next ctx.var_stream in
-    (x, {ctx with var_stream = stream})
-
   let initial b l v =
-    { var_stream = Var.make_stream (); blocks = b; live = l; mutated_vars = v }
-
-  let used_once ctx x = ctx.live.(Var.idx x) <= 1
+    { blocks = b; live = l; mutated_vars = v }
 end
 
 let add_names = Hashtbl.create 101
@@ -188,7 +181,7 @@ type state =
     backs : (int, AddrSet.t) Hashtbl.t;
     preds : (int, int) Hashtbl.t;
     mutable loops : AddrSet.t;
-    mutable loop_stack : (addr * (int * bool ref)) list;
+    mutable loop_stack : (addr * (Label.t * bool ref)) list;
     mutable visited_blocks : AddrSet.t;
     mutable interm_idx : int;
     ctx : Ctx.t; mutable blocks : Code.block AddrMap.t }
@@ -1025,7 +1018,7 @@ Format.eprintf ")@.";
   end;
   if AddrSet.mem pc st.loops then begin
     let lab =
-      match st.loop_stack with (_, (l, _)) :: _ -> l + 1 | [] -> 0 in
+      match st.loop_stack with (_, (l, _)) :: _ -> Code.Label.succ l | [] -> Code.Label.zero in
     st.loop_stack <- (pc, (lab, ref false)) :: st.loop_stack
   end;
   let succs = Hashtbl.find st.succs pc in
@@ -1081,7 +1074,7 @@ Format.eprintf "===== %d ===== (%b)@." pc3 limit_body;
         if limit_body then decr_preds st pc3;
         flush_all queue
           (J.Try_statement (Js_simpl.statement_list body,
-                            Some (Var.to_string x,
+                            Some (J.V x,
                                   Js_simpl.statement_list handler),
                             None,
                             Some pc) ::
@@ -1163,7 +1156,7 @@ res
   if AddrSet.mem pc st.loops then begin
     let label =
       match st.loop_stack with
-        (_, (l, used)) :: r -> st.loop_stack <- r; if !used then l else -1
+        (_, (l, used)) :: r -> st.loop_stack <- r; if !used then Some l else None
       | []                  -> assert false
     in
     let st =
@@ -1181,10 +1174,9 @@ res
             end),
         Some pc)
     in
-    if label = -1 then
-      [st]
-    else
-      [J.Labelled_statement (Code.string_of_ident label, st)]
+    match label with
+      | None -> [st]
+      | Some label -> [J.Labelled_statement (Code.Label.to_string label, st)]
   end else
     body
 end
@@ -1413,7 +1405,7 @@ and compile_branch st queue ((pc, _) as cont) handler backs frontier interm =
           else begin
             let (lab, used) = List.assoc pc rem in
             used := true;
-            Some (Code.string_of_ident lab)
+            Some (Code.Label.to_string lab)
           end
     in
     if debug () then begin
diff --git a/compiler/javascript.ml b/compiler/javascript.ml
index 0d76aca1d5..962ceb09ba 100644
--- a/compiler/javascript.ml
+++ b/compiler/javascript.ml
@@ -18,17 +18,8 @@
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  *)
 
-(*
-   variable_declaration_list_no_in
-   variable_declaration_no_in
-   initialiser_no_in
-...
-
-
-*)
-type foo = unit
 
-and node_pc = int option
+type node_pc = int option
 
 (* A.3 Expressions *)
 
@@ -82,7 +73,7 @@ and expression =
 
 and statement =
     Block of block
-  | Variable_statement of variable_declaration_list
+  | Variable_statement of variable_declaration list
 (*
   | Empty_statement
 *)
@@ -95,16 +86,16 @@ and statement =
 (*
   | Iteration_statement
 *)
-  | Continue_statement of identifier option
-  | Break_statement of identifier option
+  | Continue_statement of label option
+  | Break_statement of label option
   | Return_statement of expression option
 (*
   | With_statement
 *)
-  | Labelled_statement of identifier * statement
+  | Labelled_statement of label * statement
   | Switch_statement of expression * case_clause list * statement_list option
   | Throw_statement of expression
-  | Try_statement of block * (identifier * block) option * block option * node_pc
+  | Try_statement of block * (ident * block) option * block option * node_pc
 (*
   | Debugger_statement
 *)
@@ -148,3 +139,4 @@ and identifier = string
 and ident =
   | S of identifier
   | V of Code.Var.t
+and label = identifier
diff --git a/compiler/javascript.mli b/compiler/javascript.mli
index cec9a5678b..8aa2ae68d1 100644
--- a/compiler/javascript.mli
+++ b/compiler/javascript.mli
@@ -18,17 +18,7 @@
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  *)
 
-(*
-   variable_declaration_list_no_in
-   variable_declaration_no_in
-   initialiser_no_in
-...
-
-
-*)
-type foo = unit
-
-and node_pc = int option
+type node_pc = int option
 
 (* A.3 Expressions *)
 
@@ -82,7 +72,7 @@ and expression =
 
 and statement =
     Block of block
-  | Variable_statement of variable_declaration_list
+  | Variable_statement of variable_declaration list
 (*
   | Empty_statement
 *)
@@ -95,16 +85,16 @@ and statement =
 (*
   | Iteration_statement
 *)
-  | Continue_statement of string option
-  | Break_statement of string option
+  | Continue_statement of label option
+  | Break_statement of label option
   | Return_statement of expression option
 (*
   | With_statement
 *)
-  | Labelled_statement of identifier * statement
+  | Labelled_statement of label * statement
   | Switch_statement of expression * case_clause list * statement_list option
   | Throw_statement of expression
-  | Try_statement of block * (identifier * block) option * block option * node_pc
+  | Try_statement of block * (ident * block) option * block option * node_pc
 (*
   | Debugger_statement
 *)
@@ -148,3 +138,5 @@ and identifier = string
 and ident =
   | S of identifier
   | V of Code.Var.t
+
+and label = identifier
diff --git a/compiler/js_output.ml b/compiler/js_output.ml
index 79083e7b91..553155e9e9 100644
--- a/compiler/js_output.ml
+++ b/compiler/js_output.ml
@@ -819,7 +819,7 @@ and statement f s =
           PP.break f;
           PP.start_group f 1;
           PP.string f "catch(";
-          PP.string f i;
+          PP.string f (ident i);
           PP.string f ")";
           PP.break f;
           block f b;
diff --git a/compiler/js_simpl.ml b/compiler/js_simpl.ml
index 4a26af0b26..ef051d03ce 100644
--- a/compiler/js_simpl.ml
+++ b/compiler/js_simpl.ml
@@ -77,17 +77,18 @@ let rec enot_rec e =
         (e, 0)
     | J.EUn ((J.Neg | J.Pl | J.Typeof | J.Delete), _) ->
         (J.EUn (J.Not, e), 0)
+
     | J.EBool b ->
         (J.EBool (not b), 0)
     | J.ECall _ | J.EAccess _ | J.EDot _ | J.ENew _ | J.EVar _ | J.EFun _
-   | J.EStr _ | J.EArr _ | J.ENum _ | J.EObj _ | J.EQuote _
-   | J.EUn
-       (( J.IncrA
-        | J.IncrB
-        | J.DecrA
-        | J.DecrB
-        | J.Bnot ),_) ->
-     (J.EUn (J.Not, e), 1)
+    | J.EStr _ | J.EArr _ | J.ENum _ | J.EObj _ | J.EQuote _
+    | J.EUn
+        (( J.IncrA
+         | J.IncrB
+         | J.DecrA
+         | J.DecrB
+         | J.Bnot ),_) ->
+      (J.EUn (J.Not, e), 1)
   in
   if cost <= 1 then res else (J.EUn (J.Not, e), 1)
 

From 41480f9806c4f3590267abdf0d39bb2883577e0a Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Mon, 9 Sep 2013 02:22:51 -0700
Subject: [PATCH 03/60] COMPILER: Reserved var module

---
 compiler/code.ml     | 31 +++++++++++++++++--------------
 compiler/code.mli    |  7 ++++---
 compiler/generate.ml |  8 ++++----
 compiler/linker.ml   |  2 +-
 4 files changed, 26 insertions(+), 22 deletions(-)

diff --git a/compiler/code.ml b/compiler/code.ml
index ad809faee8..74eb9d1742 100644
--- a/compiler/code.ml
+++ b/compiler/code.ml
@@ -19,6 +19,22 @@
  *)
 
 (*FIX: this should probably be somewhere else... *)
+
+
+module Reserved = struct
+  let reserved = Hashtbl.create 107
+
+  let add s = if String.length s <= 5 then Hashtbl.replace reserved s ()
+
+  let mem s = Hashtbl.mem reserved s
+
+  let _ =
+    List.iter add
+      ["break"; "case"; "catch"; "do"; "else"; "for"; "if"; "in"; "new";
+       "this"; "throw"; "try"; "var"; "void"; "while"; "with"; "class";
+       "enum"; "super"; "const"; "yield"; "let"]
+end
+
 module VarPrinter = struct
   let names = Hashtbl.create 107
   let name'' v nm = Hashtbl.add names v nm
@@ -40,17 +56,6 @@ module VarPrinter = struct
       if !c < String.length nm then name'' v nm
     end
 
-  let reserved = Hashtbl.create 107
-
-  let add_reserved s =
-    if String.length s <= 5 then Hashtbl.replace reserved s ()
-
-  let _ =
-    List.iter add_reserved
-      ["break"; "case"; "catch"; "do"; "else"; "for"; "if"; "in"; "new";
-       "this"; "throw"; "try"; "var"; "void"; "while"; "with"; "class";
-       "enum"; "super"; "const"; "yield"; "let"]
-
   let known = Hashtbl.create 1001
 
   let last = ref (-1)
@@ -86,7 +91,7 @@ module VarPrinter = struct
       incr last;
       let j = !last in
       let s = format_var i j in
-      if Hashtbl.mem reserved s then
+      if Reserved.mem s then
         to_string i
       else begin
         Hashtbl.add known i s;
@@ -99,8 +104,6 @@ module VarPrinter = struct
   let _ = reset ()
 end
 
-let add_reserved_name = VarPrinter.add_reserved
-
 module Var : sig
   type t
   val print : Format.formatter -> t -> unit
diff --git a/compiler/code.mli b/compiler/code.mli
index f1c28d59a5..4477a493cb 100644
--- a/compiler/code.mli
+++ b/compiler/code.mli
@@ -18,6 +18,10 @@
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  *)
 
+module Reserved : sig
+  val add : string -> unit
+  val mem : string -> bool
+end
 module Var : sig
   type t
   val print : Format.formatter -> t -> unit
@@ -147,7 +151,4 @@ val fold_closures :
 val fold_children :
   block AddrMap.t -> addr  -> (addr -> 'c -> 'c) -> 'c -> 'c
 
-val add_reserved_name : string -> unit
-
-
 val eq : program -> program -> bool
diff --git a/compiler/generate.ml b/compiler/generate.ml
index b465b8edef..c0ba2cae7d 100644
--- a/compiler/generate.ml
+++ b/compiler/generate.ml
@@ -505,7 +505,7 @@ let register_bin_math_prim name prim =
     (fun cx cy -> J.ECall (J.EDot (J.EVar (J.S "Math"), prim), [cx; cy]))
 
 let _ =
-  Code.add_reserved_name "Math";
+  Code.Reserved.add "Math";
   register_bin_prim "caml_array_unsafe_get" `Mutable
     (fun cx cy -> J.EAccess (cx, J.EBin (J.Plus, cy, one)));
   register_bin_prim "caml_string_get" `Mutable
@@ -726,10 +726,10 @@ and translate_expr ctx queue x e =
           (J.EAccess (cx, J.EBin (J.Plus, cy, one)),
            or_p mutable_p (or_p px py), queue)
       | Extern "caml_js_var", [Pc (String nm)] ->
-          Code.add_reserved_name nm;  (*XXX HACK *)
+          Code.Reserved.add nm;  (*XXX HACK *)
           (J.EVar (J.S nm), const_p, queue)
       | Extern "caml_js_const", [Pc (String nm)] ->
-          Code.add_reserved_name nm;  (*XXX HACK *)
+          Code.Reserved.add nm;  (*XXX HACK *)
           (J.EVar (J.S nm), const_p, queue)
       | Extern "caml_js_opt_call", Pv f :: Pv o :: l ->
           let ((pf, cf), queue) = access_queue queue f in
@@ -821,7 +821,7 @@ and translate_expr ctx queue x e =
               f l queue
           | None ->
               Primitive.mark_used name;
-              Code.add_reserved_name name;  (*XXX HACK *)
+              Code.Reserved.add name;  (*XXX HACK *)
                                (* FIX: this is done at the wrong time... *)
               let prim_kind = kind (Primitive.kind name) in
               let (args, prop, queue) =
diff --git a/compiler/linker.ml b/compiler/linker.ml
index 18259fa77c..8576c0658d 100644
--- a/compiler/linker.ml
+++ b/compiler/linker.ml
@@ -178,7 +178,7 @@ let add_file f =
        let id = !last_code_id in
        List.iter
          (fun (loc, nm, kind) ->
-           Code.add_reserved_name nm;
+           Code.Reserved.add nm;
             let kind =
               match kind with
                 "pure" | "const" -> `Pure

From 3538d29abae5e85fb840cef4e521145a971ad865 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Mon, 9 Sep 2013 02:34:47 -0700
Subject: [PATCH 04/60] COMPILER: clean Var module

---
 compiler/code.ml | 18 +++++++++---------
 1 file changed, 9 insertions(+), 9 deletions(-)

diff --git a/compiler/code.ml b/compiler/code.ml
index 74eb9d1742..10b1f2b067 100644
--- a/compiler/code.ml
+++ b/compiler/code.ml
@@ -129,7 +129,7 @@ module Var : sig
   val dummy : t
 end = struct
 
-  type t = int * int
+  type t = int
 
   let last_var = ref 0
 
@@ -137,7 +137,7 @@ end = struct
 
   type stream = int
 
-  let to_string (x, i) = VarPrinter.to_string i
+  let to_string i = VarPrinter.to_string i
 
   let print f x = Format.fprintf f "%s" (to_string x)
 
@@ -145,21 +145,21 @@ end = struct
 
   let next current =
     incr last_var;
-    ((current, !last_var), current + 1)
+    (!last_var, current + 1)
 
-  let fresh () = incr last_var; (0, !last_var)
+  let fresh () = incr last_var; !last_var
 
   let count () = !last_var + 1
 
-  let idx v = snd v
+  let idx v = v
 
-  let compare (_,v1) (_,v2) = v1 - v2
+  let compare v1 v2 = v1 - v2
 
-  let name (_, i) nm = VarPrinter.name i nm
-  let propagate_name (_, i) (_, j) = VarPrinter.propagate_name i j
+  let name i nm = VarPrinter.name i nm
+  let propagate_name i j = VarPrinter.propagate_name i j
   let set_pretty () = VarPrinter.pretty := true
 
-  let dummy = (-1 , -1)
+  let dummy = -1
 end
 
 module Label = struct

From 93d4bff71f77566a59d30576a66893b282c7435b Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Tue, 10 Sep 2013 20:14:37 -0700
Subject: [PATCH 05/60] COMPILER: compute free variables

free var2
---
 compiler/.depend        |   2 +
 compiler/Makefile       |   3 +-
 compiler/js_interfer.ml | 158 ++++++++++++++++++++++++++++++++++++++++
 compiler/js_output.mli  |   4 +-
 lib/.depend             |  10 ---
 5 files changed, 164 insertions(+), 13 deletions(-)
 create mode 100644 compiler/js_interfer.ml

diff --git a/compiler/.depend b/compiler/.depend
index 848136070b..ca61cea7b5 100644
--- a/compiler/.depend
+++ b/compiler/.depend
@@ -28,6 +28,8 @@ instr.cmo : instr.cmi
 instr.cmx : instr.cmi
 javascript.cmo : code.cmi javascript.cmi
 javascript.cmx : code.cmx javascript.cmi
+js_interfer.cmo : javascript.cmi code.cmi
+js_interfer.cmx : javascript.cmx code.cmx
 js_output.cmo : pretty_print.cmi javascript.cmi code.cmi js_output.cmi
 js_output.cmx : pretty_print.cmx javascript.cmx code.cmx js_output.cmi
 js_rename.cmo : util.cmi javascript.cmi
diff --git a/compiler/Makefile b/compiler/Makefile
index b582cf3bf8..628673ff4d 100644
--- a/compiler/Makefile
+++ b/compiler/Makefile
@@ -12,7 +12,8 @@ OBJS=pretty_print.cmx util.cmx dgraph.cmx \
      instr.cmx primitive.cmx subst.cmx pure_fun.cmx deadcode.cmx \
      flow.cmx inline.cmx \
      tailcall.cmx freevars.cmx phisimpl.cmx \
-     linker.cmx generate.cmx parse_bytecode.cmx driver.cmx
+     linker.cmx generate.cmx parse_bytecode.cmx driver.cmx \
+	   js_interfer.cmx
 
 COMPOBJS=$(OBJS) main.cmx
 
diff --git a/compiler/js_interfer.ml b/compiler/js_interfer.ml
new file mode 100644
index 0000000000..699e95c92c
--- /dev/null
+++ b/compiler/js_interfer.ml
@@ -0,0 +1,158 @@
+open Javascript
+
+
+(* let rec interfer x = function *)
+(*   | Statement st -> *)
+(*   | Function_declaration f -> *)
+
+
+(* let rec graph_of_sources l = *)
+(*   List.fold_left graph_of_source [] l *)
+
+(* and graph_of_source g s = *)
+(*   match s with *)
+(*     | Statement st -> g *)
+(*     | Function_declaration f -> graph_of_fun_decl g f *)
+(* and graph_of_fun_decl g (ident, params, body, _) = *)
+(*   let vars = compute_var body in *)
+(*   List.iter (interfer ident) vars; *)
+
+
+module V = struct
+
+
+type t = {
+  def : Code.VarSet.t;
+  use : Code.VarSet.t;
+}
+
+let union t1 t2 = {
+  use = Code.VarSet.union t1.use t1.use;
+  def = Code.VarSet.union t1.def t1.def
+}
+
+let use_var t = function
+  | S _ -> t
+  | V i -> { t with use = Code.VarSet.add i t.use }
+
+let def_var t = function
+  | S _ -> t
+  | V i -> { t with def = Code.VarSet.add i t.def }
+
+let empty = {
+  def = Code.VarSet.empty;
+  use = Code.VarSet.empty
+}
+
+let rec expression t e =
+  match e with
+    | ECond (e1,e2,e3) ->
+      expression
+        (expression
+           (expression t e1)
+           e2
+        )
+        e3
+    | ESeq (e1,e2)
+    | EAccess (e1,e2)
+    | EBin (_,e1,e2) ->
+      expression (expression t e1) e2
+    | EUn (_,e1)
+    | EDot (e1,_)
+    | ENew (e1,None) -> expression t e1
+    | ECall (e,args)
+    | ENew (e,Some args) ->
+      List.fold_left (fun acc x ->
+        expression acc x) (expression t e) args
+    | EVar v -> use_var t v
+    | EFun ((ident,params,body),_) ->
+      let tbody = List.fold_left def_var empty params in
+      let tbody = match ident with
+        | None -> tbody
+        | Some v -> def_var tbody v in
+      let tbody = source_elts tbody body in
+      let tfree = Code.VarSet.diff tbody.use tbody.def in
+      {t with use = Code.VarSet.union t.use tfree }
+    | EStr _
+    | EBool _
+    | ENum _
+    | EQuote _ -> t
+    | EObj l ->
+      List.fold_left (fun acc (_,e) ->
+      expression acc e) t l
+    | EArr l ->
+      List.fold_left (fun acc x ->
+        match x with
+          | None -> acc
+          | Some e -> expression acc e) t l
+
+and source_elts t l =
+    List.fold_left (fun acc s ->
+      source_elt acc s) t l
+
+and source_elt t e =
+  match e with
+    | Statement s -> statement t s
+    | Function_declaration (id,params, body, _) ->
+      let tbody = List.fold_left def_var empty params in
+      let tbody = def_var tbody id in
+      let tbody = source_elts tbody body in
+      let tfree = Code.VarSet.diff tbody.use tbody.def in
+      { t with use = Code.VarSet.union t.use tfree }
+
+and statements t l = List.fold_left statement t l
+
+and statement t s =
+  match s with
+    | Block l -> List.fold_left statement t l
+    | Variable_statement l ->
+      List.fold_left (fun t (id,eopt) ->
+        let t = def_var t id in
+        match eopt with
+          | None -> t
+          | Some e -> expression t e) t l
+    | Expression_statement (e,_) -> expression t e
+    | If_statement(e1,s2,e3opt) ->
+      let t = statement (expression t e1) s2 in
+      begin
+        match e3opt with
+          | None -> t
+          | Some e -> statement t e
+      end
+    | Do_while_statement (s,e)
+    | While_statement (e,s) ->
+      statement (expression t e) s
+    | For_statement (e1,e2,e3,s,_) ->
+      let t = List.fold_left (fun acc x ->
+        match x with
+          | None -> acc
+          | Some e -> expression acc e ) t [e1;e2;e3] in
+      statement t s
+    | Continue_statement _
+    | Break_statement _ -> t
+    | Return_statement None -> t
+    | Return_statement (Some e) -> expression t e
+    | Labelled_statement (_,s) -> statement t s
+    | Switch_statement(e,cl,sl) ->
+      let t = expression t e in
+      let t = List.fold_left (fun t (e, sl) ->
+        let t = expression t e in
+        statements t sl) t cl in
+      begin match sl with
+        | None -> t
+        | Some sl -> statements t sl
+      end
+    | Throw_statement e ->
+      expression t e
+    | Try_statement (b,w,f,_) ->
+      let t = statements t b in
+      let t = match w with
+        | None -> t
+        | Some (id,block) ->
+          let t = def_var t id in
+          statements t block in
+      let t = match f with
+        | None -> t
+        | Some block -> statements t block
+      in t
+end
diff --git a/compiler/js_output.mli b/compiler/js_output.mli
index ffd5bd8f19..6e541cd900 100644
--- a/compiler/js_output.mli
+++ b/compiler/js_output.mli
@@ -18,8 +18,8 @@
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  *)
 
-val statement :
-  Pretty_print.t -> Javascript.statement -> Parse_bytecode.debug_loc -> unit
+(* val statement : *)
+(*   Pretty_print.t -> Javascript.statement -> Parse_bytecode.debug_loc -> unit *)
 
 val program :
   Pretty_print.t -> Javascript.function_body -> Parse_bytecode.debug_loc -> unit
diff --git a/lib/.depend b/lib/.depend
index 9a59613c74..38fa0e8546 100644
--- a/lib/.depend
+++ b/lib/.depend
@@ -59,13 +59,3 @@ url.cmi :
 webGL.cmi : typed_array.cmi js.cmi dom_html.cmi
 webSockets.cmi : js.cmi dom_html.cmi dom.cmi
 xmlHttpRequest.cmi : url.cmi js.cmi form.cmi file.cmi dom.cmi
-deriving_json/deriving_Json_lexer.cmo : \
-    deriving_json/deriving_Json_lexer.cmi
-deriving_json/deriving_Json_lexer.cmx : \
-    deriving_json/deriving_Json_lexer.cmi
-deriving_json/deriving_Json_lexer.cmi :
-deriving_json/deriving_Json.cmo : deriving_json/deriving_Json_lexer.cmi \
-    deriving_json/deriving_Json.cmi
-deriving_json/deriving_Json.cmx : deriving_json/deriving_Json_lexer.cmx \
-    deriving_json/deriving_Json.cmi
-deriving_json/deriving_Json.cmi : deriving_json/deriving_Json_lexer.cmi

From 074ee236eedf135ddae6b7155b3c5645c997967b Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Wed, 11 Sep 2013 03:09:44 -0700
Subject: [PATCH 06/60] COMPILER: variable graph coloring

better coloring

more coloring
---
 compiler/.depend        |   8 +-
 compiler/Makefile       |  12 +-
 compiler/code.ml        |  11 +-
 compiler/code.mli       |   2 +-
 compiler/generate.ml    |   3 +
 compiler/javascript.ml  |  19 +---
 compiler/js_interfer.ml | 244 ++++++++++++++++++++++++++++++++++------
 compiler/js_simpl.ml    |   4 +-
 8 files changed, 240 insertions(+), 63 deletions(-)

diff --git a/compiler/.depend b/compiler/.depend
index ca61cea7b5..26c9da57dd 100644
--- a/compiler/.depend
+++ b/compiler/.depend
@@ -17,11 +17,11 @@ flow.cmx : util.cmx subst.cmx dgraph.cmx code.cmx flow.cmi
 freevars.cmo : util.cmi code.cmi freevars.cmi
 freevars.cmx : util.cmx code.cmx freevars.cmi
 generate.cmo : util.cmi subst.cmi primitive.cmi pretty_print.cmi linker.cmi \
-    js_simpl.cmi js_output.cmi javascript.cmi freevars.cmi code.cmi \
-    generate.cmi
+    js_simpl.cmi js_output.cmi js_interfer.cmo javascript.cmi freevars.cmi \
+    code.cmi generate.cmi
 generate.cmx : util.cmx subst.cmx primitive.cmx pretty_print.cmx linker.cmx \
-    js_simpl.cmx js_output.cmx javascript.cmx freevars.cmx code.cmx \
-    generate.cmi
+    js_simpl.cmx js_output.cmx js_interfer.cmx javascript.cmx freevars.cmx \
+    code.cmx generate.cmi
 inline.cmo : util.cmi deadcode.cmi code.cmi inline.cmi
 inline.cmx : util.cmx deadcode.cmx code.cmx inline.cmi
 instr.cmo : instr.cmi
diff --git a/compiler/Makefile b/compiler/Makefile
index 628673ff4d..8566b6b325 100644
--- a/compiler/Makefile
+++ b/compiler/Makefile
@@ -5,15 +5,15 @@ all: $(COMPILER)
 
 lib: compiler.cma compiler.cmxa compiler.cmxs
 
-PACKAGES=findlib,str,unix
+PACKAGES=findlib,str,unix,ocamlgraph
 
 OBJS=pretty_print.cmx util.cmx dgraph.cmx \
      code.cmx javascript.cmx js_output.cmx js_simpl.cmx \
      instr.cmx primitive.cmx subst.cmx pure_fun.cmx deadcode.cmx \
      flow.cmx inline.cmx \
      tailcall.cmx freevars.cmx phisimpl.cmx \
-     linker.cmx generate.cmx parse_bytecode.cmx driver.cmx \
-	   js_interfer.cmx
+	   js_interfer.cmx \
+     linker.cmx generate.cmx parse_bytecode.cmx driver.cmx
 
 COMPOBJS=$(OBJS) main.cmx
 
@@ -41,13 +41,13 @@ compiler.cmxs: $(OBJS)
 	ocamlfind ocamlopt -shared -o $@ $^
 
 %.cmx: %.ml
-	ocamlfind ocamlopt -package findlib,str -for-pack Compiler -c $<
+	ocamlfind ocamlopt -package findlib,str,ocamlgraph -for-pack Compiler -c $<
 
 %.cmo: %.ml
-	ocamlfind ocamlc -package findlib,str -c $<
+	ocamlfind ocamlc -package findlib,str,ocamlgraph -c $<
 
 %.cmi: %.mli
-	ocamlfind ocamlc -package findlib,str -c $<
+	ocamlfind ocamlc -package findlib,str,ocamlgraph -c $<
 
 clean:
 	rm -f *.cm[aiox] *.cmxa *.cmxs *.o *.a
diff --git a/compiler/code.ml b/compiler/code.ml
index 10b1f2b067..fb80365f3b 100644
--- a/compiler/code.ml
+++ b/compiler/code.ml
@@ -21,6 +21,8 @@
 (*FIX: this should probably be somewhere else... *)
 
 
+let disable_compact = Util.disabled "compact"
+
 module Reserved = struct
   let reserved = Hashtbl.create 107
 
@@ -110,6 +112,8 @@ module Var : sig
   val idx : t -> int
   val to_string : t -> string
 
+  val set_mapping : (t -> int) -> unit
+
   type stream
   val make_stream : unit -> stream
   val next : stream -> t * stream
@@ -137,7 +141,12 @@ end = struct
 
   type stream = int
 
-  let to_string i = VarPrinter.to_string i
+  let mapping = ref (fun x -> x)
+  let set_mapping f =
+    if not (disable_compact ())
+    then mapping := f
+
+  let to_string i = VarPrinter.to_string (!mapping i)
 
   let print f x = Format.fprintf f "%s" (to_string x)
 
diff --git a/compiler/code.mli b/compiler/code.mli
index 4477a493cb..56a1d0170c 100644
--- a/compiler/code.mli
+++ b/compiler/code.mli
@@ -41,7 +41,7 @@ module Var : sig
   val name : t -> string -> unit
   val propagate_name : t -> t -> unit
   val set_pretty : unit -> unit
-
+  val set_mapping : (t -> int) -> unit
   val reset : unit -> unit
 end
 
diff --git a/compiler/generate.ml b/compiler/generate.ml
index c0ba2cae7d..cb33c6936f 100644
--- a/compiler/generate.ml
+++ b/compiler/generate.ml
@@ -1489,6 +1489,9 @@ let f ch ?(standalone=true) ?linkall ((pc, blocks, _) as p) dl live_vars =
     list_missing missing
   end;
   Hashtbl.clear add_names;
+  let module V = Js_interfer.V in
+  let vars = V.program p in
   let res = Js_output.program ch p dl in
+
   if times () then Format.eprintf "  code gen.: %a@." Util.Timer.print t';
   res
diff --git a/compiler/javascript.ml b/compiler/javascript.ml
index 962ceb09ba..fc9968cbd2 100644
--- a/compiler/javascript.ml
+++ b/compiler/javascript.ml
@@ -74,31 +74,22 @@ and expression =
 and statement =
     Block of block
   | Variable_statement of variable_declaration list
-(*
-  | Empty_statement
-*)
+  (* | Empty_statement *)
   | Expression_statement of expression * node_pc
   | If_statement of expression * statement * statement option
   | Do_while_statement of statement * expression
   | While_statement of expression * statement
-  | For_statement of
-      expression option * expression option * expression option * statement * node_pc
-(*
-  | Iteration_statement
-*)
+  | For_statement of  expression option * expression option * expression option * statement * node_pc
+  (* | Iteration_statement *)
   | Continue_statement of label option
   | Break_statement of label option
   | Return_statement of expression option
-(*
-  | With_statement
-*)
+  (* | With_statement of expression * statement *)
   | Labelled_statement of label * statement
   | Switch_statement of expression * case_clause list * statement_list option
   | Throw_statement of expression
   | Try_statement of block * (ident * block) option * block option * node_pc
-(*
-  | Debugger_statement
-*)
+  (* | Debugger_statement *)
 
 and block = statement_list
 
diff --git a/compiler/js_interfer.ml b/compiler/js_interfer.ml
index 699e95c92c..e200311068 100644
--- a/compiler/js_interfer.ml
+++ b/compiler/js_interfer.ml
@@ -17,35 +17,154 @@ open Javascript
 (*   let vars = compute_var body in *)
 (*   List.iter (interfer ident) vars; *)
 
+module G = Graph.Pack.Graph
+(* module G = struct *)
+(*   include Graph.Imperative.Matrix.Graph *)
+(*   module Mark = struct *)
+(*       let h = Hashtbl.create 17 *)
+(*       let get x = *)
+(*         try *)
+(*           Hashtbl.find h x *)
+(*         with _ -> *)
+(*           Hashtbl.add h x 0; *)
+(*           0 *)
+(*       let set x v = Hashtbl.add h x v *)
+(*   end *)
+(* end *)
+(*
+module D = struct
+let round f = truncate (f +. 0.5)
+let pi = 4.0 *. atan 1.0
+
+open Graphics
+let () = open_graph " 800x600"
+
+let vertex_radius = 5
+
+let draw_arrow ?(color=black) ?(width=1) (xu,yu) (xv,yv) =
+  set_color color;
+  set_line_width width;
+  let dx = float (xv - xu) in
+  let dy = float (yv - yu) in
+  let alpha = atan2 dy dx in
+  let r = sqrt (dx *. dx +. dy *. dy) in
+  let ra = float vertex_radius *. 1.5 in
+  let d = float vertex_radius +. 3. in
+  let xs, ys = float xu +. d *. dx /. r, float yu +. d *. dy /. r in
+  let xd, yd = float xv -. d *. dx /. r, float yv -. d *. dy /. r in
+  let coords theta =
+    round (xd +. ra *. cos (pi +. alpha +. theta)),
+    round (yd +. ra *. sin (pi +. alpha +. theta))
+  in
+  moveto (round xs) (round ys);
+  lineto (round xd) (round yd);
+  let x1,y1 = coords (pi /. 6.) in
+  moveto (round xd) (round yd); lineto x1 y1;
+  let x2,y2 = coords (-. pi /. 6.) in
+  moveto (round xd) (round yd); lineto x2 y2
+
+let color_vertex v color =
+  let x,y = G.V.label v in
+  set_color color;
+  fill_circle x y vertex_radius
+
+let draw_graph g =
+  set_color red;
+  set_line_width 1;
+  G.iter_vertex
+    (fun v ->
+       let (x,y) = G.V.label v in
+       draw_circle x y vertex_radius)
+    g;
+  set_color black;
+  G.iter_edges
+    (fun v1 v2 -> draw_arrow (G.V.label v1) (G.V.label v2))
+    g;
+end
+
+  *)
 
 module V = struct
 
+  module S = Code.VarSet
+  module Map = Code.VarMap
+
+  type t = {
+    def : S.t;
+    use : S.t;
+    g : G.t;
+    count : int Map.t
+  }
+
+  let incr_count (x : Code.Var.t) (map : int Map.t) n =
+    let v = try Map.find x map with _ -> 0 in
+    Map.add x (v + n) map
+
+  let use_var t = function
+    | S _ -> t
+    | V i -> { t with
+      use = S.add i t.use;
+      count = incr_count i t.count 1 }
+
+  let def_var t = function
+    | S _ -> t
+    | V i -> { t with
+      def = S.add i t.def;
+      count = incr_count i t.count 1}
 
-type t = {
-  def : Code.VarSet.t;
-  use : Code.VarSet.t;
-}
+  let rm_var t = function
+    | S _ -> t
+    | V i -> S.remove i t
 
-let union t1 t2 = {
-  use = Code.VarSet.union t1.use t1.use;
-  def = Code.VarSet.union t1.def t1.def
-}
+  let merge_count f t =  Map.fold (fun k v map -> incr_count k map v) f t
 
-let use_var t = function
-  | S _ -> t
-  | V i -> { t with use = Code.VarSet.add i t.use }
 
-let def_var t = function
-  | S _ -> t
-  | V i -> { t with def = Code.VarSet.add i t.def }
+  let empty g = {
+    def = S.empty;
+    use = S.empty;
+    count = Map.empty;
+    g
+  }
 
-let empty = {
-  def = Code.VarSet.empty;
-  use = Code.VarSet.empty
-}
+  let vertex, vertex_tbl =
+    let h = Hashtbl.create 17 in
+    (fun v ->
+      let idx = Code.Var.idx v in
+      try Hashtbl.find h v with
+        | Not_found ->
+          let r = (G.V.create idx) in
+          Hashtbl.add h v r;
+          r),h
 
-let rec expression t e =
-  match e with
+  let max_ = ref 0
+
+  let mark g ~free ~use ~def =
+    S.iter (fun u -> G.add_vertex g (vertex u)) def;
+    let u = S.union def (S.union free use) in
+    max_:= max !max_ (S.cardinal u);
+    let f a b =
+      S.iter (fun u1 ->
+        S.iter (fun u2 ->
+          if u1 <> u2
+          then
+            G.add_edge
+              g
+              (vertex u1)
+              (vertex u2)
+        ) a
+      ) b
+    in
+    f use use;
+    f use free;
+    f def use;
+    f def free
+
+  let free t = S.diff t.use t.def
+
+  let create () =
+    (* empty (G.make (Code.Var.count ())) *)
+    empty (G.create ())
+  let rec expression t e = match e with
     | ECond (e1,e2,e3) ->
       expression
         (expression
@@ -66,44 +185,44 @@ let rec expression t e =
         expression acc x) (expression t e) args
     | EVar v -> use_var t v
     | EFun ((ident,params,body),_) ->
-      let tbody = List.fold_left def_var empty params in
+      let tbody = List.fold_left def_var (empty t.g) params in
       let tbody = match ident with
         | None -> tbody
         | Some v -> def_var tbody v in
       let tbody = source_elts tbody body in
-      let tfree = Code.VarSet.diff tbody.use tbody.def in
-      {t with use = Code.VarSet.union t.use tfree }
+      let tfree = free tbody in
+      mark t.g ~free:tfree ~use:tbody.use ~def:tbody.def;
+      {t with use = S.union t.use tfree ; count = merge_count t.count tbody.count}
     | EStr _
     | EBool _
     | ENum _
     | EQuote _ -> t
     | EObj l ->
       List.fold_left (fun acc (_,e) ->
-      expression acc e) t l
+        expression acc e) t l
     | EArr l ->
       List.fold_left (fun acc x ->
         match x with
           | None -> acc
           | Some e -> expression acc e) t l
 
-and source_elts t l =
+  and source_elts t l =
     List.fold_left (fun acc s ->
       source_elt acc s) t l
 
-and source_elt t e =
-  match e with
+  and source_elt t e = match e with
     | Statement s -> statement t s
     | Function_declaration (id,params, body, _) ->
-      let tbody = List.fold_left def_var empty params in
+      let tbody = List.fold_left def_var (empty t.g) params in
       let tbody = def_var tbody id in
       let tbody = source_elts tbody body in
-      let tfree = Code.VarSet.diff tbody.use tbody.def in
-      { t with use = Code.VarSet.union t.use tfree }
+      let tfree = free tbody in
+      mark t.g ~free:tfree ~use:tbody.use ~def:tbody.def;
+      def_var { t with use = S.union t.use tfree ; count = merge_count t.count tbody.count} id
 
-and statements t l = List.fold_left statement t l
+  and statements t l = List.fold_left statement t l
 
-and statement t s =
-  match s with
+  and statement t s = match s with
     | Block l -> List.fold_left statement t l
     | Variable_statement l ->
       List.fold_left (fun t (id,eopt) ->
@@ -149,10 +268,65 @@ and statement t s =
       let t = match w with
         | None -> t
         | Some (id,block) ->
-          let t = def_var t id in
-          statements t block in
+          let t' = statements (empty t.g) block in
+          let t'' = def_var t' id in
+          let t''free = free t'' in
+          mark t.g ~free:t''free ~use:t''.use ~def:t''.def;
+          { t with
+            use = S.union t.use (rm_var t'.use id) ;
+            def = S.union t.def t'.def;
+            count = merge_count t.count t''.count}
+            in
       let t = match f with
         | None -> t
         | Some block -> statements t block
       in t
+
+  module M = Graph.Coloring.Mark(G)
+
+  let program p : unit =
+    let t = source_elts (create()) p in
+    let freevar = free t in
+    assert(S.cardinal freevar = 0);
+    mark t.g ~free:freevar ~use:t.use ~def:t.def;
+    Printf.printf "compute graph degree\n%!";
+    let d = G.fold_vertex (fun v acc -> max acc (G.in_degree t.g v)) t.g 0 in
+    let percent x all =
+      float_of_int x /. float_of_int all *. 100. in
+    let nb_vertex = (G.nb_vertex t.g) in
+    Printf.printf "max degree is %d/%d/%d  %.2f\n%!" d (!max_) nb_vertex (percent (nb_vertex - !max_) nb_vertex);
+    (* D.draw_graph t.g; *)
+
+    let rec loop n max =
+      let size = int_of_float (53.** (float_of_int n)) in
+      let size = if n = 0 then !max_  else size in
+      if n > max
+      then raise Not_found
+      else
+        try
+          Printf.printf "try coloring with %d (%d)\n%!" size n;
+          M.coloring t.g size
+        with _ -> loop (succ n) max in
+    loop 0 3;
+    let h = Hashtbl.create 17 in
+    let color_count = Hashtbl.create 17 in
+    Hashtbl.iter (fun k v ->
+
+      let color = G.Mark.get v in
+      let count = Map.find k t.count in
+
+      let cc = try Hashtbl.find color_count color with
+        | _ -> 0 in
+      Hashtbl.replace color_count color (cc + count);
+      Hashtbl.add h k color)
+      vertex_tbl;
+    (* Hashtbl.iter (fun k v -> *)
+    (*   Printf.printf "var %d # %d\n" k v)  color_count; *)
+    Code.Var.set_mapping(fun x ->
+      let c = Hashtbl.find h x in c)
+
+(* Printf.printf "freevar(%d) = %s " *)
+(*   (V.S.cardinal freevar) *)
+(*   (V.S.fold (fun id s -> s ^ ", " ^ (Code.Var.to_string id)) freevar ""); *)
+
 end
diff --git a/compiler/js_simpl.ml b/compiler/js_simpl.ml
index ef051d03ce..9774304582 100644
--- a/compiler/js_simpl.ml
+++ b/compiler/js_simpl.ml
@@ -99,8 +99,8 @@ let source_elements l =
   List.fold_right
     (fun st rem ->
        match st, rem with
-         J.Variable_statement [addr, Some (J.EFun ((None, params, body), pc))], _ ->
-           J.Function_declaration (addr, params, body, pc) :: rem
+         (* J.Variable_statement [addr, Some (J.EFun ((None, params, body), pc))], _ -> *)
+         (*   J.Function_declaration (addr, params, body, pc) :: rem *)
        | J.Variable_statement l1,
          J.Statement (J.Variable_statement l2) :: rem' ->
            J.Statement (J.Variable_statement (l1 @ l2)) :: rem'

From 460ec005c6f1487f729bb1513734f76255f086b1 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Wed, 11 Sep 2013 14:12:10 -0700
Subject: [PATCH 07/60] OPAM: add ocamlgraph deps

---
 opam/opam | 1 +
 1 file changed, 1 insertion(+)

diff --git a/opam/opam b/opam/opam
index 31ffeb4420..ffd20393bb 100644
--- a/opam/opam
+++ b/opam/opam
@@ -12,4 +12,5 @@ depends: [
   "ocamlfind"
   "deriving" {>= "9999"}
   "lwt" {>= "2.4"}
+  "ocamlgraph"
 ]

From e2dcb0972f7966adad3065dfcaf06e66e42d2b6e Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Wed, 11 Sep 2013 19:07:14 -0700
Subject: [PATCH 08/60] COMPILER: refactoring

---
 compiler/.depend            |  27 +-
 compiler/Makefile           |   2 +-
 compiler/code.ml            |  11 +-
 compiler/code.mli           |   4 +-
 compiler/driver.ml          |  45 ++-
 compiler/driver.mli         |   8 +-
 compiler/generate.ml        |  34 +--
 compiler/generate.mli       |   6 +-
 compiler/js_interfer.ml     | 332 ---------------------
 compiler/js_output.ml       | 568 ++++++++++++++++++------------------
 compiler/js_output.mli      |   5 +-
 compiler/js_var.ml          | 266 +++++++++++++++++
 compiler/linker.ml          |   2 +-
 compiler/linker.mli         |   2 +-
 compiler/main.ml            |  12 +-
 compiler/parse_bytecode.ml  |   6 +-
 compiler/parse_bytecode.mli |   2 -
 compiler/util.ml            |  11 +-
 compiler/util.mli           |   3 +-
 19 files changed, 646 insertions(+), 700 deletions(-)
 delete mode 100644 compiler/js_interfer.ml
 create mode 100644 compiler/js_var.ml

diff --git a/compiler/.depend b/compiler/.depend
index 26c9da57dd..c589e74017 100644
--- a/compiler/.depend
+++ b/compiler/.depend
@@ -7,35 +7,35 @@ deadcode.cmx : util.cmx pure_fun.cmx code.cmx deadcode.cmi
 dgraph.cmo : dgraph.cmi
 dgraph.cmx : dgraph.cmi
 driver.cmo : util.cmi tailcall.cmi phisimpl.cmi parse_bytecode.cmi \
-    js_output.cmi inline.cmi generate.cmi flow.cmi deadcode.cmi code.cmi \
-    driver.cmi
+    js_var.cmi js_output.cmi inline.cmi generate.cmi flow.cmi deadcode.cmi \
+    code.cmi driver.cmi
 driver.cmx : util.cmx tailcall.cmx phisimpl.cmx parse_bytecode.cmx \
-    js_output.cmx inline.cmx generate.cmx flow.cmx deadcode.cmx code.cmx \
-    driver.cmi
+    js_var.cmx js_output.cmx inline.cmx generate.cmx flow.cmx deadcode.cmx \
+    code.cmx driver.cmi
 flow.cmo : util.cmi subst.cmi dgraph.cmi code.cmi flow.cmi
 flow.cmx : util.cmx subst.cmx dgraph.cmx code.cmx flow.cmi
 freevars.cmo : util.cmi code.cmi freevars.cmi
 freevars.cmx : util.cmx code.cmx freevars.cmi
 generate.cmo : util.cmi subst.cmi primitive.cmi pretty_print.cmi linker.cmi \
-    js_simpl.cmi js_output.cmi js_interfer.cmo javascript.cmi freevars.cmi \
-    code.cmi generate.cmi
+    js_simpl.cmi javascript.cmi freevars.cmi code.cmi generate.cmi
 generate.cmx : util.cmx subst.cmx primitive.cmx pretty_print.cmx linker.cmx \
-    js_simpl.cmx js_output.cmx js_interfer.cmx javascript.cmx freevars.cmx \
-    code.cmx generate.cmi
+    js_simpl.cmx javascript.cmx freevars.cmx code.cmx generate.cmi
 inline.cmo : util.cmi deadcode.cmi code.cmi inline.cmi
 inline.cmx : util.cmx deadcode.cmx code.cmx inline.cmi
 instr.cmo : instr.cmi
 instr.cmx : instr.cmi
 javascript.cmo : code.cmi javascript.cmi
 javascript.cmx : code.cmx javascript.cmi
-js_interfer.cmo : javascript.cmi code.cmi
-js_interfer.cmx : javascript.cmx code.cmx
-js_output.cmo : pretty_print.cmi javascript.cmi code.cmi js_output.cmi
-js_output.cmx : pretty_print.cmx javascript.cmx code.cmx js_output.cmi
+js_output.cmo : util.cmi pretty_print.cmi parse_bytecode.cmi javascript.cmi \
+    code.cmi js_output.cmi
+js_output.cmx : util.cmx pretty_print.cmx parse_bytecode.cmx javascript.cmx \
+    code.cmx js_output.cmi
 js_rename.cmo : util.cmi javascript.cmi
 js_rename.cmx : util.cmx javascript.cmx
 js_simpl.cmo : javascript.cmi js_simpl.cmi
 js_simpl.cmx : javascript.cmx js_simpl.cmi
+js_var.cmo : javascript.cmi code.cmi js_var.cmi
+js_var.cmx : javascript.cmx code.cmx js_var.cmi
 linker.cmo : util.cmi primitive.cmi pretty_print.cmi code.cmi linker.cmi
 linker.cmx : util.cmx primitive.cmx pretty_print.cmx code.cmx linker.cmi
 main.cmo : util.cmi pretty_print.cmi parse_bytecode.cmi linker.cmi \
@@ -67,12 +67,13 @@ dgraph.cmi :
 driver.cmi : pretty_print.cmi parse_bytecode.cmi code.cmi
 flow.cmi : code.cmi
 freevars.cmi : util.cmi code.cmi
-generate.cmi : pretty_print.cmi parse_bytecode.cmi code.cmi
+generate.cmi : pretty_print.cmi parse_bytecode.cmi javascript.cmi code.cmi
 inline.cmi : code.cmi
 instr.cmi :
 javascript.cmi : code.cmi
 js_output.cmi : pretty_print.cmi parse_bytecode.cmi javascript.cmi
 js_simpl.cmi : javascript.cmi
+js_var.cmi : javascript.cmi code.cmi
 linker.cmi : pretty_print.cmi
 parse_bytecode.cmi : code.cmi
 phisimpl.cmi : code.cmi
diff --git a/compiler/Makefile b/compiler/Makefile
index 8566b6b325..1ad023a169 100644
--- a/compiler/Makefile
+++ b/compiler/Makefile
@@ -12,7 +12,7 @@ OBJS=pretty_print.cmx util.cmx dgraph.cmx \
      instr.cmx primitive.cmx subst.cmx pure_fun.cmx deadcode.cmx \
      flow.cmx inline.cmx \
      tailcall.cmx freevars.cmx phisimpl.cmx \
-	   js_interfer.cmx \
+	   js_var.cmx \
      linker.cmx generate.cmx parse_bytecode.cmx driver.cmx
 
 COMPOBJS=$(OBJS) main.cmx
diff --git a/compiler/code.ml b/compiler/code.ml
index fb80365f3b..6036aa7565 100644
--- a/compiler/code.ml
+++ b/compiler/code.ml
@@ -110,10 +110,9 @@ module Var : sig
   type t
   val print : Format.formatter -> t -> unit
   val idx : t -> int
+  val from_idx : int -> t
   val to_string : t -> string
 
-  val set_mapping : (t -> int) -> unit
-
   type stream
   val make_stream : unit -> stream
   val next : stream -> t * stream
@@ -141,12 +140,7 @@ end = struct
 
   type stream = int
 
-  let mapping = ref (fun x -> x)
-  let set_mapping f =
-    if not (disable_compact ())
-    then mapping := f
-
-  let to_string i = VarPrinter.to_string (!mapping i)
+  let to_string i = VarPrinter.to_string i
 
   let print f x = Format.fprintf f "%s" (to_string x)
 
@@ -161,6 +155,7 @@ end = struct
   let count () = !last_var + 1
 
   let idx v = v
+  let from_idx v = v
 
   let compare v1 v2 = v1 - v2
 
diff --git a/compiler/code.mli b/compiler/code.mli
index 56a1d0170c..4ea377d412 100644
--- a/compiler/code.mli
+++ b/compiler/code.mli
@@ -26,6 +26,8 @@ module Var : sig
   type t
   val print : Format.formatter -> t -> unit
   val idx : t -> int
+  val from_idx : int -> t
+
   val to_string : t -> string
 
   type stream
@@ -38,10 +40,10 @@ module Var : sig
 
   val compare : t -> t -> int
 
+
   val name : t -> string -> unit
   val propagate_name : t -> t -> unit
   val set_pretty : unit -> unit
-  val set_mapping : (t -> int) -> unit
   val reset : unit -> unit
 end
 
diff --git a/compiler/driver.ml b/compiler/driver.ml
index 2d5f8a48fb..c980905b02 100644
--- a/compiler/driver.ml
+++ b/compiler/driver.ml
@@ -120,20 +120,39 @@ let o3 =
 
 let profile = ref o1
 
-let f ?standalone ?linkall (p, d) =
-  !profile p >>> deadcode' >>> fun (p,live_vars) ->
-  fun formatter ->
-    if times ()
-    then Format.eprintf "Start Generation...@.";
-    Generate.f formatter ?standalone ?linkall p d live_vars
 
-let from_string prims s =
-  let p = Parse_bytecode.from_string prims s in
-  f ~standalone:false p
-
-let set_pretty () = Generate.set_pretty (); Parse_bytecode.set_pretty ()
-
-let set_debug_info () = Js_output.set_debug_info ()
+let f_generate formatter  ~standalone ?linkall d (p,live_vars) =
+  if times ()
+  then Format.eprintf "Start Generation...@.";
+  Generate.f formatter ~standalone ?linkall p d live_vars
+
+let f_link formatter ~standalone ?linkall pretty js =
+  if times ()
+  then Format.eprintf "Start Linking...@.";
+  Generate.f_link formatter ~standalone ?linkall pretty;
+  js
+
+let f_coloring js =
+  if times ()
+  then Format.eprintf "Start Coloring...@.";
+  js,Js_var.program js
+
+let f_output formatter d (js,subs) =
+  if times ()
+  then Format.eprintf "Start Writing file...@.";
+  Js_output.program formatter js d
+
+let f ?(standalone=true) ?linkall formatter d =
+  !profile >>
+  deadcode' >>
+  f_generate formatter ~standalone ?linkall d >>
+  f_link formatter ~standalone ?linkall false >>
+  f_coloring >>
+  f_output formatter d
+
+let from_string prims s formatter =
+  let (p,d) = Parse_bytecode.from_string prims s in
+  f ~standalone:false formatter d p
 
 let set_profile = function
   | 1 -> profile := o1
diff --git a/compiler/driver.mli b/compiler/driver.mli
index 81a2349778..36bccd1458 100644
--- a/compiler/driver.mli
+++ b/compiler/driver.mli
@@ -19,13 +19,9 @@
  *)
 
 val f :
-  ?standalone:bool -> ?linkall:bool ->
-  Code.program * Parse_bytecode.debug_loc -> Pretty_print.t -> unit
+  ?standalone:bool -> ?linkall:bool -> Pretty_print.t ->
+  Parse_bytecode.debug_loc -> Code.program -> unit
 
 val from_string : string array -> string -> Pretty_print.t -> unit
 
-val set_pretty : unit -> unit
-
-val set_debug_info : unit -> unit
-
 val set_profile : int -> unit
diff --git a/compiler/generate.ml b/compiler/generate.ml
index cb33c6936f..2f8484500f 100644
--- a/compiler/generate.ml
+++ b/compiler/generate.ml
@@ -38,7 +38,7 @@ let debug = Util.debug "gen"
 let times = Util.debug "times"
 let disable_compact_expr = Util.disabled "compactexpr"
 
-let set_pretty () = compact := false
+let pretty_off = Util.disabled ~init:true "pretty"
 
 (****)
 
@@ -76,8 +76,6 @@ module Ctx = struct
     { blocks = b; live = l; mutated_vars = v }
 end
 
-let add_names = Hashtbl.create 101
-
 let var x = J.EVar (J.V x)
 let int n = J.ENum (float n)
 let one = int 1
@@ -1475,23 +1473,23 @@ let list_missing l =
     List.iter (fun nm -> Format.eprintf "  %s@." nm) l
   end
 
-let f ch ?(standalone=true) ?linkall ((pc, blocks, _) as p) dl live_vars =
+let f ch ~standalone ?linkall ((pc, blocks, _) as p) dl live_vars =
   let mutated_vars = Freevars.f p in
   let t' = Util.Timer.make () in
   let ctx = Ctx.initial blocks live_vars mutated_vars in
   let p = compile_program standalone ctx pc in
-  if !compact then Pretty_print.set_compact ch true;
-  if standalone then begin
-    Pretty_print.string ch
-      "// This program was compiled from OCaml by js_of_ocaml 1.3";
-    Pretty_print.newline ch;
-    let missing = Linker.resolve_deps ?linkall !compact ch (Primitive.get_used ()) in
-    list_missing missing
-  end;
-  Hashtbl.clear add_names;
-  let module V = Js_interfer.V in
-  let vars = V.program p in
-  let res = Js_output.program ch p dl in
-
   if times () then Format.eprintf "  code gen.: %a@." Util.Timer.print t';
-  res
+  p
+
+
+
+let f_link ch ~standalone ?linkall pretty =
+  if standalone
+  then
+    begin
+      Pretty_print.string ch
+        "// This program was compiled from OCaml by js_of_ocaml 1.3";
+      Pretty_print.newline ch;
+      let missing = Linker.resolve_deps ?linkall ch (Primitive.get_used ()) in
+      list_missing missing
+    end
diff --git a/compiler/generate.mli b/compiler/generate.mli
index ece2e2c356..d19c7a81df 100644
--- a/compiler/generate.mli
+++ b/compiler/generate.mli
@@ -18,7 +18,7 @@
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  *)
 
-val set_pretty : unit -> unit
+val f : Pretty_print.t -> standalone:bool -> ?linkall:bool ->
+        Code.program -> Parse_bytecode.debug_loc -> int array -> Javascript.program
 
-val f : Pretty_print.t -> ?standalone:bool -> ?linkall:bool ->
-        Code.program -> Parse_bytecode.debug_loc -> int array -> unit
+val f_link : Pretty_print.t -> standalone:bool -> ?linkall:bool -> bool -> unit
diff --git a/compiler/js_interfer.ml b/compiler/js_interfer.ml
deleted file mode 100644
index e200311068..0000000000
--- a/compiler/js_interfer.ml
+++ /dev/null
@@ -1,332 +0,0 @@
-open Javascript
-
-
-(* let rec interfer x = function *)
-(*   | Statement st -> *)
-(*   | Function_declaration f -> *)
-
-
-(* let rec graph_of_sources l = *)
-(*   List.fold_left graph_of_source [] l *)
-
-(* and graph_of_source g s = *)
-(*   match s with *)
-(*     | Statement st -> g *)
-(*     | Function_declaration f -> graph_of_fun_decl g f *)
-(* and graph_of_fun_decl g (ident, params, body, _) = *)
-(*   let vars = compute_var body in *)
-(*   List.iter (interfer ident) vars; *)
-
-module G = Graph.Pack.Graph
-(* module G = struct *)
-(*   include Graph.Imperative.Matrix.Graph *)
-(*   module Mark = struct *)
-(*       let h = Hashtbl.create 17 *)
-(*       let get x = *)
-(*         try *)
-(*           Hashtbl.find h x *)
-(*         with _ -> *)
-(*           Hashtbl.add h x 0; *)
-(*           0 *)
-(*       let set x v = Hashtbl.add h x v *)
-(*   end *)
-(* end *)
-(*
-module D = struct
-let round f = truncate (f +. 0.5)
-let pi = 4.0 *. atan 1.0
-
-open Graphics
-let () = open_graph " 800x600"
-
-let vertex_radius = 5
-
-let draw_arrow ?(color=black) ?(width=1) (xu,yu) (xv,yv) =
-  set_color color;
-  set_line_width width;
-  let dx = float (xv - xu) in
-  let dy = float (yv - yu) in
-  let alpha = atan2 dy dx in
-  let r = sqrt (dx *. dx +. dy *. dy) in
-  let ra = float vertex_radius *. 1.5 in
-  let d = float vertex_radius +. 3. in
-  let xs, ys = float xu +. d *. dx /. r, float yu +. d *. dy /. r in
-  let xd, yd = float xv -. d *. dx /. r, float yv -. d *. dy /. r in
-  let coords theta =
-    round (xd +. ra *. cos (pi +. alpha +. theta)),
-    round (yd +. ra *. sin (pi +. alpha +. theta))
-  in
-  moveto (round xs) (round ys);
-  lineto (round xd) (round yd);
-  let x1,y1 = coords (pi /. 6.) in
-  moveto (round xd) (round yd); lineto x1 y1;
-  let x2,y2 = coords (-. pi /. 6.) in
-  moveto (round xd) (round yd); lineto x2 y2
-
-let color_vertex v color =
-  let x,y = G.V.label v in
-  set_color color;
-  fill_circle x y vertex_radius
-
-let draw_graph g =
-  set_color red;
-  set_line_width 1;
-  G.iter_vertex
-    (fun v ->
-       let (x,y) = G.V.label v in
-       draw_circle x y vertex_radius)
-    g;
-  set_color black;
-  G.iter_edges
-    (fun v1 v2 -> draw_arrow (G.V.label v1) (G.V.label v2))
-    g;
-end
-
-  *)
-
-module V = struct
-
-  module S = Code.VarSet
-  module Map = Code.VarMap
-
-  type t = {
-    def : S.t;
-    use : S.t;
-    g : G.t;
-    count : int Map.t
-  }
-
-  let incr_count (x : Code.Var.t) (map : int Map.t) n =
-    let v = try Map.find x map with _ -> 0 in
-    Map.add x (v + n) map
-
-  let use_var t = function
-    | S _ -> t
-    | V i -> { t with
-      use = S.add i t.use;
-      count = incr_count i t.count 1 }
-
-  let def_var t = function
-    | S _ -> t
-    | V i -> { t with
-      def = S.add i t.def;
-      count = incr_count i t.count 1}
-
-  let rm_var t = function
-    | S _ -> t
-    | V i -> S.remove i t
-
-  let merge_count f t =  Map.fold (fun k v map -> incr_count k map v) f t
-
-
-  let empty g = {
-    def = S.empty;
-    use = S.empty;
-    count = Map.empty;
-    g
-  }
-
-  let vertex, vertex_tbl =
-    let h = Hashtbl.create 17 in
-    (fun v ->
-      let idx = Code.Var.idx v in
-      try Hashtbl.find h v with
-        | Not_found ->
-          let r = (G.V.create idx) in
-          Hashtbl.add h v r;
-          r),h
-
-  let max_ = ref 0
-
-  let mark g ~free ~use ~def =
-    S.iter (fun u -> G.add_vertex g (vertex u)) def;
-    let u = S.union def (S.union free use) in
-    max_:= max !max_ (S.cardinal u);
-    let f a b =
-      S.iter (fun u1 ->
-        S.iter (fun u2 ->
-          if u1 <> u2
-          then
-            G.add_edge
-              g
-              (vertex u1)
-              (vertex u2)
-        ) a
-      ) b
-    in
-    f use use;
-    f use free;
-    f def use;
-    f def free
-
-  let free t = S.diff t.use t.def
-
-  let create () =
-    (* empty (G.make (Code.Var.count ())) *)
-    empty (G.create ())
-  let rec expression t e = match e with
-    | ECond (e1,e2,e3) ->
-      expression
-        (expression
-           (expression t e1)
-           e2
-        )
-        e3
-    | ESeq (e1,e2)
-    | EAccess (e1,e2)
-    | EBin (_,e1,e2) ->
-      expression (expression t e1) e2
-    | EUn (_,e1)
-    | EDot (e1,_)
-    | ENew (e1,None) -> expression t e1
-    | ECall (e,args)
-    | ENew (e,Some args) ->
-      List.fold_left (fun acc x ->
-        expression acc x) (expression t e) args
-    | EVar v -> use_var t v
-    | EFun ((ident,params,body),_) ->
-      let tbody = List.fold_left def_var (empty t.g) params in
-      let tbody = match ident with
-        | None -> tbody
-        | Some v -> def_var tbody v in
-      let tbody = source_elts tbody body in
-      let tfree = free tbody in
-      mark t.g ~free:tfree ~use:tbody.use ~def:tbody.def;
-      {t with use = S.union t.use tfree ; count = merge_count t.count tbody.count}
-    | EStr _
-    | EBool _
-    | ENum _
-    | EQuote _ -> t
-    | EObj l ->
-      List.fold_left (fun acc (_,e) ->
-        expression acc e) t l
-    | EArr l ->
-      List.fold_left (fun acc x ->
-        match x with
-          | None -> acc
-          | Some e -> expression acc e) t l
-
-  and source_elts t l =
-    List.fold_left (fun acc s ->
-      source_elt acc s) t l
-
-  and source_elt t e = match e with
-    | Statement s -> statement t s
-    | Function_declaration (id,params, body, _) ->
-      let tbody = List.fold_left def_var (empty t.g) params in
-      let tbody = def_var tbody id in
-      let tbody = source_elts tbody body in
-      let tfree = free tbody in
-      mark t.g ~free:tfree ~use:tbody.use ~def:tbody.def;
-      def_var { t with use = S.union t.use tfree ; count = merge_count t.count tbody.count} id
-
-  and statements t l = List.fold_left statement t l
-
-  and statement t s = match s with
-    | Block l -> List.fold_left statement t l
-    | Variable_statement l ->
-      List.fold_left (fun t (id,eopt) ->
-        let t = def_var t id in
-        match eopt with
-          | None -> t
-          | Some e -> expression t e) t l
-    | Expression_statement (e,_) -> expression t e
-    | If_statement(e1,s2,e3opt) ->
-      let t = statement (expression t e1) s2 in
-      begin
-        match e3opt with
-          | None -> t
-          | Some e -> statement t e
-      end
-    | Do_while_statement (s,e)
-    | While_statement (e,s) ->
-      statement (expression t e) s
-    | For_statement (e1,e2,e3,s,_) ->
-      let t = List.fold_left (fun acc x ->
-        match x with
-          | None -> acc
-          | Some e -> expression acc e ) t [e1;e2;e3] in
-      statement t s
-    | Continue_statement _
-    | Break_statement _ -> t
-    | Return_statement None -> t
-    | Return_statement (Some e) -> expression t e
-    | Labelled_statement (_,s) -> statement t s
-    | Switch_statement(e,cl,sl) ->
-      let t = expression t e in
-      let t = List.fold_left (fun t (e, sl) ->
-        let t = expression t e in
-        statements t sl) t cl in
-      begin match sl with
-        | None -> t
-        | Some sl -> statements t sl
-      end
-    | Throw_statement e ->
-      expression t e
-    | Try_statement (b,w,f,_) ->
-      let t = statements t b in
-      let t = match w with
-        | None -> t
-        | Some (id,block) ->
-          let t' = statements (empty t.g) block in
-          let t'' = def_var t' id in
-          let t''free = free t'' in
-          mark t.g ~free:t''free ~use:t''.use ~def:t''.def;
-          { t with
-            use = S.union t.use (rm_var t'.use id) ;
-            def = S.union t.def t'.def;
-            count = merge_count t.count t''.count}
-            in
-      let t = match f with
-        | None -> t
-        | Some block -> statements t block
-      in t
-
-  module M = Graph.Coloring.Mark(G)
-
-  let program p : unit =
-    let t = source_elts (create()) p in
-    let freevar = free t in
-    assert(S.cardinal freevar = 0);
-    mark t.g ~free:freevar ~use:t.use ~def:t.def;
-    Printf.printf "compute graph degree\n%!";
-    let d = G.fold_vertex (fun v acc -> max acc (G.in_degree t.g v)) t.g 0 in
-    let percent x all =
-      float_of_int x /. float_of_int all *. 100. in
-    let nb_vertex = (G.nb_vertex t.g) in
-    Printf.printf "max degree is %d/%d/%d  %.2f\n%!" d (!max_) nb_vertex (percent (nb_vertex - !max_) nb_vertex);
-    (* D.draw_graph t.g; *)
-
-    let rec loop n max =
-      let size = int_of_float (53.** (float_of_int n)) in
-      let size = if n = 0 then !max_  else size in
-      if n > max
-      then raise Not_found
-      else
-        try
-          Printf.printf "try coloring with %d (%d)\n%!" size n;
-          M.coloring t.g size
-        with _ -> loop (succ n) max in
-    loop 0 3;
-    let h = Hashtbl.create 17 in
-    let color_count = Hashtbl.create 17 in
-    Hashtbl.iter (fun k v ->
-
-      let color = G.Mark.get v in
-      let count = Map.find k t.count in
-
-      let cc = try Hashtbl.find color_count color with
-        | _ -> 0 in
-      Hashtbl.replace color_count color (cc + count);
-      Hashtbl.add h k color)
-      vertex_tbl;
-    (* Hashtbl.iter (fun k v -> *)
-    (*   Printf.printf "var %d # %d\n" k v)  color_count; *)
-    Code.Var.set_mapping(fun x ->
-      let c = Hashtbl.find h x in c)
-
-(* Printf.printf "freevar(%d) = %s " *)
-(*   (V.S.cardinal freevar) *)
-(*   (V.S.fold (fun id s -> s ^ ", " ^ (Code.Var.to_string id)) freevar ""); *)
-
-end
diff --git a/compiler/js_output.ml b/compiler/js_output.ml
index 553155e9e9..778587c69b 100644
--- a/compiler/js_output.ml
+++ b/compiler/js_output.ml
@@ -33,23 +33,23 @@ open Javascript
 
 module PP = Pretty_print
 
-let enable_debug = ref false
-let debug_info = ref None
+let no_debug_info = Util.disabled ~init:true "debuginfo"
 
-let set_debug_info () = enable_debug := true
+module Make(D : (sig val debug_info : Parse_bytecode.debug_loc end)) = struct
 
-let output_debug_info f pc =
-  if !enable_debug then
-    match !debug_info, pc with
-    | Some dl, Some pc ->
-      (match dl pc with
-      | Some (file, l, s, e) ->
-        PP.string f "/*";
-        PP.string f (Format.sprintf "<<%d: %s %d %d %d>>"
-                       pc file l s e);
-        PP.string f "*/"
-      | None -> ())
-    | _, _ -> ()
+  let output_debug_info f pc =
+    if not (no_debug_info())
+    then
+      match pc with
+        | None -> ()
+        | Some pc ->
+          match D.debug_info pc with
+            | Some (file, l, s, e) ->
+              PP.string f "/*";
+              PP.string f (Format.sprintf "<<%d: %s %d %d %d>>"
+                             pc file l s e);
+              PP.string f "*/"
+            | None -> ()
 
 
 let ident = function
@@ -58,128 +58,128 @@ let ident = function
 
 let opt_identifier f i =
   match i with
-    None   -> ()
-  | Some i -> PP.space f; PP.string f (ident i)
+      None   -> ()
+    | Some i -> PP.space f; PP.string f (ident i)
 
 let rec formal_parameter_list f l =
   match l with
-    []     -> ()
-  | [i]    -> PP.string f (ident i)
-  | i :: r -> PP.string f (ident i); PP.string f ","; PP.break f;
-              formal_parameter_list f r
+      []     -> ()
+    | [i]    -> PP.string f (ident i)
+    | i :: r -> PP.string f (ident i); PP.string f ","; PP.break f;
+      formal_parameter_list f r
 
 (*
- 0 Expression
- 1 AssignementExpression
- 2 ConditionalExpression
- 3 LogicalORExpression
- 4 LogicalANDExpression
- 5 BitwiseORExpression
- 6 BitwiseXORExpression
- 7 BitwiseANDExpression
- 8 EqualityExpression
- 9 RelationalExpression
-10 ShiftExpression
-11 AdditiveExpression
-12 MultiplicativeExpression
-13 UnaryExpression
-14 PostfixExpression
-15 LeftHandsideExpression
-   NewExpression
-   CallExpression
-16 MemberExpression
-   FunctionExpression
-   PrimaryExpression
+  0 Expression
+  1 AssignementExpression
+  2 ConditionalExpression
+  3 LogicalORExpression
+  4 LogicalANDExpression
+  5 BitwiseORExpression
+  6 BitwiseXORExpression
+  7 BitwiseANDExpression
+  8 EqualityExpression
+  9 RelationalExpression
+  10 ShiftExpression
+  11 AdditiveExpression
+  12 MultiplicativeExpression
+  13 UnaryExpression
+  14 PostfixExpression
+  15 LeftHandsideExpression
+  NewExpression
+  CallExpression
+  16 MemberExpression
+  FunctionExpression
+  PrimaryExpression
 *)
 
 let op_prec op =
   match op with
-    Eq | StarEq | SlashEq | ModEq | PlusEq | MinusEq
-  | LslEq | AsrEq | LsrEq | BandEq | BxorEq | BorEq -> 1, 13, 1
-(*
-  | Or -> 3, 3, 4
-  | And -> 4, 4, 5
-  | Bor -> 5, 5, 6
-  | Bxor -> 6, 6, 7
-  | Band -> 7, 7, 8
-*)
-  | Or -> 3, 3, 3
-  | And -> 4, 4, 4
-  | Bor -> 5, 5, 5
-  | Bxor -> 6, 6, 6
-  | Band -> 7, 7, 7
-  | EqEq | NotEq | EqEqEq | NotEqEq -> 8, 8, 9
-  | Lt | Le | InstanceOf -> 9, 9, 10
-  | Lsl | Lsr | Asr -> 10, 10, 11
-  | Plus | Minus -> 11, 11, 12
-  | Mul | Div | Mod -> 12, 12, 13
+      Eq | StarEq | SlashEq | ModEq | PlusEq | MinusEq
+    | LslEq | AsrEq | LsrEq | BandEq | BxorEq | BorEq -> 1, 13, 1
+  (*
+    | Or -> 3, 3, 4
+    | And -> 4, 4, 5
+    | Bor -> 5, 5, 6
+    | Bxor -> 6, 6, 7
+    | Band -> 7, 7, 8
+  *)
+    | Or -> 3, 3, 3
+    | And -> 4, 4, 4
+    | Bor -> 5, 5, 5
+    | Bxor -> 6, 6, 6
+    | Band -> 7, 7, 7
+    | EqEq | NotEq | EqEqEq | NotEqEq -> 8, 8, 9
+    | Lt | Le | InstanceOf -> 9, 9, 10
+    | Lsl | Lsr | Asr -> 10, 10, 11
+    | Plus | Minus -> 11, 11, 12
+    | Mul | Div | Mod -> 12, 12, 13
 
 let op_str op =
   match op with
-    Eq      -> "="
-  | StarEq  -> "*="
-  | SlashEq -> "/="
-  | ModEq   -> "%="
-  | PlusEq  -> "+="
-  | MinusEq -> "-="
-  | Or      -> "||"
-  | And     -> "&&"
-  | Bor     -> "|"
-  | Bxor    -> "^"
-  | Band    -> "&"
-  | EqEq    -> "=="
-  | NotEq   -> "!="
-  | EqEqEq  -> "==="
-  | NotEqEq -> "!=="
-  | LslEq   -> "<<="
-  | AsrEq   -> ">>="
-  | LsrEq   -> ">>>="
-  | BandEq  -> "&="
-  | BxorEq  -> "^="
-  | BorEq   -> "|="
-  | Lt      -> "<"
-  | Le      -> "<="
-  | Lsl     -> "<<"
-  | Lsr     -> ">>>"
-  | Asr     -> ">>"
-  | Plus    -> "+"
-  | Minus   -> "-"
-  | Mul     -> "*"
-  | Div     -> "/"
-  | Mod     -> "%"
-  | InstanceOf -> assert false
+      Eq      -> "="
+    | StarEq  -> "*="
+    | SlashEq -> "/="
+    | ModEq   -> "%="
+    | PlusEq  -> "+="
+    | MinusEq -> "-="
+    | Or      -> "||"
+    | And     -> "&&"
+    | Bor     -> "|"
+    | Bxor    -> "^"
+    | Band    -> "&"
+    | EqEq    -> "=="
+    | NotEq   -> "!="
+    | EqEqEq  -> "==="
+    | NotEqEq -> "!=="
+    | LslEq   -> "<<="
+    | AsrEq   -> ">>="
+    | LsrEq   -> ">>>="
+    | BandEq  -> "&="
+    | BxorEq  -> "^="
+    | BorEq   -> "|="
+    | Lt      -> "<"
+    | Le      -> "<="
+    | Lsl     -> "<<"
+    | Lsr     -> ">>>"
+    | Asr     -> ">>"
+    | Plus    -> "+"
+    | Minus   -> "-"
+    | Mul     -> "*"
+    | Div     -> "/"
+    | Mod     -> "%"
+    | InstanceOf -> assert false
 
 let unop_str op =
   match op with
-    Not -> "!"
-  | Neg -> "-"
-  | Pl  -> "+"
-  | Bnot -> "~"
-  | IncrA | IncrB | DecrA | DecrB
-  | Typeof | Delete -> assert false
+      Not -> "!"
+    | Neg -> "-"
+    | Pl  -> "+"
+    | Bnot -> "~"
+    | IncrA | IncrB | DecrA | DecrB
+    | Typeof | Delete -> assert false
 
 (*XXX May need to be updated... *)
 let rec ends_with_if_without_else st =
   match st with
-    If_statement (_, _, Some st) -> ends_with_if_without_else st
-  | If_statement (_, _, None)    -> true
-  | While_statement (_, st)      -> ends_with_if_without_else st
-  | _                            -> false
+      If_statement (_, _, Some st) -> ends_with_if_without_else st
+    | If_statement (_, _, None)    -> true
+    | While_statement (_, st)      -> ends_with_if_without_else st
+    | _                            -> false
 
 let rec need_paren l e =
   match e with
-    ESeq (e, _) ->
-      l <= 0 && need_paren 0 e
-  | ECond (e, _, _) ->
+      ESeq (e, _) ->
+        l <= 0 && need_paren 0 e
+    | ECond (e, _, _) ->
       l <= 2 && need_paren 3 e
-  | EBin (op, e, _) ->
+    | EBin (op, e, _) ->
       let (out, lft, rght) = op_prec op in
       l <= out && need_paren lft e
-  | ECall (e, _) | EAccess (e, _) | EDot (e, _) ->
+    | ECall (e, _) | EAccess (e, _) | EDot (e, _) ->
       l <= 15 && need_paren 15 e
-  | EVar _ | EStr _ | EArr _ | EBool _ | ENum _ | EQuote _ | EUn _ | ENew _ ->
+    | EVar _ | EStr _ | EArr _ | EBool _ | ENum _ | EQuote _ | EUn _ | ENew _ ->
       false
-  | EFun (_, _) | EObj _ ->
+    | EFun (_, _) | EObj _ ->
       true
 
 let string_escape s =
@@ -189,48 +189,48 @@ let string_escape s =
   for i = 0 to l - 1 do
     let c = s.[i] in
     match c with
-      '\000' when i = l - 1 || s.[i + 1] < '0' || s.[i + 1] > '9' ->
-        Buffer.add_string b "\\0"
-    | '\b' ->
+        '\000' when i = l - 1 || s.[i + 1] < '0' || s.[i + 1] > '9' ->
+          Buffer.add_string b "\\0"
+      | '\b' ->
         Buffer.add_string b "\\b"
-    | '\t' ->
+      | '\t' ->
         Buffer.add_string b "\\t"
-    | '\n' ->
+      | '\n' ->
         Buffer.add_string b "\\n"
-(* This escape sequence is not supported by IE < 9
-    | '\011' ->
-        Buffer.add_string b "\\v"
-*)
-    | '\012' ->
+    (* This escape sequence is not supported by IE < 9
+       | '\011' ->
+       Buffer.add_string b "\\v"
+    *)
+      | '\012' ->
         Buffer.add_string b "\\f"
-    | '\r' ->
+      | '\r' ->
         Buffer.add_string b "\\r"
-    | '"' ->
+      | '"' ->
         Buffer.add_string b "\\\""
-    | '\\' ->
+      | '\\' ->
         Buffer.add_string b "\\\\"
-    | '\000' .. '\031' | '\127' .. '\255' ->
+      | '\000' .. '\031' | '\127' .. '\255' ->
         let c = Char.code c in
         Buffer.add_string b "\\x";
         Buffer.add_char b conv.[c lsr 4];
         Buffer.add_char b conv.[c land 0xf]
-    | _ ->
+      | _ ->
         Buffer.add_char b c
   done;
   Buffer.contents b
 
 let rec expression l f e =
   match e with
-    EVar v ->
-      PP.string f (ident v)
-  | ESeq (e1, e2) ->
+      EVar v ->
+        PP.string f (ident v)
+    | ESeq (e1, e2) ->
       if l > 0 then begin PP.start_group f 1; PP.string f "(" end;
       expression 0 f e1;
       PP.string f ",";
       PP.break f;
       expression 0 f e2;
       if l > 0 then begin PP.string f ")"; PP.end_group f end
-  | EFun ((i, l, b), pc) ->
+    | EFun ((i, l, b), pc) ->
       output_debug_info f pc;
       PP.start_group f 1;
       PP.start_group f 0;
@@ -252,7 +252,7 @@ let rec expression l f e =
       PP.string f "}";
       PP.end_group f;
       PP.end_group f
-  | ECall (e, el) ->
+    | ECall (e, el) ->
       if l > 15 then begin PP.start_group f 1; PP.string f "(" end;
       PP.start_group f 1;
       expression 15 f e;
@@ -264,13 +264,13 @@ let rec expression l f e =
       PP.end_group f;
       PP.end_group f;
       if l > 15 then begin PP.string f ")"; PP.end_group f end
-  | EStr (s, `Bytes) ->
+    | EStr (s, `Bytes) ->
       PP.string f "\"";
       PP.string f (string_escape s);
       PP.string f "\""
-  | EBool b ->
+    | EBool b ->
       PP.string f (if b then "true" else "false")
-  | ENum v ->
+    | ENum v ->
       if v = infinity then
         PP.string f "Infinity"
       else if v = neg_infinity then begin
@@ -279,40 +279,40 @@ let rec expression l f e =
         else
           PP.string f "-Infinity"
       end else if v <> v then
-        PP.string f "NaN"
-      else begin
-        let s =
-          let vint = int_of_float v in
+          PP.string f "NaN"
+        else begin
+          let s =
+            let vint = int_of_float v in
           (* compiler 1000 into 1e3 *)
-          if float_of_int vint = v
-          then
-            let rec div n i =
-              if n <> 0 && n mod 10 = 0
-              then div (n/10) (succ i)
-              else
-              if i > 2
-              then Printf.sprintf "%de%d" n i
-              else string_of_int vint in
-            div vint 0
-          else
-          let s1 = Printf.sprintf "%.12g" v in
-          if v = float_of_string s1 then s1 else
-          let s2 = Printf.sprintf "%.15g" v in
-          if v = float_of_string s2 then s2 else
-          Printf.sprintf "%.18g" v
-        in
-        if
+            if float_of_int vint = v
+            then
+              let rec div n i =
+                if n <> 0 && n mod 10 = 0
+                then div (n/10) (succ i)
+                else
+                  if i > 2
+                  then Printf.sprintf "%de%d" n i
+                  else string_of_int vint in
+              div vint 0
+            else
+              let s1 = Printf.sprintf "%.12g" v in
+              if v = float_of_string s1 then s1 else
+                let s2 = Printf.sprintf "%.15g" v in
+                if v = float_of_string s2 then s2 else
+                  Printf.sprintf "%.18g" v
+          in
+          if
           (* Negative numbers may need to be parenthesized. *)
-          (l > 13 && (v < 0. || (v = 0. && 1. /. v < 0.)))
+            (l > 13 && (v < 0. || (v = 0. && 1. /. v < 0.)))
             ||
           (* Parenthesize as well when followed by a dot. *)
-          (l = 15)
-        then begin
-          PP.string f "("; PP.string f s; PP.string f ")"
-        end else
-          PP.string f s
-      end
-  | EUn (Typeof, e) ->
+              (l = 15)
+          then begin
+            PP.string f "("; PP.string f s; PP.string f ")"
+          end else
+            PP.string f s
+        end
+    | EUn (Typeof, e) ->
       if l > 13 then begin PP.start_group f 1; PP.string f "(" end;
       PP.start_group f 0;
       PP.string f "typeof";
@@ -320,7 +320,7 @@ let rec expression l f e =
       expression 13 f e;
       PP.end_group f;
       if l > 13 then begin PP.string f ")"; PP.end_group f end
-  | EUn (Delete, e) ->
+    | EUn (Delete, e) ->
       if l > 13 then begin PP.start_group f 1; PP.string f "(" end;
       PP.start_group f 0;
       PP.string f "delete";
@@ -328,22 +328,22 @@ let rec expression l f e =
       expression 13 f e;
       PP.end_group f;
       if l > 13 then begin PP.string f ")"; PP.end_group f end
-  | EUn ((IncrA | DecrA | IncrB | DecrB) as op,e) ->
-    if l > 13 then begin PP.start_group f 1; PP.string f "(" end;
-    if op = IncrA || op = DecrA
-    then expression 13 f e;
-    if op = IncrA || op = IncrB
-    then PP.string f "++"
-    else PP.string f "--";
-    if op = IncrB || op = DecrB
-    then expression 13 f e;
-    if l > 13 then begin PP.string f ")"; PP.end_group f end
-  | EUn (op, e) ->
+    | EUn ((IncrA | DecrA | IncrB | DecrB) as op,e) ->
+      if l > 13 then begin PP.start_group f 1; PP.string f "(" end;
+      if op = IncrA || op = DecrA
+      then expression 13 f e;
+      if op = IncrA || op = IncrB
+      then PP.string f "++"
+      else PP.string f "--";
+      if op = IncrB || op = DecrB
+      then expression 13 f e;
+      if l > 13 then begin PP.string f ")"; PP.end_group f end
+    | EUn (op, e) ->
       if l > 13 then begin PP.start_group f 1; PP.string f "(" end;
       PP.string f (unop_str op);
       expression 13 f e;
       if l > 13 then begin PP.string f ")"; PP.end_group f end
-  | EBin (InstanceOf, e1, e2) ->
+    | EBin (InstanceOf, e1, e2) ->
       let (out, lft, rght) = op_prec InstanceOf in
       if l > out then begin PP.start_group f 1; PP.string f "(" end;
       PP.start_group f 0;
@@ -354,7 +354,7 @@ let rec expression l f e =
       expression rght f e2;
       PP.end_group f;
       if l > out then begin PP.string f ")"; PP.end_group f end
-  | EBin (op, e1, e2) ->
+    | EBin (op, e1, e2) ->
       let (out, lft, rght) = op_prec op in
       if l > out then begin PP.start_group f 1; PP.string f "(" end;
       expression lft f e1;
@@ -362,13 +362,13 @@ let rec expression l f e =
       PP.break f;
       expression rght f e2;
       if l > out then begin PP.string f ")"; PP.end_group f end
-  | EArr el ->
+    | EArr el ->
       PP.start_group f 1;
       PP.string f "[";
       element_list f el;
       PP.string f "]";
       PP.end_group f
-  | EAccess (e, e') ->
+    | EAccess (e, e') ->
       if l > 15 then begin PP.start_group f 1; PP.string f "(" end;
       PP.start_group f 1;
       expression 15 f e;
@@ -380,13 +380,13 @@ let rec expression l f e =
       PP.end_group f;
       PP.end_group f;
       if l > 15 then begin PP.string f ")"; PP.end_group f end
-  | EDot (e, nm) ->
+    | EDot (e, nm) ->
       if l > 15 then begin PP.start_group f 1; PP.string f "(" end;
       expression 15 f e;
       PP.string f ".";
       PP.string f nm;
       if l > 15 then begin PP.string f ")"; PP.end_group f end
-  | ENew (e, None) -> (*FIX: should omit parentheses when possible*)
+    | ENew (e, None) -> (*FIX: should omit parentheses when possible*)
       if l > 15 then begin PP.start_group f 1; PP.string f "(" end;
       PP.start_group f 1;
       PP.string f "new";
@@ -396,7 +396,7 @@ let rec expression l f e =
       PP.string f "()";
       PP.end_group f;
       if l > 15 then begin PP.string f ")"; PP.end_group f end
-  | ENew (e, Some el) ->
+    | ENew (e, Some el) ->
       if l > 15 then begin PP.start_group f 1; PP.string f "(" end;
       PP.start_group f 1;
       PP.string f "new";
@@ -410,7 +410,7 @@ let rec expression l f e =
       PP.end_group f;
       PP.end_group f;
       if l > 15 then begin PP.string f ")"; PP.end_group f end
-  | ECond (e, e1, e2) ->
+    | ECond (e, e1, e2) ->
       if l > 2 then begin PP.start_group f 1; PP.string f "(" end;
       PP.start_group f 1;
       PP.start_group f 0;
@@ -428,35 +428,35 @@ let rec expression l f e =
       PP.end_group f;
       PP.end_group f;
       if l > 2 then begin PP.string f ")"; PP.end_group f end
-  | EObj lst ->
+    | EObj lst ->
       PP.start_group f 1;
       PP.string f "{";
       property_name_and_value_list f lst;
       PP.string f "}";
       PP.end_group f
-  | EQuote s ->
+    | EQuote s ->
       PP.string f "(";
       PP.string f s;
       PP.string f ")"
 
 and property_name f n =
   match n with
-    PNI s -> PP.string f s
-  | PNS s -> PP.string f "\""; PP.string f s; PP.string f "\""
-  | PNN v -> expression 0 f (ENum v)
+      PNI s -> PP.string f s
+    | PNS s -> PP.string f "\""; PP.string f s; PP.string f "\""
+    | PNN v -> expression 0 f (ENum v)
 
 and property_name_and_value_list f l =
   match l with
-    [] ->
-      ()
-  | [(pn, e)] ->
+      [] ->
+        ()
+    | [(pn, e)] ->
       PP.start_group f 0;
       property_name f pn;
       PP.string f ":";
       PP.break f;
       expression 1 f e;
       PP.end_group f
-  | (pn, e) :: r ->
+    | (pn, e) :: r ->
       PP.start_group f 0;
       property_name f pn;
       PP.string f ":";
@@ -469,17 +469,17 @@ and property_name_and_value_list f l =
 
 and element_list f el =
   match el with
-    []     ->
-      ()
-  | [e]    ->
+      []     ->
+        ()
+    | [e]    ->
       begin match e with
-        None   -> PP.string f ","
-      | Some e -> PP.start_group f 0; expression 1 f e; PP.end_group f
+          None   -> PP.string f ","
+        | Some e -> PP.start_group f 0; expression 1 f e; PP.end_group f
       end
-  | e :: r ->
+    | e :: r ->
       begin match e with
-        None   -> ()
-      | Some e -> PP.start_group f 0; expression 1 f e; PP.end_group f
+          None   -> ()
+        | Some e -> PP.start_group f 0; expression 1 f e; PP.end_group f
       end;
       PP.string f ","; PP.break f; element_list f r
 
@@ -487,48 +487,48 @@ and function_body f b = source_elements f b
 
 and arguments f l =
   match l with
-    []     -> ()
-  | [e]    -> PP.start_group f 0; expression 1 f e; PP.end_group f
-  | e :: r -> PP.start_group f 0; expression 1 f e; PP.end_group f;
-              PP.string f ","; PP.break f; arguments f r
+      []     -> ()
+    | [e]    -> PP.start_group f 0; expression 1 f e; PP.end_group f
+    | e :: r -> PP.start_group f 0; expression 1 f e; PP.end_group f;
+      PP.string f ","; PP.break f; arguments f r
 
 and variable_declaration f (i, init) =
   match init with
-    None   ->
-      PP.string f (ident i)
-  | Some e ->
+      None   ->
+        PP.string f (ident i)
+    | Some e ->
       PP.start_group f 1;
       PP.string f (ident i); PP.string f "="; PP.break f; expression 1 f e;
       PP.end_group f
 
 and variable_declaration_list f l =
   match l with
-    []     -> assert false
-  | [d]    -> variable_declaration f d
-  | d :: r -> variable_declaration f d; PP.string f ","; PP.break f;
-              variable_declaration_list f r
+      []     -> assert false
+    | [d]    -> variable_declaration f d
+    | d :: r -> variable_declaration f d; PP.string f ","; PP.break f;
+      variable_declaration_list f r
 
 and opt_expression l f e =
   match e with
-    None   -> ()
-  | Some e -> expression l f e
+      None   -> ()
+    | Some e -> expression l f e
 
 and statement f s =
   match s with
-    Block b ->
-      block f b
-  | Variable_statement l ->
+      Block b ->
+        block f b
+    | Variable_statement l ->
       begin match l with
-        []  ->
-          ()
-      | [(i, None)] ->
+          []  ->
+            ()
+        | [(i, None)] ->
           PP.start_group f 1;
           PP.string f "var";
           PP.space f;
           PP.string f (ident i);
           PP.string f ";";
           PP.end_group f
-      | [(i, Some e)] ->
+        | [(i, Some e)] ->
           PP.start_group f 1;
           PP.string f "var";
           PP.space f;
@@ -540,7 +540,7 @@ and statement f s =
           PP.string f ";";
           PP.end_group f;
           PP.end_group f
-      | l ->
+        | l ->
           PP.start_group f 1;
           PP.string f "var";
           PP.space f;
@@ -548,8 +548,8 @@ and statement f s =
           PP.string f ";";
           PP.end_group f
       end
-  | Expression_statement (EVar _, pc)-> ()
-  | Expression_statement (e, pc) ->
+    | Expression_statement (EVar _, pc)-> ()
+    | Expression_statement (e, pc) ->
       (* Parentheses are required when the expression
          starts syntactically with "{" or "function" *)
       output_debug_info f pc;
@@ -565,10 +565,10 @@ and statement f s =
         PP.string f ";";
         PP.end_group f
       end
-  | If_statement (e, s1, (Some _ as s2)) when ends_with_if_without_else s1 ->
+    | If_statement (e, s1, (Some _ as s2)) when ends_with_if_without_else s1 ->
       (* Dangling else issue... *)
       statement f (If_statement (e, Block [s1], s2))
-  | If_statement (e, s1, Some (Block _ as s2)) ->
+    | If_statement (e, s1, Some (Block _ as s2)) ->
       PP.start_group f 0;
       PP.start_group f 1;
       PP.string f "if";
@@ -590,7 +590,7 @@ and statement f s =
       statement f s2;
       PP.end_group f;
       PP.end_group f
-  | If_statement (e, s1, Some s2) ->
+    | If_statement (e, s1, Some s2) ->
       PP.start_group f 0;
       PP.start_group f 1;
       PP.string f "if";
@@ -612,7 +612,7 @@ and statement f s =
       statement f s2;
       PP.end_group f;
       PP.end_group f
-  | If_statement (e, s1, None) ->
+    | If_statement (e, s1, None) ->
       PP.start_group f 1;
       PP.start_group f 0;
       PP.string f "if";
@@ -628,7 +628,7 @@ and statement f s =
       statement f s1;
       PP.end_group f;
       PP.end_group f
-  | While_statement (e, s) ->
+    | While_statement (e, s) ->
       PP.start_group f 1;
       PP.start_group f 0;
       PP.string f "while";
@@ -644,7 +644,7 @@ and statement f s =
       statement f s;
       PP.end_group f;
       PP.end_group f
-  | Do_while_statement (Block _ as s, e) ->
+    | Do_while_statement (Block _ as s, e) ->
       PP.start_group f 0;
       PP.string f "do";
       PP.genbreak f "" 1;
@@ -660,7 +660,7 @@ and statement f s =
       PP.string f ")";
       PP.end_group f;
       PP.end_group f
-  | Do_while_statement (s, e) ->
+    | Do_while_statement (s, e) ->
       PP.start_group f 0;
       PP.string f "do";
       PP.genbreak f " " 1;
@@ -676,7 +676,7 @@ and statement f s =
       PP.string f ")";
       PP.end_group f;
       PP.end_group f
-  | For_statement (e1, e2, e3, s, pc) ->
+    | For_statement (e1, e2, e3, s, pc) ->
       output_debug_info f pc;
       PP.start_group f 1;
       PP.start_group f 0;
@@ -697,23 +697,23 @@ and statement f s =
       statement f s;
       PP.end_group f;
       PP.end_group f
-  | Continue_statement None ->
+    | Continue_statement None ->
       PP.string f "continue;"
-  | Continue_statement (Some s) ->
+    | Continue_statement (Some s) ->
       PP.string f "continue ";
       PP.string f s;
       PP.string f ";"
-  | Break_statement None ->
+    | Break_statement None ->
       PP.string f "break;"
-  | Break_statement (Some s) ->
+    | Break_statement (Some s) ->
       PP.string f "break ";
       PP.string f s;
       PP.string f ";"
-  | Return_statement e ->
+    | Return_statement e ->
       begin match e with
-        None   ->
-          PP.string f "return;"
-      | Some (EFun ((i, l, b), pc)) ->
+          None   ->
+            PP.string f "return;"
+        | Some (EFun ((i, l, b), pc)) ->
           output_debug_info f pc;
           PP.start_group f 1;
           PP.start_group f 0;
@@ -735,7 +735,7 @@ and statement f s =
           PP.string f "};";
           PP.end_group f;
           PP.end_group f
-      | Some e ->
+        | Some e ->
           PP.start_group f 7;
           PP.string f "return ";
           PP.start_group f 0;
@@ -743,15 +743,15 @@ and statement f s =
           PP.string f ";";
           PP.end_group f;
           PP.end_group f
-          (* There MUST be a space between the return and its
-             argument. A line return will not work *)
+      (* There MUST be a space between the return and its
+         argument. A line return will not work *)
       end
-  | Labelled_statement (i, s) ->
+    | Labelled_statement (i, s) ->
       PP.string f i;
       PP.string f ":";
       PP.break f;
       statement f s
-  | Switch_statement (e, cc, def) ->
+    | Switch_statement (e, cc, def) ->
       PP.start_group f 1;
       PP.start_group f 0;
       PP.string f "switch";
@@ -767,24 +767,24 @@ and statement f s =
       PP.string f "{";
       List.iter
         (fun (e, sl) ->
-           PP.start_group f 1;
-           PP.start_group f 1;
-           PP.string f "case";
-           PP.space f;
-           expression 0 f e;
-           PP.string f ":";
-           PP.end_group f;
-           PP.break f;
-           PP.start_group f 0;
-           statement_list f sl;
-           PP.end_group f;
-           PP.end_group f;
-           PP.break f)
+          PP.start_group f 1;
+          PP.start_group f 1;
+          PP.string f "case";
+          PP.space f;
+          expression 0 f e;
+          PP.string f ":";
+          PP.end_group f;
+          PP.break f;
+          PP.start_group f 0;
+          statement_list f sl;
+          PP.end_group f;
+          PP.end_group f;
+          PP.break f)
         cc;
       begin match def with
-        None ->
-          ()
-      | Some def ->
+          None ->
+            ()
+        | Some def ->
           PP.start_group f 1;
           PP.string f "default:";
           PP.break f;
@@ -796,7 +796,7 @@ and statement f s =
       PP.string f "}";
       PP.end_group f;
       PP.end_group f
-  | Throw_statement e ->
+    | Throw_statement e ->
       PP.start_group f 6;
       PP.string f "throw ";
       PP.start_group f 0;
@@ -804,18 +804,18 @@ and statement f s =
       PP.string f ";";
       PP.end_group f;
       PP.end_group f
-      (* There must be a space between the return and its
-         argument. A line return would not work *)
-  | Try_statement (b, ctch, fin, pc) ->
+  (* There must be a space between the return and its
+     argument. A line return would not work *)
+    | Try_statement (b, ctch, fin, pc) ->
       output_debug_info f pc;
       PP.start_group f 0;
       PP.string f "try";
       PP.genbreak f " " 1;
       block f b;
       begin match ctch with
-        None ->
-          ()
-      | Some (i, b) ->
+          None ->
+            ()
+        | Some (i, b) ->
           PP.break f;
           PP.start_group f 1;
           PP.string f "catch(";
@@ -826,9 +826,9 @@ and statement f s =
           PP.end_group f
       end;
       begin match fin with
-        None ->
-          ()
-      | Some b ->
+          None ->
+            ()
+        | Some b ->
           PP.break f;
           PP.start_group f 1;
           PP.string f "finally";
@@ -840,9 +840,9 @@ and statement f s =
 
 and statement_list f b =
   match b with
-    []     -> ()
-  | [s]    -> statement f s
-  | s :: r -> statement f s; PP.break f; statement_list f r
+      []     -> ()
+    | [s]    -> statement f s
+    | s :: r -> statement f s; PP.break f; statement_list f r
 
 and block f b =
   PP.start_group f 1;
@@ -853,9 +853,9 @@ and block f b =
 
 and source_element f se =
   match se with
-    Statement s ->
-      statement f s
-  | Function_declaration (i, l, b, pc) ->
+      Statement s ->
+        statement f s
+    | Function_declaration (i, l, b, pc) ->
       output_debug_info f pc;
       PP.start_group f 1;
       PP.start_group f 0;
@@ -881,14 +881,16 @@ and source_element f se =
 
 and source_elements f se =
   match se with
-    []     -> ()
-  | [s]    -> source_element f s
-  | s :: r -> source_element f s; PP.break f; source_elements f r
+      []     -> ()
+    | [s]    -> source_element f s
+    | s :: r -> source_element f s; PP.break f; source_elements f r
+
+ end
 
 let statement f s dl =
-  debug_info := Some dl;
-  statement f s
+  let module O = Make(struct let debug_info = dl end) in
+  O.statement f s
 
 let program f se dl =
-  debug_info := Some dl;
-  PP.start_group f 0; source_elements f se; PP.end_group f; PP.newline f
+  let module O = Make(struct let debug_info = dl end) in
+  PP.start_group f 0; O.source_elements f se; PP.end_group f; PP.newline f
diff --git a/compiler/js_output.mli b/compiler/js_output.mli
index 6e541cd900..f4f637c128 100644
--- a/compiler/js_output.mli
+++ b/compiler/js_output.mli
@@ -21,7 +21,4 @@
 (* val statement : *)
 (*   Pretty_print.t -> Javascript.statement -> Parse_bytecode.debug_loc -> unit *)
 
-val program :
-  Pretty_print.t -> Javascript.function_body -> Parse_bytecode.debug_loc -> unit
-
-val set_debug_info : unit -> unit
+val program : Pretty_print.t -> Javascript.program -> Parse_bytecode.debug_loc -> unit
diff --git a/compiler/js_var.ml b/compiler/js_var.ml
new file mode 100644
index 0000000000..f897700026
--- /dev/null
+++ b/compiler/js_var.ml
@@ -0,0 +1,266 @@
+open Javascript
+
+module G = Graph.Pack.Graph
+(* module G = struct *)
+(*   include Graph.Imperative.Matrix.Graph *)
+(*   module Mark = struct *)
+(*       let h = Hashtbl.create 17 *)
+(*       let get x = *)
+(*         try *)
+(*           Hashtbl.find h x *)
+(*         with _ -> *)
+(*           Hashtbl.add h x 0; *)
+(*           0 *)
+(*       let set x v = Hashtbl.add h x v *)
+(*   end *)
+(* end *)
+
+module S = Code.VarSet
+module V = Code.Var
+module VM = Code.VarMap
+
+type t = {
+  def : S.t;
+  use : S.t;
+  g : G.t;
+  count : int VM.t;
+  biggest : int;
+  vertex : (Code.Var.t, G.V.t) Hashtbl.t;
+}
+
+let incr_count (x : Code.Var.t) (map : int VM.t) n =
+  let v = try VM.find x map with _ -> 0 in
+  VM.add x (v + n) map
+
+let use_var t = function
+  | S _ -> t
+  | V i -> { t with
+    use = S.add i t.use;
+    count = incr_count i t.count 1 }
+
+let def_var t = function
+  | S _ -> t
+  | V i -> { t with
+    def = S.add i t.def;
+    count = incr_count i t.count 1}
+
+let rm_var t = function
+  | S _ -> t
+  | V i -> S.remove i t
+
+let merge_count f t =  VM.fold (fun k v map -> incr_count k map v) f t
+
+
+let empty t = {
+  t with
+    def = S.empty;
+    use = S.empty;
+    count = VM.empty;
+    biggest = 0;
+}
+
+let vertex t v =
+  let idx = Code.Var.idx v in
+  try
+    Hashtbl.find t.vertex v
+  with Not_found ->
+    let r = (G.V.create idx) in
+    Hashtbl.add t.vertex v r;
+    r
+
+let get_free t = S.diff t.use t.def
+
+let mark g =
+  let free = get_free g in
+  S.iter (fun u -> G.add_vertex g.g (vertex g u)) g.def;
+  let u = S.union g.def (S.union free g.use) in
+  let f a b =
+    S.iter (fun u1 ->
+      S.iter (fun u2 ->
+        if u1 <> u2
+        then
+          G.add_edge
+            g.g
+            (vertex g u1)
+            (vertex g u2)
+      ) a
+    ) b
+  in
+  f g.use g.use;
+  f g.use free;
+  f g.def g.use;
+  f g.def free;
+  {g with biggest = max g.biggest (S.cardinal u)}
+
+let create () = (* empty (G.make (Code.Var.count ())) *)
+  {
+    def = S.empty;
+    use = S.empty;
+    count = VM.empty;
+    biggest = 0;
+    vertex = Hashtbl.create 17;
+    g = G.create ()
+  }
+
+let merge_info ~from ~into =
+  let free = get_free from in
+  {into with
+    count = merge_count from.count into.count;
+    biggest = max from.biggest into.biggest;
+    use = S.union into.use free }
+
+let rec expression t e = match e with
+  | ECond (e1,e2,e3) ->
+    expression
+      (expression
+         (expression t e1)
+         e2
+      )
+      e3
+  | ESeq (e1,e2)
+  | EAccess (e1,e2)
+  | EBin (_,e1,e2) ->
+    expression (expression t e1) e2
+  | EUn (_,e1)
+  | EDot (e1,_)
+  | ENew (e1,None) -> expression t e1
+  | ECall (e,args)
+  | ENew (e,Some args) ->
+    List.fold_left (fun acc x ->
+      expression acc x) (expression t e) args
+  | EVar v -> use_var t v
+  | EFun ((ident,params,body),_) ->
+    let tbody = List.fold_left def_var (empty t) params in
+    let tbody = match ident with
+      | None -> tbody
+      | Some v -> def_var tbody v in
+    let tbody = source_elts tbody body in
+    let tbody = mark tbody in
+    merge_info ~from:tbody ~into:t
+  | EStr _
+  | EBool _
+  | ENum _
+  | EQuote _ -> t
+  | EObj l ->
+    List.fold_left (fun acc (_,e) ->
+      expression acc e) t l
+  | EArr l ->
+    List.fold_left (fun acc x ->
+      match x with
+        | None -> acc
+        | Some e -> expression acc e) t l
+
+and source_elts t l =
+  List.fold_left (fun acc s ->
+    source_elt acc s) t l
+
+and source_elt t e = match e with
+  | Statement s -> statement t s
+  | Function_declaration (id,params, body, _) ->
+    let tbody = List.fold_left def_var (empty t) params in
+    let tbody = def_var tbody id in
+    let tbody = source_elts tbody body in
+    let tbody = mark tbody in
+    def_var (merge_info ~from:tbody ~into:t) id
+
+and statements t l = List.fold_left statement t l
+
+and statement t s = match s with
+  | Block l -> List.fold_left statement t l
+  | Variable_statement l ->
+    List.fold_left (fun t (id,eopt) ->
+      let t = def_var t id in
+      match eopt with
+        | None -> t
+        | Some e -> expression t e) t l
+  | Expression_statement (e,_) -> expression t e
+  | If_statement(e1,s2,e3opt) ->
+    let t = statement (expression t e1) s2 in
+    begin
+      match e3opt with
+        | None -> t
+        | Some e -> statement t e
+    end
+  | Do_while_statement (s,e)
+  | While_statement (e,s) ->
+    statement (expression t e) s
+  | For_statement (e1,e2,e3,s,_) ->
+    let t = List.fold_left (fun acc x ->
+      match x with
+        | None -> acc
+        | Some e -> expression acc e ) t [e1;e2;e3] in
+    statement t s
+  | Continue_statement _
+  | Break_statement _ -> t
+  | Return_statement None -> t
+  | Return_statement (Some e) -> expression t e
+  | Labelled_statement (_,s) -> statement t s
+  | Switch_statement(e,cl,sl) ->
+    let t = expression t e in
+    let t = List.fold_left (fun t (e, sl) ->
+      let t = expression t e in
+      statements t sl) t cl in
+    begin match sl with
+      | None -> t
+      | Some sl -> statements t sl
+    end
+  | Throw_statement e ->
+    expression t e
+  | Try_statement (b,w,f,_) ->
+    let t = statements t b in
+    let t = match w with
+      | None -> t
+      | Some (id,block) ->
+        let tbody = statements (empty t) block in
+        let tbody = def_var tbody id in
+        let tbody = mark tbody in
+        let t = merge_info ~from:tbody ~into:t in
+        { t with
+          use = S.union t.use (rm_var t.use id) ;
+          def = S.union t.def (rm_var t.def id) }
+    in
+    let t = match f with
+      | None -> t
+      | Some block -> statements t block
+    in t
+
+module M = Graph.Coloring.Mark(G)
+
+let program p =
+  let t = source_elts (create()) p in
+  assert(S.cardinal (get_free t) = 0);
+  let t = mark t in
+  Printf.printf "compute graph degree\n%!";
+  let degree = G.fold_vertex (fun v acc -> max acc (G.in_degree t.g v)) t.g 0 in
+  let percent x all =
+    float_of_int x /. float_of_int all *. 100. in
+  let nb_vertex = (G.nb_vertex t.g) in
+
+  Printf.printf "degree:%d; optimal:%d #:%d gain:%.2f%%\n%!" degree t.biggest nb_vertex
+    (percent (nb_vertex - t.biggest) nb_vertex);
+
+  let rec loop = function
+    | [] -> raise Not_found
+    | k :: rem ->
+      try
+        Printf.printf "try coloring with %d\n%!" k;
+        M.coloring t.g k
+      with _ -> loop rem in
+  loop [t.biggest;degree];
+
+
+  (* build the mapping function *)
+  let vertex_count = Hashtbl.length t.vertex in
+  let color_map = Hashtbl.fold (fun var vertex map ->
+    let color = G.Mark.get vertex in
+    let count = try VM.find var t.count with _ -> failwith "no count" in
+    let varset  = S.add var (try VM.find (V.from_idx color) map with _ -> S.empty) in
+    let map = VM.add (V.from_idx color) varset map in
+    map
+  ) t.vertex VM.empty in
+  let arr = Array.of_list (VM.bindings color_map) in
+  Array.sort (fun (_,i) (_,j) -> (S.cardinal i) - (S.cardinal j)) arr;
+  let _,map = Array.fold_left (fun (i,map) (_,varset) ->
+    succ i,
+    S.fold(fun var map -> VM.add var (V.from_idx i) map) varset map) (0,VM.empty) arr
+  in map
diff --git a/compiler/linker.ml b/compiler/linker.ml
index 8576c0658d..96a4ee51d6 100644
--- a/compiler/linker.ml
+++ b/compiler/linker.ml
@@ -220,7 +220,7 @@ and resolve_dep_rec f visited path id =
     visited
   end
 
-let resolve_deps ?(linkall = false) compact f l =
+let resolve_deps ?(linkall = false) f l =
   let visited =
     List.fold_left
       (fun (visited) id -> resolve_dep_rec f visited [] id)
diff --git a/compiler/linker.mli b/compiler/linker.mli
index b99ca0063f..ca5fd2f304 100644
--- a/compiler/linker.mli
+++ b/compiler/linker.mli
@@ -19,4 +19,4 @@
  *)
 
 val add_file : string -> unit
-val resolve_deps : ?linkall:bool -> bool -> Pretty_print.t -> string list -> string list
+val resolve_deps : ?linkall:bool -> Pretty_print.t -> string list -> string list
diff --git a/compiler/main.ml b/compiler/main.ml
index 1f9673abcc..8effaf47f6 100644
--- a/compiler/main.ml
+++ b/compiler/main.ml
@@ -27,7 +27,7 @@ let f paths js_files input_file output_file =
   List.iter Linker.add_file js_files;
   let paths = List.rev_append paths [Findlib.package_directory "stdlib"] in
   let t1 = Util.Timer.make () in
-  let p =
+  let p,d =
     match input_file with
       None ->
         Parse_bytecode.from_channel ~paths stdin
@@ -39,11 +39,11 @@ let f paths js_files input_file output_file =
   in
   if times () then Format.eprintf "  parsing: %a@." Util.Timer.print t1;
   let linkall = !linkall in
-  let output_program = Driver.f ~linkall p in
+  let output_program fmt = Driver.f ~linkall fmt d p in
   begin match output_file with
-    None ->
+    | None ->
       output_program (Pretty_print.to_out_channel stdout)
-  | Some f ->
+    | Some f ->
       let ch = open_out_bin f in
       output_program (Pretty_print.to_out_channel ch);
       close_out ch
@@ -62,8 +62,8 @@ let _ =
     [("-debug", Arg.String Util.set_debug, "<name> debug module <name>");
      ("-disable",
       Arg.String Util.set_disabled, "<name> disable optimization <name>");
-     ("-pretty", Arg.Unit Driver.set_pretty, " pretty print the output");
-     ("-debuginfo", Arg.Unit Driver.set_debug_info, " output debug info");
+     ("-pretty", Arg.Unit (fun () -> Util.set_enabled "pretty"), " pretty print the output");
+     ("-debuginfo", Arg.Unit (fun () -> Util.set_enabled "debuginfo"), " output debug info");
      ("-opt", Arg.Int Driver.set_profile, "<oN> set optimization profile : o1 (default), o2, o3");
      ("-noinline", Arg.Unit (fun () -> Util.set_disabled "inline"), " disable inlining");
      ("-linkall", Arg.Set linkall, " link all primitives");
diff --git a/compiler/parse_bytecode.ml b/compiler/parse_bytecode.ml
index 0d27610ab5..0e321a19c6 100644
--- a/compiler/parse_bytecode.ml
+++ b/compiler/parse_bytecode.ml
@@ -226,9 +226,7 @@ module Debug = struct
 
 end
 
-let keep_variable_names = ref false
-
-let set_pretty () = keep_variable_names := true; Code.Var.set_pretty ()
+let don't_keep_variable_names = Util.disabled ~init:true "pretty"
 
 (****)
 
@@ -1767,7 +1765,7 @@ let from_channel ~paths ic =
   ignore(seek_section toc ic "SYMB");
   let symbols = (input_value ic : Ident.t numtable) in
 
-  if !keep_variable_names then begin
+  if not (don't_keep_variable_names ()) then begin
     try
       ignore(seek_section toc ic "DBUG");
       Debug.read ic;
diff --git a/compiler/parse_bytecode.mli b/compiler/parse_bytecode.mli
index 6c46f9c467..54962adfc7 100644
--- a/compiler/parse_bytecode.mli
+++ b/compiler/parse_bytecode.mli
@@ -24,6 +24,4 @@ val from_channel : paths:string list -> in_channel -> Code.program * debug_loc
 
 val from_string : string array -> string -> Code.program * debug_loc
 
-val set_pretty : unit -> unit
-
 val build_toplevel : unit -> unit
diff --git a/compiler/util.ml b/compiler/util.ml
index 6b69acdf8d..f82581e77f 100644
--- a/compiler/util.ml
+++ b/compiler/util.ml
@@ -74,15 +74,20 @@ let set_debug s =
 
 let disabled_lst = ref []
 
-let disabled s =
-  let state = ref false in
-  disabled_lst := (s, state) :: !disabled_lst;
+let disabled ?(init=false) s =
+  let state = ref init in
+  if not (List.mem_assoc s !disabled_lst)
+  then disabled_lst := (s, state) :: !disabled_lst;
   fun () -> !state
 
 let set_disabled s =
   try List.assoc s !disabled_lst := true with Not_found ->
    Format.eprintf "%s: no disable option named '%s'@." Sys.argv.(0) s; exit 1
 
+let set_enabled s =
+  try List.assoc s !disabled_lst := false with Not_found ->
+   Format.eprintf "%s: no disable option named '%s'@." Sys.argv.(0) s; exit 1
+
 (****)
 
 module Timer = struct
diff --git a/compiler/util.mli b/compiler/util.mli
index 4b2d66ed8a..96499d5f1a 100644
--- a/compiler/util.mli
+++ b/compiler/util.mli
@@ -33,8 +33,9 @@ val read_file : string -> string
 val debug : string -> unit -> bool
 val set_debug : string -> unit
 
-val disabled : string -> unit -> bool
+val disabled : ?init:bool -> string -> (unit -> bool)
 val set_disabled : string -> unit
+val set_enabled : string -> unit
 
 module Timer : sig
   type t

From f599901f6d26278ff68bcd7deb6e539f7b014e60 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Thu, 12 Sep 2013 00:58:46 -0700
Subject: [PATCH 09/60] COMPILER: clean -> no need for Var.stream

no need for Var.stream
---
 compiler/code.ml           | 12 ------------
 compiler/code.mli          |  5 -----
 compiler/parse_bytecode.ml | 23 +++++++++++------------
 3 files changed, 11 insertions(+), 29 deletions(-)

diff --git a/compiler/code.ml b/compiler/code.ml
index 6036aa7565..327bf0230d 100644
--- a/compiler/code.ml
+++ b/compiler/code.ml
@@ -113,10 +113,6 @@ module Var : sig
   val from_idx : int -> t
   val to_string : t -> string
 
-  type stream
-  val make_stream : unit -> stream
-  val next : stream -> t * stream
-
   val fresh : unit -> t
 
   val count : unit -> int
@@ -138,18 +134,10 @@ end = struct
 
   let reset () = last_var := 0; VarPrinter.reset ()
 
-  type stream = int
-
   let to_string i = VarPrinter.to_string i
 
   let print f x = Format.fprintf f "%s" (to_string x)
 
-  let make_stream () = 1
-
-  let next current =
-    incr last_var;
-    (!last_var, current + 1)
-
   let fresh () = incr last_var; !last_var
 
   let count () = !last_var + 1
diff --git a/compiler/code.mli b/compiler/code.mli
index 4ea377d412..42807b7c8f 100644
--- a/compiler/code.mli
+++ b/compiler/code.mli
@@ -30,17 +30,12 @@ module Var : sig
 
   val to_string : t -> string
 
-  type stream
-  val make_stream : unit -> stream
-  val next : stream -> t * stream
-
   val fresh : unit -> t
 
   val count : unit -> int
 
   val compare : t -> t -> int
 
-
   val name : t -> string -> unit
   val propagate_name : t -> t -> unit
   val set_pretty : unit -> unit
diff --git a/compiler/parse_bytecode.ml b/compiler/parse_bytecode.ml
index 0e321a19c6..4ed38c70ad 100644
--- a/compiler/parse_bytecode.ml
+++ b/compiler/parse_bytecode.ml
@@ -268,12 +268,11 @@ module State = struct
 
   type t =
     { accu : elt; stack : elt list; env : elt array; env_offset : int;
-      handlers : (Var.t * addr * int) list;
-      var_stream : Var.stream; globals : globals }
+      handlers : (Var.t * addr * int) list; globals : globals }
 
   let fresh_var state =
-    let (x, stream) = Var.next state.var_stream in
-    (x, {state with var_stream = stream; accu = Var x})
+    let x = Var.fresh () in
+    (x, {state with accu = Var x})
 
   let globals st = st.globals
 
@@ -348,18 +347,18 @@ module State = struct
                 handlers = []}
 
   let start_block state =
-    let (stack, stream) =
+    let stack =
       List.fold_right
-        (fun e (stack, stream) ->
+        (fun e stack ->
            match e with
              Dummy ->
-               (Dummy :: stack, stream)
+               Dummy :: stack
            | Var _ ->
-               let (x, stream) = Var.next stream in
-               (Var x :: stack, stream))
-        state.stack ([], state.var_stream)
+               let x = Var.fresh () in
+               Var x :: stack)
+        state.stack []
     in
-    let state = { state with stack = stack; var_stream = stream } in
+    let state = { state with stack = stack } in
     match state.accu with
       Dummy -> state
     | Var _ -> snd (fresh_var state)
@@ -385,7 +384,7 @@ module State = struct
 
   let initial g =
     { accu = Dummy; stack = []; env = [||]; env_offset = 0; handlers = [];
-      var_stream = Var.make_stream (); globals = g }
+      globals = g }
 
   let rec print_stack f l =
     match l with

From 63cec7529874075379b50e4b635617539093c4ec Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Thu, 12 Sep 2013 00:59:06 -0700
Subject: [PATCH 10/60] COMPILER : Refactoring

---
 compiler/driver.ml     | 45 ++++++++++++++++++++++++++++++------------
 compiler/generate.ml   | 30 ++++------------------------
 compiler/generate.mli  |  5 +----
 compiler/js_output.mli |  3 ---
 compiler/linker.ml     | 10 ----------
 5 files changed, 37 insertions(+), 56 deletions(-)

diff --git a/compiler/driver.ml b/compiler/driver.ml
index c980905b02..4229c2db8b 100644
--- a/compiler/driver.ml
+++ b/compiler/driver.ml
@@ -120,24 +120,42 @@ let o3 =
 
 let profile = ref o1
 
-
-let f_generate formatter  ~standalone ?linkall d (p,live_vars) =
+let generate ~standalone (p,live_vars) =
   if times ()
   then Format.eprintf "Start Generation...@.";
-  Generate.f formatter ~standalone ?linkall p d live_vars
+  Generate.f ~standalone p live_vars
 
-let f_link formatter ~standalone ?linkall pretty js =
-  if times ()
-  then Format.eprintf "Start Linking...@.";
-  Generate.f_link formatter ~standalone ?linkall pretty;
+
+let header formatter ~standalone js =
+  if standalone then begin
+    Pretty_print.string formatter
+      "// This program was compiled from OCaml by js_of_ocaml 1.3";
+    Pretty_print.newline formatter;
+  end;
+  js
+
+let link formatter ~standalone ?linkall pretty js =
+  if standalone
+  then
+    begin
+      if times ()
+      then Format.eprintf "Start Linking...@.";
+      let missing = Linker.resolve_deps ?linkall formatter (Primitive.get_used ()) in
+      match missing with
+        | [] -> ()
+        | l ->
+          Format.eprintf "Missing primitives:@.";
+          List.iter (fun nm -> Format.eprintf "  %s@." nm) l
+
+    end;
   js
 
-let f_coloring js =
+let coloring js =
   if times ()
   then Format.eprintf "Start Coloring...@.";
   js,Js_var.program js
 
-let f_output formatter d (js,subs) =
+let output formatter d (js,subs) =
   if times ()
   then Format.eprintf "Start Writing file...@.";
   Js_output.program formatter js d
@@ -145,10 +163,11 @@ let f_output formatter d (js,subs) =
 let f ?(standalone=true) ?linkall formatter d =
   !profile >>
   deadcode' >>
-  f_generate formatter ~standalone ?linkall d >>
-  f_link formatter ~standalone ?linkall false >>
-  f_coloring >>
-  f_output formatter d
+  generate ~standalone >>
+  header formatter ~standalone >>
+  link formatter ~standalone ?linkall false >>
+  coloring >>
+  output formatter d
 
 let from_string prims s formatter =
   let (p,d) = Parse_bytecode.from_string prims s in
diff --git a/compiler/generate.ml b/compiler/generate.ml
index 2f8484500f..651ae65e6b 100644
--- a/compiler/generate.ml
+++ b/compiler/generate.ml
@@ -1453,43 +1453,21 @@ and compile_closure ctx (pc, args) =
 
 let compile_program standalone ctx pc =
   let res = compile_closure ctx (pc, []) in
+  let res = generate_apply_funs res in
   if debug () then Format.eprintf "@.@.";
-(*
-  Primitive.list_used ();
-*)
   if standalone then
-    let f = J.EFun ((None, [], generate_apply_funs res), None) in
+    let f = J.EFun ((None, [], res), None) in
     [J.Statement (J.Expression_statement ((J.ECall (f, [])), Some pc))]
   else
-    let f = J.EFun ((None, [J.V (Var.fresh ())],
-                     generate_apply_funs res), None) in
+    let f = J.EFun ((None, [J.V (Var.fresh ())], res), None) in
     [J.Statement (J.Expression_statement (f, Some pc))]
 
 (**********************)
 
-let list_missing l =
-  if l <> [] then begin
-    Format.eprintf "Missing primitives:@.";
-    List.iter (fun nm -> Format.eprintf "  %s@." nm) l
-  end
-
-let f ch ~standalone ?linkall ((pc, blocks, _) as p) dl live_vars =
+let f ~standalone ((pc, blocks, _) as p) live_vars =
   let mutated_vars = Freevars.f p in
   let t' = Util.Timer.make () in
   let ctx = Ctx.initial blocks live_vars mutated_vars in
   let p = compile_program standalone ctx pc in
   if times () then Format.eprintf "  code gen.: %a@." Util.Timer.print t';
   p
-
-
-
-let f_link ch ~standalone ?linkall pretty =
-  if standalone
-  then
-    begin
-      Pretty_print.string ch
-        "// This program was compiled from OCaml by js_of_ocaml 1.3";
-      Pretty_print.newline ch;
-      let missing = Linker.resolve_deps ?linkall ch (Primitive.get_used ()) in
-      list_missing missing
-    end
diff --git a/compiler/generate.mli b/compiler/generate.mli
index d19c7a81df..7a2a4fc9b6 100644
--- a/compiler/generate.mli
+++ b/compiler/generate.mli
@@ -18,7 +18,4 @@
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  *)
 
-val f : Pretty_print.t -> standalone:bool -> ?linkall:bool ->
-        Code.program -> Parse_bytecode.debug_loc -> int array -> Javascript.program
-
-val f_link : Pretty_print.t -> standalone:bool -> ?linkall:bool -> bool -> unit
+val f : standalone:bool -> Code.program -> int array -> Javascript.program
diff --git a/compiler/js_output.mli b/compiler/js_output.mli
index f4f637c128..20686ec1d5 100644
--- a/compiler/js_output.mli
+++ b/compiler/js_output.mli
@@ -18,7 +18,4 @@
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  *)
 
-(* val statement : *)
-(*   Pretty_print.t -> Javascript.statement -> Parse_bytecode.debug_loc -> unit *)
-
 val program : Pretty_print.t -> Javascript.program -> Parse_bytecode.debug_loc -> unit
diff --git a/compiler/linker.ml b/compiler/linker.ml
index 96a4ee51d6..31fa664662 100644
--- a/compiler/linker.ml
+++ b/compiler/linker.ml
@@ -242,13 +242,3 @@ let resolve_deps ?(linkall = false) f l =
     ) provided;
   end;
   List.rev missing
-
-(*
-let _ =
-  for i = 1 to Array.length Sys.argv - 1 do
-    add_file Sys.argv.(i)
-  done;
-  let missing = ref [] in
-  Format.eprintf "%a@."
-    (fun f v -> missing := resolve_deps f v) ["caml_array_get"]
-*)

From 72dcc20bede04d73480f886f8b6ef4fa3451d608 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Thu, 12 Sep 2013 01:30:41 -0700
Subject: [PATCH 11/60] COMPILER: cleanup debugs

---
 compiler/generate.ml | 70 --------------------------------------------
 1 file changed, 70 deletions(-)

diff --git a/compiler/generate.ml b/compiler/generate.ml
index 651ae65e6b..bae799f908 100644
--- a/compiler/generate.ml
+++ b/compiler/generate.ml
@@ -236,9 +236,6 @@ let rec build_graph st pc anc =
 let rec dominance_frontier_rec st pc visited grey =
   let n = get_preds st pc in
   let v = try AddrMap.find pc visited with Not_found -> 0 in
-(*
-Format.eprintf "%d %d %d@." pc n v;
-*)
   if v < n then begin
     let v = v + 1 in
     let visited = AddrMap.add pc v visited in
@@ -263,26 +260,9 @@ let dominance_frontier st pc =
 let never_continue st (pc, _) frontier interm succs =
   (* If not found in successors, this is a backward edge *)
   let d = try List.assoc pc succs with Not_found -> AddrSet.empty in
-(*
-Format.eprintf "pc: %d@." pc;
-List.iter (fun (pc, _) ->Format.eprintf "pc: %d@." pc) succs;
-Format.eprintf "never_continue@.";
-Format.eprintf "  %d /" pc;
-AddrSet.iter (fun i -> Format.eprintf " %d" i) frontier;
-Format.eprintf " /";
-AddrMap.iter (fun i _ -> Format.eprintf " %d" i) interm;
-Format.eprintf " /";
-AddrSet.iter (fun i -> Format.eprintf " %d" i) d;
-let res =
-*)
   not (AddrSet.mem pc frontier || AddrMap.mem pc interm)
     &&
   AddrSet.is_empty d
-(*
-in
-Format.eprintf " ==> %b@." res;
-res
-*)
 
 let rec resolve_node interm pc =
   try
@@ -855,9 +835,6 @@ and translate_expr ctx queue x e =
           let ((px, cx), queue) = access_queue queue x in
           (J.EBin(J.EqEqEq, J.EUn (J.Typeof, cx), J.EStr ("number", `Bytes)),
            px, queue)
-(*
-          (boolnot (J.EBin(J.InstanceOf, cx, J.EVar ("Array"))), px, queue)
-*)
       | Ult, [Pv x; Pv y] ->
           let ((px, cx), queue) = access_queue queue x in
           let ((py, cy), queue) = access_queue queue y in
@@ -996,14 +973,6 @@ and compile_block st queue pc frontier interm =
 if queue <> [] && AddrSet.mem pc st.loops then
   flush_all queue (compile_block st [] pc frontier interm)
 else begin
-(*
-Format.eprintf "(frontier: ";
-AddrSet.iter (fun pc -> Format.eprintf "%d " pc) frontier;
-Format.eprintf ")@.";
-Format.eprintf "(interm: ";
-AddrMap.iter (fun pc (pc', _) -> Format.eprintf " %d->%d " pc pc') interm;
-Format.eprintf ")@.";
-*)
   if pc >= 0 then begin
     if AddrSet.mem pc st.visited_blocks then begin
       Format.eprintf "!!!! %d@." pc; assert false
@@ -1030,11 +999,6 @@ Format.eprintf ")@.";
       succs AddrSet.empty
   in
   let new_frontier = resolve_nodes interm grey in
-(*
-Format.eprintf "<<%d:" pc;
-AddrSet.iter (fun pc -> Format.eprintf " %d" pc) frontier;
-Format.eprintf ">>@ ";
-*)
   let block = AddrMap.find pc st.blocks in
   let (seq, queue) = translate_instr st.ctx queue pc block.body in
   let body =
@@ -1054,9 +1018,6 @@ Format.eprintf ">>@ ";
         if limit_body then incr_preds st pc3;
         assert (AddrSet.cardinal inner_frontier <= 1);
         if debug () then Format.eprintf "@[<2>try {@,";
-(*
-Format.eprintf "===== %d ===== (%b)@." pc3 limit_body;
-*)
         let body =
           compile_branch st [] (pc1, args1)
             None AddrSet.empty inner_frontier interm
@@ -1078,18 +1039,10 @@ Format.eprintf "===== %d ===== (%b)@." pc3 limit_body;
                             Some pc) ::
            if AddrSet.is_empty inner_frontier then [] else begin
              let pc = AddrSet.choose inner_frontier in
-(*
-Format.eprintf ">>Frontier: ";
-AddrSet.iter (fun pc -> Format.eprintf "%d " pc) frontier;
-Format.eprintf "@.";
-*)
              if AddrSet.mem pc frontier then [] else
                compile_block st [] pc frontier interm
            end)
     | _ ->
-(*
-Format.eprintf "[[@.";
-*)
         let (new_frontier, new_interm) =
           if AddrSet.cardinal new_frontier > 1 then begin
             let x = Code.Var.fresh () in
@@ -1097,11 +1050,6 @@ Format.eprintf "[[@.";
             if debug () then Format.eprintf "@ var %a;" Code.Var.print x;
             let idx = st.interm_idx in
             st.interm_idx <- idx - 1;
-(*
-Format.eprintf "%d ====> " idx;
-AddrSet.iter (fun pc -> Format.eprintf "%d " pc) new_frontier;
-Format.eprintf "@.";
-*)
             let cases = Array.map (fun pc -> (pc, [])) a in
             let switch =
               if Array.length cases > 2 then
@@ -1136,20 +1084,12 @@ Format.eprintf "@.";
           compile_conditional
             st queue pc block.branch block.handler
             backs new_frontier new_interm succs in
-(*
-let res =
-*)
         cond @
         if AddrSet.cardinal new_frontier = 0 then [] else begin
           let pc = AddrSet.choose new_frontier in
           if AddrSet.mem pc frontier then [] else
           compile_block st [] pc frontier interm
         end
-(*
-in
-Format.eprintf "]]@.";
-res
-*)
   in
   if AddrSet.mem pc st.loops then begin
     let label =
@@ -1182,9 +1122,6 @@ end
 and compile_if st e cont1 cont2 handler backs frontier interm succs =
   let iftrue = compile_branch st [] cont1 handler backs frontier interm in
   let iffalse = compile_branch st [] cont2 handler backs frontier interm in
-(*
-Format.eprintf "====@.";
-*)
   Js_simpl.if_statement e
     (Js_simpl.block iftrue) (never_continue st cont1 frontier interm succs)
     (Js_simpl.block iffalse) (never_continue st cont2 frontier interm succs)
@@ -1359,7 +1296,6 @@ and compile_exn_handling ctx queue (pc, args) handler continuation =
             [], [] ->
               continuation queue
           | x :: args, y :: params ->
-(*Format.eprintf "ZZZ@.";*)
               let (z, old) =
                 match old with [] -> (None, []) | z :: old -> (Some z, old)
               in
@@ -1369,7 +1305,6 @@ and compile_exn_handling ctx queue (pc, args) handler continuation =
                 loop continuation old args params queue
               else begin
                let ((px, cx), queue) = access_queue queue x in
-(*Format.eprintf "%a := %a@." Var.print y Var.print x;*)
                let (st, queue) =
 (*FIX: we should flush only the variables we need rather than doing this;
        do the same for closure free variables *)
@@ -1384,9 +1319,6 @@ and compile_exn_handling ctx queue (pc, args) handler continuation =
           | _ ->
               assert false
         in
-(*
-Format.eprintf "%d ==> %d/%d/%d@." pc (List.length h_args) (List.length h_block.params) (List.length old_args);
-*)
         loop continuation old_args h_args h_block.params queue
 
 and compile_branch st queue ((pc, _) as cont) handler backs frontier interm =
@@ -1462,8 +1394,6 @@ let compile_program standalone ctx pc =
     let f = J.EFun ((None, [J.V (Var.fresh ())], res), None) in
     [J.Statement (J.Expression_statement (f, Some pc))]
 
-(**********************)
-
 let f ~standalone ((pc, blocks, _) as p) live_vars =
   let mutated_vars = Freevars.f p in
   let t' = Util.Timer.make () in

From 0eb908e23d9623578e80d6dcc1a54c1b5a8cd998 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Thu, 12 Sep 2013 02:24:52 -0700
Subject: [PATCH 12/60] COMPILER: use colored graph to generate short var names

COMPILER: typo coloring

COMPILER: missing file
---
 compiler/.depend       |   28 +-
 compiler/driver.ml     |   17 +-
 compiler/js_output.ml  | 1596 ++++++++++++++++++++--------------------
 compiler/js_output.mli |    2 +-
 compiler/js_var.ml     |   24 +-
 compiler/js_var.mli    |   19 +
 6 files changed, 860 insertions(+), 826 deletions(-)
 create mode 100644 compiler/js_var.mli

diff --git a/compiler/.depend b/compiler/.depend
index c589e74017..5042c5afa4 100644
--- a/compiler/.depend
+++ b/compiler/.depend
@@ -6,20 +6,20 @@ deadcode.cmo : util.cmi pure_fun.cmi code.cmi deadcode.cmi
 deadcode.cmx : util.cmx pure_fun.cmx code.cmx deadcode.cmi
 dgraph.cmo : dgraph.cmi
 dgraph.cmx : dgraph.cmi
-driver.cmo : util.cmi tailcall.cmi phisimpl.cmi parse_bytecode.cmi \
-    js_var.cmi js_output.cmi inline.cmi generate.cmi flow.cmi deadcode.cmi \
-    code.cmi driver.cmi
-driver.cmx : util.cmx tailcall.cmx phisimpl.cmx parse_bytecode.cmx \
-    js_var.cmx js_output.cmx inline.cmx generate.cmx flow.cmx deadcode.cmx \
-    code.cmx driver.cmi
+driver.cmo : util.cmi tailcall.cmi primitive.cmi pretty_print.cmi \
+    phisimpl.cmi parse_bytecode.cmi linker.cmi js_var.cmi js_output.cmi \
+    inline.cmi generate.cmi flow.cmi deadcode.cmi code.cmi driver.cmi
+driver.cmx : util.cmx tailcall.cmx primitive.cmx pretty_print.cmx \
+    phisimpl.cmx parse_bytecode.cmx linker.cmx js_var.cmx js_output.cmx \
+    inline.cmx generate.cmx flow.cmx deadcode.cmx code.cmx driver.cmi
 flow.cmo : util.cmi subst.cmi dgraph.cmi code.cmi flow.cmi
 flow.cmx : util.cmx subst.cmx dgraph.cmx code.cmx flow.cmi
 freevars.cmo : util.cmi code.cmi freevars.cmi
 freevars.cmx : util.cmx code.cmx freevars.cmi
-generate.cmo : util.cmi subst.cmi primitive.cmi pretty_print.cmi linker.cmi \
-    js_simpl.cmi javascript.cmi freevars.cmi code.cmi generate.cmi
-generate.cmx : util.cmx subst.cmx primitive.cmx pretty_print.cmx linker.cmx \
-    js_simpl.cmx javascript.cmx freevars.cmx code.cmx generate.cmi
+generate.cmo : util.cmi subst.cmi primitive.cmi js_simpl.cmi javascript.cmi \
+    freevars.cmi code.cmi generate.cmi
+generate.cmx : util.cmx subst.cmx primitive.cmx js_simpl.cmx javascript.cmx \
+    freevars.cmx code.cmx generate.cmi
 inline.cmo : util.cmi deadcode.cmi code.cmi inline.cmi
 inline.cmx : util.cmx deadcode.cmx code.cmx inline.cmi
 instr.cmo : instr.cmi
@@ -34,8 +34,8 @@ js_rename.cmo : util.cmi javascript.cmi
 js_rename.cmx : util.cmx javascript.cmx
 js_simpl.cmo : javascript.cmi js_simpl.cmi
 js_simpl.cmx : javascript.cmx js_simpl.cmi
-js_var.cmo : javascript.cmi code.cmi js_var.cmi
-js_var.cmx : javascript.cmx code.cmx js_var.cmi
+js_var.cmo : util.cmi javascript.cmi code.cmi js_var.cmi
+js_var.cmx : util.cmx javascript.cmx code.cmx js_var.cmi
 linker.cmo : util.cmi primitive.cmi pretty_print.cmi code.cmi linker.cmi
 linker.cmx : util.cmx primitive.cmx pretty_print.cmx code.cmx linker.cmi
 main.cmo : util.cmi pretty_print.cmi parse_bytecode.cmi linker.cmi \
@@ -67,11 +67,11 @@ dgraph.cmi :
 driver.cmi : pretty_print.cmi parse_bytecode.cmi code.cmi
 flow.cmi : code.cmi
 freevars.cmi : util.cmi code.cmi
-generate.cmi : pretty_print.cmi parse_bytecode.cmi javascript.cmi code.cmi
+generate.cmi : javascript.cmi code.cmi
 inline.cmi : code.cmi
 instr.cmi :
 javascript.cmi : code.cmi
-js_output.cmi : pretty_print.cmi parse_bytecode.cmi javascript.cmi
+js_output.cmi : pretty_print.cmi parse_bytecode.cmi javascript.cmi code.cmi
 js_simpl.cmi : javascript.cmi
 js_var.cmi : javascript.cmi code.cmi
 linker.cmi : pretty_print.cmi
diff --git a/compiler/driver.ml b/compiler/driver.ml
index 4229c2db8b..49b665973a 100644
--- a/compiler/driver.ml
+++ b/compiler/driver.ml
@@ -150,15 +150,22 @@ let link formatter ~standalone ?linkall pretty js =
     end;
   js
 
+let coloring_disabled = Util.disabled "coloring"
+
 let coloring js =
-  if times ()
-  then Format.eprintf "Start Coloring...@.";
-  js,Js_var.program js
+  if not (coloring_disabled ())
+  then
+    begin
+      if times ()
+      then Format.eprintf "Start Coloring...@.";
+      js,Js_var.program js
+    end
+  else js, (fun v -> Code.Var.to_string v)
 
-let output formatter d (js,subs) =
+let output formatter d (js,to_string) =
   if times ()
   then Format.eprintf "Start Writing file...@.";
-  Js_output.program formatter js d
+  Js_output.program formatter d to_string js
 
 let f ?(standalone=true) ?linkall formatter d =
   !profile >>
diff --git a/compiler/js_output.ml b/compiler/js_output.ml
index 778587c69b..98b1b31559 100644
--- a/compiler/js_output.ml
+++ b/compiler/js_output.ml
@@ -35,7 +35,10 @@ module PP = Pretty_print
 
 let no_debug_info = Util.disabled ~init:true "debuginfo"
 
-module Make(D : (sig val debug_info : Parse_bytecode.debug_loc end)) = struct
+module Make(D : sig
+  val debug_info : Parse_bytecode.debug_loc
+  val to_string : Code.Var.t -> string
+end) = struct
 
   let output_debug_info f pc =
     if not (no_debug_info())
@@ -52,21 +55,21 @@ module Make(D : (sig val debug_info : Parse_bytecode.debug_loc end)) = struct
             | None -> ()
 
 
-let ident = function
-  | S s -> s
-  | V v -> Code.Var.to_string v
+  let ident = function
+    | S s -> s
+    | V v -> D.to_string v
 
-let opt_identifier f i =
-  match i with
-      None   -> ()
-    | Some i -> PP.space f; PP.string f (ident i)
+  let opt_identifier f i =
+    match i with
+        None   -> ()
+      | Some i -> PP.space f; PP.string f (ident i)
 
-let rec formal_parameter_list f l =
-  match l with
-      []     -> ()
-    | [i]    -> PP.string f (ident i)
-    | i :: r -> PP.string f (ident i); PP.string f ","; PP.break f;
-      formal_parameter_list f r
+  let rec formal_parameter_list f l =
+    match l with
+        []     -> ()
+      | [i]    -> PP.string f (ident i)
+      | i :: r -> PP.string f (ident i); PP.string f ","; PP.break f;
+        formal_parameter_list f r
 
 (*
   0 Expression
@@ -92,805 +95,804 @@ let rec formal_parameter_list f l =
   PrimaryExpression
 *)
 
-let op_prec op =
-  match op with
-      Eq | StarEq | SlashEq | ModEq | PlusEq | MinusEq
-    | LslEq | AsrEq | LsrEq | BandEq | BxorEq | BorEq -> 1, 13, 1
-  (*
-    | Or -> 3, 3, 4
-    | And -> 4, 4, 5
-    | Bor -> 5, 5, 6
-    | Bxor -> 6, 6, 7
-    | Band -> 7, 7, 8
-  *)
-    | Or -> 3, 3, 3
-    | And -> 4, 4, 4
-    | Bor -> 5, 5, 5
-    | Bxor -> 6, 6, 6
-    | Band -> 7, 7, 7
-    | EqEq | NotEq | EqEqEq | NotEqEq -> 8, 8, 9
-    | Lt | Le | InstanceOf -> 9, 9, 10
-    | Lsl | Lsr | Asr -> 10, 10, 11
-    | Plus | Minus -> 11, 11, 12
-    | Mul | Div | Mod -> 12, 12, 13
-
-let op_str op =
-  match op with
-      Eq      -> "="
-    | StarEq  -> "*="
-    | SlashEq -> "/="
-    | ModEq   -> "%="
-    | PlusEq  -> "+="
-    | MinusEq -> "-="
-    | Or      -> "||"
-    | And     -> "&&"
-    | Bor     -> "|"
-    | Bxor    -> "^"
-    | Band    -> "&"
-    | EqEq    -> "=="
-    | NotEq   -> "!="
-    | EqEqEq  -> "==="
-    | NotEqEq -> "!=="
-    | LslEq   -> "<<="
-    | AsrEq   -> ">>="
-    | LsrEq   -> ">>>="
-    | BandEq  -> "&="
-    | BxorEq  -> "^="
-    | BorEq   -> "|="
-    | Lt      -> "<"
-    | Le      -> "<="
-    | Lsl     -> "<<"
-    | Lsr     -> ">>>"
-    | Asr     -> ">>"
-    | Plus    -> "+"
-    | Minus   -> "-"
-    | Mul     -> "*"
-    | Div     -> "/"
-    | Mod     -> "%"
-    | InstanceOf -> assert false
-
-let unop_str op =
-  match op with
-      Not -> "!"
-    | Neg -> "-"
-    | Pl  -> "+"
-    | Bnot -> "~"
-    | IncrA | IncrB | DecrA | DecrB
-    | Typeof | Delete -> assert false
+  let op_prec op =
+    match op with
+        Eq | StarEq | SlashEq | ModEq | PlusEq | MinusEq
+      | LslEq | AsrEq | LsrEq | BandEq | BxorEq | BorEq -> 1, 13, 1
+    (*
+      | Or -> 3, 3, 4
+      | And -> 4, 4, 5
+      | Bor -> 5, 5, 6
+      | Bxor -> 6, 6, 7
+      | Band -> 7, 7, 8
+    *)
+      | Or -> 3, 3, 3
+      | And -> 4, 4, 4
+      | Bor -> 5, 5, 5
+      | Bxor -> 6, 6, 6
+      | Band -> 7, 7, 7
+      | EqEq | NotEq | EqEqEq | NotEqEq -> 8, 8, 9
+      | Lt | Le | InstanceOf -> 9, 9, 10
+      | Lsl | Lsr | Asr -> 10, 10, 11
+      | Plus | Minus -> 11, 11, 12
+      | Mul | Div | Mod -> 12, 12, 13
+
+  let op_str op =
+    match op with
+        Eq      -> "="
+      | StarEq  -> "*="
+      | SlashEq -> "/="
+      | ModEq   -> "%="
+      | PlusEq  -> "+="
+      | MinusEq -> "-="
+      | Or      -> "||"
+      | And     -> "&&"
+      | Bor     -> "|"
+      | Bxor    -> "^"
+      | Band    -> "&"
+      | EqEq    -> "=="
+      | NotEq   -> "!="
+      | EqEqEq  -> "==="
+      | NotEqEq -> "!=="
+      | LslEq   -> "<<="
+      | AsrEq   -> ">>="
+      | LsrEq   -> ">>>="
+      | BandEq  -> "&="
+      | BxorEq  -> "^="
+      | BorEq   -> "|="
+      | Lt      -> "<"
+      | Le      -> "<="
+      | Lsl     -> "<<"
+      | Lsr     -> ">>>"
+      | Asr     -> ">>"
+      | Plus    -> "+"
+      | Minus   -> "-"
+      | Mul     -> "*"
+      | Div     -> "/"
+      | Mod     -> "%"
+      | InstanceOf -> assert false
+
+  let unop_str op =
+    match op with
+        Not -> "!"
+      | Neg -> "-"
+      | Pl  -> "+"
+      | Bnot -> "~"
+      | IncrA | IncrB | DecrA | DecrB
+      | Typeof | Delete -> assert false
 
 (*XXX May need to be updated... *)
-let rec ends_with_if_without_else st =
-  match st with
-      If_statement (_, _, Some st) -> ends_with_if_without_else st
-    | If_statement (_, _, None)    -> true
-    | While_statement (_, st)      -> ends_with_if_without_else st
-    | _                            -> false
-
-let rec need_paren l e =
-  match e with
-      ESeq (e, _) ->
-        l <= 0 && need_paren 0 e
-    | ECond (e, _, _) ->
-      l <= 2 && need_paren 3 e
-    | EBin (op, e, _) ->
-      let (out, lft, rght) = op_prec op in
-      l <= out && need_paren lft e
-    | ECall (e, _) | EAccess (e, _) | EDot (e, _) ->
-      l <= 15 && need_paren 15 e
-    | EVar _ | EStr _ | EArr _ | EBool _ | ENum _ | EQuote _ | EUn _ | ENew _ ->
-      false
-    | EFun (_, _) | EObj _ ->
-      true
-
-let string_escape s =
-  let l = String.length s in
-  let b = Buffer.create (4 * l) in
-  let conv = "0123456789abcdef" in
-  for i = 0 to l - 1 do
-    let c = s.[i] in
-    match c with
-        '\000' when i = l - 1 || s.[i + 1] < '0' || s.[i + 1] > '9' ->
-          Buffer.add_string b "\\0"
-      | '\b' ->
-        Buffer.add_string b "\\b"
-      | '\t' ->
-        Buffer.add_string b "\\t"
-      | '\n' ->
-        Buffer.add_string b "\\n"
-    (* This escape sequence is not supported by IE < 9
-       | '\011' ->
-       Buffer.add_string b "\\v"
-    *)
-      | '\012' ->
-        Buffer.add_string b "\\f"
-      | '\r' ->
-        Buffer.add_string b "\\r"
-      | '"' ->
-        Buffer.add_string b "\\\""
-      | '\\' ->
-        Buffer.add_string b "\\\\"
-      | '\000' .. '\031' | '\127' .. '\255' ->
-        let c = Char.code c in
-        Buffer.add_string b "\\x";
-        Buffer.add_char b conv.[c lsr 4];
-        Buffer.add_char b conv.[c land 0xf]
-      | _ ->
-        Buffer.add_char b c
-  done;
-  Buffer.contents b
-
-let rec expression l f e =
-  match e with
-      EVar v ->
-        PP.string f (ident v)
-    | ESeq (e1, e2) ->
-      if l > 0 then begin PP.start_group f 1; PP.string f "(" end;
-      expression 0 f e1;
-      PP.string f ",";
-      PP.break f;
-      expression 0 f e2;
-      if l > 0 then begin PP.string f ")"; PP.end_group f end
-    | EFun ((i, l, b), pc) ->
-      output_debug_info f pc;
-      PP.start_group f 1;
-      PP.start_group f 0;
-      PP.start_group f 0;
-      PP.string f "function";
-      opt_identifier f i;
-      PP.end_group f;
-      PP.break f;
-      PP.start_group f 1;
-      PP.string f "(";
-      formal_parameter_list f l;
-      PP.string f ")";
-      PP.end_group f;
-      PP.end_group f;
-      PP.break f;
-      PP.start_group f 1;
-      PP.string f "{";
-      function_body f b;
-      PP.string f "}";
-      PP.end_group f;
-      PP.end_group f
-    | ECall (e, el) ->
-      if l > 15 then begin PP.start_group f 1; PP.string f "(" end;
-      PP.start_group f 1;
-      expression 15 f e;
-      PP.break f;
-      PP.start_group f 1;
-      PP.string f "(";
-      arguments f el;
-      PP.string f ")";
-      PP.end_group f;
-      PP.end_group f;
-      if l > 15 then begin PP.string f ")"; PP.end_group f end
-    | EStr (s, `Bytes) ->
-      PP.string f "\"";
-      PP.string f (string_escape s);
-      PP.string f "\""
-    | EBool b ->
-      PP.string f (if b then "true" else "false")
-    | ENum v ->
-      if v = infinity then
-        PP.string f "Infinity"
-      else if v = neg_infinity then begin
-        if l > 13 then
-          PP.string f "(-Infinity)"
-        else
-          PP.string f "-Infinity"
-      end else if v <> v then
-          PP.string f "NaN"
-        else begin
-          let s =
-            let vint = int_of_float v in
-          (* compiler 1000 into 1e3 *)
-            if float_of_int vint = v
-            then
-              let rec div n i =
-                if n <> 0 && n mod 10 = 0
-                then div (n/10) (succ i)
-                else
-                  if i > 2
-                  then Printf.sprintf "%de%d" n i
-                  else string_of_int vint in
-              div vint 0
-            else
-              let s1 = Printf.sprintf "%.12g" v in
-              if v = float_of_string s1 then s1 else
-                let s2 = Printf.sprintf "%.15g" v in
-                if v = float_of_string s2 then s2 else
-                  Printf.sprintf "%.18g" v
-          in
-          if
-          (* Negative numbers may need to be parenthesized. *)
-            (l > 13 && (v < 0. || (v = 0. && 1. /. v < 0.)))
-            ||
-          (* Parenthesize as well when followed by a dot. *)
-              (l = 15)
-          then begin
-            PP.string f "("; PP.string f s; PP.string f ")"
-          end else
-            PP.string f s
+  let rec ends_with_if_without_else st =
+    match st with
+        If_statement (_, _, Some st) -> ends_with_if_without_else st
+      | If_statement (_, _, None)    -> true
+      | While_statement (_, st)      -> ends_with_if_without_else st
+      | _                            -> false
+
+  let rec need_paren l e =
+    match e with
+        ESeq (e, _) ->
+          l <= 0 && need_paren 0 e
+      | ECond (e, _, _) ->
+        l <= 2 && need_paren 3 e
+      | EBin (op, e, _) ->
+        let (out, lft, rght) = op_prec op in
+        l <= out && need_paren lft e
+      | ECall (e, _) | EAccess (e, _) | EDot (e, _) ->
+        l <= 15 && need_paren 15 e
+      | EVar _ | EStr _ | EArr _ | EBool _ | ENum _ | EQuote _ | EUn _ | ENew _ ->
+        false
+      | EFun (_, _) | EObj _ ->
+        true
+
+  let string_escape s =
+    let l = String.length s in
+    let b = Buffer.create (4 * l) in
+    let conv = "0123456789abcdef" in
+    for i = 0 to l - 1 do
+      let c = s.[i] in
+      match c with
+          '\000' when i = l - 1 || s.[i + 1] < '0' || s.[i + 1] > '9' ->
+            Buffer.add_string b "\\0"
+        | '\b' ->
+          Buffer.add_string b "\\b"
+        | '\t' ->
+          Buffer.add_string b "\\t"
+        | '\n' ->
+          Buffer.add_string b "\\n"
+      (* This escape sequence is not supported by IE < 9
+         | '\011' ->
+         Buffer.add_string b "\\v"
+      *)
+        | '\012' ->
+          Buffer.add_string b "\\f"
+        | '\r' ->
+          Buffer.add_string b "\\r"
+        | '"' ->
+          Buffer.add_string b "\\\""
+        | '\\' ->
+          Buffer.add_string b "\\\\"
+        | '\000' .. '\031' | '\127' .. '\255' ->
+          let c = Char.code c in
+          Buffer.add_string b "\\x";
+          Buffer.add_char b conv.[c lsr 4];
+          Buffer.add_char b conv.[c land 0xf]
+        | _ ->
+          Buffer.add_char b c
+    done;
+    Buffer.contents b
+
+  let rec expression l f e =
+    match e with
+        EVar v ->
+          PP.string f (ident v)
+      | ESeq (e1, e2) ->
+        if l > 0 then begin PP.start_group f 1; PP.string f "(" end;
+        expression 0 f e1;
+        PP.string f ",";
+        PP.break f;
+        expression 0 f e2;
+        if l > 0 then begin PP.string f ")"; PP.end_group f end
+      | EFun ((i, l, b), pc) ->
+        output_debug_info f pc;
+        PP.start_group f 1;
+        PP.start_group f 0;
+        PP.start_group f 0;
+        PP.string f "function";
+        opt_identifier f i;
+        PP.end_group f;
+        PP.break f;
+        PP.start_group f 1;
+        PP.string f "(";
+        formal_parameter_list f l;
+        PP.string f ")";
+        PP.end_group f;
+        PP.end_group f;
+        PP.break f;
+        PP.start_group f 1;
+        PP.string f "{";
+        function_body f b;
+        PP.string f "}";
+        PP.end_group f;
+        PP.end_group f
+      | ECall (e, el) ->
+        if l > 15 then begin PP.start_group f 1; PP.string f "(" end;
+        PP.start_group f 1;
+        expression 15 f e;
+        PP.break f;
+        PP.start_group f 1;
+        PP.string f "(";
+        arguments f el;
+        PP.string f ")";
+        PP.end_group f;
+        PP.end_group f;
+        if l > 15 then begin PP.string f ")"; PP.end_group f end
+      | EStr (s, `Bytes) ->
+        PP.string f "\"";
+        PP.string f (string_escape s);
+        PP.string f "\""
+      | EBool b ->
+        PP.string f (if b then "true" else "false")
+      | ENum v ->
+        if v = infinity then
+          PP.string f "Infinity"
+        else if v = neg_infinity then begin
+          if l > 13 then
+            PP.string f "(-Infinity)"
+          else
+            PP.string f "-Infinity"
+        end else if v <> v then
+            PP.string f "NaN"
+          else begin
+            let s =
+              let vint = int_of_float v in
+            (* compiler 1000 into 1e3 *)
+              if float_of_int vint = v
+              then
+                let rec div n i =
+                  if n <> 0 && n mod 10 = 0
+                  then div (n/10) (succ i)
+                  else
+                    if i > 2
+                    then Printf.sprintf "%de%d" n i
+                    else string_of_int vint in
+                div vint 0
+              else
+                let s1 = Printf.sprintf "%.12g" v in
+                if v = float_of_string s1 then s1 else
+                  let s2 = Printf.sprintf "%.15g" v in
+                  if v = float_of_string s2 then s2 else
+                    Printf.sprintf "%.18g" v
+            in
+            if
+            (* Negative numbers may need to be parenthesized. *)
+              (l > 13 && (v < 0. || (v = 0. && 1. /. v < 0.)))
+              ||
+              (* Parenthesize as well when followed by a dot. *)
+                (l = 15)
+            then begin
+              PP.string f "("; PP.string f s; PP.string f ")"
+            end else
+              PP.string f s
+          end
+      | EUn (Typeof, e) ->
+        if l > 13 then begin PP.start_group f 1; PP.string f "(" end;
+        PP.start_group f 0;
+        PP.string f "typeof";
+        PP.space f;
+        expression 13 f e;
+        PP.end_group f;
+        if l > 13 then begin PP.string f ")"; PP.end_group f end
+      | EUn (Delete, e) ->
+        if l > 13 then begin PP.start_group f 1; PP.string f "(" end;
+        PP.start_group f 0;
+        PP.string f "delete";
+        PP.space f;
+        expression 13 f e;
+        PP.end_group f;
+        if l > 13 then begin PP.string f ")"; PP.end_group f end
+      | EUn ((IncrA | DecrA | IncrB | DecrB) as op,e) ->
+        if l > 13 then begin PP.start_group f 1; PP.string f "(" end;
+        if op = IncrA || op = DecrA
+        then expression 13 f e;
+        if op = IncrA || op = IncrB
+        then PP.string f "++"
+        else PP.string f "--";
+        if op = IncrB || op = DecrB
+        then expression 13 f e;
+        if l > 13 then begin PP.string f ")"; PP.end_group f end
+      | EUn (op, e) ->
+        if l > 13 then begin PP.start_group f 1; PP.string f "(" end;
+        PP.string f (unop_str op);
+        expression 13 f e;
+        if l > 13 then begin PP.string f ")"; PP.end_group f end
+      | EBin (InstanceOf, e1, e2) ->
+        let (out, lft, rght) = op_prec InstanceOf in
+        if l > out then begin PP.start_group f 1; PP.string f "(" end;
+        PP.start_group f 0;
+        expression lft f e1;
+        PP.space f;
+        PP.string f "instanceof";
+        PP.space f;
+        expression rght f e2;
+        PP.end_group f;
+        if l > out then begin PP.string f ")"; PP.end_group f end
+      | EBin (op, e1, e2) ->
+        let (out, lft, rght) = op_prec op in
+        if l > out then begin PP.start_group f 1; PP.string f "(" end;
+        expression lft f e1;
+        PP.string f (op_str op);
+        PP.break f;
+        expression rght f e2;
+        if l > out then begin PP.string f ")"; PP.end_group f end
+      | EArr el ->
+        PP.start_group f 1;
+        PP.string f "[";
+        element_list f el;
+        PP.string f "]";
+        PP.end_group f
+      | EAccess (e, e') ->
+        if l > 15 then begin PP.start_group f 1; PP.string f "(" end;
+        PP.start_group f 1;
+        expression 15 f e;
+        PP.break f;
+        PP.start_group f 1;
+        PP.string f "[";
+        expression 0 f e';
+        PP.string f "]";
+        PP.end_group f;
+        PP.end_group f;
+        if l > 15 then begin PP.string f ")"; PP.end_group f end
+      | EDot (e, nm) ->
+        if l > 15 then begin PP.start_group f 1; PP.string f "(" end;
+        expression 15 f e;
+        PP.string f ".";
+        PP.string f nm;
+        if l > 15 then begin PP.string f ")"; PP.end_group f end
+      | ENew (e, None) -> (*FIX: should omit parentheses when possible*)
+        if l > 15 then begin PP.start_group f 1; PP.string f "(" end;
+        PP.start_group f 1;
+        PP.string f "new";
+        PP.space f;
+        expression 16 f e;
+        PP.break f;
+        PP.string f "()";
+        PP.end_group f;
+        if l > 15 then begin PP.string f ")"; PP.end_group f end
+      | ENew (e, Some el) ->
+        if l > 15 then begin PP.start_group f 1; PP.string f "(" end;
+        PP.start_group f 1;
+        PP.string f "new";
+        PP.space f;
+        expression 16 f e;
+        PP.break f;
+        PP.start_group f 1;
+        PP.string f "(";
+        arguments f el;
+        PP.string f ")";
+        PP.end_group f;
+        PP.end_group f;
+        if l > 15 then begin PP.string f ")"; PP.end_group f end
+      | ECond (e, e1, e2) ->
+        if l > 2 then begin PP.start_group f 1; PP.string f "(" end;
+        PP.start_group f 1;
+        PP.start_group f 0;
+        expression 3 f e;
+        PP.end_group f;
+        PP.break f;
+        PP.start_group f 1;
+        PP.string f "?";
+        expression 1 f e1;
+        PP.end_group f;
+        PP.break f;
+        PP.start_group f 1;
+        PP.string f ":";
+        expression 1 f e2;
+        PP.end_group f;
+        PP.end_group f;
+        if l > 2 then begin PP.string f ")"; PP.end_group f end
+      | EObj lst ->
+        PP.start_group f 1;
+        PP.string f "{";
+        property_name_and_value_list f lst;
+        PP.string f "}";
+        PP.end_group f
+      | EQuote s ->
+        PP.string f "(";
+        PP.string f s;
+        PP.string f ")"
+
+  and property_name f n =
+    match n with
+        PNI s -> PP.string f s
+      | PNS s -> PP.string f "\""; PP.string f s; PP.string f "\""
+      | PNN v -> expression 0 f (ENum v)
+
+  and property_name_and_value_list f l =
+    match l with
+        [] ->
+          ()
+      | [(pn, e)] ->
+        PP.start_group f 0;
+        property_name f pn;
+        PP.string f ":";
+        PP.break f;
+        expression 1 f e;
+        PP.end_group f
+      | (pn, e) :: r ->
+        PP.start_group f 0;
+        property_name f pn;
+        PP.string f ":";
+        PP.break f;
+        expression 1 f e;
+        PP.end_group f;
+        PP.string f ",";
+        PP.break f;
+        property_name_and_value_list f r
+
+  and element_list f el =
+    match el with
+        []     ->
+          ()
+      | [e]    ->
+        begin match e with
+            None   -> PP.string f ","
+          | Some e -> PP.start_group f 0; expression 1 f e; PP.end_group f
         end
-    | EUn (Typeof, e) ->
-      if l > 13 then begin PP.start_group f 1; PP.string f "(" end;
-      PP.start_group f 0;
-      PP.string f "typeof";
-      PP.space f;
-      expression 13 f e;
-      PP.end_group f;
-      if l > 13 then begin PP.string f ")"; PP.end_group f end
-    | EUn (Delete, e) ->
-      if l > 13 then begin PP.start_group f 1; PP.string f "(" end;
-      PP.start_group f 0;
-      PP.string f "delete";
-      PP.space f;
-      expression 13 f e;
-      PP.end_group f;
-      if l > 13 then begin PP.string f ")"; PP.end_group f end
-    | EUn ((IncrA | DecrA | IncrB | DecrB) as op,e) ->
-      if l > 13 then begin PP.start_group f 1; PP.string f "(" end;
-      if op = IncrA || op = DecrA
-      then expression 13 f e;
-      if op = IncrA || op = IncrB
-      then PP.string f "++"
-      else PP.string f "--";
-      if op = IncrB || op = DecrB
-      then expression 13 f e;
-      if l > 13 then begin PP.string f ")"; PP.end_group f end
-    | EUn (op, e) ->
-      if l > 13 then begin PP.start_group f 1; PP.string f "(" end;
-      PP.string f (unop_str op);
-      expression 13 f e;
-      if l > 13 then begin PP.string f ")"; PP.end_group f end
-    | EBin (InstanceOf, e1, e2) ->
-      let (out, lft, rght) = op_prec InstanceOf in
-      if l > out then begin PP.start_group f 1; PP.string f "(" end;
-      PP.start_group f 0;
-      expression lft f e1;
-      PP.space f;
-      PP.string f "instanceof";
-      PP.space f;
-      expression rght f e2;
-      PP.end_group f;
-      if l > out then begin PP.string f ")"; PP.end_group f end
-    | EBin (op, e1, e2) ->
-      let (out, lft, rght) = op_prec op in
-      if l > out then begin PP.start_group f 1; PP.string f "(" end;
-      expression lft f e1;
-      PP.string f (op_str op);
-      PP.break f;
-      expression rght f e2;
-      if l > out then begin PP.string f ")"; PP.end_group f end
-    | EArr el ->
-      PP.start_group f 1;
-      PP.string f "[";
-      element_list f el;
-      PP.string f "]";
-      PP.end_group f
-    | EAccess (e, e') ->
-      if l > 15 then begin PP.start_group f 1; PP.string f "(" end;
-      PP.start_group f 1;
-      expression 15 f e;
-      PP.break f;
-      PP.start_group f 1;
-      PP.string f "[";
-      expression 0 f e';
-      PP.string f "]";
-      PP.end_group f;
-      PP.end_group f;
-      if l > 15 then begin PP.string f ")"; PP.end_group f end
-    | EDot (e, nm) ->
-      if l > 15 then begin PP.start_group f 1; PP.string f "(" end;
-      expression 15 f e;
-      PP.string f ".";
-      PP.string f nm;
-      if l > 15 then begin PP.string f ")"; PP.end_group f end
-    | ENew (e, None) -> (*FIX: should omit parentheses when possible*)
-      if l > 15 then begin PP.start_group f 1; PP.string f "(" end;
-      PP.start_group f 1;
-      PP.string f "new";
-      PP.space f;
-      expression 16 f e;
-      PP.break f;
-      PP.string f "()";
-      PP.end_group f;
-      if l > 15 then begin PP.string f ")"; PP.end_group f end
-    | ENew (e, Some el) ->
-      if l > 15 then begin PP.start_group f 1; PP.string f "(" end;
-      PP.start_group f 1;
-      PP.string f "new";
-      PP.space f;
-      expression 16 f e;
-      PP.break f;
-      PP.start_group f 1;
-      PP.string f "(";
-      arguments f el;
-      PP.string f ")";
-      PP.end_group f;
-      PP.end_group f;
-      if l > 15 then begin PP.string f ")"; PP.end_group f end
-    | ECond (e, e1, e2) ->
-      if l > 2 then begin PP.start_group f 1; PP.string f "(" end;
-      PP.start_group f 1;
-      PP.start_group f 0;
-      expression 3 f e;
-      PP.end_group f;
-      PP.break f;
-      PP.start_group f 1;
-      PP.string f "?";
-      expression 1 f e1;
-      PP.end_group f;
-      PP.break f;
-      PP.start_group f 1;
-      PP.string f ":";
-      expression 1 f e2;
-      PP.end_group f;
-      PP.end_group f;
-      if l > 2 then begin PP.string f ")"; PP.end_group f end
-    | EObj lst ->
-      PP.start_group f 1;
-      PP.string f "{";
-      property_name_and_value_list f lst;
-      PP.string f "}";
-      PP.end_group f
-    | EQuote s ->
-      PP.string f "(";
-      PP.string f s;
-      PP.string f ")"
-
-and property_name f n =
-  match n with
-      PNI s -> PP.string f s
-    | PNS s -> PP.string f "\""; PP.string f s; PP.string f "\""
-    | PNN v -> expression 0 f (ENum v)
-
-and property_name_and_value_list f l =
-  match l with
-      [] ->
-        ()
-    | [(pn, e)] ->
-      PP.start_group f 0;
-      property_name f pn;
-      PP.string f ":";
-      PP.break f;
-      expression 1 f e;
-      PP.end_group f
-    | (pn, e) :: r ->
-      PP.start_group f 0;
-      property_name f pn;
-      PP.string f ":";
-      PP.break f;
-      expression 1 f e;
-      PP.end_group f;
-      PP.string f ",";
-      PP.break f;
-      property_name_and_value_list f r
-
-and element_list f el =
-  match el with
-      []     ->
-        ()
-    | [e]    ->
-      begin match e with
-          None   -> PP.string f ","
-        | Some e -> PP.start_group f 0; expression 1 f e; PP.end_group f
-      end
-    | e :: r ->
-      begin match e with
-          None   -> ()
-        | Some e -> PP.start_group f 0; expression 1 f e; PP.end_group f
-      end;
-      PP.string f ","; PP.break f; element_list f r
-
-and function_body f b = source_elements f b
-
-and arguments f l =
-  match l with
-      []     -> ()
-    | [e]    -> PP.start_group f 0; expression 1 f e; PP.end_group f
-    | e :: r -> PP.start_group f 0; expression 1 f e; PP.end_group f;
-      PP.string f ","; PP.break f; arguments f r
-
-and variable_declaration f (i, init) =
-  match init with
-      None   ->
-        PP.string f (ident i)
-    | Some e ->
-      PP.start_group f 1;
-      PP.string f (ident i); PP.string f "="; PP.break f; expression 1 f e;
-      PP.end_group f
-
-and variable_declaration_list f l =
-  match l with
-      []     -> assert false
-    | [d]    -> variable_declaration f d
-    | d :: r -> variable_declaration f d; PP.string f ","; PP.break f;
-      variable_declaration_list f r
-
-and opt_expression l f e =
-  match e with
-      None   -> ()
-    | Some e -> expression l f e
-
-and statement f s =
-  match s with
-      Block b ->
-        block f b
-    | Variable_statement l ->
-      begin match l with
-          []  ->
-            ()
-        | [(i, None)] ->
+      | e :: r ->
+        begin match e with
+            None   -> ()
+          | Some e -> PP.start_group f 0; expression 1 f e; PP.end_group f
+        end;
+        PP.string f ","; PP.break f; element_list f r
+
+  and function_body f b = source_elements f b
+
+  and arguments f l =
+    match l with
+        []     -> ()
+      | [e]    -> PP.start_group f 0; expression 1 f e; PP.end_group f
+      | e :: r -> PP.start_group f 0; expression 1 f e; PP.end_group f;
+        PP.string f ","; PP.break f; arguments f r
+
+  and variable_declaration f (i, init) =
+    match init with
+        None   ->
+          PP.string f (ident i)
+      | Some e ->
+        PP.start_group f 1;
+        PP.string f (ident i); PP.string f "="; PP.break f; expression 1 f e;
+        PP.end_group f
+
+  and variable_declaration_list f l =
+    match l with
+        []     -> assert false
+      | [d]    -> variable_declaration f d
+      | d :: r -> variable_declaration f d; PP.string f ","; PP.break f;
+        variable_declaration_list f r
+
+  and opt_expression l f e =
+    match e with
+        None   -> ()
+      | Some e -> expression l f e
+
+  and statement f s =
+    match s with
+        Block b ->
+          block f b
+      | Variable_statement l ->
+        begin match l with
+            []  ->
+              ()
+          | [(i, None)] ->
+            PP.start_group f 1;
+            PP.string f "var";
+            PP.space f;
+            PP.string f (ident i);
+            PP.string f ";";
+            PP.end_group f
+          | [(i, Some e)] ->
+            PP.start_group f 1;
+            PP.string f "var";
+            PP.space f;
+            PP.string f (ident i);
+            PP.string f "=";
+            PP.genbreak f "" 1;
+            PP.start_group f 0;
+            expression 1 f e;
+            PP.string f ";";
+            PP.end_group f;
+            PP.end_group f
+          | l ->
+            PP.start_group f 1;
+            PP.string f "var";
+            PP.space f;
+            variable_declaration_list f l;
+            PP.string f ";";
+            PP.end_group f
+        end
+      | Expression_statement (EVar _, pc)-> ()
+      | Expression_statement (e, pc) ->
+      (* Parentheses are required when the expression
+         starts syntactically with "{" or "function" *)
+        output_debug_info f pc;
+        if need_paren 0 e then begin
           PP.start_group f 1;
-          PP.string f "var";
-          PP.space f;
-          PP.string f (ident i);
-          PP.string f ";";
+          PP.string f "(";
+          expression 0 f e;
+          PP.string f ");";
           PP.end_group f
-        | [(i, Some e)] ->
-          PP.start_group f 1;
-          PP.string f "var";
-          PP.space f;
-          PP.string f (ident i);
-          PP.string f "=";
-          PP.genbreak f "" 1;
+        end else begin
           PP.start_group f 0;
-          expression 1 f e;
-          PP.string f ";";
-          PP.end_group f;
-          PP.end_group f
-        | l ->
-          PP.start_group f 1;
-          PP.string f "var";
-          PP.space f;
-          variable_declaration_list f l;
+          expression 0 f e;
           PP.string f ";";
           PP.end_group f
-      end
-    | Expression_statement (EVar _, pc)-> ()
-    | Expression_statement (e, pc) ->
-      (* Parentheses are required when the expression
-         starts syntactically with "{" or "function" *)
-      output_debug_info f pc;
-      if need_paren 0 e then begin
+        end
+      | If_statement (e, s1, (Some _ as s2)) when ends_with_if_without_else s1 ->
+      (* Dangling else issue... *)
+        statement f (If_statement (e, Block [s1], s2))
+      | If_statement (e, s1, Some (Block _ as s2)) ->
+        PP.start_group f 0;
+        PP.start_group f 1;
+        PP.string f "if";
+        PP.break f;
         PP.start_group f 1;
         PP.string f "(";
         expression 0 f e;
-        PP.string f ");";
+        PP.string f ")";
+        PP.end_group f;
+        PP.end_group f;
+        PP.genbreak f "" 1;
+        PP.start_group f 0;
+        statement f s1;
+        PP.end_group f;
+        PP.break f;
+        PP.string f "else";
+        PP.genbreak f "" 1;
+        PP.start_group f 0;
+        statement f s2;
+        PP.end_group f;
         PP.end_group f
-      end else begin
+      | If_statement (e, s1, Some s2) ->
         PP.start_group f 0;
+        PP.start_group f 1;
+        PP.string f "if";
+        PP.break f;
+        PP.start_group f 1;
+        PP.string f "(";
         expression 0 f e;
-        PP.string f ";";
+        PP.string f ")";
+        PP.end_group f;
+        PP.end_group f;
+        PP.genbreak f "" 1;
+        PP.start_group f 0;
+        statement f s1;
+        PP.end_group f;
+        PP.break f;
+        PP.string f "else";
+        PP.genbreak f " " 1;
+        PP.start_group f 0;
+        statement f s2;
+        PP.end_group f;
         PP.end_group f
-      end
-    | If_statement (e, s1, (Some _ as s2)) when ends_with_if_without_else s1 ->
-      (* Dangling else issue... *)
-      statement f (If_statement (e, Block [s1], s2))
-    | If_statement (e, s1, Some (Block _ as s2)) ->
-      PP.start_group f 0;
-      PP.start_group f 1;
-      PP.string f "if";
-      PP.break f;
-      PP.start_group f 1;
-      PP.string f "(";
-      expression 0 f e;
-      PP.string f ")";
-      PP.end_group f;
-      PP.end_group f;
-      PP.genbreak f "" 1;
-      PP.start_group f 0;
-      statement f s1;
-      PP.end_group f;
-      PP.break f;
-      PP.string f "else";
-      PP.genbreak f "" 1;
-      PP.start_group f 0;
-      statement f s2;
-      PP.end_group f;
-      PP.end_group f
-    | If_statement (e, s1, Some s2) ->
-      PP.start_group f 0;
-      PP.start_group f 1;
-      PP.string f "if";
-      PP.break f;
-      PP.start_group f 1;
-      PP.string f "(";
-      expression 0 f e;
-      PP.string f ")";
-      PP.end_group f;
-      PP.end_group f;
-      PP.genbreak f "" 1;
-      PP.start_group f 0;
-      statement f s1;
-      PP.end_group f;
-      PP.break f;
-      PP.string f "else";
-      PP.genbreak f " " 1;
-      PP.start_group f 0;
-      statement f s2;
-      PP.end_group f;
-      PP.end_group f
-    | If_statement (e, s1, None) ->
-      PP.start_group f 1;
-      PP.start_group f 0;
-      PP.string f "if";
-      PP.break f;
-      PP.start_group f 1;
-      PP.string f "(";
-      expression 0 f e;
-      PP.string f ")";
-      PP.end_group f;
-      PP.end_group f;
-      PP.break f;
-      PP.start_group f 0;
-      statement f s1;
-      PP.end_group f;
-      PP.end_group f
-    | While_statement (e, s) ->
-      PP.start_group f 1;
-      PP.start_group f 0;
-      PP.string f "while";
-      PP.break f;
-      PP.start_group f 1;
-      PP.string f "(";
-      expression 0 f e;
-      PP.string f ")";
-      PP.end_group f;
-      PP.end_group f;
-      PP.break f;
-      PP.start_group f 0;
-      statement f s;
-      PP.end_group f;
-      PP.end_group f
-    | Do_while_statement (Block _ as s, e) ->
-      PP.start_group f 0;
-      PP.string f "do";
-      PP.genbreak f "" 1;
-      PP.start_group f 0;
-      statement f s;
-      PP.end_group f;
-      PP.break f;
-      PP.string f "while";
-      PP.genbreak f "" 1;
-      PP.start_group f 1;
-      PP.string f "(";
-      expression 0 f e;
-      PP.string f ")";
-      PP.end_group f;
-      PP.end_group f
-    | Do_while_statement (s, e) ->
-      PP.start_group f 0;
-      PP.string f "do";
-      PP.genbreak f " " 1;
-      PP.start_group f 0;
-      statement f s;
-      PP.end_group f;
-      PP.break f;
-      PP.string f "while";
-      PP.genbreak f "" 1;
-      PP.start_group f 1;
-      PP.string f "(";
-      expression 0 f e;
-      PP.string f ")";
-      PP.end_group f;
-      PP.end_group f
-    | For_statement (e1, e2, e3, s, pc) ->
-      output_debug_info f pc;
-      PP.start_group f 1;
-      PP.start_group f 0;
-      PP.string f "for";
-      PP.break f;
-      PP.start_group f 1;
-      PP.string f "(";
-      opt_expression 0 f e1;
-      PP.string f ";"; PP.break f;
-      opt_expression 0 f e2;
-      PP.string f ";"; PP.break f;
-      opt_expression 0 f e3;
-      PP.string f ")";
-      PP.end_group f;
-      PP.end_group f;
-      PP.break f;
-      PP.start_group f 0;
-      statement f s;
-      PP.end_group f;
-      PP.end_group f
-    | Continue_statement None ->
-      PP.string f "continue;"
-    | Continue_statement (Some s) ->
-      PP.string f "continue ";
-      PP.string f s;
-      PP.string f ";"
-    | Break_statement None ->
-      PP.string f "break;"
-    | Break_statement (Some s) ->
-      PP.string f "break ";
-      PP.string f s;
-      PP.string f ";"
-    | Return_statement e ->
-      begin match e with
-          None   ->
-            PP.string f "return;"
-        | Some (EFun ((i, l, b), pc)) ->
-          output_debug_info f pc;
-          PP.start_group f 1;
-          PP.start_group f 0;
-          PP.start_group f 0;
-          PP.string f "return function";
-          opt_identifier f i;
-          PP.end_group f;
-          PP.break f;
-          PP.start_group f 1;
-          PP.string f "(";
-          formal_parameter_list f l;
-          PP.string f ")";
-          PP.end_group f;
-          PP.end_group f;
-          PP.break f;
-          PP.start_group f 1;
-          PP.string f "{";
-          function_body f b;
-          PP.string f "};";
-          PP.end_group f;
-          PP.end_group f
-        | Some e ->
-          PP.start_group f 7;
-          PP.string f "return ";
-          PP.start_group f 0;
-          expression 0 f e;
-          PP.string f ";";
-          PP.end_group f;
-          PP.end_group f
+      | If_statement (e, s1, None) ->
+        PP.start_group f 1;
+        PP.start_group f 0;
+        PP.string f "if";
+        PP.break f;
+        PP.start_group f 1;
+        PP.string f "(";
+        expression 0 f e;
+        PP.string f ")";
+        PP.end_group f;
+        PP.end_group f;
+        PP.break f;
+        PP.start_group f 0;
+        statement f s1;
+        PP.end_group f;
+        PP.end_group f
+      | While_statement (e, s) ->
+        PP.start_group f 1;
+        PP.start_group f 0;
+        PP.string f "while";
+        PP.break f;
+        PP.start_group f 1;
+        PP.string f "(";
+        expression 0 f e;
+        PP.string f ")";
+        PP.end_group f;
+        PP.end_group f;
+        PP.break f;
+        PP.start_group f 0;
+        statement f s;
+        PP.end_group f;
+        PP.end_group f
+      | Do_while_statement (Block _ as s, e) ->
+        PP.start_group f 0;
+        PP.string f "do";
+        PP.genbreak f "" 1;
+        PP.start_group f 0;
+        statement f s;
+        PP.end_group f;
+        PP.break f;
+        PP.string f "while";
+        PP.genbreak f "" 1;
+        PP.start_group f 1;
+        PP.string f "(";
+        expression 0 f e;
+        PP.string f ")";
+        PP.end_group f;
+        PP.end_group f
+      | Do_while_statement (s, e) ->
+        PP.start_group f 0;
+        PP.string f "do";
+        PP.genbreak f " " 1;
+        PP.start_group f 0;
+        statement f s;
+        PP.end_group f;
+        PP.break f;
+        PP.string f "while";
+        PP.genbreak f "" 1;
+        PP.start_group f 1;
+        PP.string f "(";
+        expression 0 f e;
+        PP.string f ")";
+        PP.end_group f;
+        PP.end_group f
+      | For_statement (e1, e2, e3, s, pc) ->
+        output_debug_info f pc;
+        PP.start_group f 1;
+        PP.start_group f 0;
+        PP.string f "for";
+        PP.break f;
+        PP.start_group f 1;
+        PP.string f "(";
+        opt_expression 0 f e1;
+        PP.string f ";"; PP.break f;
+        opt_expression 0 f e2;
+        PP.string f ";"; PP.break f;
+        opt_expression 0 f e3;
+        PP.string f ")";
+        PP.end_group f;
+        PP.end_group f;
+        PP.break f;
+        PP.start_group f 0;
+        statement f s;
+        PP.end_group f;
+        PP.end_group f
+      | Continue_statement None ->
+        PP.string f "continue;"
+      | Continue_statement (Some s) ->
+        PP.string f "continue ";
+        PP.string f s;
+        PP.string f ";"
+      | Break_statement None ->
+        PP.string f "break;"
+      | Break_statement (Some s) ->
+        PP.string f "break ";
+        PP.string f s;
+        PP.string f ";"
+      | Return_statement e ->
+        begin match e with
+            None   ->
+              PP.string f "return;"
+          | Some (EFun ((i, l, b), pc)) ->
+            output_debug_info f pc;
+            PP.start_group f 1;
+            PP.start_group f 0;
+            PP.start_group f 0;
+            PP.string f "return function";
+            opt_identifier f i;
+            PP.end_group f;
+            PP.break f;
+            PP.start_group f 1;
+            PP.string f "(";
+            formal_parameter_list f l;
+            PP.string f ")";
+            PP.end_group f;
+            PP.end_group f;
+            PP.break f;
+            PP.start_group f 1;
+            PP.string f "{";
+            function_body f b;
+            PP.string f "};";
+            PP.end_group f;
+            PP.end_group f
+          | Some e ->
+            PP.start_group f 7;
+            PP.string f "return ";
+            PP.start_group f 0;
+            expression 0 f e;
+            PP.string f ";";
+            PP.end_group f;
+            PP.end_group f
       (* There MUST be a space between the return and its
          argument. A line return will not work *)
-      end
-    | Labelled_statement (i, s) ->
-      PP.string f i;
-      PP.string f ":";
-      PP.break f;
-      statement f s
-    | Switch_statement (e, cc, def) ->
-      PP.start_group f 1;
-      PP.start_group f 0;
-      PP.string f "switch";
-      PP.break f;
-      PP.start_group f 1;
-      PP.string f "(";
-      expression 0 f e;
-      PP.string f ")";
-      PP.end_group f;
-      PP.end_group f;
-      PP.break f;
-      PP.start_group f 1;
-      PP.string f "{";
-      List.iter
-        (fun (e, sl) ->
-          PP.start_group f 1;
-          PP.start_group f 1;
-          PP.string f "case";
-          PP.space f;
-          expression 0 f e;
-          PP.string f ":";
-          PP.end_group f;
-          PP.break f;
-          PP.start_group f 0;
-          statement_list f sl;
-          PP.end_group f;
-          PP.end_group f;
-          PP.break f)
-        cc;
-      begin match def with
-          None ->
-            ()
-        | Some def ->
-          PP.start_group f 1;
-          PP.string f "default:";
-          PP.break f;
-          PP.start_group f 0;
-          statement_list f def;
-          PP.end_group f;
-          PP.end_group f
-      end;
-      PP.string f "}";
-      PP.end_group f;
-      PP.end_group f
-    | Throw_statement e ->
-      PP.start_group f 6;
-      PP.string f "throw ";
-      PP.start_group f 0;
-      expression 0 f e;
-      PP.string f ";";
-      PP.end_group f;
-      PP.end_group f
-  (* There must be a space between the return and its
-     argument. A line return would not work *)
-    | Try_statement (b, ctch, fin, pc) ->
-      output_debug_info f pc;
-      PP.start_group f 0;
-      PP.string f "try";
-      PP.genbreak f " " 1;
-      block f b;
-      begin match ctch with
-          None ->
-            ()
-        | Some (i, b) ->
-          PP.break f;
-          PP.start_group f 1;
-          PP.string f "catch(";
-          PP.string f (ident i);
-          PP.string f ")";
-          PP.break f;
-          block f b;
-          PP.end_group f
-      end;
-      begin match fin with
-          None ->
-            ()
-        | Some b ->
-          PP.break f;
-          PP.start_group f 1;
-          PP.string f "finally";
-          PP.space f;
-          block f b;
-          PP.end_group f
-      end;
-      PP.end_group f
-
-and statement_list f b =
-  match b with
-      []     -> ()
-    | [s]    -> statement f s
-    | s :: r -> statement f s; PP.break f; statement_list f r
-
-and block f b =
-  PP.start_group f 1;
-  PP.string f "{";
-  statement_list f b;
-  PP.string f "}";
-  PP.end_group f
-
-and source_element f se =
-  match se with
-      Statement s ->
+        end
+      | Labelled_statement (i, s) ->
+        PP.string f i;
+        PP.string f ":";
+        PP.break f;
         statement f s
-    | Function_declaration (i, l, b, pc) ->
-      output_debug_info f pc;
-      PP.start_group f 1;
-      PP.start_group f 0;
-      PP.start_group f 0;
-      PP.string f "function";
-      PP.space f;
-      PP.string f (ident i);
-      PP.end_group f;
-      PP.break f;
-      PP.start_group f 1;
-      PP.string f "(";
-      formal_parameter_list f l;
-      PP.string f ")";
-      PP.end_group f;
-      PP.end_group f;
-      PP.break f;
-      PP.start_group f 1;
-      PP.string f "{";
-      function_body f b;
-      PP.string f "}";
-      PP.end_group f;
-      PP.end_group f
-
-and source_elements f se =
-  match se with
-      []     -> ()
-    | [s]    -> source_element f s
-    | s :: r -> source_element f s; PP.break f; source_elements f r
-
- end
-
-let statement f s dl =
-  let module O = Make(struct let debug_info = dl end) in
-  O.statement f s
-
-let program f se dl =
-  let module O = Make(struct let debug_info = dl end) in
+      | Switch_statement (e, cc, def) ->
+        PP.start_group f 1;
+        PP.start_group f 0;
+        PP.string f "switch";
+        PP.break f;
+        PP.start_group f 1;
+        PP.string f "(";
+        expression 0 f e;
+        PP.string f ")";
+        PP.end_group f;
+        PP.end_group f;
+        PP.break f;
+        PP.start_group f 1;
+        PP.string f "{";
+        List.iter
+          (fun (e, sl) ->
+            PP.start_group f 1;
+            PP.start_group f 1;
+            PP.string f "case";
+            PP.space f;
+            expression 0 f e;
+            PP.string f ":";
+            PP.end_group f;
+            PP.break f;
+            PP.start_group f 0;
+            statement_list f sl;
+            PP.end_group f;
+            PP.end_group f;
+            PP.break f)
+          cc;
+        begin match def with
+            None ->
+              ()
+          | Some def ->
+            PP.start_group f 1;
+            PP.string f "default:";
+            PP.break f;
+            PP.start_group f 0;
+            statement_list f def;
+            PP.end_group f;
+            PP.end_group f
+        end;
+        PP.string f "}";
+        PP.end_group f;
+        PP.end_group f
+      | Throw_statement e ->
+        PP.start_group f 6;
+        PP.string f "throw ";
+        PP.start_group f 0;
+        expression 0 f e;
+        PP.string f ";";
+        PP.end_group f;
+        PP.end_group f
+    (* There must be a space between the return and its
+       argument. A line return would not work *)
+      | Try_statement (b, ctch, fin, pc) ->
+        output_debug_info f pc;
+        PP.start_group f 0;
+        PP.string f "try";
+        PP.genbreak f " " 1;
+        block f b;
+        begin match ctch with
+            None ->
+              ()
+          | Some (i, b) ->
+            PP.break f;
+            PP.start_group f 1;
+            PP.string f "catch(";
+            PP.string f (ident i);
+            PP.string f ")";
+            PP.break f;
+            block f b;
+            PP.end_group f
+        end;
+        begin match fin with
+            None ->
+              ()
+          | Some b ->
+            PP.break f;
+            PP.start_group f 1;
+            PP.string f "finally";
+            PP.space f;
+            block f b;
+            PP.end_group f
+        end;
+        PP.end_group f
+
+  and statement_list f b =
+    match b with
+        []     -> ()
+      | [s]    -> statement f s
+      | s :: r -> statement f s; PP.break f; statement_list f r
+
+  and block f b =
+    PP.start_group f 1;
+    PP.string f "{";
+    statement_list f b;
+    PP.string f "}";
+    PP.end_group f
+
+  and source_element f se =
+    match se with
+        Statement s ->
+          statement f s
+      | Function_declaration (i, l, b, pc) ->
+        output_debug_info f pc;
+        PP.start_group f 1;
+        PP.start_group f 0;
+        PP.start_group f 0;
+        PP.string f "function";
+        PP.space f;
+        PP.string f (ident i);
+        PP.end_group f;
+        PP.break f;
+        PP.start_group f 1;
+        PP.string f "(";
+        formal_parameter_list f l;
+        PP.string f ")";
+        PP.end_group f;
+        PP.end_group f;
+        PP.break f;
+        PP.start_group f 1;
+        PP.string f "{";
+        function_body f b;
+        PP.string f "}";
+        PP.end_group f;
+        PP.end_group f
+
+  and source_elements f se =
+    match se with
+        []     -> ()
+      | [s]    -> source_element f s
+      | s :: r -> source_element f s; PP.break f; source_elements f r
+
+end
+
+let program f dl to_string se =
+  let module O = Make(struct
+    let debug_info = dl
+    let to_string = to_string
+  end) in
   PP.start_group f 0; O.source_elements f se; PP.end_group f; PP.newline f
diff --git a/compiler/js_output.mli b/compiler/js_output.mli
index 20686ec1d5..69c717074e 100644
--- a/compiler/js_output.mli
+++ b/compiler/js_output.mli
@@ -18,4 +18,4 @@
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  *)
 
-val program : Pretty_print.t -> Javascript.program -> Parse_bytecode.debug_loc -> unit
+val program : Pretty_print.t ->  Parse_bytecode.debug_loc -> (Code.Var.t -> string) -> Javascript.program -> unit
diff --git a/compiler/js_var.ml b/compiler/js_var.ml
index f897700026..5c9c8c231b 100644
--- a/compiler/js_var.ml
+++ b/compiler/js_var.ml
@@ -1,5 +1,7 @@
 open Javascript
 
+let debug = Util.debug "coloring"
+
 module G = Graph.Pack.Graph
 (* module G = struct *)
 (*   include Graph.Imperative.Matrix.Graph *)
@@ -230,37 +232,41 @@ let program p =
   let t = source_elts (create()) p in
   assert(S.cardinal (get_free t) = 0);
   let t = mark t in
-  Printf.printf "compute graph degree\n%!";
+  if debug ()
+  then Printf.eprintf "compute graph degree\n%!";
   let degree = G.fold_vertex (fun v acc -> max acc (G.in_degree t.g v)) t.g 0 in
   let percent x all =
     float_of_int x /. float_of_int all *. 100. in
   let nb_vertex = (G.nb_vertex t.g) in
 
-  Printf.printf "degree:%d; optimal:%d #:%d gain:%.2f%%\n%!" degree t.biggest nb_vertex
+  if debug ()
+  then Printf.eprintf "degree:%d; optimal:%d #:%d gain:%.2f%%\n%!" degree t.biggest nb_vertex
     (percent (nb_vertex - t.biggest) nb_vertex);
 
   let rec loop = function
     | [] -> raise Not_found
     | k :: rem ->
       try
-        Printf.printf "try coloring with %d\n%!" k;
+        if debug ()
+        then Printf.eprintf "try coloring with %d\n%!" k;
         M.coloring t.g k
       with _ -> loop rem in
   loop [t.biggest;degree];
 
-
   (* build the mapping function *)
-  let vertex_count = Hashtbl.length t.vertex in
   let color_map = Hashtbl.fold (fun var vertex map ->
     let color = G.Mark.get vertex in
-    let count = try VM.find var t.count with _ -> failwith "no count" in
     let varset  = S.add var (try VM.find (V.from_idx color) map with _ -> S.empty) in
     let map = VM.add (V.from_idx color) varset map in
     map
   ) t.vertex VM.empty in
   let arr = Array.of_list (VM.bindings color_map) in
-  Array.sort (fun (_,i) (_,j) -> (S.cardinal i) - (S.cardinal j)) arr;
+  Array.sort (fun (_,i) (_,j) -> (S.cardinal j) - (S.cardinal i)) arr;
   let _,map = Array.fold_left (fun (i,map) (_,varset) ->
+    (* let count = S.cardinal varset in *)
+    let name = V.to_string (V.from_idx i) in
     succ i,
-    S.fold(fun var map -> VM.add var (V.from_idx i) map) varset map) (0,VM.empty) arr
-  in map
+    S.fold(fun var map ->
+      VM.add var name map) varset map) (0,VM.empty) arr
+  in
+  (fun v -> VM.find v map)
diff --git a/compiler/js_var.mli b/compiler/js_var.mli
new file mode 100644
index 0000000000..28a8aceada
--- /dev/null
+++ b/compiler/js_var.mli
@@ -0,0 +1,19 @@
+(* Js_of_ocaml compiler
+ * http://www.ocsigen.org/js_of_ocaml/
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, with linking exception;
+ * either version 2.1 of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+ *)
+
+val program : Javascript.program -> (Code.Var.t -> string)

From 008c8b0449c958cf14b26f1c87aa5b6ce512388e Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Thu, 12 Sep 2013 03:19:05 -0700
Subject: [PATCH 13/60] EXAMPLES: rm warning

---
 examples/cubes/cubes.ml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/examples/cubes/cubes.ml b/examples/cubes/cubes.ml
index dbb6b97d4c..8712868eb9 100644
--- a/examples/cubes/cubes.ml
+++ b/examples/cubes/cubes.ml
@@ -47,7 +47,7 @@ let update a =
     end else
       false
   end else begin
-    if get a (i - 1) j k & get a i (j - 1) k && get a i j (k - 1) then begin
+    if get a (i - 1) j k && get a i (j - 1) k && get a i j (k - 1) then begin
       a.(i).(j).(k) <- true;
       true
     end else

From 4a7e3c31007ba40988291036d6990198cc8a94e5 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Thu, 12 Sep 2013 03:42:41 -0700
Subject: [PATCH 14/60] COMPILER: delete jsfile in case of error

---
 compiler/main.ml | 11 ++++++++---
 1 file changed, 8 insertions(+), 3 deletions(-)

diff --git a/compiler/main.ml b/compiler/main.ml
index 8effaf47f6..adaabd1e39 100644
--- a/compiler/main.ml
+++ b/compiler/main.ml
@@ -44,9 +44,14 @@ let f paths js_files input_file output_file =
     | None ->
       output_program (Pretty_print.to_out_channel stdout)
     | Some f ->
-      let ch = open_out_bin f in
-      output_program (Pretty_print.to_out_channel ch);
-      close_out ch
+      try
+        let ch = open_out_bin f in
+        output_program (Pretty_print.to_out_channel ch);
+        close_out ch
+      with exc ->
+        Sys.remove f;
+        Format.eprintf "compilation error: %s@." (Printexc.to_string exc);
+        raise exc
   end;
   if times () then Format.eprintf "compilation: %a@." Util.Timer.print t
 

From 205248b35bda72d1758fb6917cf0d8dbd5b0a421 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Thu, 12 Sep 2013 13:14:33 -0700
Subject: [PATCH 15/60] COMPILER: static evaluation

---
 compiler/.depend      |   2 +
 compiler/Makefile     |   2 +-
 compiler/constant.ml  | 191 ++++++++++++++++++++++++++++++++++++++++++
 compiler/deadcode.ml  |   2 +-
 compiler/deadcode.mli |   2 +-
 compiler/driver.ml    |  19 ++---
 6 files changed, 205 insertions(+), 13 deletions(-)
 create mode 100644 compiler/constant.ml

diff --git a/compiler/.depend b/compiler/.depend
index 5042c5afa4..04704bcec2 100644
--- a/compiler/.depend
+++ b/compiler/.depend
@@ -1,5 +1,7 @@
 code.cmo : util.cmi code.cmi
 code.cmx : util.cmx code.cmi
+constant.cmo : util.cmi primitive.cmi code.cmi
+constant.cmx : util.cmx primitive.cmx code.cmx
 control.cmo : subst.cmi code.cmi control.cmi
 control.cmx : subst.cmx code.cmx control.cmi
 deadcode.cmo : util.cmi pure_fun.cmi code.cmi deadcode.cmi
diff --git a/compiler/Makefile b/compiler/Makefile
index 1ad023a169..bc9b7dbc93 100644
--- a/compiler/Makefile
+++ b/compiler/Makefile
@@ -10,7 +10,7 @@ PACKAGES=findlib,str,unix,ocamlgraph
 OBJS=pretty_print.cmx util.cmx dgraph.cmx \
      code.cmx javascript.cmx js_output.cmx js_simpl.cmx \
      instr.cmx primitive.cmx subst.cmx pure_fun.cmx deadcode.cmx \
-     flow.cmx inline.cmx \
+     flow.cmx inline.cmx constant.cmx \
      tailcall.cmx freevars.cmx phisimpl.cmx \
 	   js_var.cmx \
      linker.cmx generate.cmx parse_bytecode.cmx driver.cmx
diff --git a/compiler/constant.ml b/compiler/constant.ml
new file mode 100644
index 0000000000..0bce3d9890
--- /dev/null
+++ b/compiler/constant.ml
@@ -0,0 +1,191 @@
+open Code
+
+let static_eval_disabled = Util.disabled "static_eval"
+let propagate_constant_disabled = Util.disabled "constant"
+
+let eval_prim x =
+  if static_eval_disabled ()
+  then None
+  else
+    let bool b = Some (Int (if b then 1 else 0)) in
+    match x with
+      | Not, [Pc (Int i)] -> bool (i=0)
+      | Lt,  [Pc (Int i);Pc (Int j) ] -> bool (i < j)
+      | Le,  [Pc (Int i);Pc (Int j) ] -> bool (i <= j)
+      | Eq,  [Pc (Int i);Pc (Int j) ] -> bool (i = j)
+      | Neq, [Pc (Int i);Pc (Int j) ] -> bool (i <> j)
+      | IsInt, [Pc (Int _)] -> bool (true)
+      | Ult, [Pc (Int i);Pc (Int j) ] -> bool (j < 0 || i < j)
+      | WrapInt, [Pc (Int i)] -> Some (Int i)
+      | Extern name, l ->
+        let name = Primitive.resolve name in
+        let module Int = Int32 in
+        let int2 = match l with
+          | [Pc (Int i); Pc (Int j)] -> fun f -> (try Some (Int (Int.to_int (f (Int.of_int i) (Int.of_int j)))) with _ -> None)
+          | _ -> fun _ -> None in
+        let int2_1 = match l with
+          | [Pc (Int i); Pc (Int j)] -> fun f -> (try Some (Int (Int.to_int (f (Int.of_int i) j))) with _ -> None)
+          | _ -> fun _ -> None in
+        let f2_aux =
+          try
+            let i,j = match l with
+              | [Pc (Float i); Pc (Float j)]-> i,j
+              | [Pc (Int i) ; Pc (Int j)] -> float_of_int i,float_of_int j
+              | [Pc (Int i) ; Pc (Float j)] -> float_of_int i,j
+              | [Pc (Float i) ; Pc (Int j)] -> i,float_of_int j
+              | _ -> raise Not_found
+            in
+            fun f -> (try Some (f i j) with _ -> None)
+          with _ -> fun _ -> None in
+        let f2 f = f2_aux (fun i j -> Float (f i j)) in
+        let f1 = match l with
+          | [Pc (Float i)] -> fun f -> (try Some (Float (f i)) with _ -> None)
+          | [Pc (Int i)] -> fun f -> (try Some (Float (f (float_of_int i))) with _ -> None)
+          | _ -> fun _ -> None in
+        let f2b f = f2_aux (fun i j -> Int (if f i j then 1 else 0)) in
+        (match name, l with
+          (* int *)
+          | "%int_add", _ -> int2 (Int.add)
+          | "%int_sub", _ -> int2 (Int.sub)
+          | "%direct_int_mul", _ -> int2 (Int.mul )
+          | "%direct_int_div", _ -> int2 (Int.div)
+          | "%direct_int_mod", _ -> int2 (Int.rem)
+          | "%int_and", _ -> int2 (Int.logand)
+          | "%int_or", _  -> int2 (Int.logor)
+          | "%int_xor", _ -> int2 (Int.logxor)
+          | "%int_lsl", _ -> int2_1 (Int.shift_left)
+          | "%int_lsr", _ -> int2_1 (Int.shift_right_logical)
+          | "%int_asr", _ -> int2_1 (Int.shift_right)
+          | "%int_neg", [Pc (Int i)] -> Some (Int (Int.to_int (Int.neg (Int.of_int i) )))
+          (* float *)
+          | "caml_eq_float", _ -> f2b (=)
+          | "caml_neq_float", _ -> f2b (<>)
+          | "caml_ge_float", _ -> f2b (>=)
+          | "caml_le_float", _ -> f2b (<=)
+          | "caml_gt_float", _ -> f2b (>)
+          | "caml_lt_float", _ -> f2b (<)
+          | "caml_add_float",_ -> f2 (+.)
+          | "caml_sub_float",_ -> f2 (-.)
+          | "caml_mul_float",_ -> f2 ( *. )
+          | "caml_div_float",_ -> f2 ( /. )
+          | "caml_fmod_float",_ -> f2 mod_float
+          | "caml_int_of_float",[Pc (Float f)] -> Some (Int (int_of_float f))
+          | "to_int",[Pc (Float f)]  -> Some (Int (int_of_float f))
+          | "to_int",[Pc (Int i)] -> Some (Int i)
+          (* Math *)
+          | "caml_abs_float",_ -> f1 abs_float
+          | "caml_acos_float",_ -> f1 acos
+          | "caml_asin_float",_ -> f1 asin
+          | "caml_atan_float",_ -> f1 atan
+          | "caml_atan2_float",_ -> f2 atan2
+          | "caml_ceil_float",_ -> f1 ceil
+          | "caml_cos_float",_ -> f1 cos
+          | "caml_exp_float",_ -> f1 exp
+          | "caml_floor_float",_ -> f1 floor
+          | "caml_log_float",_ -> f1 log
+          | "caml_power_float",_ -> f2 ( ** )
+          | "caml_sin_float",_ -> f1 sin
+          | "caml_sqrt_float",_ -> f1 sqrt
+          | "caml_tan_float",_ -> f1 tan
+          (* other *)
+          | ("caml_js_equals"|"caml_equal"), [Pc c1;Pc c2] -> bool (c1 = c2)
+          | ("caml_js_equals"|"caml_equal"), [Pv x1;Pv x2] when x1 = x2 -> bool true
+          | _ -> None)
+      | _ -> None
+
+
+let propagate constants defs blocks free_pc pc =
+  let block = AddrMap.find pc blocks in
+  let body,constants = List.fold_left (fun (acc,constants) i ->
+      match i with
+        | Let (x,Prim (prim, prim_args))  ->
+          let prim_args = List.map (function
+              | Pv x' when VarMap.mem x' constants -> Pc (VarMap.find x' constants)
+              | x -> x) prim_args in
+          let exp,constants = match eval_prim (prim,prim_args) with
+            | Some c ->
+              let constants =
+                if defs.(Var.idx x) = 1
+                then VarMap.add x c constants
+                else constants in
+              Constant c, constants
+            | _ ->
+              (* if List.for_all (function Pc _ -> true | Pv _ -> false) prim_args *)
+              (* then (match prim with *)
+              (*   | Extern name -> Format.eprintf "%s(%d)@." name (List.length prim_args) *)
+              (*   | _ -> ()); *)
+              Prim (prim, prim_args),constants in
+          (Let (x,exp)::acc),constants
+        | Let (x,Field(y,n)) when VarMap.mem y constants ->
+          begin
+            match VarMap.find y constants with
+              | Tuple (_,tup) ->
+                let c = tup.(n) in
+                let constants =
+                  if defs.(Var.idx x) = 1
+                  then VarMap.add x c constants
+                  else constants in
+                Let (x, Constant c)::acc,constants
+              | _ -> (Let(x,Field(y,n)))::acc, constants
+          end
+        | x -> (x::acc),constants
+    ) ([],constants) block.body in
+  let body = List.rev body in
+  (* simplify branch *)
+  let branch = match block.branch with
+    | Cond (cond,x,ftrue,ffalse) when VarMap.mem x constants ->
+      let res = match cond, VarMap.find x constants with
+        | IsTrue, Int 1 -> true
+        | IsTrue, Int 0 -> false
+        | CEq i, Int j -> i = j
+        | CLt i, Int j -> i < j
+        | CLe i, Int j -> i<= j
+        | CUlt i, Int j -> j < 0 || i < j
+        | _ -> assert false in
+      (match res with
+        | true -> Branch ftrue
+        | false -> Branch ffalse)
+    | b -> b in
+  let blocks = AddrMap.add pc {block with body;branch} blocks in
+  blocks, free_pc, constants
+
+let rec is_mutable = function
+  | String _
+  | Float_array _ -> true
+  | Tuple (_,arr) ->
+    for i = 0 to Array.length arr do
+      ignore(not (is_mutable arr.(i)) || raise Not_found)
+    done;
+    false
+  | _ -> false
+
+let is_mutable x =
+  try is_mutable x with _ -> true
+
+let get_constant (_, blocks, _) defs =
+  AddrMap.fold
+    (fun _ block constants ->
+      List.fold_left
+        (fun constants i ->
+          match i with
+            | Let (x, Const i) when defs.(Var.idx x) = 1 ->
+              VarMap.add x (Int i) constants
+            | Let (x, Constant c) when not (is_mutable c) && defs.(Var.idx x) = 1 ->
+              VarMap.add x c constants
+            | _ -> constants)
+        constants block.body)
+    blocks VarMap.empty
+
+
+let f ((pc,blocks,free_pc) as p) defs =
+  if propagate_constant_disabled ()
+  then p
+  else
+    let constants = get_constant p defs in
+    let blocks,free_pc,_ =
+      AddrMap.fold
+        (fun pc _ (blocks, free_pc,constants) ->
+          propagate constants defs blocks free_pc pc)
+        blocks
+        (blocks, free_pc,constants)
+    in (pc,blocks,free_pc)
diff --git a/compiler/deadcode.ml b/compiler/deadcode.ml
index b19e03ccb1..91d693a8d6 100644
--- a/compiler/deadcode.ml
+++ b/compiler/deadcode.ml
@@ -254,4 +254,4 @@ let f ((pc, blocks, free_pc) as program) =
       blocks AddrMap.empty
   in
   if times () then Format.eprintf "  dead code elim.: %a@." Util.Timer.print t;
-  (pc, blocks, free_pc), st.live
+  (pc, blocks, free_pc), st.live, Array.map List.length st.defs
diff --git a/compiler/deadcode.mli b/compiler/deadcode.mli
index 93c284591e..7a89e3f0f5 100644
--- a/compiler/deadcode.mli
+++ b/compiler/deadcode.mli
@@ -20,4 +20,4 @@
 
 val disabled : unit -> bool
 
-val f : Code.program -> Code.program * int array
+val f : Code.program -> Code.program * int array * int array
diff --git a/compiler/driver.ml b/compiler/driver.ml
index 49b665973a..7ce87320b1 100644
--- a/compiler/driver.ml
+++ b/compiler/driver.ml
@@ -29,21 +29,19 @@ let deadcode' p =
   Deadcode.f p
 
 let deadcode p =
-  let r,_ = deadcode' p
+  let r,_,_ = deadcode' p
   in r
 
 let inline p =
-  let (p,live_vars) = deadcode' p in
+  let (p,live_vars,_) = deadcode' p in
   if debug () then Format.eprintf "Inlining...@.";
   Inline.f p live_vars
 
 let constant p =
-p
-(*
   let (p,_,defs) = deadcode' p in
   if debug () then Format.eprintf "Constant...@.";
   Constant.f p defs
-*)
+
 let flow p =
   if debug () then Format.eprintf "Data flow...@.";
   Flow.f p
@@ -63,7 +61,7 @@ let (>>>) x f = f x
 
 let (>>) f g = fun x -> g (f x)
 
-let rec loop max name round i p =
+let rec loop max name round i (p : 'a) : 'a =
   let p' = round p in
   if i >= max || Code.eq p' p
   then p'
@@ -78,7 +76,7 @@ let identity x = x
 
 (* o1 *)
 
-let o1 =
+let o1 : 'a -> 'a=
   print >>
   tailcall >>
   phi >>
@@ -95,17 +93,18 @@ let o1 =
 
 (* o2 *)
 
-let o2 =
+let o2 : 'a -> 'a =
   loop 10 "o1" o1 1 >>
   print
 
 (* o3 *)
 
-let round1 =
+let round1 : 'a -> 'a =
   print >>
   tailcall >>
   inline >> (* inlining may reveal new tailcall opt *)
   constant >>
+  (* deadcode required before flow simple -> provided by constant *)
   flow_simple >> (* flow simple to keep information for furture tailcall opt *)
   identity
 
@@ -120,7 +119,7 @@ let o3 =
 
 let profile = ref o1
 
-let generate ~standalone (p,live_vars) =
+let generate ~standalone (p,live_vars,_) =
   if times ()
   then Format.eprintf "Start Generation...@.";
   Generate.f ~standalone p live_vars

From 24df69566ad429cf4d333bbd7973dd63002e36e9 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Thu, 12 Sep 2013 13:17:27 -0700
Subject: [PATCH 16/60] COMPILER: better variables queue with dep tracking (//
 renaming)

---
 compiler/generate.ml  | 218 +++++++++++++++++++++++++-----------------
 compiler/js_simpl.ml  |  38 ++++++++
 compiler/js_simpl.mli |   4 +
 3 files changed, 170 insertions(+), 90 deletions(-)

diff --git a/compiler/generate.ml b/compiler/generate.ml
index bae799f908..9f9197ef3f 100644
--- a/compiler/generate.ml
+++ b/compiler/generate.ml
@@ -137,30 +137,79 @@ let kind k =
   match k with
     `Pure -> const_p | `Mutable -> mutable_p | `Mutator -> mutator_p
 
+type queue_elt = {
+  prop : int;
+  cardinal : int;
+  ce : J.expression;
+  deps : Code.VarSet.t
+}
+
 let access_queue queue x =
   try
-    let res = List.assoc x queue in
-    (res, List.remove_assoc x queue)
+    let elt = List.assoc x queue in
+    if elt.cardinal = 1
+    then
+      (elt.prop,elt.ce), List.remove_assoc x queue
+    else
+      ((elt.prop,elt.ce), List.map (function (x',elt) when x = x' -> x',{elt with cardinal=pred elt.cardinal} | x -> x) queue)
   with Not_found ->
     ((const_p, var x), queue)
 
+let access_queue' queue x =
+  match x with
+    | Pc c -> (const_p,constant c),queue
+    | Pv x -> access_queue queue x
+
+let access_queue_may_flush queue v x =
+  let tx,queue = access_queue queue x in
+  let _,instrs,queue = List.fold_left (fun (deps,instrs,queue) ((y,elt) as eq) ->
+      if Code.VarSet.exists (fun p -> Code.VarSet.mem p deps) elt.deps
+      then (Code.VarSet.add ( y) deps),
+        ((J.Variable_statement [ J.V y, Some elt.ce]) ::instrs),
+        queue
+      else  deps,instrs,(eq::queue)
+    ) (Code.VarSet.singleton ( v),[],[]) queue
+  in instrs,(tx,List.rev queue)
+
+
+
 let should_flush cond prop = cond <> const_p && cond + prop >= flush_p
 
 let flush_queue expr_queue prop l =
   let (instrs, expr_queue) =
     if prop >= flush_p then (expr_queue, []) else
-    List.partition (fun (y, (p, _)) -> should_flush prop p) expr_queue
+      List.partition (fun (y, elt) -> should_flush prop elt.prop) expr_queue
   in
   let instrs =
-    List.map (fun (x, (_, ce)) ->
+    List.map (fun (x, elt) ->
                 J.Variable_statement
-                  [J.V x, Some ce]) instrs
+                  [J.V x, Some elt.ce]) instrs
   in
   (List.rev_append instrs l, expr_queue)
 
+(* let flush_queue expr_queue prop l = *)
+(*   let l : J.statement list = l in *)
+(*   let (instrs, expr_queue) = *)
+(*     if prop >= flush_p then (List.fold_left (fun instrs (x,elt) -> *)
+(*       J.Variable_statement [ x, Some elt.ce] :: instrs) l expr_queue, []) *)
+(*     else *)
+(*       let _,instrs, expr_queue = *)
+(*         List.fold_left (fun (deps,instrs, expr_queue) ((y, elt) as eq) -> *)
+(*           if should_flush prop elt.prop *)
+(*           then ( *)
+(*             (y::deps), *)
+(*             ((J.Variable_statement [ y, Some elt.ce]) ::instrs), *)
+(*             expr_queue) *)
+(*           else *)
+(*             deps,instrs,(eq::expr_queue) *)
+(*         ) ([],l,[]) expr_queue in *)
+(*       instrs,List.rev expr_queue in *)
+(*   (\* List.partition (fun (y, (p, _,_,_)) -> should_flush prop p) expr_queue *\) *)
+(*   (instrs, expr_queue) *)
+
 let flush_all expr_queue l = fst (flush_queue expr_queue flush_p l)
 
-let enqueue expr_queue prop x ce =
+let enqueue expr_queue prop x ce cardinal =
   let (instrs, expr_queue) =
     if disable_compact_expr () then
       flush_queue expr_queue flush_p []
@@ -169,7 +218,13 @@ let enqueue expr_queue prop x ce =
     else
       [], expr_queue
   in
-  (instrs, (x, (prop, ce)) :: expr_queue)
+  let deps = Js_simpl.get_variable Code.VarSet.empty ce in
+  let deps = List.fold_left (fun deps (x',elt) ->
+      if Code.VarSet.mem ( x') deps
+      then Code.VarSet.union elt.deps deps
+      else deps) deps expr_queue
+  in
+  (instrs, (x, {prop; ce; cardinal; deps}) :: expr_queue)
 
 (****)
 
@@ -313,19 +368,11 @@ let parallel_renaming ctx params args continuation queue =
   let l = List.rev (visit_all params args) in
   List.fold_left
     (fun continuation (y, x) ->
-       fun queue ->
-       let ((px, cx), queue) = access_queue queue x in
-       let (st, queue) =
-(*
-         let idx = Var.idx y in
-         let len = Array.length ctx.Ctx.live in
-         match if idx >= len then 2 else ctx.Ctx.live.(Var.idx y) with
-           0 -> assert false
-         | 1 -> enqueue queue px y cx
-         | _ -> *)
-         flush_queue queue px [J.Variable_statement [J.V y, Some cx]]
-       in
-       st @ continuation queue)
+    fun queue ->
+      let instrs,((px, cx), queue) = access_queue_may_flush queue y x in
+      let (st, queue) = flush_queue queue px (instrs@[J.Variable_statement [ J.V y, Some cx]])
+      in
+      st @ continuation queue)
     continuation l queue
 
 (****)
@@ -445,33 +492,32 @@ let register_un_prim name k f =
   register_prim name k
     (fun l queue ->
        match l with
-         [Pv x] ->
-           let ((px, cx), queue) = access_queue queue x in
+         [x] ->
+           let ((px, cx), queue) = access_queue' queue x in
            (f cx, or_p (kind k) px, queue)
-       | _ ->
+         | _ ->
            assert false)
 
 let register_bin_prim name k f =
   register_prim name k
     (fun l queue ->
        match l with
-         [Pv x; Pv y] ->
-           let ((px, cx), queue) = access_queue queue x in
-           let ((py, cy), queue) = access_queue queue y in
+         [x;y] ->
+           let ((px, cx), queue) = access_queue' queue x in
+           let ((py, cy), queue) = access_queue' queue y in
            (f cx cy, or_p (kind k) (or_p px py), queue)
-       | _ ->
-           assert false)
+         | _ -> assert false)
 
 let register_tern_prim name f =
   register_prim name `Mutator
     (fun l queue ->
        match l with
-         [Pv x; Pv y; Pv z] ->
-           let ((px, cx), queue) = access_queue queue x in
-           let ((py, cy), queue) = access_queue queue y in
-           let ((pz, cz), queue) = access_queue queue z in
+         [x;y;z] ->
+           let ((px, cx), queue) = access_queue' queue x in
+           let ((py, cy), queue) = access_queue' queue y in
+           let ((pz, cz), queue) = access_queue' queue z in
            (f cx cy cz, or_p mutator_p (or_p px (or_p py pz)), queue)
-       | _ ->
+         | _ ->
            assert false)
 
 let register_un_math_prim name prim =
@@ -695,12 +741,12 @@ and translate_expr ctx queue x e =
       (constant c, const_p, queue)
   | Prim (p, l) ->
       begin match p, l with
-        Vectlength, [Pv x] ->
-          let ((px, cx), queue) = access_queue queue x in
+        Vectlength, [x] ->
+          let ((px, cx), queue) = access_queue' queue x in
           (J.EBin (J.Minus, J.EDot (cx, "length"), one), px, queue)
-      | Array_get, [Pv x; Pv y] ->
-          let ((px, cx), queue) = access_queue queue x in
-          let ((py, cy), queue) = access_queue queue y in
+      | Array_get, [x; y] ->
+          let ((px, cx), queue) = access_queue' queue x in
+          let ((py, cy), queue) = access_queue' queue y in
           (J.EAccess (cx, J.EBin (J.Plus, cy, one)),
            or_p mutable_p (or_p px py), queue)
       | Extern "caml_js_var", [Pc (String nm)] ->
@@ -715,9 +761,9 @@ and translate_expr ctx queue x e =
           let (args, prop, queue) =
             List.fold_right
               (fun x (args, prop, queue) ->
-                 let x = match x with Pv x -> x | _ -> assert false in
-                 let ((prop', cx), queue) = access_queue queue x in
-                 (cx :: args, or_p prop prop', queue))
+                let ((prop', cx), queue) = access_queue' queue x in
+                (cx :: args, or_p prop prop', queue)
+              )
               l ([], mutator_p, queue)
           in
           (J.ECall (J.EDot (cf, "call"), co :: args),
@@ -727,8 +773,7 @@ and translate_expr ctx queue x e =
           let (args, prop, queue) =
             List.fold_right
               (fun x (args, prop, queue) ->
-                 let x = match x with Pv x -> x | _ -> assert false in
-                 let ((prop', cx), queue) = access_queue queue x in
+                 let ((prop', cx), queue) = access_queue' queue x in
                  (cx :: args, or_p prop prop', queue))
               l ([], mutator_p, queue)
           in
@@ -738,8 +783,7 @@ and translate_expr ctx queue x e =
           let (args, prop, queue) =
             List.fold_right
               (fun x (args, prop, queue) ->
-                 let x = match x with Pv x -> x | _ -> assert false in
-                 let ((prop', cx), queue) = access_queue queue x in
+                 let ((prop', cx), queue) = access_queue' queue x in
                  (cx :: args, or_p prop prop', queue))
               l ([], mutator_p, queue)
           in
@@ -749,8 +793,7 @@ and translate_expr ctx queue x e =
           let (args, prop, queue) =
             List.fold_right
               (fun x (args, prop, queue) ->
-                 let x = match x with Pv x -> x | _ -> assert false in
-                 let ((prop', cx), queue) = access_queue queue x in
+                 let ((prop', cx), queue) = access_queue' queue x in
                  (cx :: args, or_p prop prop', queue))
               l ([], mutator_p, queue)
           in
@@ -805,44 +848,43 @@ and translate_expr ctx queue x e =
               let (args, prop, queue) =
                 List.fold_right
                   (fun x (args, prop, queue) ->
-                     let x = match x with Pv x -> x | _ -> assert false in
-                     let ((prop', cx), queue) = access_queue queue x in
-                     (cx :: args, or_p prop prop', queue))
+                    let ((prop', cx), queue) = access_queue' queue x in
+                    (cx :: args, or_p prop prop', queue))
                   l ([], prim_kind, queue)
               in
               (J.ECall (J.EVar (J.S name), args), prop, queue)
           end
-      | Not, [Pv x] ->
-          let ((px, cx), queue) = access_queue queue x in
+      | Not, [x] ->
+          let ((px, cx), queue) = access_queue' queue x in
           (J.EBin (J.Minus, one, cx), px, queue)
-      | Lt, [Pv x; Pv y] ->
-          let ((px, cx), queue) = access_queue queue x in
-          let ((py, cy), queue) = access_queue queue y in
+      | Lt, [x; y] ->
+          let ((px, cx), queue) = access_queue' queue x in
+          let ((py, cy), queue) = access_queue' queue y in
           (bool (J.EBin (J.Lt, cx, cy)), or_p px py, queue)
-      | Le, [Pv x; Pv y] ->
-          let ((px, cx), queue) = access_queue queue x in
-          let ((py, cy), queue) = access_queue queue y in
+      | Le, [x; y] ->
+          let ((px, cx), queue) = access_queue' queue x in
+          let ((py, cy), queue) = access_queue' queue y in
           (bool (J.EBin (J.Le, cx, cy)), or_p px py, queue)
-      | Eq, [Pv x; Pv y] ->
-          let ((px, cx), queue) = access_queue queue x in
-          let ((py, cy), queue) = access_queue queue y in
+      | Eq, [x; y] ->
+          let ((px, cx), queue) = access_queue' queue x in
+          let ((py, cy), queue) = access_queue' queue y in
           (bool (J.EBin (J.EqEqEq, cx, cy)), or_p px py, queue)
-      | Neq, [Pv x; Pv y] ->
-          let ((px, cx), queue) = access_queue queue x in
-          let ((py, cy), queue) = access_queue queue y in
+      | Neq, [x; y] ->
+          let ((px, cx), queue) = access_queue' queue x in
+          let ((py, cy), queue) = access_queue' queue y in
           (bool (J.EBin (J.NotEqEq, cx, cy)), or_p px py, queue)
-      | IsInt, [Pv x] ->
-          let ((px, cx), queue) = access_queue queue x in
+      | IsInt, [x] ->
+          let ((px, cx), queue) = access_queue' queue x in
           (J.EBin(J.EqEqEq, J.EUn (J.Typeof, cx), J.EStr ("number", `Bytes)),
            px, queue)
-      | Ult, [Pv x; Pv y] ->
-          let ((px, cx), queue) = access_queue queue x in
-          let ((py, cy), queue) = access_queue queue y in
+      | Ult, [x; y] ->
+          let ((px, cx), queue) = access_queue' queue x in
+          let ((py, cy), queue) = access_queue' queue y in
           (bool (J.EBin (J.Or, J.EBin (J.Lt, cy, int 0),
                          J.EBin (J.Lt, cx, cy))),
            or_p px py, queue)
-      | WrapInt, [Pv x] ->
-          let ((px, cx), queue) = access_queue queue x in
+      | WrapInt, [x] ->
+          let ((px, cx), queue) = access_queue' queue x in
           (to_int cx, px, queue)
       | (Vectlength | Array_get | Not | IsInt | Eq |
          Neq | Lt | Le | Ult | WrapInt), _ ->
@@ -869,7 +911,7 @@ and translate_closures ctx expr_queue l =
       let (st, expr_queue) =
         match ctx.Ctx.live.(Var.idx x) with
           0 -> flush_queue expr_queue flush_p [J.Expression_statement (cl, None)]
-        | 1 -> enqueue expr_queue flush_p x cl
+        | 1 -> enqueue expr_queue flush_p x cl 1
         | _ -> flush_queue expr_queue flush_p
                  [J.Variable_statement [J.V x, Some cl]]
       in
@@ -936,10 +978,17 @@ and translate_instr ctx expr_queue pc instr =
         match i with
           Let (x, e) ->
             let (ce, prop, expr_queue) = translate_expr ctx expr_queue x e in
-            begin match ctx.Ctx.live.(Var.idx x) with
-              0 -> flush_queue expr_queue prop [J.Expression_statement
+            begin match ctx.Ctx.live.(Var.idx x),e with
+              0,_ -> flush_queue expr_queue prop [J.Expression_statement
                                                    (ce, Some pc)]
-            | 1 -> enqueue expr_queue prop x ce
+            | 1,_ -> enqueue expr_queue prop x ce 1
+            (* We could inline more.
+               size_v : length of the variable after serialization
+               size_c : length of the constant after serialization
+               num : number of occurence
+               size_c * n < size_v * n + size_v + 1 + size_c
+            *)
+            | n,(Const _| Constant (Int _|Float _| Int32 _| Nativeint _)) -> enqueue expr_queue prop x ce n
             | _ -> flush_queue expr_queue prop
                      [J.Variable_statement [J.V x, Some ce]]
             end
@@ -950,7 +999,7 @@ and translate_instr ctx expr_queue pc instr =
               [J.Expression_statement
                   ((J.EBin (J.Eq, J.EAccess (cx, int (n + 1)), cy)), Some pc)]
         | Offset_ref (x, n) ->
-(* FIX: may overflow.. *)
+          (* FIX: may overflow.. *)
             let ((px, cx), expr_queue) = access_queue expr_queue x in
             flush_queue expr_queue mutator_p
               [J.Expression_statement
@@ -1253,20 +1302,9 @@ and compile_conditional st queue pc last handler backs frontier interm succs =
 and compile_argument_passing ctx queue (pc, args) backs continuation =
   if args = [] then
     continuation queue
-  else begin
+  else
     let block = AddrMap.find pc ctx.Ctx.blocks in
-    (* We flush on backward edged.  We do not need to flush on forward
-       edges, as the block parameter variables are fresh. *)
-    (*FIX: this is overly aggressive: we should instead keep track of
-      dependencies between queued variables and take this into account
-      to perform parallel renaming. *)
-    let cont queue =
-      parallel_renaming ctx block.params args continuation queue in
-    if AddrSet.mem pc backs then
-      flush_all queue (cont [])
-    else
-      cont queue
-  end
+    parallel_renaming ctx block.params args continuation queue
 
 and compile_exn_handling ctx queue (pc, args) handler continuation =
   if pc < 0 then
@@ -1310,7 +1348,7 @@ and compile_exn_handling ctx queue (pc, args) handler continuation =
        do the same for closure free variables *)
                  match 2 (*ctx.Ctx.live.(Var.idx y)*) with
                    0 -> assert false
-                 | 1 -> enqueue queue px y cx
+                 | 1 -> enqueue queue px y cx 1
                  | _ -> flush_queue queue px
                           [J.Variable_statement [J.V y, Some cx]]
                in
diff --git a/compiler/js_simpl.ml b/compiler/js_simpl.ml
index 9774304582..23e10a761c 100644
--- a/compiler/js_simpl.ml
+++ b/compiler/js_simpl.ml
@@ -214,3 +214,41 @@ let rec if_statement e iftrue truestop (iffalse : J.statement) falsestop =
         iftrue truestop iftrue' falsestop
   | _ ->
       if_statement_2 e iftrue truestop iffalse falsestop
+
+
+module VSet = Set.Make(struct
+    type t = J.ident
+    let compare = J.compare_ident
+end)
+
+
+let rec get_variable acc = function
+  | J.ESeq (e1,e2)
+  | J.EBin (_,e1,e2)
+  | J.EAccess (e1,e2) -> get_variable (get_variable acc e1) e2
+  | J.ECond (e1,e2,e3) ->
+    get_variable (
+      get_variable (
+        get_variable
+          acc
+          e1)
+        e2)
+      e2
+  | J.EUn (_,e1)
+  | J.EDot (e1,_)
+  | J.ENew (e1,None) -> get_variable acc e1
+  | J.ECall (e1,el)
+  | J.ENew (e1,Some el) -> List.fold_left get_variable acc (e1::el)
+  | J.EVar (J.V v) -> Code.VarSet.add v acc
+  | J.EVar (J.S _) -> acc
+  | J.EFun _
+  | J.EStr _
+  | J.EBool _
+  | J.ENum _
+  | J.EQuote _ -> acc
+  | J.EArr a -> List.fold_left (fun acc i ->
+                  match i with
+                    | None -> acc
+                    | Some e1 -> get_variable acc e1) acc a
+  | J.EObj l -> List.fold_left (fun acc (_,e1) ->
+                  get_variable acc e1) acc l
diff --git a/compiler/js_simpl.mli b/compiler/js_simpl.mli
index 398a4ce4fe..3ad56131e7 100644
--- a/compiler/js_simpl.mli
+++ b/compiler/js_simpl.mli
@@ -30,3 +30,7 @@ val statement_list : statement_list -> statement_list
 val block : statement_list -> statement
 
 val if_statement : expression -> statement -> bool -> statement -> bool -> statement list
+
+
+module VSet : Set.S with type elt = Javascript.ident
+val get_variable : Code.VarSet.t -> expression -> Code.VarSet.t

From b1dadc61ee29ab25662c54aa7ff4a964dd49c89e Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Thu, 12 Sep 2013 13:22:37 -0700
Subject: [PATCH 17/60] COMPILER: depend

---
 compiler/.depend | 12 +++++++-----
 1 file changed, 7 insertions(+), 5 deletions(-)

diff --git a/compiler/.depend b/compiler/.depend
index 04704bcec2..b5977b6359 100644
--- a/compiler/.depend
+++ b/compiler/.depend
@@ -10,10 +10,12 @@ dgraph.cmo : dgraph.cmi
 dgraph.cmx : dgraph.cmi
 driver.cmo : util.cmi tailcall.cmi primitive.cmi pretty_print.cmi \
     phisimpl.cmi parse_bytecode.cmi linker.cmi js_var.cmi js_output.cmi \
-    inline.cmi generate.cmi flow.cmi deadcode.cmi code.cmi driver.cmi
+    inline.cmi generate.cmi flow.cmi deadcode.cmi constant.cmo code.cmi \
+    driver.cmi
 driver.cmx : util.cmx tailcall.cmx primitive.cmx pretty_print.cmx \
     phisimpl.cmx parse_bytecode.cmx linker.cmx js_var.cmx js_output.cmx \
-    inline.cmx generate.cmx flow.cmx deadcode.cmx code.cmx driver.cmi
+    inline.cmx generate.cmx flow.cmx deadcode.cmx constant.cmx code.cmx \
+    driver.cmi
 flow.cmo : util.cmi subst.cmi dgraph.cmi code.cmi flow.cmi
 flow.cmx : util.cmx subst.cmx dgraph.cmx code.cmx flow.cmi
 freevars.cmo : util.cmi code.cmi freevars.cmi
@@ -34,8 +36,8 @@ js_output.cmx : util.cmx pretty_print.cmx parse_bytecode.cmx javascript.cmx \
     code.cmx js_output.cmi
 js_rename.cmo : util.cmi javascript.cmi
 js_rename.cmx : util.cmx javascript.cmx
-js_simpl.cmo : javascript.cmi js_simpl.cmi
-js_simpl.cmx : javascript.cmx js_simpl.cmi
+js_simpl.cmo : javascript.cmi code.cmi js_simpl.cmi
+js_simpl.cmx : javascript.cmx code.cmx js_simpl.cmi
 js_var.cmo : util.cmi javascript.cmi code.cmi js_var.cmi
 js_var.cmx : util.cmx javascript.cmx code.cmx js_var.cmi
 linker.cmo : util.cmi primitive.cmi pretty_print.cmi code.cmi linker.cmi
@@ -74,7 +76,7 @@ inline.cmi : code.cmi
 instr.cmi :
 javascript.cmi : code.cmi
 js_output.cmi : pretty_print.cmi parse_bytecode.cmi javascript.cmi code.cmi
-js_simpl.cmi : javascript.cmi
+js_simpl.cmi : javascript.cmi code.cmi
 js_var.cmi : javascript.cmi code.cmi
 linker.cmi : pretty_print.cmi
 parse_bytecode.cmi : code.cmi

From d23bd516f4fe06b65c67901f57fc9263de3139f8 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Thu, 12 Sep 2013 13:24:23 -0700
Subject: [PATCH 18/60] COMPILER: utils

---
 compiler/javascript.ml | 8 ++++++++
 1 file changed, 8 insertions(+)

diff --git a/compiler/javascript.ml b/compiler/javascript.ml
index fc9968cbd2..c1d46a772b 100644
--- a/compiler/javascript.ml
+++ b/compiler/javascript.ml
@@ -131,3 +131,11 @@ and ident =
   | S of identifier
   | V of Code.Var.t
 and label = identifier
+
+
+let compare_ident t1 t2 =
+  match t1, t2 with
+    | V v1, V v2 -> Code.Var.compare v1 v2
+    | S s1, S s2 -> String.compare s1 s2
+    | S _, V _ -> -1
+    | V _, S _ -> 1

From 20f266a7d01dbb6556a93c8a9159187a3e2a9985 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Thu, 12 Sep 2013 15:41:37 -0700
Subject: [PATCH 19/60] COMPILER: typo

---
 compiler/flow.ml | 3 +--
 1 file changed, 1 insertion(+), 2 deletions(-)

diff --git a/compiler/flow.ml b/compiler/flow.ml
index 208c91ca2f..423aea28e8 100644
--- a/compiler/flow.ml
+++ b/compiler/flow.ml
@@ -246,8 +246,7 @@ let approx_lift f s = VarSet.fold (fun y u -> a_max (f y) u) s Known
 
 let propagate2 ?(skip_param=false) defs known_origins possibly_mutable st x =
   match defs.(Var.idx x) with
-    Param ->
-      true
+    Param -> skip_param
   | Phi s ->
       VarSet.exists (fun y -> VarTbl.get st y) s
   | Expr e ->

From df0ac0d9c07f06d0abef1e72a329ba8d1f15a5d0 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Thu, 12 Sep 2013 17:32:11 -0700
Subject: [PATCH 20/60] LIB: restore depend

---
 lib/.depend | 10 ++++++++++
 1 file changed, 10 insertions(+)

diff --git a/lib/.depend b/lib/.depend
index 38fa0e8546..9a59613c74 100644
--- a/lib/.depend
+++ b/lib/.depend
@@ -59,3 +59,13 @@ url.cmi :
 webGL.cmi : typed_array.cmi js.cmi dom_html.cmi
 webSockets.cmi : js.cmi dom_html.cmi dom.cmi
 xmlHttpRequest.cmi : url.cmi js.cmi form.cmi file.cmi dom.cmi
+deriving_json/deriving_Json_lexer.cmo : \
+    deriving_json/deriving_Json_lexer.cmi
+deriving_json/deriving_Json_lexer.cmx : \
+    deriving_json/deriving_Json_lexer.cmi
+deriving_json/deriving_Json_lexer.cmi :
+deriving_json/deriving_Json.cmo : deriving_json/deriving_Json_lexer.cmi \
+    deriving_json/deriving_Json.cmi
+deriving_json/deriving_Json.cmx : deriving_json/deriving_Json_lexer.cmx \
+    deriving_json/deriving_Json.cmi
+deriving_json/deriving_Json.cmi : deriving_json/deriving_Json_lexer.cmi

From bc5648d4498436143fbac651d892b4d8e8ad1152 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Thu, 12 Sep 2013 18:17:15 -0700
Subject: [PATCH 21/60] COMPILER: fix scope of try_statement

---
 compiler/js_var.ml | 50 ++++++++++++++++++++++------------------------
 1 file changed, 24 insertions(+), 26 deletions(-)

diff --git a/compiler/js_var.ml b/compiler/js_var.ml
index 5c9c8c231b..dc44e64367 100644
--- a/compiler/js_var.ml
+++ b/compiler/js_var.ml
@@ -73,25 +73,20 @@ let vertex t v =
 let get_free t = S.diff t.use t.def
 
 let mark g =
-  let free = get_free g in
-  S.iter (fun u -> G.add_vertex g.g (vertex g u)) g.def;
-  let u = S.union g.def (S.union free g.use) in
-  let f a b =
-    S.iter (fun u1 ->
-      S.iter (fun u2 ->
-        if u1 <> u2
-        then
-          G.add_edge
-            g.g
-            (vertex g u1)
-            (vertex g u2)
-      ) a
-    ) b
-  in
-  f g.use g.use;
-  f g.use free;
-  f g.def g.use;
-  f g.def free;
+  let u = S.union g.def g.use in
+  S.iter (fun u -> G.add_vertex g.g (vertex g u)) u;
+  S.fold (fun u1 set ->
+    let set = S.remove u1 set in
+    S.iter (fun u2 ->
+      if u1 <> u2
+      then
+        G.add_edge
+          g.g
+          (vertex g u1)
+          (vertex g u2)
+    ) set;
+    set
+  ) u u;
   {g with biggest = max g.biggest (S.cardinal u)}
 
 let create () = (* empty (G.make (Code.Var.count ())) *)
@@ -213,13 +208,16 @@ and statement t s = match s with
     let t = match w with
       | None -> t
       | Some (id,block) ->
-        let tbody = statements (empty t) block in
-        let tbody = def_var tbody id in
-        let tbody = mark tbody in
-        let t = merge_info ~from:tbody ~into:t in
-        { t with
-          use = S.union t.use (rm_var t.use id) ;
-          def = S.union t.def (rm_var t.def id) }
+        let t = statements t block in
+        let t = def_var t id in
+        t
+        (* let tbody = statements (empty t) block in *)
+        (* let tbody = def_var tbody id in *)
+        (* let tbody = mark tbody in *)
+        (* let t = merge_info ~from:tbody ~into:t in *)
+        (* { t with *)
+        (*   use = S.union t.use (rm_var t.use id) ; *)
+        (*   def = S.union t.def (rm_var t.def id) } *)
     in
     let t = match f with
       | None -> t

From cb17587267610b6388ab772413128008d68fef61 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Thu, 12 Sep 2013 18:23:29 -0700
Subject: [PATCH 22/60] COMPILER: make it compile

---
 compiler/js_simpl.ml  | 6 ------
 compiler/js_simpl.mli | 2 --
 2 files changed, 8 deletions(-)

diff --git a/compiler/js_simpl.ml b/compiler/js_simpl.ml
index 23e10a761c..d598a5f472 100644
--- a/compiler/js_simpl.ml
+++ b/compiler/js_simpl.ml
@@ -216,12 +216,6 @@ let rec if_statement e iftrue truestop (iffalse : J.statement) falsestop =
       if_statement_2 e iftrue truestop iffalse falsestop
 
 
-module VSet = Set.Make(struct
-    type t = J.ident
-    let compare = J.compare_ident
-end)
-
-
 let rec get_variable acc = function
   | J.ESeq (e1,e2)
   | J.EBin (_,e1,e2)
diff --git a/compiler/js_simpl.mli b/compiler/js_simpl.mli
index 3ad56131e7..e543638a4c 100644
--- a/compiler/js_simpl.mli
+++ b/compiler/js_simpl.mli
@@ -31,6 +31,4 @@ val block : statement_list -> statement
 
 val if_statement : expression -> statement -> bool -> statement -> bool -> statement list
 
-
-module VSet : Set.S with type elt = Javascript.ident
 val get_variable : Code.VarSet.t -> expression -> Code.VarSet.t

From 252d2686cc8db698a90792211dd7e30696a40abd Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Thu, 12 Sep 2013 13:18:46 -0700
Subject: [PATCH 23/60] COMPILER: Js optim

---
 compiler/js_simpl.ml | 78 +++++++++++++++++++++++++++++++++++++-------
 1 file changed, 67 insertions(+), 11 deletions(-)

diff --git a/compiler/js_simpl.ml b/compiler/js_simpl.ml
index d598a5f472..fb1dc61c49 100644
--- a/compiler/js_simpl.ml
+++ b/compiler/js_simpl.ml
@@ -75,7 +75,7 @@ let rec enot_rec e =
         end
     | J.EUn (J.Not, e) ->
         (e, 0)
-    | J.EUn ((J.Neg | J.Pl | J.Typeof | J.Delete), _) ->
+    | J.EUn ((J.Neg | J.Pl | J.Typeof | J.Delete | J.Bnot ), _) ->
         (J.EUn (J.Not, e), 0)
 
     | J.EBool b ->
@@ -86,8 +86,7 @@ let rec enot_rec e =
         (( J.IncrA
          | J.IncrB
          | J.DecrA
-         | J.DecrB
-         | J.Bnot ),_) ->
+         | J.DecrB ),_) ->
       (J.EUn (J.Not, e), 1)
   in
   if cost <= 1 then res else (J.EUn (J.Not, e), 1)
@@ -108,6 +107,53 @@ let source_elements l =
            J.Statement st :: rem)
     l []
 
+let tr = function
+  | J.Div -> J.SlashEq
+  | J.Mod -> J.ModEq
+  | J.Lsl -> J.LslEq
+  | J.Asr -> J.AsrEq
+  | J.Lsr -> J.LsrEq
+  | J.Band -> J.BandEq
+  | J.Bor -> J.BorEq
+  | J.Bxor -> J.BxorEq
+  | J.Mul -> J.StarEq
+  | J.Plus -> J.PlusEq
+  | J.Minus -> J.MinusEq
+  | _ -> assert false
+
+let var isint = function
+  | (x,Some (J.EBin (J.Plus,y, J.EVar x')))
+  | (x,Some (J.EBin (J.Plus, J.EVar x',y))) when x = x' ->
+    if y = J.ENum 1.
+    then Some (J.EUn (J.IncrB,J.EVar x))
+    else Some (J.EBin (J.PlusEq, J.EVar x,y))
+  | (x,Some (J.EBin (J.Minus, J.EVar x',y))) when x = x' ->
+    if y = J.ENum 1.
+    then Some (J.EUn (J.DecrB,J.EVar x))
+    else Some (J.EBin (J.MinusEq, J.EVar x,y))
+  | (x,Some (J.EBin (J.Mul,y, J.EVar x')))
+  | (x,Some (J.EBin (J.Mul, J.EVar x',y))) when x = x' ->
+    Some (J.EBin (J.StarEq, J.EVar x,y))
+  | (x,Some (J.EBin (J.Div | J.Mod | J.Lsl | J.Asr | J. Lsr | J.Band | J.Bxor | J.Bor as unop, J.EVar x',y))) when x = x' && not isint ->
+    Some (J.EBin (tr unop, J.EVar x,y))
+  | x -> None
+
+let var = function
+  | (x,Some (J.EBin (J.Bor,e,J.ENum 0.))) -> var true (x,Some e)
+  | x -> var false x
+
+let optim_hh l =
+  List.fold_right (fun st rem ->
+    match st with
+      | J.Variable_statement l1 ->
+        let x = List.map (function x ->
+            match var x with
+              | Some e -> J.Expression_statement (e,None)
+              | None -> J.Variable_statement [x]) l1 in
+        x@rem
+      | _ -> st::rem
+  ) l []
+
 let statement_list l =
   List.fold_right
     (fun st rem ->
@@ -116,7 +162,7 @@ let statement_list l =
            J.Variable_statement (l1 @ l2) :: rem'
        | _ ->
            st :: rem)
-    l []
+    (optim_hh l) []
 
 let block l = match l with [s] -> s | _ -> J.Block (statement_list l)
 
@@ -157,7 +203,17 @@ let assignment_of_statement st =
   | J.Block l                        -> assignment_of_statement_list l
   | _                                -> raise Not_assignment
 
+let simplify_condition = function
+    (* | J.ECond _  -> J.ENum 1. *)
+    | J.ECond (e, J.ENum 1., J.ENum 0.) -> e
+    | J.ECond (e, J.ENum 0., J.ENum 1.) -> J.EUn (J.Not, e)
+    | J.ECond (J.EBin((J.NotEqEq | J.NotEq), J.ENum n, y ),e1,e2)
+    | J.ECond (J.EBin((J.NotEqEq | J.NotEq), y, J.ENum n),e1,e2) ->
+      J.ECond (J.EBin(J.Band,y,J.ENum n),e1,e2)
+    | cond        -> cond
+
 let rec if_statement_2 e iftrue truestop iffalse falsestop =
+  let e = simplify_condition e in
   match iftrue, iffalse with
     (* Empty blocks *)
     J.Block [], J.Block [] ->
@@ -172,7 +228,11 @@ let rec if_statement_2 e iftrue truestop iffalse falsestop =
         let (x1, e1) = assignment_of_statement iftrue in
         let (x2, e2) = assignment_of_statement iffalse in
         if x1 <> x2 then raise Not_assignment;
-        [J.Variable_statement [x1, Some (J.ECond (e, e1, e2))]]
+        let exp =
+          if e1 = e
+          then J.EBin(J.Or,e,e2)
+          else J.ECond (e, e1, e2) in
+        [J.Variable_statement [x1, Some exp]]
       with Not_assignment -> try
         let e1 = expression_of_statement iftrue in
         let e2 = expression_of_statement iffalse in
@@ -189,12 +249,8 @@ let rec if_statement_2 e iftrue truestop iffalse falsestop =
 let unopt b = match b with Some b -> b | None -> J.Block []
 
 let rec if_statement e iftrue truestop (iffalse : J.statement) falsestop =
-  let e =
-    (*FIX: should be done at an earlier stage*)
-    match e with
-      J.ECond (e, J.ENum 1., J.ENum 0.) -> e
-    | _                                 -> e
-  in
+  (*FIX: should be done at an earlier stage*)
+  let e = simplify_condition e in
   match iftrue, iffalse with
     (* Shared statements *)
   | J.If_statement (e', iftrue', iffalse'), _

From 25c2b1d46ba9e326f3309235cdacae79ab64c026 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Sat, 14 Sep 2013 12:40:22 -0700
Subject: [PATCH 24/60] COMPILER: refactoring options

---
 compiler/.depend           | 76 +++++++++++++++++++------------------
 compiler/Makefile          |  2 +-
 compiler/code.ml           |  9 +----
 compiler/code.mli          |  1 -
 compiler/constant.ml       | 29 ++++++--------
 compiler/deadcode.ml       |  8 ++--
 compiler/deadcode.mli      |  2 -
 compiler/driver.ml         | 33 ++++++++++------
 compiler/flow.ml           |  7 ++--
 compiler/freevars.ml       |  2 +-
 compiler/generate.ml       | 20 ++++------
 compiler/inline.ml         | 25 ++++---------
 compiler/js_output.ml      |  4 +-
 compiler/js_var.ml         |  2 +-
 compiler/main.ml           | 20 +++++-----
 compiler/option.ml         | 77 ++++++++++++++++++++++++++++++++++++++
 compiler/parse_bytecode.ml |  6 +--
 compiler/phisimpl.ml       |  2 +-
 compiler/tailcall.ml       |  2 +-
 compiler/util.ml           | 38 -------------------
 compiler/util.mli          |  7 ----
 toplevel/toplevel.ml       |  5 ---
 22 files changed, 189 insertions(+), 188 deletions(-)
 create mode 100644 compiler/option.ml

diff --git a/compiler/.depend b/compiler/.depend
index b5977b6359..1ce3d3f99d 100644
--- a/compiler/.depend
+++ b/compiler/.depend
@@ -1,57 +1,61 @@
-code.cmo : util.cmi code.cmi
-code.cmx : util.cmx code.cmi
-constant.cmo : util.cmi primitive.cmi code.cmi
-constant.cmx : util.cmx primitive.cmx code.cmx
+code.cmo : util.cmi option.cmo code.cmi
+code.cmx : util.cmx option.cmx code.cmi
+constant.cmo : primitive.cmi option.cmo code.cmi
+constant.cmx : primitive.cmx option.cmx code.cmx
 control.cmo : subst.cmi code.cmi control.cmi
 control.cmx : subst.cmx code.cmx control.cmi
-deadcode.cmo : util.cmi pure_fun.cmi code.cmi deadcode.cmi
-deadcode.cmx : util.cmx pure_fun.cmx code.cmx deadcode.cmi
+deadcode.cmo : util.cmi pure_fun.cmi option.cmo code.cmi deadcode.cmi
+deadcode.cmx : util.cmx pure_fun.cmx option.cmx code.cmx deadcode.cmi
 dgraph.cmo : dgraph.cmi
 dgraph.cmx : dgraph.cmi
-driver.cmo : util.cmi tailcall.cmi primitive.cmi pretty_print.cmi \
-    phisimpl.cmi parse_bytecode.cmi linker.cmi js_var.cmi js_output.cmi \
+driver.cmo : tailcall.cmi primitive.cmi pretty_print.cmi phisimpl.cmi \
+    parse_bytecode.cmi option.cmo linker.cmi js_var.cmi js_output.cmi \
     inline.cmi generate.cmi flow.cmi deadcode.cmi constant.cmo code.cmi \
     driver.cmi
-driver.cmx : util.cmx tailcall.cmx primitive.cmx pretty_print.cmx \
-    phisimpl.cmx parse_bytecode.cmx linker.cmx js_var.cmx js_output.cmx \
+driver.cmx : tailcall.cmx primitive.cmx pretty_print.cmx phisimpl.cmx \
+    parse_bytecode.cmx option.cmx linker.cmx js_var.cmx js_output.cmx \
     inline.cmx generate.cmx flow.cmx deadcode.cmx constant.cmx code.cmx \
     driver.cmi
-flow.cmo : util.cmi subst.cmi dgraph.cmi code.cmi flow.cmi
-flow.cmx : util.cmx subst.cmx dgraph.cmx code.cmx flow.cmi
-freevars.cmo : util.cmi code.cmi freevars.cmi
-freevars.cmx : util.cmx code.cmx freevars.cmi
-generate.cmo : util.cmi subst.cmi primitive.cmi js_simpl.cmi javascript.cmi \
-    freevars.cmi code.cmi generate.cmi
-generate.cmx : util.cmx subst.cmx primitive.cmx js_simpl.cmx javascript.cmx \
-    freevars.cmx code.cmx generate.cmi
-inline.cmo : util.cmi deadcode.cmi code.cmi inline.cmi
-inline.cmx : util.cmx deadcode.cmx code.cmx inline.cmi
+flow.cmo : util.cmi subst.cmi option.cmo dgraph.cmi code.cmi flow.cmi
+flow.cmx : util.cmx subst.cmx option.cmx dgraph.cmx code.cmx flow.cmi
+freevars.cmo : util.cmi option.cmo code.cmi freevars.cmi
+freevars.cmx : util.cmx option.cmx code.cmx freevars.cmi
+generate.cmo : util.cmi subst.cmi primitive.cmi option.cmo js_simpl.cmi \
+    javascript.cmi freevars.cmi code.cmi generate.cmi
+generate.cmx : util.cmx subst.cmx primitive.cmx option.cmx js_simpl.cmx \
+    javascript.cmx freevars.cmx code.cmx generate.cmi
+inline.cmo : code.cmi inline.cmi
+inline.cmx : code.cmx inline.cmi
 instr.cmo : instr.cmi
 instr.cmx : instr.cmi
 javascript.cmo : code.cmi javascript.cmi
 javascript.cmx : code.cmx javascript.cmi
-js_output.cmo : util.cmi pretty_print.cmi parse_bytecode.cmi javascript.cmi \
-    code.cmi js_output.cmi
-js_output.cmx : util.cmx pretty_print.cmx parse_bytecode.cmx javascript.cmx \
-    code.cmx js_output.cmi
+js_output.cmo : pretty_print.cmi parse_bytecode.cmi option.cmo \
+    javascript.cmi code.cmi js_output.cmi
+js_output.cmx : pretty_print.cmx parse_bytecode.cmx option.cmx \
+    javascript.cmx code.cmx js_output.cmi
 js_rename.cmo : util.cmi javascript.cmi
 js_rename.cmx : util.cmx javascript.cmx
 js_simpl.cmo : javascript.cmi code.cmi js_simpl.cmi
 js_simpl.cmx : javascript.cmx code.cmx js_simpl.cmi
-js_var.cmo : util.cmi javascript.cmi code.cmi js_var.cmi
-js_var.cmx : util.cmx javascript.cmx code.cmx js_var.cmi
+js_var.cmo : option.cmo javascript.cmi code.cmi js_var.cmi
+js_var.cmx : option.cmx javascript.cmx code.cmx js_var.cmi
 linker.cmo : util.cmi primitive.cmi pretty_print.cmi code.cmi linker.cmi
 linker.cmx : util.cmx primitive.cmx pretty_print.cmx code.cmx linker.cmi
-main.cmo : util.cmi pretty_print.cmi parse_bytecode.cmi linker.cmi \
-    driver.cmi
-main.cmx : util.cmx pretty_print.cmx parse_bytecode.cmx linker.cmx \
-    driver.cmx
-parse_bytecode.cmo : util.cmi primitive.cmi instr.cmi code.cmi \
+main.cmo : util.cmi pretty_print.cmi parse_bytecode.cmi option.cmo \
+    linker.cmi driver.cmi
+main.cmx : util.cmx pretty_print.cmx parse_bytecode.cmx option.cmx \
+    linker.cmx driver.cmx
+option.cmo :
+option.cmx :
+parse_bytecode.cmo : util.cmi primitive.cmi option.cmo instr.cmi code.cmi \
     parse_bytecode.cmi
-parse_bytecode.cmx : util.cmx primitive.cmx instr.cmx code.cmx \
+parse_bytecode.cmx : util.cmx primitive.cmx option.cmx instr.cmx code.cmx \
     parse_bytecode.cmi
-phisimpl.cmo : util.cmi subst.cmi dgraph.cmi code.cmi phisimpl.cmi
-phisimpl.cmx : util.cmx subst.cmx dgraph.cmx code.cmx phisimpl.cmi
+phisimpl.cmo : util.cmi subst.cmi option.cmo dgraph.cmi code.cmi \
+    phisimpl.cmi
+phisimpl.cmx : util.cmx subst.cmx option.cmx dgraph.cmx code.cmx \
+    phisimpl.cmi
 pretty_print.cmo : pretty_print.cmi
 pretty_print.cmx : pretty_print.cmi
 primitive.cmo : util.cmi primitive.cmi
@@ -60,8 +64,8 @@ pure_fun.cmo : primitive.cmi code.cmi pure_fun.cmi
 pure_fun.cmx : primitive.cmx code.cmx pure_fun.cmi
 subst.cmo : util.cmi code.cmi subst.cmi
 subst.cmx : util.cmx code.cmx subst.cmi
-tailcall.cmo : util.cmi subst.cmi code.cmi tailcall.cmi
-tailcall.cmx : util.cmx subst.cmx code.cmx tailcall.cmi
+tailcall.cmo : util.cmi subst.cmi option.cmo code.cmi tailcall.cmi
+tailcall.cmx : util.cmx subst.cmx option.cmx code.cmx tailcall.cmi
 util.cmo : util.cmi
 util.cmx : util.cmi
 code.cmi : util.cmi
diff --git a/compiler/Makefile b/compiler/Makefile
index bc9b7dbc93..80ac4e1a43 100644
--- a/compiler/Makefile
+++ b/compiler/Makefile
@@ -7,7 +7,7 @@ lib: compiler.cma compiler.cmxa compiler.cmxs
 
 PACKAGES=findlib,str,unix,ocamlgraph
 
-OBJS=pretty_print.cmx util.cmx dgraph.cmx \
+OBJS=pretty_print.cmx util.cmx option.cmx dgraph.cmx \
      code.cmx javascript.cmx js_output.cmx js_simpl.cmx \
      instr.cmx primitive.cmx subst.cmx pure_fun.cmx deadcode.cmx \
      flow.cmx inline.cmx constant.cmx \
diff --git a/compiler/code.ml b/compiler/code.ml
index 327bf0230d..0132d87fd1 100644
--- a/compiler/code.ml
+++ b/compiler/code.ml
@@ -20,9 +20,6 @@
 
 (*FIX: this should probably be somewhere else... *)
 
-
-let disable_compact = Util.disabled "compact"
-
 module Reserved = struct
   let reserved = Hashtbl.create 107
 
@@ -73,11 +70,9 @@ module VarPrinter = struct
     else
       format_ident ((x - 54) / 64) ^ char c2 ((x - 54) mod 64)
 
-  let pretty = ref false
-
   let format_var i x =
     let s = format_ident x in
-    if !pretty then begin
+    if Option.Optim.pretty () then begin
       try
         let nm = Hashtbl.find names i in
         Format.sprintf "%s_%s_" nm s
@@ -121,7 +116,6 @@ module Var : sig
 
   val name : t -> string -> unit
   val propagate_name : t -> t -> unit
-  val set_pretty : unit -> unit
 
   val reset : unit -> unit
 
@@ -149,7 +143,6 @@ end = struct
 
   let name i nm = VarPrinter.name i nm
   let propagate_name i j = VarPrinter.propagate_name i j
-  let set_pretty () = VarPrinter.pretty := true
 
   let dummy = -1
 end
diff --git a/compiler/code.mli b/compiler/code.mli
index 42807b7c8f..130a761cb3 100644
--- a/compiler/code.mli
+++ b/compiler/code.mli
@@ -38,7 +38,6 @@ module Var : sig
 
   val name : t -> string -> unit
   val propagate_name : t -> t -> unit
-  val set_pretty : unit -> unit
   val reset : unit -> unit
 end
 
diff --git a/compiler/constant.ml b/compiler/constant.ml
index 0bce3d9890..754568af9e 100644
--- a/compiler/constant.ml
+++ b/compiler/constant.ml
@@ -1,12 +1,8 @@
 open Code
 
-let static_eval_disabled = Util.disabled "static_eval"
-let propagate_constant_disabled = Util.disabled "constant"
-
 let eval_prim x =
-  if static_eval_disabled ()
-  then None
-  else
+  if Option.Optim.staticeval ()
+  then
     let bool b = Some (Int (if b then 1 else 0)) in
     match x with
       | Not, [Pc (Int i)] -> bool (i=0)
@@ -92,7 +88,7 @@ let eval_prim x =
           | ("caml_js_equals"|"caml_equal"), [Pv x1;Pv x2] when x1 = x2 -> bool true
           | _ -> None)
       | _ -> None
-
+  else None
 
 let propagate constants defs blocks free_pc pc =
   let block = AddrMap.find pc blocks in
@@ -178,14 +174,11 @@ let get_constant (_, blocks, _) defs =
 
 
 let f ((pc,blocks,free_pc) as p) defs =
-  if propagate_constant_disabled ()
-  then p
-  else
-    let constants = get_constant p defs in
-    let blocks,free_pc,_ =
-      AddrMap.fold
-        (fun pc _ (blocks, free_pc,constants) ->
-          propagate constants defs blocks free_pc pc)
-        blocks
-        (blocks, free_pc,constants)
-    in (pc,blocks,free_pc)
+  let constants = get_constant p defs in
+  let blocks,free_pc,_ =
+    AddrMap.fold
+      (fun pc _ (blocks, free_pc,constants) ->
+        propagate constants defs blocks free_pc pc)
+      blocks
+      (blocks, free_pc,constants)
+  in (pc,blocks,free_pc)
diff --git a/compiler/deadcode.ml b/compiler/deadcode.ml
index 91d693a8d6..587333635c 100644
--- a/compiler/deadcode.ml
+++ b/compiler/deadcode.ml
@@ -18,8 +18,8 @@
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  *)
 
-let debug = Util.debug "deadcode"
-let times = Util.debug "times"
+let debug = Option.Debug.find "deadcode"
+let times = Option.Debug.find "times"
 
 open Code
 
@@ -34,10 +34,8 @@ type t =
 
 (****)
 
-let disabled = Util.disabled "deadcode"
-
 let pure_expr pure_funs e =
-  Pure_fun.pure_expr pure_funs e && not (disabled ())
+  Pure_fun.pure_expr pure_funs e && Option.Optim.deadcode ()
 
 (****)
 
diff --git a/compiler/deadcode.mli b/compiler/deadcode.mli
index 7a89e3f0f5..d2a2bcdc20 100644
--- a/compiler/deadcode.mli
+++ b/compiler/deadcode.mli
@@ -18,6 +18,4 @@
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  *)
 
-val disabled : unit -> bool
-
 val f : Code.program -> Code.program * int array * int array
diff --git a/compiler/driver.ml b/compiler/driver.ml
index 7ce87320b1..658e531ec8 100644
--- a/compiler/driver.ml
+++ b/compiler/driver.ml
@@ -18,8 +18,8 @@
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  *)
 
-let debug = Util.debug "main"
-let times = Util.debug "times"
+let debug = Option.Debug.find "main"
+let times = Option.Debug.find "times"
 let tailcall p =
   if debug () then Format.eprintf "Tail-call optimization...@.";
   Tailcall.f p
@@ -33,15 +33,20 @@ let deadcode p =
   in r
 
 let inline p =
-  let (p,live_vars,_) = deadcode' p in
-  if debug () then Format.eprintf "Inlining...@.";
-  Inline.f p live_vars
+  if Option.Optim.inline () && Option.Optim.deadcode ()
+  then
+    let (p,live_vars,_) = deadcode' p in
+    if debug () then Format.eprintf "Inlining...@.";
+    Inline.f p live_vars
+  else p
 
 let constant p =
-  let (p,_,defs) = deadcode' p in
-  if debug () then Format.eprintf "Constant...@.";
-  Constant.f p defs
-
+  if Option.Optim.constant ()
+  then
+    let (p,_,defs) = deadcode' p in
+    if debug () then Format.eprintf "Constant...@.";
+    Constant.f p defs
+  else p
 let flow p =
   if debug () then Format.eprintf "Data flow...@.";
   Flow.f p
@@ -149,10 +154,8 @@ let link formatter ~standalone ?linkall pretty js =
     end;
   js
 
-let coloring_disabled = Util.disabled "coloring"
-
 let coloring js =
-  if not (coloring_disabled ())
+  if Option.Optim.shortvar ()
   then
     begin
       if times ()
@@ -166,7 +169,13 @@ let output formatter d (js,to_string) =
   then Format.eprintf "Start Writing file...@.";
   Js_output.program formatter d to_string js
 
+
+let configure formatter p =
+  Pretty_print.set_compact formatter (not (Option.Optim.pretty ()));
+  p
+
 let f ?(standalone=true) ?linkall formatter d =
+  configure formatter >>
   !profile >>
   deadcode' >>
   generate ~standalone >>
diff --git a/compiler/flow.ml b/compiler/flow.ml
index 423aea28e8..6aac788adf 100644
--- a/compiler/flow.ml
+++ b/compiler/flow.ml
@@ -18,9 +18,8 @@
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  *)
 
-let debug = Util.debug "flow"
-let disable_optcall = Util.disabled "optcall"
-let times = Util.debug "times"
+let debug = Option.Debug.find "flow"
+let times = Option.Debug.find "times"
 
 open Code
 
@@ -325,7 +324,7 @@ let function_cardinality ((defs, _, _) as info) x =
 
 let specialize_instr info i =
   match i with
-    Let (x, Apply (f, l, _)) when not (disable_optcall ()) ->
+    Let (x, Apply (f, l, _)) when Option.Optim.optcall () ->
       Let (x, Apply (f, l, function_cardinality info f))
 
 (*FIX this should be moved to a different file (javascript specific) *)
diff --git a/compiler/freevars.ml b/compiler/freevars.ml
index 86a3e9242f..aa0a6e57f8 100644
--- a/compiler/freevars.ml
+++ b/compiler/freevars.ml
@@ -19,7 +19,7 @@
  *)
 
 
-let times = Util.debug "times"
+let times = Option.Debug.find "times"
 
 open Code
 
diff --git a/compiler/generate.ml b/compiler/generate.ml
index 9f9197ef3f..e7ac009ff1 100644
--- a/compiler/generate.ml
+++ b/compiler/generate.ml
@@ -33,12 +33,8 @@ Patterns:
 - CLEAN UP!!!
 *)
 
-let compact = ref true
-let debug = Util.debug "gen"
-let times = Util.debug "times"
-let disable_compact_expr = Util.disabled "compactexpr"
-
-let pretty_off = Util.disabled ~init:true "pretty"
+let debug = Option.Debug.find "gen"
+let times = Option.Debug.find "times"
 
 (****)
 
@@ -211,12 +207,12 @@ let flush_all expr_queue l = fst (flush_queue expr_queue flush_p l)
 
 let enqueue expr_queue prop x ce cardinal =
   let (instrs, expr_queue) =
-    if disable_compact_expr () then
-      flush_queue expr_queue flush_p []
-    else if is_mutable prop then
-      flush_queue expr_queue prop []
-    else
-      [], expr_queue
+    if Option.Optim.compact () then
+      if is_mutable prop then
+        flush_queue expr_queue prop []
+      else
+        [], expr_queue
+    else flush_queue expr_queue flush_p []
   in
   let deps = Js_simpl.get_variable Code.VarSet.empty ce in
   let deps = List.fold_left (fun deps (x',elt) ->
diff --git a/compiler/inline.ml b/compiler/inline.ml
index 0d265f07e4..fef2898ed1 100644
--- a/compiler/inline.ml
+++ b/compiler/inline.ml
@@ -20,9 +20,6 @@
 
 open Code
 
-let inline_disabled = Util.disabled "inline"
-(****)
-
 let get_closures (_, blocks, _) =
   AddrMap.fold
     (fun _ block closures ->
@@ -131,18 +128,12 @@ let inline closures live_vars blocks free_pc pc =
 
 (****)
 
-(*FIX: this is unefficient, as we still perform the other
-  optimizations phases repeatedly *)
-
 let f ((pc, blocks, free_pc) as p) live_vars =
-  if not (inline_disabled() || Deadcode.disabled ()) then begin
-    let closures = get_closures p in
-    let (blocks, free_pc) =
-      AddrMap.fold
-        (fun pc _ (blocks, free_pc) ->
-           inline closures live_vars blocks free_pc pc)
-        blocks (blocks, free_pc)
-    in
-    (pc, blocks, free_pc)
-  end else
-    p
+  let closures = get_closures p in
+  let (blocks, free_pc) =
+    AddrMap.fold
+      (fun pc _ (blocks, free_pc) ->
+        inline closures live_vars blocks free_pc pc)
+      blocks (blocks, free_pc)
+  in
+  (pc, blocks, free_pc)
diff --git a/compiler/js_output.ml b/compiler/js_output.ml
index 98b1b31559..f8987525b8 100644
--- a/compiler/js_output.ml
+++ b/compiler/js_output.ml
@@ -33,15 +33,13 @@ open Javascript
 
 module PP = Pretty_print
 
-let no_debug_info = Util.disabled ~init:true "debuginfo"
-
 module Make(D : sig
   val debug_info : Parse_bytecode.debug_loc
   val to_string : Code.Var.t -> string
 end) = struct
 
   let output_debug_info f pc =
-    if not (no_debug_info())
+    if Option.Optim.debuginfo ()
     then
       match pc with
         | None -> ()
diff --git a/compiler/js_var.ml b/compiler/js_var.ml
index dc44e64367..4511516458 100644
--- a/compiler/js_var.ml
+++ b/compiler/js_var.ml
@@ -1,6 +1,6 @@
 open Javascript
 
-let debug = Util.debug "coloring"
+let debug = Option.Debug.find "shortvar"
 
 module G = Graph.Pack.Graph
 (* module G = struct *)
diff --git a/compiler/main.ml b/compiler/main.ml
index adaabd1e39..b9e57210fd 100644
--- a/compiler/main.ml
+++ b/compiler/main.ml
@@ -18,11 +18,9 @@
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  *)
 
-let debug = Util.debug "main"
-let times = Util.debug "times"
-let linkall = ref false
+let times = Option.Debug.find "times"
 
-let f paths js_files input_file output_file =
+let f linkall paths js_files input_file output_file =
   let t = Util.Timer.make () in
   List.iter Linker.add_file js_files;
   let paths = List.rev_append paths [Findlib.package_directory "stdlib"] in
@@ -38,7 +36,6 @@ let f paths js_files input_file output_file =
         p
   in
   if times () then Format.eprintf "  parsing: %a@." Util.Timer.print t1;
-  let linkall = !linkall in
   let output_program fmt = Driver.f ~linkall fmt d p in
   begin match output_file with
     | None ->
@@ -62,15 +59,16 @@ let _ =
   let output_file = ref None in
   let input_file = ref None in
   let no_runtime = ref false in
+  let linkall = ref false in
   let paths = ref [] in
   let options =
-    [("-debug", Arg.String Util.set_debug, "<name> debug module <name>");
+    [("-debug", Arg.String Option.Debug.set, "<name> debug module <name>");
      ("-disable",
-      Arg.String Util.set_disabled, "<name> disable optimization <name>");
-     ("-pretty", Arg.Unit (fun () -> Util.set_enabled "pretty"), " pretty print the output");
-     ("-debuginfo", Arg.Unit (fun () -> Util.set_enabled "debuginfo"), " output debug info");
+      Arg.String Option.Optim.disable, "<name> disable optimization <name>");
+     ("-pretty", Arg.Unit (fun () -> Option.Optim.enable "pretty"), " pretty print the output");
+     ("-debuginfo", Arg.Unit (fun () -> Option.Optim.enable "debuginfo"), " output debug info");
      ("-opt", Arg.Int Driver.set_profile, "<oN> set optimization profile : o1 (default), o2, o3");
-     ("-noinline", Arg.Unit (fun () -> Util.set_disabled "inline"), " disable inlining");
+     ("-noinline", Arg.Unit (fun () -> Option.Optim.disable "inline"), " disable inlining");
      ("-linkall", Arg.Set linkall, " link all primitives");
      ("-noruntime", Arg.Unit (fun () -> no_runtime := true),
       " do not include the standard runtime");
@@ -91,7 +89,7 @@ let _ =
   let runtime = if !no_runtime then [] else ["+runtime.js"] in
   let chop_extension s =
     try Filename.chop_extension s with Invalid_argument _ -> s in
-  f !paths (runtime @ List.rev !js_files) !input_file
+  f !linkall !paths (runtime @ List.rev !js_files) !input_file
     (match !output_file with
        Some _ -> !output_file
      | None   -> Util.opt_map (fun s -> chop_extension s ^ ".js") !input_file)
diff --git a/compiler/option.ml b/compiler/option.ml
new file mode 100644
index 0000000000..9d108c7066
--- /dev/null
+++ b/compiler/option.ml
@@ -0,0 +1,77 @@
+
+(****)
+
+
+(****)
+
+let disabled_lst = ref []
+
+let disabled ?(init=false) s =
+  let state = ref init in
+  if not (List.mem_assoc s !disabled_lst)
+  then disabled_lst := (s, state) :: !disabled_lst;
+  fun () -> !state
+
+let set_disabled s =
+  try List.assoc s !disabled_lst := true with Not_found ->
+   Format.eprintf "%s: no disable option named '%s'@." Sys.argv.(0) s; exit 1
+
+let set_enabled s =
+  try List.assoc s !disabled_lst := false with Not_found ->
+   Format.eprintf "%s: no disable option named '%s'@." Sys.argv.(0) s; exit 1
+
+(****)
+
+
+(* Optimisation *)
+
+
+module Debug = struct
+  let debugs : (string * bool ref) list ref = ref []
+
+  let find s =
+    let state =
+      try
+        List.assoc s !debugs
+      with Not_found ->
+        let state = ref false in
+        debugs := (s, state) :: !debugs;
+        state
+    in
+    fun () -> !state
+
+  let set s =
+    try List.assoc s !debugs := true with Not_found -> ()
+
+end
+
+module Optim = struct
+
+  let optims = ref []
+
+  let o ~name ~default =
+    let state =
+      try
+        List.assoc name !optims
+      with Not_found ->
+        let state = ref default in
+        optims := (name, state) :: !optims;
+        state
+    in
+    fun () -> !state
+
+  let disable s =
+    try List.assoc s !optims := false with Not_found -> ()
+  let enable s =
+    try List.assoc s !optims := true with Not_found -> ()
+
+  let pretty =     o ~name:"pretty" ~default:false
+  let debuginfo =  o ~name:"debuginfo" ~default:false
+  let deadcode =   o ~name:"deadcode" ~default:true
+  let shortvar =  o ~name:"shortvar" ~default:true
+  let compact =    o ~name:"compact" ~default:true
+  let optcall =    o ~name:"optcall" ~default:true
+  let inline =     o ~name:"inline" ~default:true
+  let staticeval = o ~name:"staticeval" ~default:false
+  let constant =   o ~name:"constant" ~default:true
+end
diff --git a/compiler/parse_bytecode.ml b/compiler/parse_bytecode.ml
index 4ed38c70ad..0be4b69cd4 100644
--- a/compiler/parse_bytecode.ml
+++ b/compiler/parse_bytecode.ml
@@ -23,7 +23,7 @@
 open Code
 open Instr
 
-let debug = Util.debug "parser"
+let debug = Option.Debug.find "parser"
 
 (****)
 
@@ -226,8 +226,6 @@ module Debug = struct
 
 end
 
-let don't_keep_variable_names = Util.disabled ~init:true "pretty"
-
 (****)
 
 type globals =
@@ -1764,7 +1762,7 @@ let from_channel ~paths ic =
   ignore(seek_section toc ic "SYMB");
   let symbols = (input_value ic : Ident.t numtable) in
 
-  if not (don't_keep_variable_names ()) then begin
+  if Option.Optim.pretty () then begin
     try
       ignore(seek_section toc ic "DBUG");
       Debug.read ic;
diff --git a/compiler/phisimpl.ml b/compiler/phisimpl.ml
index 23e5e2fcca..a0b28df6dd 100644
--- a/compiler/phisimpl.ml
+++ b/compiler/phisimpl.ml
@@ -18,7 +18,7 @@
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  *)
 
-let times = Util.debug "times"
+let times = Option.Debug.find "times"
 
 open Code
 
diff --git a/compiler/tailcall.ml b/compiler/tailcall.ml
index 5b1d879019..8c4ebcf149 100644
--- a/compiler/tailcall.ml
+++ b/compiler/tailcall.ml
@@ -18,7 +18,7 @@
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  *)
 
-let times = Util.debug "times"
+let times = Option.Debug.find "times"
 
 open Code
 
diff --git a/compiler/util.ml b/compiler/util.ml
index f82581e77f..953e55fe76 100644
--- a/compiler/util.ml
+++ b/compiler/util.ml
@@ -52,44 +52,6 @@ let read_file f =
   close_in ch;
   Buffer.contents b
 
-(****)
-
-let debugs = ref []
-
-let debug s =
-  let state =
-    try
-      List.assoc s !debugs
-    with Not_found ->
-      let state = ref false in
-      debugs := (s, state) :: !debugs;
-      state
-  in
-  fun () -> !state
-
-let set_debug s =
-  try List.assoc s !debugs := true with Not_found -> ()
-
-(****)
-
-let disabled_lst = ref []
-
-let disabled ?(init=false) s =
-  let state = ref init in
-  if not (List.mem_assoc s !disabled_lst)
-  then disabled_lst := (s, state) :: !disabled_lst;
-  fun () -> !state
-
-let set_disabled s =
-  try List.assoc s !disabled_lst := true with Not_found ->
-   Format.eprintf "%s: no disable option named '%s'@." Sys.argv.(0) s; exit 1
-
-let set_enabled s =
-  try List.assoc s !disabled_lst := false with Not_found ->
-   Format.eprintf "%s: no disable option named '%s'@." Sys.argv.(0) s; exit 1
-
-(****)
-
 module Timer = struct
   type t = float
   let timer = ref (fun _ -> 0.)
diff --git a/compiler/util.mli b/compiler/util.mli
index 96499d5f1a..f339ba1fb9 100644
--- a/compiler/util.mli
+++ b/compiler/util.mli
@@ -30,13 +30,6 @@ val opt_iter : ('a -> unit) -> 'a option -> unit
 val find_in_paths : string list -> string -> string
 val read_file : string -> string
 
-val debug : string -> unit -> bool
-val set_debug : string -> unit
-
-val disabled : ?init:bool -> string -> (unit -> bool)
-val set_disabled : string -> unit
-val set_enabled : string -> unit
-
 module Timer : sig
   type t
   val init : (unit -> float) -> unit
diff --git a/toplevel/toplevel.ml b/toplevel/toplevel.ml
index b8c5f94dc6..c3a2c7ad42 100644
--- a/toplevel/toplevel.ml
+++ b/toplevel/toplevel.ml
@@ -50,11 +50,6 @@ external global_data : unit -> global_data Js.t = "caml_get_global_data"
 let g = global_data ()
 
 let _ =
-(*
-  Util.set_debug "parser";
-  Util.set_debug "deadcode";
-  Util.set_debug "main";
-*)
   let toc = g##toc in
   let prims = split_primitives (List.assoc "PRIM" toc) in
 

From f87716f37417fa913dbc33bf78ee29f622219a33 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Sat, 14 Sep 2013 13:21:40 -0700
Subject: [PATCH 25/60] COMPILER: some cleanning

---
 compiler/code.ml   |  2 --
 compiler/code.mli  |  1 -
 compiler/js_var.ml | 16 ++++++++--------
 compiler/util.ml   |  1 +
 4 files changed, 9 insertions(+), 11 deletions(-)

diff --git a/compiler/code.ml b/compiler/code.ml
index 0132d87fd1..f36c3f2521 100644
--- a/compiler/code.ml
+++ b/compiler/code.ml
@@ -105,7 +105,6 @@ module Var : sig
   type t
   val print : Format.formatter -> t -> unit
   val idx : t -> int
-  val from_idx : int -> t
   val to_string : t -> string
 
   val fresh : unit -> t
@@ -137,7 +136,6 @@ end = struct
   let count () = !last_var + 1
 
   let idx v = v
-  let from_idx v = v
 
   let compare v1 v2 = v1 - v2
 
diff --git a/compiler/code.mli b/compiler/code.mli
index 130a761cb3..e0e9ff0f40 100644
--- a/compiler/code.mli
+++ b/compiler/code.mli
@@ -26,7 +26,6 @@ module Var : sig
   type t
   val print : Format.formatter -> t -> unit
   val idx : t -> int
-  val from_idx : int -> t
 
   val to_string : t -> string
 
diff --git a/compiler/js_var.ml b/compiler/js_var.ml
index 4511516458..36c281cd90 100644
--- a/compiler/js_var.ml
+++ b/compiler/js_var.ml
@@ -252,19 +252,19 @@ let program p =
   loop [t.biggest;degree];
 
   (* build the mapping function *)
+  let module M = Util.IntMap in
   let color_map = Hashtbl.fold (fun var vertex map ->
     let color = G.Mark.get vertex in
-    let varset  = S.add var (try VM.find (V.from_idx color) map with _ -> S.empty) in
-    let map = VM.add (V.from_idx color) varset map in
+    let varset  = S.add var (try M.find color map with _ -> S.empty) in
+    let map = M.add color varset map in
     map
-  ) t.vertex VM.empty in
-  let arr = Array.of_list (VM.bindings color_map) in
+  ) t.vertex M.empty in
+  let arr = Array.of_list (M.bindings color_map) in
   Array.sort (fun (_,i) (_,j) -> (S.cardinal j) - (S.cardinal i)) arr;
-  let _,map = Array.fold_left (fun (i,map) (_,varset) ->
+  let map = Array.fold_left (fun map (_,varset) ->
     (* let count = S.cardinal varset in *)
-    let name = V.to_string (V.from_idx i) in
-    succ i,
+    let name = V.to_string (S.choose varset) in
     S.fold(fun var map ->
-      VM.add var name map) varset map) (0,VM.empty) arr
+      VM.add var name map) varset map) VM.empty arr
   in
   (fun v -> VM.find v map)
diff --git a/compiler/util.ml b/compiler/util.ml
index 953e55fe76..db09ffb4ab 100644
--- a/compiler/util.ml
+++ b/compiler/util.ml
@@ -23,6 +23,7 @@ module IntSet = Set.Make (Int)
 module IntMap = Map.Make (Int)
 
 module StringSet = Set.Make (String)
+module StringMap = Map.Make (String)
 
 let opt_map f x = match x with None -> None | Some v -> Some (f v)
 let opt_iter f x = match x with None -> () | Some v -> f v

From 4362f98e1c4440e336f592eea8c9e4f7df8ff19e Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Sat, 14 Sep 2013 13:57:52 -0700
Subject: [PATCH 26/60] COMPILER: mv specialize

---
 compiler/.depend       |   6 +-
 compiler/Makefile      |   2 +-
 compiler/driver.ml     |   4 +-
 compiler/flow.ml       | 219 +++++------------------------------------
 compiler/flow.mli      |  14 ++-
 compiler/specialize.ml | 191 +++++++++++++++++++++++++++++++++++
 6 files changed, 238 insertions(+), 198 deletions(-)
 create mode 100644 compiler/specialize.ml

diff --git a/compiler/.depend b/compiler/.depend
index 1ce3d3f99d..9602aea009 100644
--- a/compiler/.depend
+++ b/compiler/.depend
@@ -38,8 +38,8 @@ js_rename.cmo : util.cmi javascript.cmi
 js_rename.cmx : util.cmx javascript.cmx
 js_simpl.cmo : javascript.cmi code.cmi js_simpl.cmi
 js_simpl.cmx : javascript.cmx code.cmx js_simpl.cmi
-js_var.cmo : option.cmo javascript.cmi code.cmi js_var.cmi
-js_var.cmx : option.cmx javascript.cmx code.cmx js_var.cmi
+js_var.cmo : util.cmi option.cmo javascript.cmi code.cmi js_var.cmi
+js_var.cmx : util.cmx option.cmx javascript.cmx code.cmx js_var.cmi
 linker.cmo : util.cmi primitive.cmi pretty_print.cmi code.cmi linker.cmi
 linker.cmx : util.cmx primitive.cmx pretty_print.cmx code.cmx linker.cmi
 main.cmo : util.cmi pretty_print.cmi parse_bytecode.cmi option.cmo \
@@ -62,6 +62,8 @@ primitive.cmo : util.cmi primitive.cmi
 primitive.cmx : util.cmx primitive.cmi
 pure_fun.cmo : primitive.cmi code.cmi pure_fun.cmi
 pure_fun.cmx : primitive.cmx code.cmx pure_fun.cmi
+specialize.cmo : option.cmo flow.cmi code.cmi
+specialize.cmx : option.cmx flow.cmx code.cmx
 subst.cmo : util.cmi code.cmi subst.cmi
 subst.cmx : util.cmx code.cmx subst.cmi
 tailcall.cmo : util.cmi subst.cmi option.cmo code.cmi tailcall.cmi
diff --git a/compiler/Makefile b/compiler/Makefile
index 80ac4e1a43..29a3da7ea0 100644
--- a/compiler/Makefile
+++ b/compiler/Makefile
@@ -10,7 +10,7 @@ PACKAGES=findlib,str,unix,ocamlgraph
 OBJS=pretty_print.cmx util.cmx option.cmx dgraph.cmx \
      code.cmx javascript.cmx js_output.cmx js_simpl.cmx \
      instr.cmx primitive.cmx subst.cmx pure_fun.cmx deadcode.cmx \
-     flow.cmx inline.cmx constant.cmx \
+     flow.cmx specialize.cmx inline.cmx constant.cmx \
      tailcall.cmx freevars.cmx phisimpl.cmx \
 	   js_var.cmx \
      linker.cmx generate.cmx parse_bytecode.cmx driver.cmx
diff --git a/compiler/driver.ml b/compiler/driver.ml
index 658e531ec8..9ad28900ef 100644
--- a/compiler/driver.ml
+++ b/compiler/driver.ml
@@ -49,11 +49,11 @@ let constant p =
   else p
 let flow p =
   if debug () then Format.eprintf "Data flow...@.";
-  Flow.f p
+  fst (Flow.f p)
 
 let flow_simple p =
   if debug () then Format.eprintf "Data flow...@.";
-  Flow.f ~skip_param:true p
+  fst (Flow.f ~skip_param:true p)
 
 let phi p =
   if debug () then Format.eprintf "Variable passing simplification...@.";
diff --git a/compiler/flow.ml b/compiler/flow.ml
index 6aac788adf..298419e55f 100644
--- a/compiler/flow.ml
+++ b/compiler/flow.ml
@@ -29,6 +29,13 @@ let add_var = VarISet.add
 
 type def = Phi of VarSet.t | Expr of Code.expr | Param
 
+type info = {
+  info_defs:def array;
+  info_known_origins : Code.VarSet.t Code.VarTbl.t;
+  info_maybe_unknown : bool Code.VarTbl.t;
+  info_possibly_mutable : bool array
+}
+
 let undefined = Phi VarSet.empty
 
 let is_undefined d = match d with Phi s -> VarSet.is_empty s | _ -> false
@@ -283,199 +290,22 @@ let solver2 ?skip_param vars deps defs known_origins possibly_mutable =
   in
   Solver2.f () g (propagate2 ?skip_param defs known_origins possibly_mutable)
 
-(****)
-
-let get_approx (defs, known_origins, maybe_unknown) f top join x =
-  let s = VarTbl.get known_origins x in
-  if VarTbl.get maybe_unknown x then top else
+let get_approx {info_defs; info_known_origins;info_maybe_unknown} f top join x =
+  let s = VarTbl.get info_known_origins x in
+  if VarTbl.get info_maybe_unknown x then top else
   match VarSet.cardinal s with
     0 -> top
   | 1 -> f (VarSet.choose s)
   | _ -> VarSet.fold (fun x u -> join (f x) u) s (f (VarSet.choose s))
 
-let the_def_of ((defs, _, _) as info) x =
-  match x with
-    | Pv x ->
-      get_approx info
-        (fun x -> match defs.(Var.idx x) with Expr e -> Some e | _ -> None)
-        None (fun u v -> None) x
-    | Pc c -> Some (Constant c)
-
-let the_int ((defs, _, _) as info) x =
-  match x with
-    | Pv x ->
-      get_approx info
-        (fun x -> match defs.(Var.idx x) with Expr (Const i) -> Some i | _ -> None)
-        None
-        (fun u v -> match u, v with Some i, Some j when i = j -> u | _ -> None)
-        x
-    | Pc (Int i) -> Some i
-    | _ -> None
-
-let function_cardinality ((defs, _, _) as info) x =
-  get_approx info
-    (fun x ->
-       match defs.(Var.idx x) with
-         Expr (Closure (l, _)) -> Some (List.length l)
-       | _                     -> None)
-    None
-    (fun u v -> match u, v with Some n, Some m when n = m -> u | _ -> None)
-    x
-
-let specialize_instr info i =
-  match i with
-    Let (x, Apply (f, l, _)) when Option.Optim.optcall () ->
-      Let (x, Apply (f, l, function_cardinality info f))
-
-(*FIX this should be moved to a different file (javascript specific) *)
-  | Let (x, Prim (Extern "caml_js_var", [y])) ->
-      begin match the_def_of info y with
-        Some (Constant (String _ as c)) ->
-          Let (x, Prim (Extern "caml_js_var", [Pc c]))
-      | _ ->
-          i
-      end
-  | Let (x, Prim (Extern "caml_js_const", [y])) ->
-      begin match the_def_of info y with
-        Some (Constant (String _ as c)) ->
-          Let (x, Prim (Extern "caml_js_const", [Pc c]))
-      | _ ->
-          i
-      end
-  | Let (x, Prim (Extern "caml_js_call", [f; o; a])) ->
-      begin match the_def_of info a with
-        Some (Block (_, a)) ->
-          let a = Array.map (fun x -> Pv x) a in
-          Let (x, Prim (Extern "caml_js_opt_call",
-                        f :: o :: Array.to_list a))
-      | _ ->
-          i
-      end
-  | Let (x, Prim (Extern "caml_js_fun_call", [f; a])) ->
-      begin match the_def_of info a with
-        Some (Block (_, a)) ->
-          let a = Array.map (fun x -> Pv x) a in
-          Let (x, Prim (Extern "caml_js_opt_fun_call",
-                        f :: Array.to_list a))
-      | _ ->
-          i
-      end
-  | Let (x, Prim (Extern "caml_js_meth_call", [o; m; a])) ->
-      begin match the_def_of info m with
-        Some (Constant (String _ as m)) ->
-          begin match the_def_of info a with
-            Some (Block (_, a)) ->
-              let a = Array.map (fun x -> Pv x) a in
-              Let (x, Prim (Extern "caml_js_opt_meth_call",
-                            o :: Pc m :: Array.to_list a))
-          | _ ->
-              i
-          end
-      | _ ->
-          i
-      end
-  | Let (x, Prim (Extern "caml_js_new", [c; a])) ->
-      begin match the_def_of info a with
-        Some (Block (_, a)) ->
-          let a = Array.map (fun x -> Pv x) a in
-          Let (x, Prim (Extern "caml_js_opt_new",
-                        c :: Array.to_list a))
-      | _ ->
-          i
-      end
-  | Let (x, Prim (Extern "caml_js_object", [a])) ->
-      begin try
-        let a =
-          match the_def_of info a with
-            Some (Block (_, a)) -> a
-          | _                   -> raise Exit
-        in
-        let a =
-          Array.map
-            (fun x ->
-               match the_def_of info (Pv x) with
-                 Some (Block (_, [|k; v|])) ->
-                   let k =
-                     match the_def_of info (Pv k) with
-                       Some (Constant (String _ as s)) -> Pc s
-                     | _                               -> raise Exit
-                   in
-                   [k; Pv v]
-               | _ ->
-                   raise Exit)
-            a
-        in
-        Let (x, Prim (Extern "caml_js_opt_object",
-                      List.flatten (Array.to_list a)))
-      with Exit ->
-        i
-      end
-  | Let (x, Prim (Extern "caml_js_get", [o; f])) ->
-      begin match the_def_of info f with
-        Some (Constant (String _ as c)) ->
-          Let (x, Prim (Extern "caml_js_get", [o; Pc c]))
-      | _ ->
-          i
-      end
-  | Let (x, Prim (Extern "caml_js_set", [o; f; v])) ->
-      begin match the_def_of info f with
-        Some (Constant (String _ as c)) ->
-          Let (x, Prim (Extern "caml_js_set", [o; Pc c; v]))
-      | _ ->
-          i
-      end
-  | Let (x, Prim (Extern "caml_js_delete", [o; f])) ->
-      begin match the_def_of info f with
-        Some (Constant (String _ as c)) ->
-          Let (x, Prim (Extern "caml_js_delete", [o; Pc c]))
-      | _ ->
-          i
-      end
-  | Let (x, Prim (Extern "%int_mul", [y; z])) ->
-      begin match the_int info y, the_int info z with
-        Some j, _ | _, Some j when abs j < 0x200000 ->
-          Let (x, Prim (Extern "%direct_int_mul", [y; z]))
-      | _ ->
-          i
-      end
-  | Let (x, Prim (Extern "%int_div", [y; z])) ->
-      begin match the_int info z with
-        Some j when j <> 0 ->
-          Let (x, Prim (Extern "%direct_int_div", [y; z]))
-      | _ ->
-          i
-      end
-  | Let (x, Prim (Extern "%int_mod", [y; z])) ->
-      begin match the_int info z with
-        Some j when j <> 0 ->
-          Let (x, Prim (Extern "%direct_int_mod", [y; z]))
-      | _ ->
-          i
-      end
-
-  | _ ->
-      i
-
-let specialize_instrs info (pc, blocks, free_pc) =
-  let blocks =
-    AddrMap.map
-      (fun block ->
-         { block with Code.body =
-             List.map (fun i -> specialize_instr info i) block.body })
-      blocks
-  in
-  (pc, blocks, free_pc)
-
-(****)
-
 (*XXX Maybe we could iterate? *)
-let direct_approx defs known_origins maybe_unknown possibly_mutable x =
-  match defs.(Var.idx x) with
+let direct_approx info x =
+  match info.info_defs.(Var.idx x) with
     Expr (Field (y, n)) ->
-      get_approx (defs, known_origins, maybe_unknown)
+      get_approx info
         (fun z ->
-           if possibly_mutable.(Var.idx z) then None else
-           match defs.(Var.idx z) with
+           if info.info_possibly_mutable.(Var.idx z) then None else
+           match info.info_defs.(Var.idx z) with
              Expr (Block (_, a)) when n < Array.length a ->
                Some a.(n)
            | _ ->
@@ -489,20 +319,20 @@ let direct_approx defs known_origins maybe_unknown possibly_mutable x =
   | _ ->
       None
 
-let build_subst defs vars known_origins maybe_unknown possibly_mutable =
+let build_subst info  vars =
   let nv = Var.count () in
   let subst = Array.make nv None in
   VarISet.iter
     (fun x ->
-       let u = VarTbl.get maybe_unknown x in
+       let u = VarTbl.get info.info_maybe_unknown x in
        if not u then begin
-         let s = VarTbl.get known_origins x in
+         let s = VarTbl.get info.info_known_origins x in
          if VarSet.cardinal s = 1 then
            subst.(Var.idx x) <- Some (VarSet.choose s)
        end;
        if subst.(Var.idx x) = None then
          subst.(Var.idx x) <-
-           direct_approx defs known_origins maybe_unknown possibly_mutable x)
+           direct_approx info x)
     vars;
   subst
 
@@ -536,9 +366,14 @@ let f ?skip_param ((pc, blocks, free_pc) as p) =
   end;
 
   let t5 = Util.Timer.make () in
-  let p = specialize_instrs (defs, known_origins, maybe_unknown) p in
-  let s = build_subst defs vars known_origins maybe_unknown possibly_mutable in
+  let info = {
+    info_defs = defs;
+    info_known_origins = known_origins;
+    info_maybe_unknown = maybe_unknown;
+    info_possibly_mutable = possibly_mutable;
+  } in
+  let s = build_subst info vars in
   let p = Subst.program (Subst.from_array s) p in
   if times () then Format.eprintf "    flow analysis 5: %a@." Util.Timer.print t5;
   if times () then Format.eprintf "  flow analysis: %a@." Util.Timer.print t;
-  p
+  p, info
diff --git a/compiler/flow.mli b/compiler/flow.mli
index 4676f8f060..ad99ea2465 100644
--- a/compiler/flow.mli
+++ b/compiler/flow.mli
@@ -37,4 +37,16 @@ val get_label : t -> Code.Var.t option
 
 *)
 
-val f : ?skip_param:bool -> Code.program -> Code.program (* * t array*)
+type def = Phi of Code.VarSet.t | Expr of Code.expr | Param
+
+type info = {
+  info_defs:def array;
+  info_known_origins : Code.VarSet.t Code.VarTbl.t;
+  info_maybe_unknown : bool Code.VarTbl.t;
+  info_possibly_mutable : bool array;
+}
+
+val get_approx : info -> (Code.VarSet.elt -> 'b) ->
+           'b -> ('b -> 'b -> 'b) -> Code.VarTbl.key -> 'b
+
+val f : ?skip_param:bool -> Code.program -> Code.program * info
diff --git a/compiler/specialize.ml b/compiler/specialize.ml
new file mode 100644
index 0000000000..6ba1ec0900
--- /dev/null
+++ b/compiler/specialize.ml
@@ -0,0 +1,191 @@
+
+
+
+open Code
+open Flow
+
+(****)
+
+let the_def_of info x =
+  match x with
+    | Pv x ->
+      get_approx info
+        (fun x -> match info.info_defs.(Var.idx x) with Expr e -> Some e | _ -> None)
+        None (fun u v -> None) x
+    | Pc c -> Some (Constant c)
+
+let the_int info x =
+  match x with
+    | Pv x ->
+      get_approx info
+        (fun x -> match info.info_defs.(Var.idx x) with Expr (Const i) -> Some i | _ -> None)
+        None
+        (fun u v -> match u, v with Some i, Some j when i = j -> u | _ -> None)
+        x
+    | Pc (Int i) -> Some i
+    | _ -> None
+
+let function_cardinality info x =
+  get_approx info
+    (fun x ->
+       match info.info_defs.(Var.idx x) with
+         Expr (Closure (l, _)) -> Some (List.length l)
+       | _                     -> None)
+    None
+    (fun u v -> match u, v with Some n, Some m when n = m -> u | _ -> None)
+    x
+
+let specialize_instr info i =
+  match i with
+    Let (x, Apply (f, l, _)) when Option.Optim.optcall () ->
+      Let (x, Apply (f, l, function_cardinality info f))
+
+(*FIX this should be moved to a different file (javascript specific) *)
+  | Let (x, Prim (Extern "caml_js_var", [y])) ->
+      begin match the_def_of info y with
+        Some (Constant (String _ as c)) ->
+          Let (x, Prim (Extern "caml_js_var", [Pc c]))
+      | _ ->
+          i
+      end
+  | Let (x, Prim (Extern "caml_js_const", [y])) ->
+      begin match the_def_of info y with
+        Some (Constant (String _ as c)) ->
+          Let (x, Prim (Extern "caml_js_const", [Pc c]))
+      | _ ->
+          i
+      end
+  | Let (x, Prim (Extern "caml_js_call", [f; o; a])) ->
+      begin match the_def_of info a with
+        Some (Block (_, a)) ->
+          let a = Array.map (fun x -> Pv x) a in
+          Let (x, Prim (Extern "caml_js_opt_call",
+                        f :: o :: Array.to_list a))
+      | _ ->
+          i
+      end
+  | Let (x, Prim (Extern "caml_js_fun_call", [f; a])) ->
+      begin match the_def_of info a with
+        Some (Block (_, a)) ->
+          let a = Array.map (fun x -> Pv x) a in
+          Let (x, Prim (Extern "caml_js_opt_fun_call",
+                        f :: Array.to_list a))
+      | _ ->
+          i
+      end
+  | Let (x, Prim (Extern "caml_js_meth_call", [o; m; a])) ->
+      begin match the_def_of info m with
+        Some (Constant (String _ as m)) ->
+          begin match the_def_of info a with
+            Some (Block (_, a)) ->
+              let a = Array.map (fun x -> Pv x) a in
+              Let (x, Prim (Extern "caml_js_opt_meth_call",
+                            o :: Pc m :: Array.to_list a))
+          | _ ->
+              i
+          end
+      | _ ->
+          i
+      end
+  | Let (x, Prim (Extern "caml_js_new", [c; a])) ->
+      begin match the_def_of info a with
+        Some (Block (_, a)) ->
+          let a = Array.map (fun x -> Pv x) a in
+          Let (x, Prim (Extern "caml_js_opt_new",
+                        c :: Array.to_list a))
+      | _ ->
+          i
+      end
+  | Let (x, Prim (Extern "caml_js_object", [a])) ->
+      begin try
+        let a =
+          match the_def_of info a with
+            Some (Block (_, a)) -> a
+          | _                   -> raise Exit
+        in
+        let a =
+          Array.map
+            (fun x ->
+               match the_def_of info (Pv x) with
+                 Some (Block (_, [|k; v|])) ->
+                   let k =
+                     match the_def_of info (Pv k) with
+                       Some (Constant (String _ as s)) -> Pc s
+                     | _                               -> raise Exit
+                   in
+                   [k; Pv v]
+               | _ ->
+                   raise Exit)
+            a
+        in
+        Let (x, Prim (Extern "caml_js_opt_object",
+                      List.flatten (Array.to_list a)))
+      with Exit ->
+        i
+      end
+  | Let (x, Prim (Extern "caml_js_get", [o; f])) ->
+      begin match the_def_of info f with
+        Some (Constant (String _ as c)) ->
+          Let (x, Prim (Extern "caml_js_get", [o; Pc c]))
+      | _ ->
+          i
+      end
+  | Let (x, Prim (Extern "caml_js_set", [o; f; v])) ->
+      begin match the_def_of info f with
+        Some (Constant (String _ as c)) ->
+          Let (x, Prim (Extern "caml_js_set", [o; Pc c; v]))
+      | _ ->
+          i
+      end
+  | Let (x, Prim (Extern "caml_js_delete", [o; f])) ->
+      begin match the_def_of info f with
+        Some (Constant (String _ as c)) ->
+          Let (x, Prim (Extern "caml_js_delete", [o; Pc c]))
+      | _ ->
+          i
+      end
+  | Let (x, Prim (Extern "%int_mul", [y; z])) ->
+      begin match the_int info y, the_int info z with
+        Some j, _ | _, Some j when abs j < 0x200000 ->
+          Let (x, Prim (Extern "%direct_int_mul", [y; z]))
+      | _ ->
+          i
+      end
+  | Let (x, Prim (Extern "%int_div", [y; z])) ->
+      begin match the_int info z with
+        Some j when j <> 0 ->
+          Let (x, Prim (Extern "%direct_int_div", [y; z]))
+      | _ ->
+          i
+      end
+  | Let (x, Prim (Extern "%int_mod", [y; z])) ->
+      begin match the_int info z with
+        Some j when j <> 0 ->
+          Let (x, Prim (Extern "%direct_int_mod", [y; z]))
+      | _ ->
+          i
+      end
+
+  | _ ->
+      i
+
+let specialize_instrs info (pc, blocks, free_pc) =
+  let blocks =
+    AddrMap.map
+      (fun block ->
+         { block with Code.body =
+             List.map (fun i -> specialize_instr info i) block.body })
+      blocks
+  in
+  (pc, blocks, free_pc)
+
+(****)
+
+
+
+
+
+
+let f p info =
+  let p = specialize_instrs info p in
+  p

From 5c39ab15682a050e274488e75fc00b93f59c6e7a Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Sat, 14 Sep 2013 14:49:09 -0700
Subject: [PATCH 27/60] COMPILER: split specialize

---
 compiler/Makefile         |   2 +-
 compiler/specialize.ml    | 162 +-----------------------------------
 compiler/specialize_js.ml | 167 ++++++++++++++++++++++++++++++++++++++
 3 files changed, 170 insertions(+), 161 deletions(-)
 create mode 100644 compiler/specialize_js.ml

diff --git a/compiler/Makefile b/compiler/Makefile
index 29a3da7ea0..a3f4a96ec7 100644
--- a/compiler/Makefile
+++ b/compiler/Makefile
@@ -10,7 +10,7 @@ PACKAGES=findlib,str,unix,ocamlgraph
 OBJS=pretty_print.cmx util.cmx option.cmx dgraph.cmx \
      code.cmx javascript.cmx js_output.cmx js_simpl.cmx \
      instr.cmx primitive.cmx subst.cmx pure_fun.cmx deadcode.cmx \
-     flow.cmx specialize.cmx inline.cmx constant.cmx \
+     flow.cmx specialize.cmx specialize_js.cmx inline.cmx constant.cmx \
      tailcall.cmx freevars.cmx phisimpl.cmx \
 	   js_var.cmx \
      linker.cmx generate.cmx parse_bytecode.cmx driver.cmx
diff --git a/compiler/specialize.ml b/compiler/specialize.ml
index 6ba1ec0900..5fd1b0095d 100644
--- a/compiler/specialize.ml
+++ b/compiler/specialize.ml
@@ -1,30 +1,6 @@
-
-
-
 open Code
 open Flow
 
-(****)
-
-let the_def_of info x =
-  match x with
-    | Pv x ->
-      get_approx info
-        (fun x -> match info.info_defs.(Var.idx x) with Expr e -> Some e | _ -> None)
-        None (fun u v -> None) x
-    | Pc c -> Some (Constant c)
-
-let the_int info x =
-  match x with
-    | Pv x ->
-      get_approx info
-        (fun x -> match info.info_defs.(Var.idx x) with Expr (Const i) -> Some i | _ -> None)
-        None
-        (fun u v -> match u, v with Some i, Some j when i = j -> u | _ -> None)
-        x
-    | Pc (Int i) -> Some i
-    | _ -> None
-
 let function_cardinality info x =
   get_approx info
     (fun x ->
@@ -37,136 +13,9 @@ let function_cardinality info x =
 
 let specialize_instr info i =
   match i with
-    Let (x, Apply (f, l, _)) when Option.Optim.optcall () ->
+    | Let (x, Apply (f, l, _)) when Option.Optim.optcall () ->
       Let (x, Apply (f, l, function_cardinality info f))
-
-(*FIX this should be moved to a different file (javascript specific) *)
-  | Let (x, Prim (Extern "caml_js_var", [y])) ->
-      begin match the_def_of info y with
-        Some (Constant (String _ as c)) ->
-          Let (x, Prim (Extern "caml_js_var", [Pc c]))
-      | _ ->
-          i
-      end
-  | Let (x, Prim (Extern "caml_js_const", [y])) ->
-      begin match the_def_of info y with
-        Some (Constant (String _ as c)) ->
-          Let (x, Prim (Extern "caml_js_const", [Pc c]))
-      | _ ->
-          i
-      end
-  | Let (x, Prim (Extern "caml_js_call", [f; o; a])) ->
-      begin match the_def_of info a with
-        Some (Block (_, a)) ->
-          let a = Array.map (fun x -> Pv x) a in
-          Let (x, Prim (Extern "caml_js_opt_call",
-                        f :: o :: Array.to_list a))
-      | _ ->
-          i
-      end
-  | Let (x, Prim (Extern "caml_js_fun_call", [f; a])) ->
-      begin match the_def_of info a with
-        Some (Block (_, a)) ->
-          let a = Array.map (fun x -> Pv x) a in
-          Let (x, Prim (Extern "caml_js_opt_fun_call",
-                        f :: Array.to_list a))
-      | _ ->
-          i
-      end
-  | Let (x, Prim (Extern "caml_js_meth_call", [o; m; a])) ->
-      begin match the_def_of info m with
-        Some (Constant (String _ as m)) ->
-          begin match the_def_of info a with
-            Some (Block (_, a)) ->
-              let a = Array.map (fun x -> Pv x) a in
-              Let (x, Prim (Extern "caml_js_opt_meth_call",
-                            o :: Pc m :: Array.to_list a))
-          | _ ->
-              i
-          end
-      | _ ->
-          i
-      end
-  | Let (x, Prim (Extern "caml_js_new", [c; a])) ->
-      begin match the_def_of info a with
-        Some (Block (_, a)) ->
-          let a = Array.map (fun x -> Pv x) a in
-          Let (x, Prim (Extern "caml_js_opt_new",
-                        c :: Array.to_list a))
-      | _ ->
-          i
-      end
-  | Let (x, Prim (Extern "caml_js_object", [a])) ->
-      begin try
-        let a =
-          match the_def_of info a with
-            Some (Block (_, a)) -> a
-          | _                   -> raise Exit
-        in
-        let a =
-          Array.map
-            (fun x ->
-               match the_def_of info (Pv x) with
-                 Some (Block (_, [|k; v|])) ->
-                   let k =
-                     match the_def_of info (Pv k) with
-                       Some (Constant (String _ as s)) -> Pc s
-                     | _                               -> raise Exit
-                   in
-                   [k; Pv v]
-               | _ ->
-                   raise Exit)
-            a
-        in
-        Let (x, Prim (Extern "caml_js_opt_object",
-                      List.flatten (Array.to_list a)))
-      with Exit ->
-        i
-      end
-  | Let (x, Prim (Extern "caml_js_get", [o; f])) ->
-      begin match the_def_of info f with
-        Some (Constant (String _ as c)) ->
-          Let (x, Prim (Extern "caml_js_get", [o; Pc c]))
-      | _ ->
-          i
-      end
-  | Let (x, Prim (Extern "caml_js_set", [o; f; v])) ->
-      begin match the_def_of info f with
-        Some (Constant (String _ as c)) ->
-          Let (x, Prim (Extern "caml_js_set", [o; Pc c; v]))
-      | _ ->
-          i
-      end
-  | Let (x, Prim (Extern "caml_js_delete", [o; f])) ->
-      begin match the_def_of info f with
-        Some (Constant (String _ as c)) ->
-          Let (x, Prim (Extern "caml_js_delete", [o; Pc c]))
-      | _ ->
-          i
-      end
-  | Let (x, Prim (Extern "%int_mul", [y; z])) ->
-      begin match the_int info y, the_int info z with
-        Some j, _ | _, Some j when abs j < 0x200000 ->
-          Let (x, Prim (Extern "%direct_int_mul", [y; z]))
-      | _ ->
-          i
-      end
-  | Let (x, Prim (Extern "%int_div", [y; z])) ->
-      begin match the_int info z with
-        Some j when j <> 0 ->
-          Let (x, Prim (Extern "%direct_int_div", [y; z]))
-      | _ ->
-          i
-      end
-  | Let (x, Prim (Extern "%int_mod", [y; z])) ->
-      begin match the_int info z with
-        Some j when j <> 0 ->
-          Let (x, Prim (Extern "%direct_int_mod", [y; z]))
-      | _ ->
-          i
-      end
-
-  | _ ->
+    | _ ->
       i
 
 let specialize_instrs info (pc, blocks, free_pc) =
@@ -179,13 +28,6 @@ let specialize_instrs info (pc, blocks, free_pc) =
   in
   (pc, blocks, free_pc)
 
-(****)
-
-
-
-
-
-
 let f p info =
   let p = specialize_instrs info p in
   p
diff --git a/compiler/specialize_js.ml b/compiler/specialize_js.ml
new file mode 100644
index 0000000000..f4d4c74a90
--- /dev/null
+++ b/compiler/specialize_js.ml
@@ -0,0 +1,167 @@
+open Code
+open Flow
+
+let the_def_of info x =
+  match x with
+    | Pv x ->
+      get_approx info
+        (fun x -> match info.info_defs.(Var.idx x) with Expr e -> Some e | _ -> None)
+        None (fun u v -> None) x
+    | Pc c -> Some (Constant c)
+
+let the_int info x =
+  match x with
+    | Pv x ->
+      get_approx info
+        (fun x -> match info.info_defs.(Var.idx x) with Expr (Const i) -> Some i | _ -> None)
+        None
+        (fun u v -> match u, v with Some i, Some j when i = j -> u | _ -> None)
+        x
+    | Pc (Int i) -> Some i
+    | _ -> None
+
+
+let specialize_instr info i =
+  match i with
+
+  | Let (x, Prim (Extern "caml_js_var", [y])) ->
+      begin match the_def_of info y with
+        Some (Constant (String _ as c)) ->
+          Let (x, Prim (Extern "caml_js_var", [Pc c]))
+      | _ ->
+          i
+      end
+  | Let (x, Prim (Extern "caml_js_const", [y])) ->
+      begin match the_def_of info y with
+        Some (Constant (String _ as c)) ->
+          Let (x, Prim (Extern "caml_js_const", [Pc c]))
+      | _ ->
+          i
+      end
+  | Let (x, Prim (Extern "caml_js_call", [f; o; a])) ->
+      begin match the_def_of info a with
+        Some (Block (_, a)) ->
+          let a = Array.map (fun x -> Pv x) a in
+          Let (x, Prim (Extern "caml_js_opt_call",
+                        f :: o :: Array.to_list a))
+      | _ ->
+          i
+      end
+  | Let (x, Prim (Extern "caml_js_fun_call", [f; a])) ->
+      begin match the_def_of info a with
+        Some (Block (_, a)) ->
+          let a = Array.map (fun x -> Pv x) a in
+          Let (x, Prim (Extern "caml_js_opt_fun_call",
+                        f :: Array.to_list a))
+      | _ ->
+          i
+      end
+  | Let (x, Prim (Extern "caml_js_meth_call", [o; m; a])) ->
+      begin match the_def_of info m with
+        Some (Constant (String _ as m)) ->
+          begin match the_def_of info a with
+            Some (Block (_, a)) ->
+              let a = Array.map (fun x -> Pv x) a in
+              Let (x, Prim (Extern "caml_js_opt_meth_call",
+                            o :: Pc m :: Array.to_list a))
+          | _ ->
+              i
+          end
+      | _ ->
+          i
+      end
+  | Let (x, Prim (Extern "caml_js_new", [c; a])) ->
+      begin match the_def_of info a with
+        Some (Block (_, a)) ->
+          let a = Array.map (fun x -> Pv x) a in
+          Let (x, Prim (Extern "caml_js_opt_new",
+                        c :: Array.to_list a))
+      | _ ->
+          i
+      end
+  | Let (x, Prim (Extern "caml_js_object", [a])) ->
+      begin try
+        let a =
+          match the_def_of info a with
+            Some (Block (_, a)) -> a
+          | _                   -> raise Exit
+        in
+        let a =
+          Array.map
+            (fun x ->
+               match the_def_of info (Pv x) with
+                 Some (Block (_, [|k; v|])) ->
+                   let k =
+                     match the_def_of info (Pv k) with
+                       Some (Constant (String _ as s)) -> Pc s
+                     | _                               -> raise Exit
+                   in
+                   [k; Pv v]
+               | _ ->
+                   raise Exit)
+            a
+        in
+        Let (x, Prim (Extern "caml_js_opt_object",
+                      List.flatten (Array.to_list a)))
+      with Exit ->
+        i
+      end
+  | Let (x, Prim (Extern "caml_js_get", [o; f])) ->
+      begin match the_def_of info f with
+        Some (Constant (String _ as c)) ->
+          Let (x, Prim (Extern "caml_js_get", [o; Pc c]))
+      | _ ->
+          i
+      end
+  | Let (x, Prim (Extern "caml_js_set", [o; f; v])) ->
+      begin match the_def_of info f with
+        Some (Constant (String _ as c)) ->
+          Let (x, Prim (Extern "caml_js_set", [o; Pc c; v]))
+      | _ ->
+          i
+      end
+  | Let (x, Prim (Extern "caml_js_delete", [o; f])) ->
+      begin match the_def_of info f with
+        Some (Constant (String _ as c)) ->
+          Let (x, Prim (Extern "caml_js_delete", [o; Pc c]))
+      | _ ->
+          i
+      end
+  | Let (x, Prim (Extern "%int_mul", [y; z])) ->
+      begin match the_int info y, the_int info z with
+        Some j, _ | _, Some j when abs j < 0x200000 ->
+          Let (x, Prim (Extern "%direct_int_mul", [y; z]))
+      | _ ->
+          i
+      end
+  | Let (x, Prim (Extern "%int_div", [y; z])) ->
+      begin match the_int info z with
+        Some j when j <> 0 ->
+          Let (x, Prim (Extern "%direct_int_div", [y; z]))
+      | _ ->
+          i
+      end
+  | Let (x, Prim (Extern "%int_mod", [y; z])) ->
+      begin match the_int info z with
+        Some j when j <> 0 ->
+          Let (x, Prim (Extern "%direct_int_mod", [y; z]))
+      | _ ->
+          i
+      end
+  | _ -> i
+
+let specialize_instrs info (pc, blocks, free_pc) =
+  let blocks =
+    AddrMap.map
+      (fun block ->
+         { block with Code.body =
+             List.map (fun i -> specialize_instr info i) block.body })
+      blocks
+  in
+  (pc, blocks, free_pc)
+
+(****)
+
+let f p info =
+  let p = specialize_instrs info p in
+  p

From 05920c3dcd9d68e07d4616af6a1c586f25961504 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Sat, 14 Sep 2013 18:00:46 -0700
Subject: [PATCH 28/60] COMPILER: plugback specialize

---
 compiler/Makefile         |   2 +-
 compiler/constant.ml      | 184 --------------------------------------
 compiler/driver.ml        |  35 +++++---
 compiler/flow.ml          |  10 +++
 compiler/option.ml        |   2 +-
 compiler/specialize_js.ml | 163 ++++++++++++++++++++++++++++++++-
 6 files changed, 196 insertions(+), 200 deletions(-)
 delete mode 100644 compiler/constant.ml

diff --git a/compiler/Makefile b/compiler/Makefile
index a3f4a96ec7..82644212bf 100644
--- a/compiler/Makefile
+++ b/compiler/Makefile
@@ -10,7 +10,7 @@ PACKAGES=findlib,str,unix,ocamlgraph
 OBJS=pretty_print.cmx util.cmx option.cmx dgraph.cmx \
      code.cmx javascript.cmx js_output.cmx js_simpl.cmx \
      instr.cmx primitive.cmx subst.cmx pure_fun.cmx deadcode.cmx \
-     flow.cmx specialize.cmx specialize_js.cmx inline.cmx constant.cmx \
+     flow.cmx specialize.cmx specialize_js.cmx inline.cmx \
      tailcall.cmx freevars.cmx phisimpl.cmx \
 	   js_var.cmx \
      linker.cmx generate.cmx parse_bytecode.cmx driver.cmx
diff --git a/compiler/constant.ml b/compiler/constant.ml
deleted file mode 100644
index 754568af9e..0000000000
--- a/compiler/constant.ml
+++ /dev/null
@@ -1,184 +0,0 @@
-open Code
-
-let eval_prim x =
-  if Option.Optim.staticeval ()
-  then
-    let bool b = Some (Int (if b then 1 else 0)) in
-    match x with
-      | Not, [Pc (Int i)] -> bool (i=0)
-      | Lt,  [Pc (Int i);Pc (Int j) ] -> bool (i < j)
-      | Le,  [Pc (Int i);Pc (Int j) ] -> bool (i <= j)
-      | Eq,  [Pc (Int i);Pc (Int j) ] -> bool (i = j)
-      | Neq, [Pc (Int i);Pc (Int j) ] -> bool (i <> j)
-      | IsInt, [Pc (Int _)] -> bool (true)
-      | Ult, [Pc (Int i);Pc (Int j) ] -> bool (j < 0 || i < j)
-      | WrapInt, [Pc (Int i)] -> Some (Int i)
-      | Extern name, l ->
-        let name = Primitive.resolve name in
-        let module Int = Int32 in
-        let int2 = match l with
-          | [Pc (Int i); Pc (Int j)] -> fun f -> (try Some (Int (Int.to_int (f (Int.of_int i) (Int.of_int j)))) with _ -> None)
-          | _ -> fun _ -> None in
-        let int2_1 = match l with
-          | [Pc (Int i); Pc (Int j)] -> fun f -> (try Some (Int (Int.to_int (f (Int.of_int i) j))) with _ -> None)
-          | _ -> fun _ -> None in
-        let f2_aux =
-          try
-            let i,j = match l with
-              | [Pc (Float i); Pc (Float j)]-> i,j
-              | [Pc (Int i) ; Pc (Int j)] -> float_of_int i,float_of_int j
-              | [Pc (Int i) ; Pc (Float j)] -> float_of_int i,j
-              | [Pc (Float i) ; Pc (Int j)] -> i,float_of_int j
-              | _ -> raise Not_found
-            in
-            fun f -> (try Some (f i j) with _ -> None)
-          with _ -> fun _ -> None in
-        let f2 f = f2_aux (fun i j -> Float (f i j)) in
-        let f1 = match l with
-          | [Pc (Float i)] -> fun f -> (try Some (Float (f i)) with _ -> None)
-          | [Pc (Int i)] -> fun f -> (try Some (Float (f (float_of_int i))) with _ -> None)
-          | _ -> fun _ -> None in
-        let f2b f = f2_aux (fun i j -> Int (if f i j then 1 else 0)) in
-        (match name, l with
-          (* int *)
-          | "%int_add", _ -> int2 (Int.add)
-          | "%int_sub", _ -> int2 (Int.sub)
-          | "%direct_int_mul", _ -> int2 (Int.mul )
-          | "%direct_int_div", _ -> int2 (Int.div)
-          | "%direct_int_mod", _ -> int2 (Int.rem)
-          | "%int_and", _ -> int2 (Int.logand)
-          | "%int_or", _  -> int2 (Int.logor)
-          | "%int_xor", _ -> int2 (Int.logxor)
-          | "%int_lsl", _ -> int2_1 (Int.shift_left)
-          | "%int_lsr", _ -> int2_1 (Int.shift_right_logical)
-          | "%int_asr", _ -> int2_1 (Int.shift_right)
-          | "%int_neg", [Pc (Int i)] -> Some (Int (Int.to_int (Int.neg (Int.of_int i) )))
-          (* float *)
-          | "caml_eq_float", _ -> f2b (=)
-          | "caml_neq_float", _ -> f2b (<>)
-          | "caml_ge_float", _ -> f2b (>=)
-          | "caml_le_float", _ -> f2b (<=)
-          | "caml_gt_float", _ -> f2b (>)
-          | "caml_lt_float", _ -> f2b (<)
-          | "caml_add_float",_ -> f2 (+.)
-          | "caml_sub_float",_ -> f2 (-.)
-          | "caml_mul_float",_ -> f2 ( *. )
-          | "caml_div_float",_ -> f2 ( /. )
-          | "caml_fmod_float",_ -> f2 mod_float
-          | "caml_int_of_float",[Pc (Float f)] -> Some (Int (int_of_float f))
-          | "to_int",[Pc (Float f)]  -> Some (Int (int_of_float f))
-          | "to_int",[Pc (Int i)] -> Some (Int i)
-          (* Math *)
-          | "caml_abs_float",_ -> f1 abs_float
-          | "caml_acos_float",_ -> f1 acos
-          | "caml_asin_float",_ -> f1 asin
-          | "caml_atan_float",_ -> f1 atan
-          | "caml_atan2_float",_ -> f2 atan2
-          | "caml_ceil_float",_ -> f1 ceil
-          | "caml_cos_float",_ -> f1 cos
-          | "caml_exp_float",_ -> f1 exp
-          | "caml_floor_float",_ -> f1 floor
-          | "caml_log_float",_ -> f1 log
-          | "caml_power_float",_ -> f2 ( ** )
-          | "caml_sin_float",_ -> f1 sin
-          | "caml_sqrt_float",_ -> f1 sqrt
-          | "caml_tan_float",_ -> f1 tan
-          (* other *)
-          | ("caml_js_equals"|"caml_equal"), [Pc c1;Pc c2] -> bool (c1 = c2)
-          | ("caml_js_equals"|"caml_equal"), [Pv x1;Pv x2] when x1 = x2 -> bool true
-          | _ -> None)
-      | _ -> None
-  else None
-
-let propagate constants defs blocks free_pc pc =
-  let block = AddrMap.find pc blocks in
-  let body,constants = List.fold_left (fun (acc,constants) i ->
-      match i with
-        | Let (x,Prim (prim, prim_args))  ->
-          let prim_args = List.map (function
-              | Pv x' when VarMap.mem x' constants -> Pc (VarMap.find x' constants)
-              | x -> x) prim_args in
-          let exp,constants = match eval_prim (prim,prim_args) with
-            | Some c ->
-              let constants =
-                if defs.(Var.idx x) = 1
-                then VarMap.add x c constants
-                else constants in
-              Constant c, constants
-            | _ ->
-              (* if List.for_all (function Pc _ -> true | Pv _ -> false) prim_args *)
-              (* then (match prim with *)
-              (*   | Extern name -> Format.eprintf "%s(%d)@." name (List.length prim_args) *)
-              (*   | _ -> ()); *)
-              Prim (prim, prim_args),constants in
-          (Let (x,exp)::acc),constants
-        | Let (x,Field(y,n)) when VarMap.mem y constants ->
-          begin
-            match VarMap.find y constants with
-              | Tuple (_,tup) ->
-                let c = tup.(n) in
-                let constants =
-                  if defs.(Var.idx x) = 1
-                  then VarMap.add x c constants
-                  else constants in
-                Let (x, Constant c)::acc,constants
-              | _ -> (Let(x,Field(y,n)))::acc, constants
-          end
-        | x -> (x::acc),constants
-    ) ([],constants) block.body in
-  let body = List.rev body in
-  (* simplify branch *)
-  let branch = match block.branch with
-    | Cond (cond,x,ftrue,ffalse) when VarMap.mem x constants ->
-      let res = match cond, VarMap.find x constants with
-        | IsTrue, Int 1 -> true
-        | IsTrue, Int 0 -> false
-        | CEq i, Int j -> i = j
-        | CLt i, Int j -> i < j
-        | CLe i, Int j -> i<= j
-        | CUlt i, Int j -> j < 0 || i < j
-        | _ -> assert false in
-      (match res with
-        | true -> Branch ftrue
-        | false -> Branch ffalse)
-    | b -> b in
-  let blocks = AddrMap.add pc {block with body;branch} blocks in
-  blocks, free_pc, constants
-
-let rec is_mutable = function
-  | String _
-  | Float_array _ -> true
-  | Tuple (_,arr) ->
-    for i = 0 to Array.length arr do
-      ignore(not (is_mutable arr.(i)) || raise Not_found)
-    done;
-    false
-  | _ -> false
-
-let is_mutable x =
-  try is_mutable x with _ -> true
-
-let get_constant (_, blocks, _) defs =
-  AddrMap.fold
-    (fun _ block constants ->
-      List.fold_left
-        (fun constants i ->
-          match i with
-            | Let (x, Const i) when defs.(Var.idx x) = 1 ->
-              VarMap.add x (Int i) constants
-            | Let (x, Constant c) when not (is_mutable c) && defs.(Var.idx x) = 1 ->
-              VarMap.add x c constants
-            | _ -> constants)
-        constants block.body)
-    blocks VarMap.empty
-
-
-let f ((pc,blocks,free_pc) as p) defs =
-  let constants = get_constant p defs in
-  let blocks,free_pc,_ =
-    AddrMap.fold
-      (fun pc _ (blocks, free_pc,constants) ->
-        propagate constants defs blocks free_pc pc)
-      blocks
-      (blocks, free_pc,constants)
-  in (pc,blocks,free_pc)
diff --git a/compiler/driver.ml b/compiler/driver.ml
index 9ad28900ef..24fe8caefd 100644
--- a/compiler/driver.ml
+++ b/compiler/driver.ml
@@ -40,20 +40,26 @@ let inline p =
     Inline.f p live_vars
   else p
 
-let constant p =
-  if Option.Optim.constant ()
-  then
-    let (p,_,defs) = deadcode' p in
-    if debug () then Format.eprintf "Constant...@.";
-    Constant.f p defs
-  else p
+let specialize_1 (p,info) =
+  if debug () then Format.eprintf "Specialize...@.";
+  Specialize.f p info
+
+let specialize_js (p,info) =
+  if debug () then Format.eprintf "Specialize js...@.";
+  Specialize_js.f p info
+
+let specialize (p,info) =
+  let p = specialize_1 (p,info)in
+  let p = specialize_js (p,info) in
+  p
+
 let flow p =
   if debug () then Format.eprintf "Data flow...@.";
-  fst (Flow.f p)
+  Flow.f p
 
 let flow_simple p =
   if debug () then Format.eprintf "Data flow...@.";
-  fst (Flow.f ~skip_param:true p)
+  Flow.f ~skip_param:true p
 
 let phi p =
   if debug () then Format.eprintf "Variable passing simplification...@.";
@@ -86,14 +92,17 @@ let o1 : 'a -> 'a=
   tailcall >>
   phi >>
   flow >>
+  specialize >>
   inline >>
   deadcode >>
   print >>
   flow >>
+  specialize >>
   inline >>
   deadcode >>
   phi >>
   flow >>
+  specialize >>
   identity
 
 (* o2 *)
@@ -108,13 +117,17 @@ let round1 : 'a -> 'a =
   print >>
   tailcall >>
   inline >> (* inlining may reveal new tailcall opt *)
-  constant >>
+  deadcode >>
   (* deadcode required before flow simple -> provided by constant *)
   flow_simple >> (* flow simple to keep information for furture tailcall opt *)
+  specialize >>
   identity
 
 let round2 =
-  constant >> o1
+  flow >>
+  specialize >>
+  deadcode >>
+  o1
 
 let o3 =
   loop 10 "tailcall+inline" round1 1 >>
diff --git a/compiler/flow.ml b/compiler/flow.ml
index 298419e55f..24aa3eee04 100644
--- a/compiler/flow.ml
+++ b/compiler/flow.ml
@@ -198,6 +198,16 @@ let expr_escape st x e =
       ()
   | Apply (_, l, _) ->
       List.iter (fun x -> block_escape st x) l
+  | Prim ((Extern ( "caml_fill_string" |
+                   "caml_string_get" |
+                   "caml_string_set" )), (Pv s::_ as l)) ->
+    st.possibly_mutable.(Var.idx s) <- true;
+      List.iter
+        (fun x ->
+           match x with
+             Pv x -> block_escape st x
+           | Pc _ -> ())
+        l
   | Prim (_, l) ->
       List.iter
         (fun x ->
diff --git a/compiler/option.ml b/compiler/option.ml
index 9d108c7066..8f8b0584ff 100644
--- a/compiler/option.ml
+++ b/compiler/option.ml
@@ -72,6 +72,6 @@ module Optim = struct
   let compact =    o ~name:"compact" ~default:true
   let optcall =    o ~name:"optcall" ~default:true
   let inline =     o ~name:"inline" ~default:true
-  let staticeval = o ~name:"staticeval" ~default:false
+  let staticeval = o ~name:"staticeval" ~default:true
   let constant =   o ~name:"constant" ~default:true
 end
diff --git a/compiler/specialize_js.ml b/compiler/specialize_js.ml
index f4d4c74a90..7ba702419a 100644
--- a/compiler/specialize_js.ml
+++ b/compiler/specialize_js.ml
@@ -21,9 +21,156 @@ let the_int info x =
     | _ -> None
 
 
-let specialize_instr info i =
+let eval_prim x =
+  let bool b = Some (Int (if b then 1 else 0)) in
+  match x with
+    | Not, [Int i] -> bool (i=0)
+    | Lt,  [Int i; Int j ] -> bool (i < j)
+    | Le,  [Int i; Int j ] -> bool (i <= j)
+    | Eq,  [Int i; Int j ] -> bool (i = j)
+    | Neq, [Int i; Int j ] -> bool (i <> j)
+    | IsInt, [Int _] -> bool true
+    | Ult, [Int i; Int j ] -> bool (j < 0 || i < j)
+    | WrapInt, [Int i] -> Some (Int i)
+    | Extern name, l ->
+      let name = Primitive.resolve name in
+      let module Int = Int32 in
+      let int2 = match l with
+        | [Int i; Int j] -> fun f ->
+          (try Some (Int (Int.to_int (f (Int.of_int i) (Int.of_int j)))) with _ -> None)
+        | _ -> fun _ -> None in
+      let int2_1 = match l with
+        | [Int i; Int j] -> fun f ->
+          (try Some (Int (Int.to_int (f (Int.of_int i) j))) with _ -> None)
+        | _ -> fun _ -> None in
+      let f2_aux =
+        try
+          let i,j = match l with
+            | [Float i; Float j]-> i,j
+            | [Int i ; Int j] -> float_of_int i,float_of_int j
+            | [Int i ; Float j] -> float_of_int i,j
+            | [Float i ; Int j] -> i,float_of_int j
+            | _ -> raise Not_found
+          in
+          fun f -> (try Some (f i j) with _ -> None)
+        with _ -> fun _ -> None in
+      let f2 f = f2_aux (fun i j -> Float (f i j)) in
+      let f1 = match l with
+        | [Float i] -> fun f -> (try Some (Float (f i)) with _ -> None)
+        | [Int i] -> fun f -> (try Some (Float (f (float_of_int i))) with _ -> None)
+        | _ -> fun _ -> None in
+      let f2b f = f2_aux (fun i j -> Int (if f i j then 1 else 0)) in
+      (match name, l with
+        (* int *)
+        | "%int_add", _ -> int2 (Int.add)
+        | "%int_sub", _ -> int2 (Int.sub)
+        | "%direct_int_mul", _ -> int2 (Int.mul )
+        | "%direct_int_div", _ -> int2 (Int.div)
+        | "%direct_int_mod", _ -> int2 (Int.rem)
+        | "%int_and", _ -> int2 (Int.logand)
+        | "%int_or", _  -> int2 (Int.logor)
+        | "%int_xor", _ -> int2 (Int.logxor)
+        | "%int_lsl", _ -> int2_1 (Int.shift_left)
+        | "%int_lsr", _ -> int2_1 (Int.shift_right_logical)
+        | "%int_asr", _ -> int2_1 (Int.shift_right)
+        | "%int_neg", [Int i] -> Some (Int (Int.to_int (Int.neg (Int.of_int i) )))
+        (* float *)
+        | "caml_eq_float", _ -> f2b (=)
+        | "caml_neq_float", _ -> f2b (<>)
+        | "caml_ge_float", _ -> f2b (>=)
+        | "caml_le_float", _ -> f2b (<=)
+        | "caml_gt_float", _ -> f2b (>)
+        | "caml_lt_float", _ -> f2b (<)
+        | "caml_add_float",_ -> f2 (+.)
+        | "caml_sub_float",_ -> f2 (-.)
+        | "caml_mul_float",_ -> f2 ( *. )
+        | "caml_div_float",_ -> f2 ( /. )
+        | "caml_fmod_float",_ -> f2 mod_float
+        | "caml_int_of_float",[Float f] -> Some (Int (int_of_float f))
+        | "to_int",[Float f]  -> Some (Int (int_of_float f))
+        | "to_int",[Int i] -> Some (Int i)
+          (* Math *)
+        | "caml_abs_float",_ -> f1 abs_float
+        | "caml_acos_float",_ -> f1 acos
+        | "caml_asin_float",_ -> f1 asin
+        | "caml_atan_float",_ -> f1 atan
+        | "caml_atan2_float",_ -> f2 atan2
+        | "caml_ceil_float",_ -> f1 ceil
+        | "caml_cos_float",_ -> f1 cos
+        | "caml_exp_float",_ -> f1 exp
+        | "caml_floor_float",_ -> f1 floor
+        | "caml_log_float",_ -> f1 log
+        | "caml_power_float",_ -> f2 ( ** )
+        | "caml_sin_float",_ -> f1 sin
+        | "caml_sqrt_float",_ -> f1 sqrt
+        | "caml_tan_float",_ -> f1 tan
+        | _ -> None)
+    | _ -> None
+
+exception Not_constant
+
+let eval_instr info i =
   match i with
+    | Let (x, Prim (Extern ("caml_js_equals"|"caml_equal"), [Pv y; Pv z])) when Var.compare y z = 0 ->
+      Let (x , Constant (Int 1))
+    | Let (x, Prim (Extern ("caml_js_equals"|"caml_equal"), [y;z])) ->
+      begin match the_def_of info y, the_def_of info z with
+        | Some (Constant e1), Some (Constant e2) ->
+          let c =
+            if e1 = e2
+            then 1
+            else 0 in
+          Let (x , Constant (Int c))
+        | _ -> i
+      end
+    | Let (x,Prim (Extern ("caml_js_from_string"), [y])) ->
+      begin match the_def_of info y with
+        | Some (Constant (String str) as c) ->
+          begin match y with
+            | Pv y when false && not (info.info_possibly_mutable.(Var.idx y)) ->
+              Let(x,c)
+            | Pc _ ->
+              Let(x, c)
+            | _ -> i
+          end
+        | _ -> i
+      end
+    | Let (x,Prim (prim, prim_args)) ->
+      begin
+        try
+          let prim_args = List.map (fun x ->
+            match the_def_of info x with
+              | Some (Constant c) -> c
+              | Some (Const i) -> Int i
+              | _ -> raise Not_constant) prim_args in
+          match eval_prim (prim,prim_args) with
+            | Some c -> Let (x,Constant c)
+            | _ -> i
+        with Not_constant -> i
+      end
+    | _ -> i
 
+let eval_branch info = function
+  | Cond (cond,x,ftrue,ffalse) as b->
+    begin
+      match the_int info (Pv x) with
+        | Some j ->
+          let res = match cond with
+            | IsTrue -> (match j with 0 -> false | 1 -> true | _ -> assert false)
+            | CEq i -> i = j
+            | CLt i -> i < j
+            | CLe i -> i<= j
+            | CUlt i -> j < 0 || i < j
+          in
+          (match res with
+            | true -> Branch ftrue
+            | false -> Branch ffalse)
+        | _ -> b
+    end
+  | _ as b -> b
+
+let specialize_instr info i =
+  match i with
   | Let (x, Prim (Extern "caml_js_var", [y])) ->
       begin match the_def_of info y with
         Some (Constant (String _ as c)) ->
@@ -154,8 +301,18 @@ let specialize_instrs info (pc, blocks, free_pc) =
   let blocks =
     AddrMap.map
       (fun block ->
-         { block with Code.body =
-             List.map (fun i -> specialize_instr info i) block.body })
+         { block with
+           Code.body =
+             List.map (fun i ->
+               let i = specialize_instr info i in
+               if Option.Optim.staticeval()
+               then eval_instr info i
+               else i) block.body;
+           Code.branch =
+             if Option.Optim.staticeval()
+             then eval_branch info block.branch
+             else block.branch
+           })
       blocks
   in
   (pc, blocks, free_pc)

From ec9a51d4814ac92630cd3268f8c1f18ec063b8f5 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Sat, 14 Sep 2013 18:06:20 -0700
Subject: [PATCH 29/60] COMPILER: add IString

---
 compiler/code.ml     | 3 +++
 compiler/code.mli    | 1 +
 compiler/generate.ml | 2 ++
 3 files changed, 6 insertions(+)

diff --git a/compiler/code.ml b/compiler/code.ml
index f36c3f2521..2f1fe9f6f8 100644
--- a/compiler/code.ml
+++ b/compiler/code.ml
@@ -194,6 +194,7 @@ type prim =
 
 type constant =
     String of string
+  | IString of string
   | Float of float
   | Float_array of float array
   | Int32 of int32
@@ -258,6 +259,8 @@ let rec print_constant f x =
   match x with
     String s ->
       Format.fprintf f "%S" s
+  | IString s ->
+      Format.fprintf f "%S" s
   | Float fl ->
       Format.fprintf f "%.12g" fl
   | Float_array a ->
diff --git a/compiler/code.mli b/compiler/code.mli
index e0e9ff0f40..38c7368f64 100644
--- a/compiler/code.mli
+++ b/compiler/code.mli
@@ -86,6 +86,7 @@ type prim =
 
 type constant =
     String of string
+  | IString of string
   | Float of float
   | Float_array of float array
   | Int32 of int32
diff --git a/compiler/generate.ml b/compiler/generate.ml
index e7ac009ff1..0318f25600 100644
--- a/compiler/generate.ml
+++ b/compiler/generate.ml
@@ -90,6 +90,8 @@ let rec constant x =
     String s ->
       Primitive.mark_used "MlString";
       J.ENew (J.EVar (J.S "MlString"), Some [J.EStr (s, `Bytes)])
+  | IString s ->
+    J.EStr (s, `Bytes)
   | Float f ->
       float_const f
   | Float_array a ->

From 28166bed61885c22d9338f78a9b7451d921f78ac Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Sat, 14 Sep 2013 18:23:11 -0700
Subject: [PATCH 30/60] COMPILER: propagate constant string

---
 compiler/.depend          | 20 ++++++++++----------
 compiler/specialize_js.ml |  8 ++++----
 2 files changed, 14 insertions(+), 14 deletions(-)

diff --git a/compiler/.depend b/compiler/.depend
index 9602aea009..11ac6d9a90 100644
--- a/compiler/.depend
+++ b/compiler/.depend
@@ -1,21 +1,19 @@
 code.cmo : util.cmi option.cmo code.cmi
 code.cmx : util.cmx option.cmx code.cmi
-constant.cmo : primitive.cmi option.cmo code.cmi
-constant.cmx : primitive.cmx option.cmx code.cmx
 control.cmo : subst.cmi code.cmi control.cmi
 control.cmx : subst.cmx code.cmx control.cmi
 deadcode.cmo : util.cmi pure_fun.cmi option.cmo code.cmi deadcode.cmi
 deadcode.cmx : util.cmx pure_fun.cmx option.cmx code.cmx deadcode.cmi
 dgraph.cmo : dgraph.cmi
 dgraph.cmx : dgraph.cmi
-driver.cmo : tailcall.cmi primitive.cmi pretty_print.cmi phisimpl.cmi \
-    parse_bytecode.cmi option.cmo linker.cmi js_var.cmi js_output.cmi \
-    inline.cmi generate.cmi flow.cmi deadcode.cmi constant.cmo code.cmi \
-    driver.cmi
-driver.cmx : tailcall.cmx primitive.cmx pretty_print.cmx phisimpl.cmx \
-    parse_bytecode.cmx option.cmx linker.cmx js_var.cmx js_output.cmx \
-    inline.cmx generate.cmx flow.cmx deadcode.cmx constant.cmx code.cmx \
-    driver.cmi
+driver.cmo : tailcall.cmi specialize_js.cmo specialize.cmo primitive.cmi \
+    pretty_print.cmi phisimpl.cmi parse_bytecode.cmi option.cmo linker.cmi \
+    js_var.cmi js_output.cmi inline.cmi generate.cmi flow.cmi deadcode.cmi \
+    code.cmi driver.cmi
+driver.cmx : tailcall.cmx specialize_js.cmx specialize.cmx primitive.cmx \
+    pretty_print.cmx phisimpl.cmx parse_bytecode.cmx option.cmx linker.cmx \
+    js_var.cmx js_output.cmx inline.cmx generate.cmx flow.cmx deadcode.cmx \
+    code.cmx driver.cmi
 flow.cmo : util.cmi subst.cmi option.cmo dgraph.cmi code.cmi flow.cmi
 flow.cmx : util.cmx subst.cmx option.cmx dgraph.cmx code.cmx flow.cmi
 freevars.cmo : util.cmi option.cmo code.cmi freevars.cmi
@@ -64,6 +62,8 @@ pure_fun.cmo : primitive.cmi code.cmi pure_fun.cmi
 pure_fun.cmx : primitive.cmx code.cmx pure_fun.cmi
 specialize.cmo : option.cmo flow.cmi code.cmi
 specialize.cmx : option.cmx flow.cmx code.cmx
+specialize_js.cmo : primitive.cmi option.cmo flow.cmi code.cmi
+specialize_js.cmx : primitive.cmx option.cmx flow.cmx code.cmx
 subst.cmo : util.cmi code.cmi subst.cmi
 subst.cmx : util.cmx code.cmx subst.cmi
 tailcall.cmo : util.cmi subst.cmi option.cmo code.cmi tailcall.cmi
diff --git a/compiler/specialize_js.ml b/compiler/specialize_js.ml
index 7ba702419a..ee62cdde9c 100644
--- a/compiler/specialize_js.ml
+++ b/compiler/specialize_js.ml
@@ -125,12 +125,12 @@ let eval_instr info i =
       end
     | Let (x,Prim (Extern ("caml_js_from_string"), [y])) ->
       begin match the_def_of info y with
-        | Some (Constant (String str) as c) ->
+        | Some (Constant (String str)) ->
           begin match y with
-            | Pv y when false && not (info.info_possibly_mutable.(Var.idx y)) ->
-              Let(x,c)
+            | Pv y when true || not (info.info_possibly_mutable.(Var.idx y)) ->
+              Let(x,(Constant (IString str)))
             | Pc _ ->
-              Let(x, c)
+              Let(x, (Constant (IString str)))
             | _ -> i
           end
         | _ -> i

From 6a1c9e74be31d07ae7e5fba5c05a90fa3cc9f344 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Sat, 14 Sep 2013 18:57:15 -0700
Subject: [PATCH 31/60] COMPILER: add static eval

---
 compiler/.depend          |   6 +-
 compiler/Makefile         |   2 +-
 compiler/driver.ml        |  20 ++++-
 compiler/eval.ml          | 165 +++++++++++++++++++++++++++++++++++
 compiler/flow.ml          |  26 +++++-
 compiler/flow.mli         |   4 +
 compiler/specialize_js.ml | 177 +-------------------------------------
 7 files changed, 214 insertions(+), 186 deletions(-)
 create mode 100644 compiler/eval.ml

diff --git a/compiler/.depend b/compiler/.depend
index 11ac6d9a90..36b810ac29 100644
--- a/compiler/.depend
+++ b/compiler/.depend
@@ -14,6 +14,8 @@ driver.cmx : tailcall.cmx specialize_js.cmx specialize.cmx primitive.cmx \
     pretty_print.cmx phisimpl.cmx parse_bytecode.cmx option.cmx linker.cmx \
     js_var.cmx js_output.cmx inline.cmx generate.cmx flow.cmx deadcode.cmx \
     code.cmx driver.cmi
+eval.cmo : primitive.cmi option.cmo flow.cmi code.cmi
+eval.cmx : primitive.cmx option.cmx flow.cmx code.cmx
 flow.cmo : util.cmi subst.cmi option.cmo dgraph.cmi code.cmi flow.cmi
 flow.cmx : util.cmx subst.cmx option.cmx dgraph.cmx code.cmx flow.cmi
 freevars.cmo : util.cmi option.cmo code.cmi freevars.cmi
@@ -62,8 +64,8 @@ pure_fun.cmo : primitive.cmi code.cmi pure_fun.cmi
 pure_fun.cmx : primitive.cmx code.cmx pure_fun.cmi
 specialize.cmo : option.cmo flow.cmi code.cmi
 specialize.cmx : option.cmx flow.cmx code.cmx
-specialize_js.cmo : primitive.cmi option.cmo flow.cmi code.cmi
-specialize_js.cmx : primitive.cmx option.cmx flow.cmx code.cmx
+specialize_js.cmo : flow.cmi code.cmi
+specialize_js.cmx : flow.cmx code.cmx
 subst.cmo : util.cmi code.cmi subst.cmi
 subst.cmx : util.cmx code.cmx subst.cmi
 tailcall.cmo : util.cmi subst.cmi option.cmo code.cmi tailcall.cmi
diff --git a/compiler/Makefile b/compiler/Makefile
index 82644212bf..25addc53ed 100644
--- a/compiler/Makefile
+++ b/compiler/Makefile
@@ -10,7 +10,7 @@ PACKAGES=findlib,str,unix,ocamlgraph
 OBJS=pretty_print.cmx util.cmx option.cmx dgraph.cmx \
      code.cmx javascript.cmx js_output.cmx js_simpl.cmx \
      instr.cmx primitive.cmx subst.cmx pure_fun.cmx deadcode.cmx \
-     flow.cmx specialize.cmx specialize_js.cmx inline.cmx \
+     flow.cmx specialize.cmx specialize_js.cmx eval.cmx inline.cmx \
      tailcall.cmx freevars.cmx phisimpl.cmx \
 	   js_var.cmx \
      linker.cmx generate.cmx parse_bytecode.cmx driver.cmx
diff --git a/compiler/driver.ml b/compiler/driver.ml
index 24fe8caefd..6701880e65 100644
--- a/compiler/driver.ml
+++ b/compiler/driver.ml
@@ -48,10 +48,20 @@ let specialize_js (p,info) =
   if debug () then Format.eprintf "Specialize js...@.";
   Specialize_js.f p info
 
-let specialize (p,info) =
+let specialize' (p,info) =
   let p = specialize_1 (p,info)in
   let p = specialize_js (p,info) in
-  p
+  p,info
+
+let specialize p =
+  fst (specialize' p)
+
+let eval (p,info) =
+  if Option.Optim.staticeval()
+  then
+    let (p,live_vars,_) = deadcode' p in
+    Eval.f info live_vars p
+  else p
 
 let flow p =
   if debug () then Format.eprintf "Data flow...@.";
@@ -120,12 +130,14 @@ let round1 : 'a -> 'a =
   deadcode >>
   (* deadcode required before flow simple -> provided by constant *)
   flow_simple >> (* flow simple to keep information for furture tailcall opt *)
-  specialize >>
+  specialize' >>
+  eval >>
   identity
 
 let round2 =
   flow >>
-  specialize >>
+  specialize' >>
+  eval >>
   deadcode >>
   o1
 
diff --git a/compiler/eval.ml b/compiler/eval.ml
new file mode 100644
index 0000000000..522b57a9fc
--- /dev/null
+++ b/compiler/eval.ml
@@ -0,0 +1,165 @@
+open Code
+open Flow
+
+let eval_prim x =
+  let bool b = Some (Int (if b then 1 else 0)) in
+  match x with
+    | Not, [Int i] -> bool (i=0)
+    | Lt,  [Int i; Int j ] -> bool (i < j)
+    | Le,  [Int i; Int j ] -> bool (i <= j)
+    | Eq,  [Int i; Int j ] -> bool (i = j)
+    | Neq, [Int i; Int j ] -> bool (i <> j)
+    | IsInt, [Int _] -> bool true
+    | Ult, [Int i; Int j ] -> bool (j < 0 || i < j)
+    | WrapInt, [Int i] -> Some (Int i)
+    | Extern name, l ->
+      let name = Primitive.resolve name in
+      let module Int = Int32 in
+      let int2 = match l with
+        | [Int i; Int j] -> fun f ->
+          (try Some (Int (Int.to_int (f (Int.of_int i) (Int.of_int j)))) with _ -> None)
+        | _ -> fun _ -> None in
+      let int2_1 = match l with
+        | [Int i; Int j] -> fun f ->
+          (try Some (Int (Int.to_int (f (Int.of_int i) j))) with _ -> None)
+        | _ -> fun _ -> None in
+      let f2_aux =
+        try
+          let i,j = match l with
+            | [Float i; Float j]-> i,j
+            | [Int i ; Int j] -> float_of_int i,float_of_int j
+            | [Int i ; Float j] -> float_of_int i,j
+            | [Float i ; Int j] -> i,float_of_int j
+            | _ -> raise Not_found
+          in
+          fun f -> (try Some (f i j) with _ -> None)
+        with _ -> fun _ -> None in
+      let f2 f = f2_aux (fun i j -> Float (f i j)) in
+      let f1 = match l with
+        | [Float i] -> fun f -> (try Some (Float (f i)) with _ -> None)
+        | [Int i] -> fun f -> (try Some (Float (f (float_of_int i))) with _ -> None)
+        | _ -> fun _ -> None in
+      let f2b f = f2_aux (fun i j -> Int (if f i j then 1 else 0)) in
+      (match name, l with
+        (* int *)
+        | "%int_add", _ -> int2 (Int.add)
+        | "%int_sub", _ -> int2 (Int.sub)
+        | "%direct_int_mul", _ -> int2 (Int.mul )
+        | "%direct_int_div", _ -> int2 (Int.div)
+        | "%direct_int_mod", _ -> int2 (Int.rem)
+        | "%int_and", _ -> int2 (Int.logand)
+        | "%int_or", _  -> int2 (Int.logor)
+        | "%int_xor", _ -> int2 (Int.logxor)
+        | "%int_lsl", _ -> int2_1 (Int.shift_left)
+        | "%int_lsr", _ -> int2_1 (Int.shift_right_logical)
+        | "%int_asr", _ -> int2_1 (Int.shift_right)
+        | "%int_neg", [Int i] -> Some (Int (Int.to_int (Int.neg (Int.of_int i) )))
+        (* float *)
+        | "caml_eq_float", _ -> f2b (=)
+        | "caml_neq_float", _ -> f2b (<>)
+        | "caml_ge_float", _ -> f2b (>=)
+        | "caml_le_float", _ -> f2b (<=)
+        | "caml_gt_float", _ -> f2b (>)
+        | "caml_lt_float", _ -> f2b (<)
+        | "caml_add_float",_ -> f2 (+.)
+        | "caml_sub_float",_ -> f2 (-.)
+        | "caml_mul_float",_ -> f2 ( *. )
+        | "caml_div_float",_ -> f2 ( /. )
+        | "caml_fmod_float",_ -> f2 mod_float
+        | "caml_int_of_float",[Float f] -> Some (Int (int_of_float f))
+        | "to_int",[Float f]  -> Some (Int (int_of_float f))
+        | "to_int",[Int i] -> Some (Int i)
+          (* Math *)
+        | "caml_abs_float",_ -> f1 abs_float
+        | "caml_acos_float",_ -> f1 acos
+        | "caml_asin_float",_ -> f1 asin
+        | "caml_atan_float",_ -> f1 atan
+        | "caml_atan2_float",_ -> f2 atan2
+        | "caml_ceil_float",_ -> f1 ceil
+        | "caml_cos_float",_ -> f1 cos
+        | "caml_exp_float",_ -> f1 exp
+        | "caml_floor_float",_ -> f1 floor
+        | "caml_log_float",_ -> f1 log
+        | "caml_power_float",_ -> f2 ( ** )
+        | "caml_sin_float",_ -> f1 sin
+        | "caml_sqrt_float",_ -> f1 sqrt
+        | "caml_tan_float",_ -> f1 tan
+        | _ -> None)
+    | _ -> None
+
+exception Not_constant
+
+let eval_instr info live i =
+  match i with
+    | Let (x, Prim (Extern ("caml_js_equals"|"caml_equal"), [Pv y; Pv z])) when Var.compare y z = 0 ->
+      Let (x , Constant (Int 1))
+    | Let (x, Prim (Extern ("caml_js_equals"|"caml_equal"), [y;z])) ->
+      begin match the_def_of info y, the_def_of info z with
+        | Some (Constant e1), Some (Constant e2) ->
+          let c =
+            if e1 = e2
+            then 1
+            else 0 in
+          Let (x , Constant (Int c))
+        | _ -> i
+      end
+    | Let (x,Prim (Extern ("caml_js_from_string"), [y])) ->
+      begin match the_def_of info y with
+        | Some (Constant (String str)) ->
+          begin match y with
+            | Pv y when live.(Var.idx y) <= 1 ->
+              Let(x,(Constant (IString str)))
+            | Pc _ ->
+              Let(x, (Constant (IString str)))
+            | _ -> i
+          end
+        | _ -> i
+      end
+    | Let (x,Prim (prim, prim_args)) ->
+      begin
+        try
+          let prim_args = List.map (fun x ->
+            match the_def_of info x with
+              | Some (Constant c) -> c
+              | Some (Const i) -> Int i
+              | _ -> raise Not_constant) prim_args in
+          match eval_prim (prim,prim_args) with
+            | Some c -> Let (x,Constant c)
+            | _ -> i
+        with Not_constant -> i
+      end
+    | _ -> i
+
+let eval_branch info = function
+  | Cond (cond,x,ftrue,ffalse) as b->
+    begin
+      match the_int info (Pv x) with
+        | Some j ->
+          let res = match cond with
+            | IsTrue -> (match j with 0 -> false | 1 -> true | _ -> assert false)
+            | CEq i -> i = j
+            | CLt i -> i < j
+            | CLe i -> i<= j
+            | CUlt i -> j < 0 || i < j
+          in
+          (match res with
+            | true -> Branch ftrue
+            | false -> Branch ffalse)
+        | _ -> b
+    end
+  | _ as b -> b
+
+
+
+let f info live (pc, blocks, free_pc) =
+  let blocks =
+    AddrMap.map
+      (fun block ->
+         { block with
+           Code.body =
+             List.map (eval_instr info live) block.body;
+           Code.branch = eval_branch info block.branch
+         })
+      blocks
+  in
+  (pc, blocks, free_pc)
diff --git a/compiler/flow.ml b/compiler/flow.ml
index 24aa3eee04..11421f1768 100644
--- a/compiler/flow.ml
+++ b/compiler/flow.ml
@@ -36,6 +36,7 @@ type info = {
   info_possibly_mutable : bool array
 }
 
+
 let undefined = Phi VarSet.empty
 
 let is_undefined d = match d with Phi s -> VarSet.is_empty s | _ -> false
@@ -204,9 +205,9 @@ let expr_escape st x e =
     st.possibly_mutable.(Var.idx s) <- true;
       List.iter
         (fun x ->
-           match x with
-             Pv x -> block_escape st x
-           | Pc _ -> ())
+          match x with
+              Pv x -> block_escape st x
+            | Pc _ -> ())
         l
   | Prim (_, l) ->
       List.iter
@@ -308,6 +309,25 @@ let get_approx {info_defs; info_known_origins;info_maybe_unknown} f top join x =
   | 1 -> f (VarSet.choose s)
   | _ -> VarSet.fold (fun x u -> join (f x) u) s (f (VarSet.choose s))
 
+let the_def_of info x =
+  match x with
+    | Pv x ->
+      get_approx info
+        (fun x -> match info.info_defs.(Var.idx x) with Expr e -> Some e | _ -> None)
+        None (fun u v -> None) x
+    | Pc c -> Some (Constant c)
+
+let the_int info x =
+  match x with
+    | Pv x ->
+      get_approx info
+        (fun x -> match info.info_defs.(Var.idx x) with Expr (Const i) -> Some i | _ -> None)
+        None
+        (fun u v -> match u, v with Some i, Some j when i = j -> u | _ -> None)
+        x
+    | Pc (Int i) -> Some i
+    | _ -> None
+
 (*XXX Maybe we could iterate? *)
 let direct_approx info x =
   match info.info_defs.(Var.idx x) with
diff --git a/compiler/flow.mli b/compiler/flow.mli
index ad99ea2465..0437386263 100644
--- a/compiler/flow.mli
+++ b/compiler/flow.mli
@@ -49,4 +49,8 @@ type info = {
 val get_approx : info -> (Code.VarSet.elt -> 'b) ->
            'b -> ('b -> 'b -> 'b) -> Code.VarTbl.key -> 'b
 
+val the_def_of : info -> Code.prim_arg -> Code.expr option
+
+val the_int : info -> Code.prim_arg -> int option
+
 val f : ?skip_param:bool -> Code.program -> Code.program * info
diff --git a/compiler/specialize_js.ml b/compiler/specialize_js.ml
index ee62cdde9c..6d23b33ff5 100644
--- a/compiler/specialize_js.ml
+++ b/compiler/specialize_js.ml
@@ -1,173 +1,6 @@
 open Code
 open Flow
 
-let the_def_of info x =
-  match x with
-    | Pv x ->
-      get_approx info
-        (fun x -> match info.info_defs.(Var.idx x) with Expr e -> Some e | _ -> None)
-        None (fun u v -> None) x
-    | Pc c -> Some (Constant c)
-
-let the_int info x =
-  match x with
-    | Pv x ->
-      get_approx info
-        (fun x -> match info.info_defs.(Var.idx x) with Expr (Const i) -> Some i | _ -> None)
-        None
-        (fun u v -> match u, v with Some i, Some j when i = j -> u | _ -> None)
-        x
-    | Pc (Int i) -> Some i
-    | _ -> None
-
-
-let eval_prim x =
-  let bool b = Some (Int (if b then 1 else 0)) in
-  match x with
-    | Not, [Int i] -> bool (i=0)
-    | Lt,  [Int i; Int j ] -> bool (i < j)
-    | Le,  [Int i; Int j ] -> bool (i <= j)
-    | Eq,  [Int i; Int j ] -> bool (i = j)
-    | Neq, [Int i; Int j ] -> bool (i <> j)
-    | IsInt, [Int _] -> bool true
-    | Ult, [Int i; Int j ] -> bool (j < 0 || i < j)
-    | WrapInt, [Int i] -> Some (Int i)
-    | Extern name, l ->
-      let name = Primitive.resolve name in
-      let module Int = Int32 in
-      let int2 = match l with
-        | [Int i; Int j] -> fun f ->
-          (try Some (Int (Int.to_int (f (Int.of_int i) (Int.of_int j)))) with _ -> None)
-        | _ -> fun _ -> None in
-      let int2_1 = match l with
-        | [Int i; Int j] -> fun f ->
-          (try Some (Int (Int.to_int (f (Int.of_int i) j))) with _ -> None)
-        | _ -> fun _ -> None in
-      let f2_aux =
-        try
-          let i,j = match l with
-            | [Float i; Float j]-> i,j
-            | [Int i ; Int j] -> float_of_int i,float_of_int j
-            | [Int i ; Float j] -> float_of_int i,j
-            | [Float i ; Int j] -> i,float_of_int j
-            | _ -> raise Not_found
-          in
-          fun f -> (try Some (f i j) with _ -> None)
-        with _ -> fun _ -> None in
-      let f2 f = f2_aux (fun i j -> Float (f i j)) in
-      let f1 = match l with
-        | [Float i] -> fun f -> (try Some (Float (f i)) with _ -> None)
-        | [Int i] -> fun f -> (try Some (Float (f (float_of_int i))) with _ -> None)
-        | _ -> fun _ -> None in
-      let f2b f = f2_aux (fun i j -> Int (if f i j then 1 else 0)) in
-      (match name, l with
-        (* int *)
-        | "%int_add", _ -> int2 (Int.add)
-        | "%int_sub", _ -> int2 (Int.sub)
-        | "%direct_int_mul", _ -> int2 (Int.mul )
-        | "%direct_int_div", _ -> int2 (Int.div)
-        | "%direct_int_mod", _ -> int2 (Int.rem)
-        | "%int_and", _ -> int2 (Int.logand)
-        | "%int_or", _  -> int2 (Int.logor)
-        | "%int_xor", _ -> int2 (Int.logxor)
-        | "%int_lsl", _ -> int2_1 (Int.shift_left)
-        | "%int_lsr", _ -> int2_1 (Int.shift_right_logical)
-        | "%int_asr", _ -> int2_1 (Int.shift_right)
-        | "%int_neg", [Int i] -> Some (Int (Int.to_int (Int.neg (Int.of_int i) )))
-        (* float *)
-        | "caml_eq_float", _ -> f2b (=)
-        | "caml_neq_float", _ -> f2b (<>)
-        | "caml_ge_float", _ -> f2b (>=)
-        | "caml_le_float", _ -> f2b (<=)
-        | "caml_gt_float", _ -> f2b (>)
-        | "caml_lt_float", _ -> f2b (<)
-        | "caml_add_float",_ -> f2 (+.)
-        | "caml_sub_float",_ -> f2 (-.)
-        | "caml_mul_float",_ -> f2 ( *. )
-        | "caml_div_float",_ -> f2 ( /. )
-        | "caml_fmod_float",_ -> f2 mod_float
-        | "caml_int_of_float",[Float f] -> Some (Int (int_of_float f))
-        | "to_int",[Float f]  -> Some (Int (int_of_float f))
-        | "to_int",[Int i] -> Some (Int i)
-          (* Math *)
-        | "caml_abs_float",_ -> f1 abs_float
-        | "caml_acos_float",_ -> f1 acos
-        | "caml_asin_float",_ -> f1 asin
-        | "caml_atan_float",_ -> f1 atan
-        | "caml_atan2_float",_ -> f2 atan2
-        | "caml_ceil_float",_ -> f1 ceil
-        | "caml_cos_float",_ -> f1 cos
-        | "caml_exp_float",_ -> f1 exp
-        | "caml_floor_float",_ -> f1 floor
-        | "caml_log_float",_ -> f1 log
-        | "caml_power_float",_ -> f2 ( ** )
-        | "caml_sin_float",_ -> f1 sin
-        | "caml_sqrt_float",_ -> f1 sqrt
-        | "caml_tan_float",_ -> f1 tan
-        | _ -> None)
-    | _ -> None
-
-exception Not_constant
-
-let eval_instr info i =
-  match i with
-    | Let (x, Prim (Extern ("caml_js_equals"|"caml_equal"), [Pv y; Pv z])) when Var.compare y z = 0 ->
-      Let (x , Constant (Int 1))
-    | Let (x, Prim (Extern ("caml_js_equals"|"caml_equal"), [y;z])) ->
-      begin match the_def_of info y, the_def_of info z with
-        | Some (Constant e1), Some (Constant e2) ->
-          let c =
-            if e1 = e2
-            then 1
-            else 0 in
-          Let (x , Constant (Int c))
-        | _ -> i
-      end
-    | Let (x,Prim (Extern ("caml_js_from_string"), [y])) ->
-      begin match the_def_of info y with
-        | Some (Constant (String str)) ->
-          begin match y with
-            | Pv y when true || not (info.info_possibly_mutable.(Var.idx y)) ->
-              Let(x,(Constant (IString str)))
-            | Pc _ ->
-              Let(x, (Constant (IString str)))
-            | _ -> i
-          end
-        | _ -> i
-      end
-    | Let (x,Prim (prim, prim_args)) ->
-      begin
-        try
-          let prim_args = List.map (fun x ->
-            match the_def_of info x with
-              | Some (Constant c) -> c
-              | Some (Const i) -> Int i
-              | _ -> raise Not_constant) prim_args in
-          match eval_prim (prim,prim_args) with
-            | Some c -> Let (x,Constant c)
-            | _ -> i
-        with Not_constant -> i
-      end
-    | _ -> i
-
-let eval_branch info = function
-  | Cond (cond,x,ftrue,ffalse) as b->
-    begin
-      match the_int info (Pv x) with
-        | Some j ->
-          let res = match cond with
-            | IsTrue -> (match j with 0 -> false | 1 -> true | _ -> assert false)
-            | CEq i -> i = j
-            | CLt i -> i < j
-            | CLe i -> i<= j
-            | CUlt i -> j < 0 || i < j
-          in
-          (match res with
-            | true -> Branch ftrue
-            | false -> Branch ffalse)
-        | _ -> b
-    end
-  | _ as b -> b
 
 let specialize_instr info i =
   match i with
@@ -303,15 +136,7 @@ let specialize_instrs info (pc, blocks, free_pc) =
       (fun block ->
          { block with
            Code.body =
-             List.map (fun i ->
-               let i = specialize_instr info i in
-               if Option.Optim.staticeval()
-               then eval_instr info i
-               else i) block.body;
-           Code.branch =
-             if Option.Optim.staticeval()
-             then eval_branch info block.branch
-             else block.branch
+             List.map (specialize_instr info) block.body;
            })
       blocks
   in

From 17ecae0726717680d3a6d70d21ffb840db1f2061 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Sat, 14 Sep 2013 19:00:43 -0700
Subject: [PATCH 32/60] COMPILER: remove previous attempt

---
 compiler/flow.ml | 10 ----------
 1 file changed, 10 deletions(-)

diff --git a/compiler/flow.ml b/compiler/flow.ml
index 11421f1768..b339666ddd 100644
--- a/compiler/flow.ml
+++ b/compiler/flow.ml
@@ -199,16 +199,6 @@ let expr_escape st x e =
       ()
   | Apply (_, l, _) ->
       List.iter (fun x -> block_escape st x) l
-  | Prim ((Extern ( "caml_fill_string" |
-                   "caml_string_get" |
-                   "caml_string_set" )), (Pv s::_ as l)) ->
-    st.possibly_mutable.(Var.idx s) <- true;
-      List.iter
-        (fun x ->
-          match x with
-              Pv x -> block_escape st x
-            | Pc _ -> ())
-        l
   | Prim (_, l) ->
       List.iter
         (fun x ->

From b665c0f2a5b0105f4292a7a9f919a96adedd2cb9 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Mon, 10 Jun 2013 14:05:21 -0700
Subject: [PATCH 33/60] COMPILER: share string constant

Conflicts:
	compiler/.depend
	lib/.depend

Conflicts:
	compiler/generate.ml

Conflicts:
	compiler/constant.ml
	compiler/driver.ml
	compiler/flow.ml
---
 compiler/code.ml     |  1 +
 compiler/code.mli    |  1 +
 compiler/generate.ml | 78 ++++++++++++++++++++++++++++++++++++--------
 runtime/mlString.js  |  3 ++
 4 files changed, 69 insertions(+), 14 deletions(-)

diff --git a/compiler/code.ml b/compiler/code.ml
index 2f1fe9f6f8..ec15510303 100644
--- a/compiler/code.ml
+++ b/compiler/code.ml
@@ -154,6 +154,7 @@ end
 
 module VarSet = Set.Make (Var)
 module VarMap = Map.Make (Var)
+module StringMap = Map.Make(String)
 module VarTbl = struct
   type 'a t = 'a array
   type key = Var.t
diff --git a/compiler/code.mli b/compiler/code.mli
index 38c7368f64..0b32917a74 100644
--- a/compiler/code.mli
+++ b/compiler/code.mli
@@ -49,6 +49,7 @@ end
 
 module VarSet : Set.S with type elt = Var.t
 module VarMap : Map.S with type key = Var.t
+module StringMap : Map.S with type key = string
 module VarTbl : sig
   type 'a t
   type key = Var.t
diff --git a/compiler/generate.ml b/compiler/generate.ml
index 0318f25600..a096f48d51 100644
--- a/compiler/generate.ml
+++ b/compiler/generate.ml
@@ -66,10 +66,20 @@ module Ctx = struct
   type t =
     { mutable blocks : block AddrMap.t;
       live : int array;
-      mutated_vars : VarSet.t AddrMap.t }
+      mutated_vars : VarSet.t AddrMap.t;
+      strings : int StringMap.t }
 
-  let initial b l v =
-    { blocks = b; live = l; mutated_vars = v }
+  let initial b l v strings =
+    { blocks = b; live = l; mutated_vars = v; strings }
+
+  let string_used_once ctx x =
+    if String.length x <= 1
+    then true
+    else
+      try
+        let n = StringMap.find x ctx.strings in
+        n <= 1
+      with _ -> false
 end
 
 let var x = J.EVar (J.V x)
@@ -85,13 +95,36 @@ let float_val e = e (*J.EAccess (e, one)*)
 
 let float_const f = val_float (J.ENum f)
 
-let rec constant x =
+let strings_state = ref []
+let clear_string () = strings_state:=[]
+let get_strings () = !strings_state
+let get_string s =
+  try List.assoc s !strings_state with _ ->
+    let v = J.V (Var.fresh ()) in
+    strings_state := (s,v)::!strings_state;
+    v
+
+let rec constant ?ctx x =
   match x with
     String s ->
-      Primitive.mark_used "MlString";
-      J.ENew (J.EVar (J.S "MlString"), Some [J.EStr (s, `Bytes)])
+      let once = match ctx with
+        | None -> false
+        | Some ctx -> Ctx.string_used_once ctx s in
+      Primitive.mark_used "s";
+      if once
+      then J.ECall (J.EVar (J.S "s"), [J.EStr (s,`Bytes)])
+      else
+        let x = get_string s in
+        J.ECall (J.EVar (J.S "s"), [J.EVar x])
   | IString s ->
-    J.EStr (s, `Bytes)
+      let once = match ctx with
+        | None -> false
+        | Some ctx -> Ctx.string_used_once ctx s in
+      if once
+      then J.EStr (s,`Bytes)
+      else
+        let x = get_string s in
+        J.EVar x
   | Float f ->
       float_const f
   | Float_array a ->
@@ -108,7 +141,7 @@ let rec constant x =
               Some (int (Int64.to_int (Int64.shift_right i 48) land 0xffff))]
   | Tuple (tag, a) ->
       J.EArr (Some (int tag) ::
-              Array.to_list (Array.map (fun x -> Some (constant x)) a))
+              Array.to_list (Array.map (fun x -> Some (constant ?ctx x)) a))
   | Int i ->
       int i
 
@@ -736,7 +769,7 @@ and translate_expr ctx queue x e =
       in
       (cl, flush_p, queue)
   | Constant c ->
-      (constant c, const_p, queue)
+      (constant ~ctx c, const_p, queue)
   | Prim (p, l) ->
       begin match p, l with
         Vectlength, [x] ->
@@ -873,7 +906,7 @@ and translate_expr ctx queue x e =
           (bool (J.EBin (J.NotEqEq, cx, cy)), or_p px py, queue)
       | IsInt, [x] ->
           let ((px, cx), queue) = access_queue' queue x in
-          (J.EBin(J.EqEqEq, J.EUn (J.Typeof, cx), J.EStr ("number", `Bytes)),
+          (J.EBin(J.EqEqEq, J.EUn (J.Typeof, cx), (J.EVar (get_string "number"))),
            px, queue)
       | Ult, [x; y] ->
           let ((px, cx), queue) = access_queue' queue x in
@@ -1277,7 +1310,7 @@ and compile_conditional st queue pc last handler backs frontier interm succs =
              so we can directly refer to it *)
           (Js_simpl.if_statement
               (J.EBin(J.EqEqEq, J.EUn (J.Typeof, var x),
-                      J.EStr ("number", `Bytes)))
+                      (J.EVar (get_string "number"))))
               (build_switch (var x) a1)
               false
               (build_switch (J.EAccess(var x, J.ENum 0.)) a2)
@@ -1420,20 +1453,37 @@ and compile_closure ctx (pc, args) =
   Js_simpl.source_elements res
 
 let compile_program standalone ctx pc =
+  clear_string ();
   let res = compile_closure ctx (pc, []) in
   let res = generate_apply_funs res in
+  let strings = J.Variable_statement (List.map (fun (s,v) -> v, Some (J.EStr(s,`Bytes))) (get_strings ())) in
   if debug () then Format.eprintf "@.@.";
   if standalone then
     let f = J.EFun ((None, [], res), None) in
-    [J.Statement (J.Expression_statement ((J.ECall (f, [])), Some pc))]
+    [J.Statement strings;J.Statement (J.Expression_statement ((J.ECall (f, [])), Some pc))]
   else
     let f = J.EFun ((None, [J.V (Var.fresh ())], res), None) in
-    [J.Statement (J.Expression_statement (f, Some pc))]
+    [J.Statement strings;J.Statement (J.Expression_statement (f, Some pc))]
+
+
+let get_all_strings (_, blocks, _) =
+  AddrMap.fold
+    (fun _ block constants ->
+      List.fold_left
+        (fun constants i ->
+          match i with
+            | Let (x, Constant (String s | IString s)) ->
+              let n = try StringMap.find s constants with _ -> 0 in
+              StringMap.add s (n+1) constants
+            | _ -> constants)
+        constants block.body)
+    blocks StringMap.empty
 
 let f ~standalone ((pc, blocks, _) as p) live_vars =
   let mutated_vars = Freevars.f p in
   let t' = Util.Timer.make () in
-  let ctx = Ctx.initial blocks live_vars mutated_vars in
+  let strings = get_all_strings p in
+  let ctx = Ctx.initial blocks live_vars mutated_vars strings in
   let p = compile_program standalone ctx pc in
   if times () then Format.eprintf "  code gen.: %a@." Util.Timer.print t';
   p
diff --git a/runtime/mlString.js b/runtime/mlString.js
index abaffd5112..58a8a72658 100644
--- a/runtime/mlString.js
+++ b/runtime/mlString.js
@@ -305,3 +305,6 @@ function caml_blit_string(s1, i1, s2, i2, len) {
   if (!a) a = s2.toArray(); else { s2.bytes = s2.string = null; }
   s1.blitToArray (i1, a, i2, len);
 }
+//Provides: s const
+//Requires: MlString
+function s(x){return new MlString(x);}

From 9de7047fbc8972961c60ca0fffb80afb7e6dff5a Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Sat, 14 Sep 2013 21:57:33 -0700
Subject: [PATCH 34/60] COMPILER: detect caml_format_int %d

COMPILER: fix previous commit
---
 compiler/.depend          |  12 ++---
 compiler/eval.ml          |  27 ++++++----
 compiler/generate.ml      | 108 ++++++++++++++++++--------------------
 compiler/inline.ml        |   1 +
 compiler/specialize_js.ml |   6 +++
 5 files changed, 81 insertions(+), 73 deletions(-)

diff --git a/compiler/.depend b/compiler/.depend
index 36b810ac29..9baaf678e4 100644
--- a/compiler/.depend
+++ b/compiler/.depend
@@ -8,14 +8,14 @@ dgraph.cmo : dgraph.cmi
 dgraph.cmx : dgraph.cmi
 driver.cmo : tailcall.cmi specialize_js.cmo specialize.cmo primitive.cmi \
     pretty_print.cmi phisimpl.cmi parse_bytecode.cmi option.cmo linker.cmi \
-    js_var.cmi js_output.cmi inline.cmi generate.cmi flow.cmi deadcode.cmi \
-    code.cmi driver.cmi
+    js_var.cmi js_output.cmi inline.cmi generate.cmi flow.cmi eval.cmo \
+    deadcode.cmi code.cmi driver.cmi
 driver.cmx : tailcall.cmx specialize_js.cmx specialize.cmx primitive.cmx \
     pretty_print.cmx phisimpl.cmx parse_bytecode.cmx option.cmx linker.cmx \
-    js_var.cmx js_output.cmx inline.cmx generate.cmx flow.cmx deadcode.cmx \
-    code.cmx driver.cmi
-eval.cmo : primitive.cmi option.cmo flow.cmi code.cmi
-eval.cmx : primitive.cmx option.cmx flow.cmx code.cmx
+    js_var.cmx js_output.cmx inline.cmx generate.cmx flow.cmx eval.cmx \
+    deadcode.cmx code.cmx driver.cmi
+eval.cmo : primitive.cmi flow.cmi code.cmi
+eval.cmx : primitive.cmx flow.cmx code.cmx
 flow.cmo : util.cmi subst.cmi option.cmo dgraph.cmi code.cmi flow.cmi
 flow.cmx : util.cmx subst.cmx option.cmx dgraph.cmx code.cmx flow.cmi
 freevars.cmo : util.cmi option.cmo code.cmi freevars.cmi
diff --git a/compiler/eval.ml b/compiler/eval.ml
index 522b57a9fc..8c447cd1ef 100644
--- a/compiler/eval.ml
+++ b/compiler/eval.ml
@@ -115,18 +115,23 @@ let eval_instr info live i =
           end
         | _ -> i
       end
-    | Let (x,Prim (prim, prim_args)) ->
+    | Let (x,Prim (prim, prim_args)) when false ->
       begin
-        try
-          let prim_args = List.map (fun x ->
-            match the_def_of info x with
-              | Some (Constant c) -> c
-              | Some (Const i) -> Int i
-              | _ -> raise Not_constant) prim_args in
-          match eval_prim (prim,prim_args) with
-            | Some c -> Let (x,Constant c)
-            | _ -> i
-        with Not_constant -> i
+        let prim_args' = List.map (fun x ->
+          match the_def_of info x with
+            | Some (Constant c) -> Some c
+            | Some (Const i) -> Some (Int i)
+            | _ -> None) prim_args in
+        let res =
+          if List.for_all (function Some _ -> true | _ -> false) prim_args'
+          then eval_prim (prim,List.map (function Some c -> c | None -> assert false) prim_args')
+          else None in
+        match res with
+          | Some c -> Let (x,Constant c)
+          | _ -> Let(x, Prim(prim, (List.map2 (fun arg c ->
+            match c with
+              | Some c -> Pc c
+              | _ -> arg) prim_args prim_args')))
       end
     | _ -> i
 
diff --git a/compiler/generate.ml b/compiler/generate.ml
index a096f48d51..5b56902340 100644
--- a/compiler/generate.ml
+++ b/compiler/generate.ml
@@ -104,27 +104,21 @@ let get_string s =
     strings_state := (s,v)::!strings_state;
     v
 
-let rec constant ?ctx x =
+let rec constant ~ctx x =
   match x with
     String s ->
-      let once = match ctx with
-        | None -> false
-        | Some ctx -> Ctx.string_used_once ctx s in
       Primitive.mark_used "s";
-      if once
+      if Ctx.string_used_once ctx s
       then J.ECall (J.EVar (J.S "s"), [J.EStr (s,`Bytes)])
       else
         let x = get_string s in
         J.ECall (J.EVar (J.S "s"), [J.EVar x])
   | IString s ->
-      let once = match ctx with
-        | None -> false
-        | Some ctx -> Ctx.string_used_once ctx s in
-      if once
-      then J.EStr (s,`Bytes)
-      else
-        let x = get_string s in
-        J.EVar x
+    if Ctx.string_used_once ctx s
+    then J.EStr (s,`Bytes)
+    else
+      let x = get_string s in
+      J.EVar x
   | Float f ->
       float_const f
   | Float_array a ->
@@ -141,7 +135,7 @@ let rec constant ?ctx x =
               Some (int (Int64.to_int (Int64.shift_right i 48) land 0xffff))]
   | Tuple (tag, a) ->
       J.EArr (Some (int tag) ::
-              Array.to_list (Array.map (fun x -> Some (constant ?ctx x)) a))
+              Array.to_list (Array.map (fun x -> Some (constant ~ctx x)) a))
   | Int i ->
       int i
 
@@ -186,9 +180,9 @@ let access_queue queue x =
   with Not_found ->
     ((const_p, var x), queue)
 
-let access_queue' queue x =
+let access_queue' ~ctx queue x =
   match x with
-    | Pc c -> (const_p,constant c),queue
+    | Pc c -> (const_p,constant ~ctx c),queue
     | Pv x -> access_queue queue x
 
 let access_queue_may_flush queue v x =
@@ -470,7 +464,7 @@ let _ =
      "caml_int32_of_float", "caml_int_of_float";
      "caml_int32_to_float", "%identity";
      "caml_int32_format", "caml_format_int";
-     "caml_int32_of_string", "caml_int_of_string";
+     "caml_int32_of_string", "caml_int_of_amlstring";
      "caml_int32_compare", "caml_int_compare";
      "caml_nativeint_neg", "%int_neg";
      "caml_nativeint_add", "%int_add";
@@ -521,32 +515,32 @@ let register_prim name k f =
 
 let register_un_prim name k f =
   register_prim name k
-    (fun l queue ->
+    (fun l queue ctx ->
        match l with
          [x] ->
-           let ((px, cx), queue) = access_queue' queue x in
+           let ((px, cx), queue) = access_queue' ~ctx queue x in
            (f cx, or_p (kind k) px, queue)
          | _ ->
            assert false)
 
 let register_bin_prim name k f =
   register_prim name k
-    (fun l queue ->
+    (fun l queue ctx ->
        match l with
          [x;y] ->
-           let ((px, cx), queue) = access_queue' queue x in
-           let ((py, cy), queue) = access_queue' queue y in
+           let ((px, cx), queue) = access_queue' ~ctx queue x in
+           let ((py, cy), queue) = access_queue' ~ctx queue y in
            (f cx cy, or_p (kind k) (or_p px py), queue)
          | _ -> assert false)
 
 let register_tern_prim name f =
   register_prim name `Mutator
-    (fun l queue ->
+    (fun l queue ctx ->
        match l with
          [x;y;z] ->
-           let ((px, cx), queue) = access_queue' queue x in
-           let ((py, cy), queue) = access_queue' queue y in
-           let ((pz, cz), queue) = access_queue' queue z in
+           let ((px, cx), queue) = access_queue' ~ctx queue x in
+           let ((py, cy), queue) = access_queue' ~ctx queue y in
+           let ((pz, cz), queue) = access_queue' ~ctx queue z in
            (f cx cy cz, or_p mutator_p (or_p px (or_p py pz)), queue)
          | _ ->
            assert false)
@@ -561,6 +555,8 @@ let register_bin_math_prim name prim =
 
 let _ =
   Code.Reserved.add "Math";
+  register_un_prim "%caml_format_int_special" `Pure
+    (fun cx -> J.ECall (J.EVar (J.S "s"), [J.EBin (J.Plus,J.EStr("",`Bytes),cx)]));
   register_bin_prim "caml_array_unsafe_get" `Mutable
     (fun cx cy -> J.EAccess (cx, J.EBin (J.Plus, cy, one)));
   register_bin_prim "caml_string_get" `Mutable
@@ -773,11 +769,11 @@ and translate_expr ctx queue x e =
   | Prim (p, l) ->
       begin match p, l with
         Vectlength, [x] ->
-          let ((px, cx), queue) = access_queue' queue x in
+          let ((px, cx), queue) = access_queue' ~ctx queue x in
           (J.EBin (J.Minus, J.EDot (cx, "length"), one), px, queue)
       | Array_get, [x; y] ->
-          let ((px, cx), queue) = access_queue' queue x in
-          let ((py, cy), queue) = access_queue' queue y in
+          let ((px, cx), queue) = access_queue' ~ctx queue x in
+          let ((py, cy), queue) = access_queue' ~ctx queue y in
           (J.EAccess (cx, J.EBin (J.Plus, cy, one)),
            or_p mutable_p (or_p px py), queue)
       | Extern "caml_js_var", [Pc (String nm)] ->
@@ -792,7 +788,7 @@ and translate_expr ctx queue x e =
           let (args, prop, queue) =
             List.fold_right
               (fun x (args, prop, queue) ->
-                let ((prop', cx), queue) = access_queue' queue x in
+                let ((prop', cx), queue) = access_queue' ~ctx queue x in
                 (cx :: args, or_p prop prop', queue)
               )
               l ([], mutator_p, queue)
@@ -804,7 +800,7 @@ and translate_expr ctx queue x e =
           let (args, prop, queue) =
             List.fold_right
               (fun x (args, prop, queue) ->
-                 let ((prop', cx), queue) = access_queue' queue x in
+                 let ((prop', cx), queue) = access_queue' ~ctx queue x in
                  (cx :: args, or_p prop prop', queue))
               l ([], mutator_p, queue)
           in
@@ -814,7 +810,7 @@ and translate_expr ctx queue x e =
           let (args, prop, queue) =
             List.fold_right
               (fun x (args, prop, queue) ->
-                 let ((prop', cx), queue) = access_queue' queue x in
+                 let ((prop', cx), queue) = access_queue' ~ctx queue x in
                  (cx :: args, or_p prop prop', queue))
               l ([], mutator_p, queue)
           in
@@ -824,7 +820,7 @@ and translate_expr ctx queue x e =
           let (args, prop, queue) =
             List.fold_right
               (fun x (args, prop, queue) ->
-                 let ((prop', cx), queue) = access_queue' queue x in
+                 let ((prop', cx), queue) = access_queue' ~ctx queue x in
                  (cx :: args, or_p prop prop', queue))
               l ([], mutator_p, queue)
           in
@@ -867,55 +863,55 @@ and translate_expr ctx queue x e =
           let (prop, fields, queue) = build_fields queue fields in
           (J.EObj fields, prop, queue)
       | Extern name, l ->
+        begin
           let name = Primitive.resolve name in
-          begin match internal_prim name with
-            Some f ->
-              f l queue
-          | None ->
+          match internal_prim name with
+            | Some f -> f l queue ctx
+            | None ->
               Primitive.mark_used name;
               Code.Reserved.add name;  (*XXX HACK *)
-                               (* FIX: this is done at the wrong time... *)
+              (* FIX: this is done at the wrong time... *)
               let prim_kind = kind (Primitive.kind name) in
               let (args, prop, queue) =
                 List.fold_right
                   (fun x (args, prop, queue) ->
-                    let ((prop', cx), queue) = access_queue' queue x in
+                    let ((prop', cx), queue) = access_queue' ~ctx queue x in
                     (cx :: args, or_p prop prop', queue))
                   l ([], prim_kind, queue)
               in
               (J.ECall (J.EVar (J.S name), args), prop, queue)
-          end
+        end
       | Not, [x] ->
-          let ((px, cx), queue) = access_queue' queue x in
+          let ((px, cx), queue) = access_queue' ~ctx  queue x in
           (J.EBin (J.Minus, one, cx), px, queue)
       | Lt, [x; y] ->
-          let ((px, cx), queue) = access_queue' queue x in
-          let ((py, cy), queue) = access_queue' queue y in
+          let ((px, cx), queue) = access_queue' ~ctx  queue x in
+          let ((py, cy), queue) = access_queue' ~ctx  queue y in
           (bool (J.EBin (J.Lt, cx, cy)), or_p px py, queue)
       | Le, [x; y] ->
-          let ((px, cx), queue) = access_queue' queue x in
-          let ((py, cy), queue) = access_queue' queue y in
+          let ((px, cx), queue) = access_queue' ~ctx  queue x in
+          let ((py, cy), queue) = access_queue' ~ctx  queue y in
           (bool (J.EBin (J.Le, cx, cy)), or_p px py, queue)
       | Eq, [x; y] ->
-          let ((px, cx), queue) = access_queue' queue x in
-          let ((py, cy), queue) = access_queue' queue y in
+          let ((px, cx), queue) = access_queue' ~ctx  queue x in
+          let ((py, cy), queue) = access_queue' ~ctx  queue y in
           (bool (J.EBin (J.EqEqEq, cx, cy)), or_p px py, queue)
       | Neq, [x; y] ->
-          let ((px, cx), queue) = access_queue' queue x in
-          let ((py, cy), queue) = access_queue' queue y in
+          let ((px, cx), queue) = access_queue' ~ctx  queue x in
+          let ((py, cy), queue) = access_queue' ~ctx  queue y in
           (bool (J.EBin (J.NotEqEq, cx, cy)), or_p px py, queue)
       | IsInt, [x] ->
-          let ((px, cx), queue) = access_queue' queue x in
+          let ((px, cx), queue) = access_queue' ~ctx  queue x in
           (J.EBin(J.EqEqEq, J.EUn (J.Typeof, cx), (J.EVar (get_string "number"))),
            px, queue)
       | Ult, [x; y] ->
-          let ((px, cx), queue) = access_queue' queue x in
-          let ((py, cy), queue) = access_queue' queue y in
+          let ((px, cx), queue) = access_queue' ~ctx  queue x in
+          let ((py, cy), queue) = access_queue' ~ctx  queue y in
           (bool (J.EBin (J.Or, J.EBin (J.Lt, cy, int 0),
                          J.EBin (J.Lt, cx, cy))),
            or_p px py, queue)
       | WrapInt, [x] ->
-          let ((px, cx), queue) = access_queue' queue x in
+          let ((px, cx), queue) = access_queue' ~ctx  queue x in
           (to_int cx, px, queue)
       | (Vectlength | Array_get | Not | IsInt | Eq |
          Neq | Lt | Le | Ult | WrapInt), _ ->
@@ -1456,14 +1452,14 @@ let compile_program standalone ctx pc =
   clear_string ();
   let res = compile_closure ctx (pc, []) in
   let res = generate_apply_funs res in
-  let strings = J.Variable_statement (List.map (fun (s,v) -> v, Some (J.EStr(s,`Bytes))) (get_strings ())) in
+  let res = J.Statement (J.Variable_statement (List.map (fun (s,v) -> v, Some (J.EStr(s,`Bytes))) (get_strings ()))) :: res in
   if debug () then Format.eprintf "@.@.";
   if standalone then
     let f = J.EFun ((None, [], res), None) in
-    [J.Statement strings;J.Statement (J.Expression_statement ((J.ECall (f, [])), Some pc))]
+    [J.Statement (J.Expression_statement ((J.ECall (f, [])), Some pc))]
   else
     let f = J.EFun ((None, [J.V (Var.fresh ())], res), None) in
-    [J.Statement strings;J.Statement (J.Expression_statement (f, Some pc))]
+    [J.Statement (J.Expression_statement (f, Some pc))]
 
 
 let get_all_strings (_, blocks, _) =
diff --git a/compiler/inline.ml b/compiler/inline.ml
index fef2898ed1..6ef1f83340 100644
--- a/compiler/inline.ml
+++ b/compiler/inline.ml
@@ -120,6 +120,7 @@ let inline closures live_vars blocks free_pc pc =
                    body = []; branch = Branch (clos_pc, clos_args) } blocks
              in
              ([], (Branch (free_pc + 1, args), blocks, free_pc + 2))
+
          | _ ->
              (i :: rem, state))
       block.body ([], (block.branch, blocks, free_pc))
diff --git a/compiler/specialize_js.ml b/compiler/specialize_js.ml
index 6d23b33ff5..e6a926dbf5 100644
--- a/compiler/specialize_js.ml
+++ b/compiler/specialize_js.ml
@@ -4,6 +4,12 @@ open Flow
 
 let specialize_instr info i =
   match i with
+  | Let (x, Prim (Extern "caml_format_int", [y;z])) ->
+    begin match the_def_of info y with
+      | Some (Constant (String "%d")) ->
+        Let (x, Prim (Extern "%caml_format_int_special", [z]))
+      | _ -> i
+    end
   | Let (x, Prim (Extern "caml_js_var", [y])) ->
       begin match the_def_of info y with
         Some (Constant (String _ as c)) ->

From 9c44e5ea3e8584c2b6a7aa2e4121c96ace22f8a3 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Sun, 15 Sep 2013 21:31:18 -0700
Subject: [PATCH 35/60] COMPILER: Sharing

---
 compiler/.depend      |  16 ++-
 compiler/Makefile     |   2 +-
 compiler/code.ml      |   1 -
 compiler/code.mli     |   1 -
 compiler/driver.ml    |   4 +-
 compiler/generate.ml  | 293 ++++++++++++++++++++++++------------------
 compiler/js_var.ml    |  38 +++++-
 compiler/linker.ml    |   4 +-
 compiler/primitive.ml |  14 +-
 compiler/reserved.ml  |  43 +++++++
 compiler/util.mli     |   1 +
 runtime/mlString.js   |   8 +-
 12 files changed, 281 insertions(+), 144 deletions(-)
 create mode 100644 compiler/reserved.ml

diff --git a/compiler/.depend b/compiler/.depend
index 9baaf678e4..d89771ce68 100644
--- a/compiler/.depend
+++ b/compiler/.depend
@@ -24,8 +24,8 @@ generate.cmo : util.cmi subst.cmi primitive.cmi option.cmo js_simpl.cmi \
     javascript.cmi freevars.cmi code.cmi generate.cmi
 generate.cmx : util.cmx subst.cmx primitive.cmx option.cmx js_simpl.cmx \
     javascript.cmx freevars.cmx code.cmx generate.cmi
-inline.cmo : code.cmi inline.cmi
-inline.cmx : code.cmx inline.cmi
+inline.cmo : subst.cmi code.cmi inline.cmi
+inline.cmx : subst.cmx code.cmx inline.cmi
 instr.cmo : instr.cmi
 instr.cmx : instr.cmi
 javascript.cmo : code.cmi javascript.cmi
@@ -38,8 +38,10 @@ js_rename.cmo : util.cmi javascript.cmi
 js_rename.cmx : util.cmx javascript.cmx
 js_simpl.cmo : javascript.cmi code.cmi js_simpl.cmi
 js_simpl.cmx : javascript.cmx code.cmx js_simpl.cmi
-js_var.cmo : util.cmi option.cmo javascript.cmi code.cmi js_var.cmi
-js_var.cmx : util.cmx option.cmx javascript.cmx code.cmx js_var.cmi
+js_var.cmo : util.cmi primitive.cmi option.cmo javascript.cmi code.cmi \
+    js_var.cmi
+js_var.cmx : util.cmx primitive.cmx option.cmx javascript.cmx code.cmx \
+    js_var.cmi
 linker.cmo : util.cmi primitive.cmi pretty_print.cmi code.cmi linker.cmi
 linker.cmx : util.cmx primitive.cmx pretty_print.cmx code.cmx linker.cmi
 main.cmo : util.cmi pretty_print.cmi parse_bytecode.cmi option.cmo \
@@ -58,10 +60,12 @@ phisimpl.cmx : util.cmx subst.cmx option.cmx dgraph.cmx code.cmx \
     phisimpl.cmi
 pretty_print.cmo : pretty_print.cmi
 pretty_print.cmx : pretty_print.cmi
-primitive.cmo : util.cmi primitive.cmi
-primitive.cmx : util.cmx primitive.cmi
+primitive.cmo : util.cmi reserved.cmo primitive.cmi
+primitive.cmx : util.cmx reserved.cmx primitive.cmi
 pure_fun.cmo : primitive.cmi code.cmi pure_fun.cmi
 pure_fun.cmx : primitive.cmx code.cmx pure_fun.cmi
+reserved.cmo :
+reserved.cmx :
 specialize.cmo : option.cmo flow.cmi code.cmi
 specialize.cmx : option.cmx flow.cmx code.cmx
 specialize_js.cmo : flow.cmi code.cmi
diff --git a/compiler/Makefile b/compiler/Makefile
index 25addc53ed..8bb276b0a3 100644
--- a/compiler/Makefile
+++ b/compiler/Makefile
@@ -8,7 +8,7 @@ lib: compiler.cma compiler.cmxa compiler.cmxs
 PACKAGES=findlib,str,unix,ocamlgraph
 
 OBJS=pretty_print.cmx util.cmx option.cmx dgraph.cmx \
-     code.cmx javascript.cmx js_output.cmx js_simpl.cmx \
+     code.cmx reserved.cmx javascript.cmx js_output.cmx js_simpl.cmx \
      instr.cmx primitive.cmx subst.cmx pure_fun.cmx deadcode.cmx \
      flow.cmx specialize.cmx specialize_js.cmx eval.cmx inline.cmx \
      tailcall.cmx freevars.cmx phisimpl.cmx \
diff --git a/compiler/code.ml b/compiler/code.ml
index ec15510303..2f1fe9f6f8 100644
--- a/compiler/code.ml
+++ b/compiler/code.ml
@@ -154,7 +154,6 @@ end
 
 module VarSet = Set.Make (Var)
 module VarMap = Map.Make (Var)
-module StringMap = Map.Make(String)
 module VarTbl = struct
   type 'a t = 'a array
   type key = Var.t
diff --git a/compiler/code.mli b/compiler/code.mli
index 0b32917a74..38c7368f64 100644
--- a/compiler/code.mli
+++ b/compiler/code.mli
@@ -49,7 +49,6 @@ end
 
 module VarSet : Set.S with type elt = Var.t
 module VarMap : Map.S with type key = Var.t
-module StringMap : Map.S with type key = string
 module VarTbl : sig
   type 'a t
   type key = Var.t
diff --git a/compiler/driver.ml b/compiler/driver.ml
index 6701880e65..1c8706e60c 100644
--- a/compiler/driver.ml
+++ b/compiler/driver.ml
@@ -204,9 +204,11 @@ let f ?(standalone=true) ?linkall formatter d =
   !profile >>
   deadcode' >>
   generate ~standalone >>
+  coloring >>
+
   header formatter ~standalone >>
   link formatter ~standalone ?linkall false >>
-  coloring >>
+
   output formatter d
 
 let from_string prims s formatter =
diff --git a/compiler/generate.ml b/compiler/generate.ml
index 5b56902340..07f102b726 100644
--- a/compiler/generate.ml
+++ b/compiler/generate.ml
@@ -36,9 +36,8 @@ Patterns:
 let debug = Option.Debug.find "gen"
 let times = Option.Debug.find "times"
 
-(****)
-
 open Code
+open Util
 
 module J = Javascript
 
@@ -62,24 +61,120 @@ let list_group f l =
 
 (****)
 
+
+module Share = struct
+  type 'a aux = {
+    strings : 'a StringMap.t;
+    applies : 'a IntMap.t;
+    prims :   'a StringMap.t;
+  }
+
+
+  let empty_aux = { prims = StringMap.empty;
+                    strings = StringMap.empty;
+                    applies = IntMap.empty }
+
+  type t = {
+    mutable count : int aux;
+    mutable vars : J.ident aux;
+  }
+
+  let add_string s t =
+    let n = try StringMap.find s t.strings with _ -> 0 in
+    {t with strings = StringMap.add s (n+1) t.strings}
+
+  let add_prim s t =
+    let n = try StringMap.find s t.prims with _ -> 0 in
+    {t with prims  = StringMap.add s (n+1) t.prims}
+
+  let add_apply i t =
+    let n = try IntMap.find i t.applies with _ -> 0 in
+    {t with applies = IntMap.add i (n+1) t.applies }
+
+  let get (_, blocks, _) : t =
+    let count = AddrMap.fold
+      (fun _ block share ->
+        List.fold_left
+          (fun share i ->
+            match i with
+              | Let (_, Constant (String s)) ->
+                let share = add_string s share in
+                add_prim "caml_new_string" share
+              | Let (_, Constant (IString s)) ->
+                add_string s share
+              | Let (_, Apply (_,args,None)) ->
+                add_apply (List.length args) share
+              | Let (_, Prim (Extern name, args)) ->
+                let name = Primitive.resolve name in
+                add_prim name share
+              | _ -> share
+          )
+          share block.body)
+      blocks empty_aux
+    in {count; vars = empty_aux}
+
+  let get_string gen s t =
+    try
+      let c = StringMap.find s t.count.strings in
+      if c > 1
+      then
+        try
+          J.EVar (StringMap.find s t.vars.strings)
+        with _ ->
+          let x = Var.fresh() in
+          let v = J.V x in
+          t.vars <- { t.vars with strings = StringMap.add s v t.vars.strings };
+          J.EVar v
+      else
+        gen s
+    with _ -> gen s
+
+  let get_prim gen s t =
+    try
+      let c = StringMap.find s t.count.prims in
+      if c > 1
+      then
+        try
+          J.EVar (StringMap.find s t.vars.prims)
+        with _ ->
+          let x = Var.fresh() in
+          let v = J.V x in
+          t.vars <- { t.vars with prims = StringMap.add s v t.vars.prims };
+          J.EVar v
+      else
+        gen s
+    with _ -> gen s
+
+
+  let get_apply gen n t =
+    try
+      let c = IntMap.find n t.count.applies in
+      if c > 1
+      then
+        try
+          J.EVar (IntMap.find n t.vars.applies)
+        with _ ->
+          let x = Var.fresh() in
+          let v = J.V x in
+          t.vars <- { t.vars with applies = IntMap.add n v t.vars.applies };
+          J.EVar v
+      else
+        gen n
+    with _ -> gen n
+
+end
+
+
 module Ctx = struct
   type t =
     { mutable blocks : block AddrMap.t;
       live : int array;
       mutated_vars : VarSet.t AddrMap.t;
-      strings : int StringMap.t }
+      share: Share.t }
 
-  let initial b l v strings =
-    { blocks = b; live = l; mutated_vars = v; strings }
+  let initial b l v share =
+    { blocks = b; live = l; mutated_vars = v; share }
 
-  let string_used_once ctx x =
-    if String.length x <= 1
-    then true
-    else
-      try
-        let n = StringMap.find x ctx.strings in
-        n <= 1
-      with _ -> false
 end
 
 let var x = J.EVar (J.V x)
@@ -95,30 +190,14 @@ let float_val e = e (*J.EAccess (e, one)*)
 
 let float_const f = val_float (J.ENum f)
 
-let strings_state = ref []
-let clear_string () = strings_state:=[]
-let get_strings () = !strings_state
-let get_string s =
-  try List.assoc s !strings_state with _ ->
-    let v = J.V (Var.fresh ()) in
-    strings_state := (s,v)::!strings_state;
-    v
-
 let rec constant ~ctx x =
   match x with
     String s ->
-      Primitive.mark_used "s";
-      if Ctx.string_used_once ctx s
-      then J.ECall (J.EVar (J.S "s"), [J.EStr (s,`Bytes)])
-      else
-        let x = get_string s in
-        J.ECall (J.EVar (J.S "s"), [J.EVar x])
+      let e = Share.get_string (fun s -> J.EStr (s,`Bytes)) s ctx.Ctx.share in
+      let p = Share.get_prim (fun s -> J.EVar (J.S s)) "caml_new_string" ctx.Ctx.share in
+      J.ECall (p,[e])
   | IString s ->
-    if Ctx.string_used_once ctx s
-    then J.EStr (s,`Bytes)
-    else
-      let x = get_string s in
-      J.EVar x
+      Share.get_string (fun s -> J.EStr (s,`Bytes)) s ctx.Ctx.share
   | Float f ->
       float_const f
   | Float_array a ->
@@ -212,26 +291,6 @@ let flush_queue expr_queue prop l =
   in
   (List.rev_append instrs l, expr_queue)
 
-(* let flush_queue expr_queue prop l = *)
-(*   let l : J.statement list = l in *)
-(*   let (instrs, expr_queue) = *)
-(*     if prop >= flush_p then (List.fold_left (fun instrs (x,elt) -> *)
-(*       J.Variable_statement [ x, Some elt.ce] :: instrs) l expr_queue, []) *)
-(*     else *)
-(*       let _,instrs, expr_queue = *)
-(*         List.fold_left (fun (deps,instrs, expr_queue) ((y, elt) as eq) -> *)
-(*           if should_flush prop elt.prop *)
-(*           then ( *)
-(*             (y::deps), *)
-(*             ((J.Variable_statement [ y, Some elt.ce]) ::instrs), *)
-(*             expr_queue) *)
-(*           else *)
-(*             deps,instrs,(eq::expr_queue) *)
-(*         ) ([],l,[]) expr_queue in *)
-(*       instrs,List.rev expr_queue in *)
-(*   (\* List.partition (fun (y, (p, _,_,_)) -> should_flush prop p) expr_queue *\) *)
-(*   (instrs, expr_queue) *)
-
 let flush_all expr_queue l = fst (flush_queue expr_queue flush_p l)
 
 let enqueue expr_queue prop x ce cardinal =
@@ -402,41 +461,23 @@ let parallel_renaming ctx params args continuation queue =
 
 (****)
 
-let apply_funs = ref Util.IntMap.empty
-
-let get_apply_fun n =
-  try
-    Util.IntMap.find n !apply_funs
-  with Not_found ->
-    Primitive.mark_used "caml_call_gen";
-    let x = J.V (Var.fresh ()) in
-    apply_funs := Util.IntMap.add n x !apply_funs;
-    x
-
-let generate_apply_funs cont =
-  let funs = !apply_funs in
-  apply_funs := Util.IntMap.empty;
-  Util.IntMap.fold
-    (fun n x cont ->
-       let f = J.V (Var.fresh ()) in
-       let params =
-         Array.to_list (Array.init n (fun _ -> J.V (Var.fresh ())))
-       in
-       let f' = J.EVar f in
-       let params' = List.map (fun x -> J.EVar x) params in
-       J.Function_declaration
-         (x, f :: params,
-          [J.Statement
-             (J.Return_statement
-                (Some
-                   (J.ECond (J.EBin (J.EqEq, J.EDot (f', "length"),
-                                     J.ENum (float n)),
-                             J.ECall (f', params'),
-                             J.ECall (J.EVar (J.S "caml_call_gen"),
-                                      [f'; J.EArr (List.map (fun x -> Some x) params')])))))],
-          None) ::
-       cont)
-    funs cont
+let generate_apply_fun ?x n =
+  let f = J.V (Var.fresh ()) in
+  let params =
+    Array.to_list (Array.init n (fun _ -> J.V (Var.fresh ())))
+  in
+  let f' = J.EVar f in
+  let params' = List.map (fun x -> J.EVar x) params in
+  J.EFun ((x, f :: params,
+           [J.Statement
+               (J.Return_statement
+                  (Some
+                     (J.ECond (J.EBin (J.EqEq, J.EDot (f', "length"),
+                                       J.ENum (float n)),
+                               J.ECall (f', params'),
+                               J.ECall (J.EVar (J.S "caml_call_gen"),
+                                        [f'; J.EArr (List.map (fun x -> Some x) params')])))))]),
+          None)
 
 (****)
 
@@ -523,6 +564,16 @@ let register_un_prim name k f =
          | _ ->
            assert false)
 
+let register_un_prim_ctx name k f =
+  register_prim name k
+    (fun l queue ctx ->
+       match l with
+         [x] ->
+           let ((px, cx), queue) = access_queue' ~ctx queue x in
+           (f ctx cx, or_p (kind k) px, queue)
+         | _ ->
+           assert false)
+
 let register_bin_prim name k f =
   register_prim name k
     (fun l queue ctx ->
@@ -554,9 +605,10 @@ let register_bin_math_prim name prim =
     (fun cx cy -> J.ECall (J.EDot (J.EVar (J.S "Math"), prim), [cx; cy]))
 
 let _ =
-  Code.Reserved.add "Math";
-  register_un_prim "%caml_format_int_special" `Pure
-    (fun cx -> J.ECall (J.EVar (J.S "s"), [J.EBin (J.Plus,J.EStr("",`Bytes),cx)]));
+  register_un_prim_ctx  "%caml_format_int_special" `Pure
+    (fun ctx cx ->
+      let p = Share.get_prim (fun s -> J.EVar (J.S s)) "caml_new_string" ctx.Ctx.share in
+      J.ECall (p, [J.EBin (J.Plus,J.EStr("",`Bytes),cx)]));
   register_bin_prim "caml_array_unsafe_get" `Mutable
     (fun cx cy -> J.EAccess (cx, J.EBin (J.Plus, cy, one)));
   register_bin_prim "caml_string_get" `Mutable
@@ -640,9 +692,7 @@ let _ =
   register_un_prim "caml_js_from_string" `Mutable
     (fun cx -> J.ECall (J.EDot (cx, "toString"), []));
   register_un_prim "caml_js_to_string" `Mutable
-    (fun cx ->
-       Primitive.mark_used "MlString";
-       J.ENew (J.EVar (J.S "MlWrappedString"), Some [cx]));
+    (fun cx -> J.ENew (J.EVar (J.S "MlWrappedString"), Some [cx]));
   register_tern_prim "caml_js_set"
     (fun cx cy cz -> J.EBin (J.Eq, J.EAccess (cx, cy), cz));
   register_bin_prim "caml_js_get" `Mutable
@@ -720,8 +770,8 @@ and translate_expr ctx queue x e =
                access_queue queue x in (cx :: args, or_p prop prop', queue))
           (x :: l) ([], mutator_p, queue)
       in
-      let y = get_apply_fun (List.length l) in
-      (J.ECall (J.EVar y, args),
+      let y = Share.get_apply (generate_apply_fun) (List.length l) ctx.Ctx.share in
+      (J.ECall (y, args),
        prop, queue)
   | Block (tag, a) ->
       let (contents, prop, queue) =
@@ -777,11 +827,9 @@ and translate_expr ctx queue x e =
           (J.EAccess (cx, J.EBin (J.Plus, cy, one)),
            or_p mutable_p (or_p px py), queue)
       | Extern "caml_js_var", [Pc (String nm)] ->
-          Code.Reserved.add nm;  (*XXX HACK *)
-          (J.EVar (J.S nm), const_p, queue)
+        (J.EVar (J.S nm), const_p, queue)
       | Extern "caml_js_const", [Pc (String nm)] ->
-          Code.Reserved.add nm;  (*XXX HACK *)
-          (J.EVar (J.S nm), const_p, queue)
+        (J.EVar (J.S nm), const_p, queue)
       | Extern "caml_js_opt_call", Pv f :: Pv o :: l ->
           let ((pf, cf), queue) = access_queue queue f in
           let ((po, co), queue) = access_queue queue o in
@@ -868,9 +916,7 @@ and translate_expr ctx queue x e =
           match internal_prim name with
             | Some f -> f l queue ctx
             | None ->
-              Primitive.mark_used name;
-              Code.Reserved.add name;  (*XXX HACK *)
-              (* FIX: this is done at the wrong time... *)
+              let prim = Share.get_prim (fun s -> J.EVar (J.S s)) name ctx.Ctx.share in
               let prim_kind = kind (Primitive.kind name) in
               let (args, prop, queue) =
                 List.fold_right
@@ -879,7 +925,7 @@ and translate_expr ctx queue x e =
                     (cx :: args, or_p prop prop', queue))
                   l ([], prim_kind, queue)
               in
-              (J.ECall (J.EVar (J.S name), args), prop, queue)
+              (J.ECall (prim, args), prop, queue)
         end
       | Not, [x] ->
           let ((px, cx), queue) = access_queue' ~ctx  queue x in
@@ -902,7 +948,7 @@ and translate_expr ctx queue x e =
           (bool (J.EBin (J.NotEqEq, cx, cy)), or_p px py, queue)
       | IsInt, [x] ->
           let ((px, cx), queue) = access_queue' ~ctx  queue x in
-          (J.EBin(J.EqEqEq, J.EUn (J.Typeof, cx), (J.EVar (get_string "number"))),
+          (J.EBin(J.EqEqEq, J.EUn (J.Typeof, cx), (Share.get_string (fun s -> J.EStr (s,`Bytes)) "number" ctx.Ctx.share)),
            px, queue)
       | Ult, [x; y] ->
           let ((px, cx), queue) = access_queue' ~ctx  queue x in
@@ -1306,7 +1352,7 @@ and compile_conditional st queue pc last handler backs frontier interm succs =
              so we can directly refer to it *)
           (Js_simpl.if_statement
               (J.EBin(J.EqEqEq, J.EUn (J.Typeof, var x),
-                      (J.EVar (get_string "number"))))
+                      (Share.get_string (fun s -> J.EStr (s,`Bytes)) "number" st.ctx.Ctx.share)))
               (build_switch (var x) a1)
               false
               (build_switch (J.EAccess(var x, J.ENum 0.)) a2)
@@ -1448,11 +1494,24 @@ and compile_closure ctx (pc, args) =
   if debug () then Format.eprintf "}@]@ ";
   Js_simpl.source_elements res
 
+
+let generate_shared_value ctx =
+  let strings =
+    J.Statement (
+      J.Variable_statement (
+        List.map (fun (s,v) -> v, Some (J.EStr(s,`Bytes))) (StringMap.bindings ctx.Ctx.share.Share.vars.Share.strings)
+        @ List.map (fun (s,v) -> v, Some (J.EVar (J.S s))) (StringMap.bindings ctx.Ctx.share.Share.vars.Share.prims)
+      )) in
+  let applies = List.map (fun (n,v) ->
+    match generate_apply_fun n with
+      | J.EFun ((_,param,body),_) ->
+        J.Function_declaration (v,param,body,None)
+      | _ -> assert false) (IntMap.bindings ctx.Ctx.share.Share.vars.Share.applies) in
+  strings::applies
+
 let compile_program standalone ctx pc =
-  clear_string ();
   let res = compile_closure ctx (pc, []) in
-  let res = generate_apply_funs res in
-  let res = J.Statement (J.Variable_statement (List.map (fun (s,v) -> v, Some (J.EStr(s,`Bytes))) (get_strings ()))) :: res in
+  let res = generate_shared_value ctx @ res in
   if debug () then Format.eprintf "@.@.";
   if standalone then
     let f = J.EFun ((None, [], res), None) in
@@ -1462,24 +1521,12 @@ let compile_program standalone ctx pc =
     [J.Statement (J.Expression_statement (f, Some pc))]
 
 
-let get_all_strings (_, blocks, _) =
-  AddrMap.fold
-    (fun _ block constants ->
-      List.fold_left
-        (fun constants i ->
-          match i with
-            | Let (x, Constant (String s | IString s)) ->
-              let n = try StringMap.find s constants with _ -> 0 in
-              StringMap.add s (n+1) constants
-            | _ -> constants)
-        constants block.body)
-    blocks StringMap.empty
 
 let f ~standalone ((pc, blocks, _) as p) live_vars =
   let mutated_vars = Freevars.f p in
   let t' = Util.Timer.make () in
-  let strings = get_all_strings p in
-  let ctx = Ctx.initial blocks live_vars mutated_vars strings in
+  let share = Share.get p in
+  let ctx = Ctx.initial blocks live_vars mutated_vars share in
   let p = compile_program standalone ctx pc in
   if times () then Format.eprintf "  code gen.: %a@." Util.Timer.print t';
   p
diff --git a/compiler/js_var.ml b/compiler/js_var.ml
index 36c281cd90..70069bf776 100644
--- a/compiler/js_var.ml
+++ b/compiler/js_var.ml
@@ -1,3 +1,4 @@
+open Util
 open Javascript
 
 let debug = Option.Debug.find "shortvar"
@@ -28,20 +29,27 @@ type t = {
   count : int VM.t;
   biggest : int;
   vertex : (Code.Var.t, G.V.t) Hashtbl.t;
+  def_name: StringSet.t;
+  use_name: StringSet.t;
 }
 
 let incr_count (x : Code.Var.t) (map : int VM.t) n =
   let v = try VM.find x map with _ -> 0 in
   VM.add x (v + n) map
 
+let use_name s t = { t with use_name = StringSet.add s t.use_name  }
+
+let def_name s t = { t with def_name = StringSet.add s t.def_name  }
+
+
 let use_var t = function
-  | S _ -> t
+  | S s -> use_name s t
   | V i -> { t with
     use = S.add i t.use;
     count = incr_count i t.count 1 }
 
 let def_var t = function
-  | S _ -> t
+  | S s -> def_name s t
   | V i -> { t with
     def = S.add i t.def;
     count = incr_count i t.count 1}
@@ -58,6 +66,8 @@ let empty t = {
     def = S.empty;
     use = S.empty;
     count = VM.empty;
+    def_name = StringSet.empty;
+    use_name = StringSet.empty;
     biggest = 0;
 }
 
@@ -72,6 +82,8 @@ let vertex t v =
 
 let get_free t = S.diff t.use t.def
 
+let get_free_name t = StringSet.diff t.use_name t.def_name
+
 let mark g =
   let u = S.union g.def g.use in
   S.iter (fun u -> G.add_vertex g.g (vertex g u)) u;
@@ -96,15 +108,20 @@ let create () = (* empty (G.make (Code.Var.count ())) *)
     count = VM.empty;
     biggest = 0;
     vertex = Hashtbl.create 17;
-    g = G.create ()
+    g = G.create ();
+    use_name = StringSet.empty;
+    def_name = StringSet.empty;
   }
 
 let merge_info ~from ~into =
   let free = get_free from in
+  let free_name = get_free_name from in
+
   {into with
     count = merge_count from.count into.count;
     biggest = max from.biggest into.biggest;
-    use = S.union into.use free }
+    use = S.union into.use free;
+    use_name = StringSet.union into.use_name free_name}
 
 let rec expression t e = match e with
   | ECond (e1,e2,e3) ->
@@ -226,9 +243,20 @@ and statement t s = match s with
 
 module M = Graph.Coloring.Mark(G)
 
+
 let program p =
   let t = source_elts (create()) p in
-  assert(S.cardinal (get_free t) = 0);
+  let free = get_free t in
+  if S.cardinal free != 0
+  then begin
+    failwith "free variables"
+  end;
+  let free_name = get_free_name t in
+  StringSet.iter (fun s ->
+    (* Printf.eprintf "use %s\n%!" s; *)
+    Code.Reserved.add s;
+    Primitive.mark_used s;
+  ) free_name;
   let t = mark t in
   if debug ()
   then Printf.eprintf "compute graph degree\n%!";
diff --git a/compiler/linker.ml b/compiler/linker.ml
index 31fa664662..c7f2e500d9 100644
--- a/compiler/linker.ml
+++ b/compiler/linker.ml
@@ -147,9 +147,7 @@ let parse_file f =
     while true do
       incr i;
       let x = read_line ch (f, !i) in
-(*
-      debug x;
-*)
+      (* debug x; *)
       l := x :: !l
     done
   with End_of_file -> () end;
diff --git a/compiler/primitive.ml b/compiler/primitive.ml
index feed3617e7..bc1f9cd8be 100644
--- a/compiler/primitive.ml
+++ b/compiler/primitive.ml
@@ -39,8 +39,20 @@ let is_pure nm = kind nm <> `Mutator
 
 let primitives = ref Util.StringSet.empty
 
+let ign =
+  let h = Hashtbl.create 17 in
+  List.iter (fun s -> Hashtbl.add h s ()) Reserved.provided;
+  (fun s ->
+    let s =
+      try
+        let i = String.index s '.' in
+        String.sub s 0 i
+      with _ -> s in
+    Hashtbl.mem h s)
+
 let mark_used nm =
-  primitives := Util.StringSet.add nm !primitives
+  if not (ign nm)
+  then primitives := Util.StringSet.add nm !primitives
 
 let list_used () =
   Format.eprintf "Primitives:@.";
diff --git a/compiler/reserved.ml b/compiler/reserved.ml
new file mode 100644
index 0000000000..4928a270ce
--- /dev/null
+++ b/compiler/reserved.ml
@@ -0,0 +1,43 @@
+
+
+
+let keyword =
+  ["break"; "case"; "catch"; "do"; "else"; "for"; "if"; "in"; "new";
+   "this"; "throw"; "try"; "var"; "void"; "while"; "with"; "class";
+   "enum"; "super"; "const"; "yield"; "let" ]
+
+
+let provided = [
+  "ActiveXObject";
+  "Array";
+  "Date";
+  "Math";
+  "JSON";
+  "RegExp";
+  "String";
+  "XMLHttpRequest";
+  "decodeURI";
+  "decodeURIComponent";
+  "encodeURI";
+  "encodeURIComponent";
+  "escape";
+  "event";
+  "isNaN";
+  "parseFloat";
+  "parseInt";
+  "location";
+  "window";
+  "unescape";
+  "this";
+  "true"; "false"; "undefined"; "null"
+]
+
+let reserved = Hashtbl.create 107
+
+let add s = if String.length s <= 5 then Hashtbl.replace reserved s ()
+
+let mem s = Hashtbl.mem reserved s
+
+let _ =
+  List.iter add keyword;
+  List.iter add provided
diff --git a/compiler/util.mli b/compiler/util.mli
index f339ba1fb9..e1a684caf2 100644
--- a/compiler/util.mli
+++ b/compiler/util.mli
@@ -22,6 +22,7 @@ module IntSet : Set.S with type elt = int
 module IntMap : Map.S with type key = int
 
 module StringSet : Set.S with type elt = string
+module StringMap : Map.S with type key = string
 
 val opt_filter : ('a -> bool) -> 'a option -> 'a option
 val opt_map : ('a -> 'b) -> 'a option -> 'b option
diff --git a/runtime/mlString.js b/runtime/mlString.js
index 58a8a72658..5d7c668b31 100644
--- a/runtime/mlString.js
+++ b/runtime/mlString.js
@@ -237,10 +237,14 @@ MlString.prototype = {
 }
 
 // Conversion Javascript -> Caml
+//Provides: MlWrappedString
+//Requires: MlString
 function MlWrappedString (s) { this.string = s; }
 MlWrappedString.prototype = new MlString();
 
 // Uninitialized Caml string
+//Provides: MlMakeString
+//Requires: MlString
 function MlMakeString (l) { this.bytes = ""; this.len = l; }
 MlMakeString.prototype = new MlString ();
 
@@ -305,6 +309,6 @@ function caml_blit_string(s1, i1, s2, i2, len) {
   if (!a) a = s2.toArray(); else { s2.bytes = s2.string = null; }
   s1.blitToArray (i1, a, i2, len);
 }
-//Provides: s const
+//Provides: caml_new_string
 //Requires: MlString
-function s(x){return new MlString(x);}
+function caml_new_string(x){return new MlString(x);}

From 62e0f98e89f81dbb08dfe5b0402bc33827d8c286 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Sun, 15 Sep 2013 22:26:16 -0700
Subject: [PATCH 36/60] COMPILER: more sharing

---
 compiler/generate.ml | 45 ++++++++++++++++++++++++++++++++++----------
 1 file changed, 35 insertions(+), 10 deletions(-)

diff --git a/compiler/generate.ml b/compiler/generate.ml
index 07f102b726..94061a919e 100644
--- a/compiler/generate.ml
+++ b/compiler/generate.ml
@@ -91,29 +91,52 @@ module Share = struct
     let n = try IntMap.find i t.applies with _ -> 0 in
     {t with applies = IntMap.add i (n+1) t.applies }
 
+  let add_code_string s share =
+    let share = add_string s share in
+    add_prim "caml_new_string" share
+
+  let add_code_istring s share =
+    add_string s share
+
+  let rec get_constant c t =
+    match c with
+      | String s -> add_code_string s t
+      | IString s -> add_code_istring s t
+      | Tuple (_,args) -> Array.fold_left (fun t c ->
+        get_constant c t) t args
+      | _ -> t
+
+  let add_args args t =
+    List.fold_left(fun t a ->
+      match a with
+        | Pc c -> get_constant c t
+        | _ -> t) t args
+
+
   let get (_, blocks, _) : t =
     let count = AddrMap.fold
       (fun _ block share ->
         List.fold_left
           (fun share i ->
             match i with
-              | Let (_, Constant (String s)) ->
-                let share = add_string s share in
-                add_prim "caml_new_string" share
-              | Let (_, Constant (IString s)) ->
-                add_string s share
+              | Let (_, Constant c) -> get_constant c share
               | Let (_, Apply (_,args,None)) ->
                 add_apply (List.length args) share
               | Let (_, Prim (Extern name, args)) ->
                 let name = Primitive.resolve name in
-                add_prim name share
+                let share = add_prim name share in
+                add_args args share
+              | Let (_, Prim (_, args)) ->
+                add_args args share
               | _ -> share
           )
           share block.body)
-      blocks empty_aux
-    in {count; vars = empty_aux}
+      blocks empty_aux in
+    let count = add_string "number" count in
+    {count; vars = empty_aux}
 
   let get_string gen s t =
+    let s = Primitive.resolve s in
     try
       let c = StringMap.find s t.count.strings in
       if c > 1
@@ -127,7 +150,9 @@ module Share = struct
           J.EVar v
       else
         gen s
-    with _ -> gen s
+    with _ ->
+      Printf.eprintf "missed %S\n%!" s;
+      gen s
 
   let get_prim gen s t =
     try
@@ -891,7 +916,7 @@ and translate_expr ctx queue x e =
               [] ->
                 []
             | Pc (String nm) :: Pc (String v) :: r ->
-                (J.PNS nm, J.EStr (v, `Bytes)) :: build_fields r
+                (J.PNS nm, Share.get_string (fun v -> J.EStr (v, `Bytes)) v ctx.Ctx.share ) :: build_fields r
             | _ ->
                 assert false
           in

From 007abb1d5cb7347ed39775d488e6cd1d3aa464d6 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Sun, 15 Sep 2013 22:42:23 -0700
Subject: [PATCH 37/60] COMPILER: more sharing (hack)

---
 compiler/generate.ml | 2 ++
 1 file changed, 2 insertions(+)

diff --git a/compiler/generate.ml b/compiler/generate.ml
index 94061a919e..3c34e5135c 100644
--- a/compiler/generate.ml
+++ b/compiler/generate.ml
@@ -132,6 +132,8 @@ module Share = struct
           )
           share block.body)
       blocks empty_aux in
+    (* hack to shared "number" string *)
+    let count = add_string "number" count in
     let count = add_string "number" count in
     {count; vars = empty_aux}
 

From a91990485e7d9e7422af14bb29d0441074cd1223 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Sun, 15 Sep 2013 23:03:35 -0700
Subject: [PATCH 38/60] COMPILER: fix

---
 compiler/driver.ml  | 12 ++++--------
 compiler/js_var.ml  | 40 ++++++++++++++++++++++++----------------
 runtime/mlString.js |  2 +-
 3 files changed, 29 insertions(+), 25 deletions(-)

diff --git a/compiler/driver.ml b/compiler/driver.ml
index 1c8706e60c..b4c51915f5 100644
--- a/compiler/driver.ml
+++ b/compiler/driver.ml
@@ -180,14 +180,10 @@ let link formatter ~standalone ?linkall pretty js =
   js
 
 let coloring js =
-  if Option.Optim.shortvar ()
-  then
-    begin
-      if times ()
-      then Format.eprintf "Start Coloring...@.";
-      js,Js_var.program js
-    end
-  else js, (fun v -> Code.Var.to_string v)
+  if times ()
+  then Format.eprintf "Start Coloring...@.";
+  js,Js_var.program js
+
 
 let output formatter d (js,to_string) =
   if times ()
diff --git a/compiler/js_var.ml b/compiler/js_var.ml
index 70069bf776..d4d5665049 100644
--- a/compiler/js_var.ml
+++ b/compiler/js_var.ml
@@ -87,7 +87,7 @@ let get_free_name t = StringSet.diff t.use_name t.def_name
 let mark g =
   let u = S.union g.def g.use in
   S.iter (fun u -> G.add_vertex g.g (vertex g u)) u;
-  S.fold (fun u1 set ->
+  let _ = S.fold (fun u1 set ->
     let set = S.remove u1 set in
     S.iter (fun u2 ->
       if u1 <> u2
@@ -98,7 +98,7 @@ let mark g =
           (vertex g u2)
     ) set;
     set
-  ) u u;
+  ) u u in
   {g with biggest = max g.biggest (S.cardinal u)}
 
 let create () = (* empty (G.make (Code.Var.count ())) *)
@@ -244,20 +244,7 @@ and statement t s = match s with
 module M = Graph.Coloring.Mark(G)
 
 
-let program p =
-  let t = source_elts (create()) p in
-  let free = get_free t in
-  if S.cardinal free != 0
-  then begin
-    failwith "free variables"
-  end;
-  let free_name = get_free_name t in
-  StringSet.iter (fun s ->
-    (* Printf.eprintf "use %s\n%!" s; *)
-    Code.Reserved.add s;
-    Primitive.mark_used s;
-  ) free_name;
-  let t = mark t in
+let assign t =
   if debug ()
   then Printf.eprintf "compute graph degree\n%!";
   let degree = G.fold_vertex (fun v acc -> max acc (G.in_degree t.g v)) t.g 0 in
@@ -296,3 +283,24 @@ let program p =
       VM.add var name map) varset map) VM.empty arr
   in
   (fun v -> VM.find v map)
+
+
+
+let program p =
+  let t = source_elts (create()) p in
+  let t = mark t in
+  let free = get_free t in
+  if S.cardinal free != 0
+  then begin
+    failwith "free variables"
+  end;
+  let free_name = get_free_name t in
+
+  StringSet.iter (fun s ->
+    (* Printf.eprintf "use %s\n%!" s; *)
+    Code.Reserved.add s;
+    Primitive.mark_used s;
+  ) free_name;
+  if Option.Optim.shortvar ()
+  then assign t
+  else (fun v -> Code.Var.to_string v)
diff --git a/runtime/mlString.js b/runtime/mlString.js
index 5d7c668b31..55ba96cd14 100644
--- a/runtime/mlString.js
+++ b/runtime/mlString.js
@@ -257,8 +257,8 @@ function MlStringFromArray (a) {
 MlStringFromArray.prototype = new MlString ();
 
 //Provides: caml_create_string const
-//Requires: MlString
 //Requires: caml_invalid_argument
+//Requires: MlMakeString
 function caml_create_string(len) {
   if (len < 0) caml_invalid_argument("String.create");
   return new MlMakeString(len);

From 114079a05572e56b7ec57dfe008675b01edb77f7 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Sun, 15 Sep 2013 23:22:18 -0700
Subject: [PATCH 39/60] COMPILER: missing cleaning

---
 compiler/.depend   | 16 ++++++++--------
 compiler/Makefile  |  2 +-
 compiler/code.ml   | 16 ----------------
 compiler/code.mli  |  4 ----
 compiler/js_var.ml |  2 +-
 compiler/linker.ml |  1 -
 6 files changed, 10 insertions(+), 31 deletions(-)

diff --git a/compiler/.depend b/compiler/.depend
index d89771ce68..2a7288690d 100644
--- a/compiler/.depend
+++ b/compiler/.depend
@@ -1,5 +1,5 @@
-code.cmo : util.cmi option.cmo code.cmi
-code.cmx : util.cmx option.cmx code.cmi
+code.cmo : util.cmi reserved.cmo option.cmo code.cmi
+code.cmx : util.cmx reserved.cmx option.cmx code.cmi
 control.cmo : subst.cmi code.cmi control.cmi
 control.cmx : subst.cmx code.cmx control.cmi
 deadcode.cmo : util.cmi pure_fun.cmi option.cmo code.cmi deadcode.cmi
@@ -38,12 +38,12 @@ js_rename.cmo : util.cmi javascript.cmi
 js_rename.cmx : util.cmx javascript.cmx
 js_simpl.cmo : javascript.cmi code.cmi js_simpl.cmi
 js_simpl.cmx : javascript.cmx code.cmx js_simpl.cmi
-js_var.cmo : util.cmi primitive.cmi option.cmo javascript.cmi code.cmi \
-    js_var.cmi
-js_var.cmx : util.cmx primitive.cmx option.cmx javascript.cmx code.cmx \
-    js_var.cmi
-linker.cmo : util.cmi primitive.cmi pretty_print.cmi code.cmi linker.cmi
-linker.cmx : util.cmx primitive.cmx pretty_print.cmx code.cmx linker.cmi
+js_var.cmo : util.cmi reserved.cmo primitive.cmi option.cmo javascript.cmi \
+    code.cmi js_var.cmi
+js_var.cmx : util.cmx reserved.cmx primitive.cmx option.cmx javascript.cmx \
+    code.cmx js_var.cmi
+linker.cmo : util.cmi primitive.cmi pretty_print.cmi linker.cmi
+linker.cmx : util.cmx primitive.cmx pretty_print.cmx linker.cmi
 main.cmo : util.cmi pretty_print.cmi parse_bytecode.cmi option.cmo \
     linker.cmi driver.cmi
 main.cmx : util.cmx pretty_print.cmx parse_bytecode.cmx option.cmx \
diff --git a/compiler/Makefile b/compiler/Makefile
index 8bb276b0a3..87d9947149 100644
--- a/compiler/Makefile
+++ b/compiler/Makefile
@@ -8,7 +8,7 @@ lib: compiler.cma compiler.cmxa compiler.cmxs
 PACKAGES=findlib,str,unix,ocamlgraph
 
 OBJS=pretty_print.cmx util.cmx option.cmx dgraph.cmx \
-     code.cmx reserved.cmx javascript.cmx js_output.cmx js_simpl.cmx \
+     reserved.cmx code.cmx javascript.cmx js_output.cmx js_simpl.cmx \
      instr.cmx primitive.cmx subst.cmx pure_fun.cmx deadcode.cmx \
      flow.cmx specialize.cmx specialize_js.cmx eval.cmx inline.cmx \
      tailcall.cmx freevars.cmx phisimpl.cmx \
diff --git a/compiler/code.ml b/compiler/code.ml
index 2f1fe9f6f8..0317de5c92 100644
--- a/compiler/code.ml
+++ b/compiler/code.ml
@@ -18,22 +18,6 @@
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  *)
 
-(*FIX: this should probably be somewhere else... *)
-
-module Reserved = struct
-  let reserved = Hashtbl.create 107
-
-  let add s = if String.length s <= 5 then Hashtbl.replace reserved s ()
-
-  let mem s = Hashtbl.mem reserved s
-
-  let _ =
-    List.iter add
-      ["break"; "case"; "catch"; "do"; "else"; "for"; "if"; "in"; "new";
-       "this"; "throw"; "try"; "var"; "void"; "while"; "with"; "class";
-       "enum"; "super"; "const"; "yield"; "let"]
-end
-
 module VarPrinter = struct
   let names = Hashtbl.create 107
   let name'' v nm = Hashtbl.add names v nm
diff --git a/compiler/code.mli b/compiler/code.mli
index 38c7368f64..67a85cc380 100644
--- a/compiler/code.mli
+++ b/compiler/code.mli
@@ -18,10 +18,6 @@
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  *)
 
-module Reserved : sig
-  val add : string -> unit
-  val mem : string -> bool
-end
 module Var : sig
   type t
   val print : Format.formatter -> t -> unit
diff --git a/compiler/js_var.ml b/compiler/js_var.ml
index d4d5665049..6b6ca82979 100644
--- a/compiler/js_var.ml
+++ b/compiler/js_var.ml
@@ -298,7 +298,7 @@ let program p =
 
   StringSet.iter (fun s ->
     (* Printf.eprintf "use %s\n%!" s; *)
-    Code.Reserved.add s;
+    Reserved.add s;
     Primitive.mark_used s;
   ) free_name;
   if Option.Optim.shortvar ()
diff --git a/compiler/linker.ml b/compiler/linker.ml
index c7f2e500d9..fb2ea4f02e 100644
--- a/compiler/linker.ml
+++ b/compiler/linker.ml
@@ -176,7 +176,6 @@ let add_file f =
        let id = !last_code_id in
        List.iter
          (fun (loc, nm, kind) ->
-           Code.Reserved.add nm;
             let kind =
               match kind with
                 "pure" | "const" -> `Pure

From 14bd57f44adf8859fdaff3049cf1337fff758918 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Sun, 15 Sep 2013 23:50:36 -0700
Subject: [PATCH 40/60] TODO: update

---
 TODO.txt | 22 +---------------------
 1 file changed, 1 insertion(+), 21 deletions(-)

diff --git a/TODO.txt b/TODO.txt
index 64ae2ecb26..c1d194fd46 100644
--- a/TODO.txt
+++ b/TODO.txt
@@ -1,14 +1,6 @@
 Priorities
 ==========
 
-- use short names for primitives
-- share string constants
-  =====> generic mechanism for sharing constants?
-
-- optimize pattern (new Mlstring("foo").toString())
-                 ===> "foo" converted to UTF-8
-- new MlString(x) replaced by primitive
-
 - unhoist functions when possible
 
 ---------
@@ -80,8 +72,6 @@ Compiler optimizations
 
 - fix control.ml
 
-- detect caml_format_int("%d", x) and generate ""+x
-
 - syntactic sugar for Javascript literal strings
   + optimization to avoid going through Caml strings
 
@@ -93,13 +83,9 @@ Compiler optimizations
   ===> explicit conversion to boolean; specialized "if" that operates
        on booleans directly
 
-- inlining (especially of functions that are used only once!)
 - constant hoisting (including functions, out of loops and functions)
 - inline also partially applied functions
 
-- implement variable coalescing (in code generation, reuse the same
-  name for several variables when they have a disting lifetime)
-
 - we should check stack compatibility when parsing:
   when jumping somewhere, the stack should keep the same shape
 
@@ -184,10 +170,7 @@ COMPACT MODE
 ============
 - We need to insert newlines from time to time to avoid problems with
   some routers...
-- Code for variable renaming in Javascript code
-  ==> also eliminate redundant "var"?
-- Start with function parameters.  Then, variables that are used most.
-- Use interference mechanism...
+- eliminate redundant "var"?
 
 IMPROVEMENTS
 ============
@@ -197,9 +180,6 @@ IMPROVEMENTS
   ==> gdtoa
     http://caml.inria.fr/pub/ml-archives/caml-list/2002/12/2813f8e8be115b0bad1bc16b1e41b744.en.html
 
-- We only have to make sure we do not use a
-  reserved word nor a function used outside for naming variables
-
 - explicit conversion from int to boolean
 
 - simplify conditional definition

From b236fa91f4341a102c6e7d93b88a3d6c2b13df0c Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Mon, 16 Sep 2013 00:32:02 -0700
Subject: [PATCH 41/60] COMPILER: restore some js_simpl

---
 compiler/js_simpl.ml | 6 ++++--
 1 file changed, 4 insertions(+), 2 deletions(-)

diff --git a/compiler/js_simpl.ml b/compiler/js_simpl.ml
index fb1dc61c49..6e370ccd94 100644
--- a/compiler/js_simpl.ml
+++ b/compiler/js_simpl.ml
@@ -20,6 +20,8 @@
 
 module J = Javascript
 
+
+
 let eplus_int e1 e2 =
   match e2,e1 with
     J.ENum n, _ when n < 0. ->
@@ -98,8 +100,8 @@ let source_elements l =
   List.fold_right
     (fun st rem ->
        match st, rem with
-         (* J.Variable_statement [addr, Some (J.EFun ((None, params, body), pc))], _ -> *)
-         (*   J.Function_declaration (addr, params, body, pc) :: rem *)
+       | J.Variable_statement [addr, Some (J.EFun ((None, params, body), pc))], _ ->
+         J.Function_declaration (addr, params, body, pc) :: rem
        | J.Variable_statement l1,
          J.Statement (J.Variable_statement l2) :: rem' ->
            J.Statement (J.Variable_statement (l1 @ l2)) :: rem'

From f962906896eb9c7a1558ad65a80a813377f7f5a4 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Mon, 16 Sep 2013 10:14:31 -0700
Subject: [PATCH 42/60] COMPILER: mv VarPrinter

---
 compiler/Makefile       |  4 +-
 compiler/code.ml        | 87 +++++------------------------------------
 compiler/code.mli       |  6 ---
 compiler/generate.ml    |  8 ++--
 compiler/javascript.ml  | 31 +++++++++------
 compiler/javascript.mli | 27 +++++++------
 compiler/js_output.ml   |  6 +--
 compiler/util.ml        | 84 +++++++++++++++++++++++++++++++++++++++
 compiler/util.mli       | 12 ++++++
 9 files changed, 151 insertions(+), 114 deletions(-)

diff --git a/compiler/Makefile b/compiler/Makefile
index 87d9947149..c6597d4316 100644
--- a/compiler/Makefile
+++ b/compiler/Makefile
@@ -7,8 +7,8 @@ lib: compiler.cma compiler.cmxa compiler.cmxs
 
 PACKAGES=findlib,str,unix,ocamlgraph
 
-OBJS=pretty_print.cmx util.cmx option.cmx dgraph.cmx \
-     reserved.cmx code.cmx javascript.cmx js_output.cmx js_simpl.cmx \
+OBJS=pretty_print.cmx reserved.cmx util.cmx option.cmx dgraph.cmx \
+     code.cmx javascript.cmx js_output.cmx js_simpl.cmx \
      instr.cmx primitive.cmx subst.cmx pure_fun.cmx deadcode.cmx \
      flow.cmx specialize.cmx specialize_js.cmx eval.cmx inline.cmx \
      tailcall.cmx freevars.cmx phisimpl.cmx \
diff --git a/compiler/code.ml b/compiler/code.ml
index 0317de5c92..fbcaaf1c24 100644
--- a/compiler/code.ml
+++ b/compiler/code.ml
@@ -18,75 +18,10 @@
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  *)
 
-module VarPrinter = struct
-  let names = Hashtbl.create 107
-  let name'' v nm = Hashtbl.add names v nm
-  let propagate_name v v' =
-    try name'' v' (Hashtbl.find names v) with Not_found -> ()
-  let name v nm =
-    let is_alpha c = (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') in
-    let is_num c = (c >= '0' && c <= '9') in
-    if String.length nm > 0 then begin
-      let nm = String.copy nm in
-      if not (is_alpha nm.[0]) then nm.[0] <- '_';
-      for i = 1 to String.length nm - 1 do
-        if not (is_alpha nm.[i] || is_num nm.[i]) then nm.[i] <- '_';
-      done;
-      let c = ref 0 in
-      for i = 0 to String.length nm - 1 do
-        if nm.[i] = '_' then incr c
-      done;
-      if !c < String.length nm then name'' v nm
-    end
-
-  let known = Hashtbl.create 1001
-
-  let last = ref (-1)
-
-  let c1 = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_$"
-  let c2 = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_$"
-
-  let rec format_ident x =
-    assert (x >= 0);
-    let char c x = String.make 1 (c.[x]) in
-    if x < 54 then
-       char c1 x
-    else
-      format_ident ((x - 54) / 64) ^ char c2 ((x - 54) mod 64)
-
-  let format_var i x =
-    let s = format_ident x in
-    if Option.Optim.pretty () then begin
-      try
-        let nm = Hashtbl.find names i in
-        Format.sprintf "%s_%s_" nm s
-      with Not_found ->
-        Format.sprintf "_%s_" s
-    end else
-      s
-
-  let rec to_string i =
-    try
-      Hashtbl.find known i
-    with Not_found ->
-      incr last;
-      let j = !last in
-      let s = format_var i j in
-      if Reserved.mem s then
-        to_string i
-      else begin
-        Hashtbl.add known i s;
-        s
-      end
-
-  let reset () =
-    Hashtbl.clear names; Hashtbl.clear known; last := -1
-
-  let _ = reset ()
-end
 
 module Var : sig
   type t
+
   val print : Format.formatter -> t -> unit
   val idx : t -> int
   val to_string : t -> string
@@ -105,13 +40,18 @@ module Var : sig
   val dummy : t
 end = struct
 
+  open Util
   type t = int
 
+  let printer = VarPrinter.create ()
+
   let last_var = ref 0
 
-  let reset () = last_var := 0; VarPrinter.reset ()
+  let reset () =
+    last_var := 0;
+    VarPrinter.reset printer
 
-  let to_string i = VarPrinter.to_string i
+  let to_string i = VarPrinter.to_string printer i
 
   let print f x = Format.fprintf f "%s" (to_string x)
 
@@ -123,19 +63,12 @@ end = struct
 
   let compare v1 v2 = v1 - v2
 
-  let name i nm = VarPrinter.name i nm
-  let propagate_name i j = VarPrinter.propagate_name i j
+  let name i nm = VarPrinter.name printer i nm
+  let propagate_name i j = VarPrinter.propagate_name printer i j
 
   let dummy = -1
 end
 
-module Label = struct
-  type t = int
-  let zero = 0
-  let succ t = succ t
-  let to_string t = VarPrinter.format_ident t
-end
-
 module VarSet = Set.Make (Var)
 module VarMap = Map.Make (Var)
 module VarTbl = struct
diff --git a/compiler/code.mli b/compiler/code.mli
index 67a85cc380..e9ff9c4d0a 100644
--- a/compiler/code.mli
+++ b/compiler/code.mli
@@ -36,12 +36,6 @@ module Var : sig
   val reset : unit -> unit
 end
 
-module Label : sig
-  type t
-  val zero : t
-  val succ : t -> t
-  val to_string : t -> string
-end
 
 module VarSet : Set.S with type elt = Var.t
 module VarMap : Map.S with type key = Var.t
diff --git a/compiler/generate.ml b/compiler/generate.ml
index 3c34e5135c..ad665cebc4 100644
--- a/compiler/generate.ml
+++ b/compiler/generate.ml
@@ -345,7 +345,7 @@ type state =
     backs : (int, AddrSet.t) Hashtbl.t;
     preds : (int, int) Hashtbl.t;
     mutable loops : AddrSet.t;
-    mutable loop_stack : (addr * (Label.t * bool ref)) list;
+    mutable loop_stack : (addr * (J.Label.t * bool ref)) list;
     mutable visited_blocks : AddrSet.t;
     mutable interm_idx : int;
     ctx : Ctx.t; mutable blocks : Code.block AddrMap.t }
@@ -1134,7 +1134,7 @@ else begin
   end;
   if AddrSet.mem pc st.loops then begin
     let lab =
-      match st.loop_stack with (_, (l, _)) :: _ -> Code.Label.succ l | [] -> Code.Label.zero in
+      match st.loop_stack with (_, (l, _)) :: _ -> J.Label.succ l | [] -> J.Label.zero in
     st.loop_stack <- (pc, (lab, ref false)) :: st.loop_stack
   end;
   let succs = Hashtbl.find st.succs pc in
@@ -1263,7 +1263,7 @@ else begin
     in
     match label with
       | None -> [st]
-      | Some label -> [J.Labelled_statement (Code.Label.to_string label, st)]
+      | Some label -> [J.Labelled_statement (label, st)]
   end else
     body
 end
@@ -1473,7 +1473,7 @@ and compile_branch st queue ((pc, _) as cont) handler backs frontier interm =
           else begin
             let (lab, used) = List.assoc pc rem in
             used := true;
-            Some (Code.Label.to_string lab)
+            Some lab
           end
     in
     if debug () then begin
diff --git a/compiler/javascript.ml b/compiler/javascript.ml
index c1d46a772b..3913850021 100644
--- a/compiler/javascript.ml
+++ b/compiler/javascript.ml
@@ -19,8 +19,25 @@
  *)
 
 
+module Label = struct
+  open Util
+  type t = int
+
+  let printer = VarPrinter.create ()
+
+  let zero = 0
+  let succ t = succ t
+  let to_string t = VarPrinter.to_string printer t
+end
+
 type node_pc = int option
 
+type identifier = string
+
+type ident =
+  | S of identifier
+  | V of Code.Var.t
+
 (* A.3 Expressions *)
 
 and array_litteral = element_list
@@ -81,11 +98,11 @@ and statement =
   | While_statement of expression * statement
   | For_statement of  expression option * expression option * expression option * statement * node_pc
   (* | Iteration_statement *)
-  | Continue_statement of label option
-  | Break_statement of label option
+  | Continue_statement of Label.t option
+  | Break_statement of Label.t option
   | Return_statement of expression option
   (* | With_statement of expression * statement *)
-  | Labelled_statement of label * statement
+  | Labelled_statement of Label.t * statement
   | Switch_statement of expression * case_clause list * statement_list option
   | Throw_statement of expression
   | Try_statement of block * (ident * block) option * block option * node_pc
@@ -125,14 +142,6 @@ and source_element =
     Statement of statement
   | Function_declaration of function_declaration
 
-and identifier = string
-
-and ident =
-  | S of identifier
-  | V of Code.Var.t
-and label = identifier
-
-
 let compare_ident t1 t2 =
   match t1, t2 with
     | V v1, V v2 -> Code.Var.compare v1 v2
diff --git a/compiler/javascript.mli b/compiler/javascript.mli
index 8aa2ae68d1..ed0b409aa8 100644
--- a/compiler/javascript.mli
+++ b/compiler/javascript.mli
@@ -18,10 +18,23 @@
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  *)
 
+module Label : sig
+  type t
+  val zero : t
+  val succ : t -> t
+  val to_string : t -> string
+end
+
 type node_pc = int option
 
 (* A.3 Expressions *)
 
+type identifier = string
+
+type ident =
+  | S of identifier
+  | V of Code.Var.t
+
 and array_litteral = element_list
 
 and element_list = expression option list
@@ -85,13 +98,13 @@ and statement =
 (*
   | Iteration_statement
 *)
-  | Continue_statement of label option
-  | Break_statement of label option
+  | Continue_statement of Label.t option
+  | Break_statement of Label.t option
   | Return_statement of expression option
 (*
   | With_statement
 *)
-  | Labelled_statement of label * statement
+  | Labelled_statement of Label.t * statement
   | Switch_statement of expression * case_clause list * statement_list option
   | Throw_statement of expression
   | Try_statement of block * (ident * block) option * block option * node_pc
@@ -132,11 +145,3 @@ and source_elements = source_element list
 and source_element =
     Statement of statement
   | Function_declaration of function_declaration
-
-and identifier = string
-
-and ident =
-  | S of identifier
-  | V of Code.Var.t
-
-and label = identifier
diff --git a/compiler/js_output.ml b/compiler/js_output.ml
index f8987525b8..8bc795e817 100644
--- a/compiler/js_output.ml
+++ b/compiler/js_output.ml
@@ -702,13 +702,13 @@ end) = struct
         PP.string f "continue;"
       | Continue_statement (Some s) ->
         PP.string f "continue ";
-        PP.string f s;
+        PP.string f (Javascript.Label.to_string s);
         PP.string f ";"
       | Break_statement None ->
         PP.string f "break;"
       | Break_statement (Some s) ->
         PP.string f "break ";
-        PP.string f s;
+        PP.string f (Javascript.Label.to_string s);
         PP.string f ";"
       | Return_statement e ->
         begin match e with
@@ -748,7 +748,7 @@ end) = struct
          argument. A line return will not work *)
         end
       | Labelled_statement (i, s) ->
-        PP.string f i;
+        PP.string f (Javascript.Label.to_string i);
         PP.string f ":";
         PP.break f;
         statement f s
diff --git a/compiler/util.ml b/compiler/util.ml
index db09ffb4ab..e4fa5d541b 100644
--- a/compiler/util.ml
+++ b/compiler/util.ml
@@ -61,3 +61,87 @@ module Timer = struct
   let get t = !timer () -. t
   let print f t = Format.fprintf f "%.2f" (get t)
 end
+
+
+
+module VarPrinter = struct
+
+  type t = {
+    names : (int,string) Hashtbl.t;
+    known : (int,string) Hashtbl.t;
+    mutable last : int;
+    mutable pretty : bool;
+  }
+
+  let c1 = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_$"
+  let c2 = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_$"
+
+  let name_raw t v nm = Hashtbl.add t.names v nm
+  let propagate_name t v v' =
+    try name_raw t v' (Hashtbl.find t.names v) with Not_found -> ()
+
+  let is_alpha c = (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')
+  let is_num c = (c >= '0' && c <= '9')
+
+  let name t v nm =
+    if String.length nm > 0 then begin
+      let nm = String.copy nm in
+      if not (is_alpha nm.[0]) then nm.[0] <- '_';
+      for i = 1 to String.length nm - 1 do
+        if not (is_alpha nm.[i] || is_num nm.[i]) then nm.[i] <- '_';
+      done;
+      let c = ref 0 in
+      for i = 0 to String.length nm - 1 do
+        if nm.[i] = '_' then incr c
+      done;
+      if !c < String.length nm then name_raw t v nm
+    end
+
+  let rec format_ident x =
+    assert (x >= 0);
+    let char c x = String.make 1 (c.[x]) in
+    if x < 54 then
+      char c1 x
+    else
+      format_ident ((x - 54) / 64) ^ char c2 ((x - 54) mod 64)
+
+  let format_var t i x =
+    let s = format_ident x in
+    if t.pretty then begin
+      try
+        let nm = Hashtbl.find t.names i in
+        Format.sprintf "%s_%s_" nm s
+      with Not_found ->
+        Format.sprintf "_%s_" s
+    end else
+      s
+
+  let rec to_string t i =
+    try
+      Hashtbl.find t.known i
+    with Not_found ->
+      t.last <- t.last + 1;
+      let j = t.last in
+      let s = format_var t i j in
+      if Reserved.mem s then
+        to_string t i
+      else begin
+        Hashtbl.add t.known i s;
+        s
+      end
+
+  let set_pretty t b = t.pretty <- b
+
+
+  let reset t =
+    Hashtbl.clear t.names; Hashtbl.clear t.known; t.last <- -1
+
+  let create () =
+    let t = {
+      names = Hashtbl.create 107;
+      known = Hashtbl.create 1001;
+      last = -1;
+      pretty = false;
+    } in
+    reset t; t
+end
diff --git a/compiler/util.mli b/compiler/util.mli
index e1a684caf2..6e4b0e3fac 100644
--- a/compiler/util.mli
+++ b/compiler/util.mli
@@ -38,3 +38,15 @@ module Timer : sig
   val get : t -> float
   val print : Format.formatter -> t -> unit
 end
+
+module VarPrinter : sig
+  type t
+
+  val create : unit -> t
+  val reset : t -> unit
+  val to_string : t -> int -> string
+  val name : t -> int -> string -> unit
+  val propagate_name : t -> int -> int -> unit
+  val set_pretty : t -> bool -> unit
+
+end

From ddb79643e165a9d3a9cf041c2ec5b3f307f12699 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Mon, 16 Sep 2013 10:27:39 -0700
Subject: [PATCH 43/60] COMPILER: catch only NoColoring exc

---
 compiler/js_var.ml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/compiler/js_var.ml b/compiler/js_var.ml
index 6b6ca82979..f11f5d95fe 100644
--- a/compiler/js_var.ml
+++ b/compiler/js_var.ml
@@ -263,7 +263,7 @@ let assign t =
         if debug ()
         then Printf.eprintf "try coloring with %d\n%!" k;
         M.coloring t.g k
-      with _ -> loop rem in
+      with M.NoColoring -> loop rem in
   loop [t.biggest;degree];
 
   (* build the mapping function *)

From 21bf13322038467623535f83374bb9ea444847e8 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Mon, 16 Sep 2013 10:34:05 -0700
Subject: [PATCH 44/60] COMPILER: use temp file

---
 compiler/main.ml | 9 ++++++---
 1 file changed, 6 insertions(+), 3 deletions(-)

diff --git a/compiler/main.ml b/compiler/main.ml
index b9e57210fd..078892dd64 100644
--- a/compiler/main.ml
+++ b/compiler/main.ml
@@ -41,12 +41,15 @@ let f linkall paths js_files input_file output_file =
     | None ->
       output_program (Pretty_print.to_out_channel stdout)
     | Some f ->
+      let f_tmp = f^".tmp" in
       try
-        let ch = open_out_bin f in
+        let ch = open_out_bin f_tmp in
         output_program (Pretty_print.to_out_channel ch);
-        close_out ch
+        close_out ch;
+        (try Sys.remove f with _ -> ());
+        Sys.rename f_tmp f
       with exc ->
-        Sys.remove f;
+        Sys.remove f_tmp;
         Format.eprintf "compilation error: %s@." (Printexc.to_string exc);
         raise exc
   end;

From b863412b832400210f80b1aa895580328cee0c37 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Mon, 16 Sep 2013 23:50:08 -0700
Subject: [PATCH 45/60] COMPILER: use real temp file

---
 compiler/main.ml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/compiler/main.ml b/compiler/main.ml
index 078892dd64..f152e2710b 100644
--- a/compiler/main.ml
+++ b/compiler/main.ml
@@ -41,7 +41,7 @@ let f linkall paths js_files input_file output_file =
     | None ->
       output_program (Pretty_print.to_out_channel stdout)
     | Some f ->
-      let f_tmp = f^".tmp" in
+      let f_tmp = Filename.temp_file (Filename.basename f) ".tmpjs" in
       try
         let ch = open_out_bin f_tmp in
         output_program (Pretty_print.to_out_channel ch);

From fb1a023622e7cb437c7b6724de41217cb28dd5be Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Mon, 23 Sep 2013 17:28:21 -0700
Subject: [PATCH 46/60] COMPILER: remove some try-catch

---
 compiler/eval.ml | 115 +++++++++++++++++++++++------------------------
 1 file changed, 57 insertions(+), 58 deletions(-)

diff --git a/compiler/eval.ml b/compiler/eval.ml
index 8c447cd1ef..11bce47aa6 100644
--- a/compiler/eval.ml
+++ b/compiler/eval.ml
@@ -15,75 +15,74 @@ let eval_prim x =
     | Extern name, l ->
       let name = Primitive.resolve name in
       let module Int = Int32 in
-      let int2 = match l with
-        | [Int i; Int j] -> fun f ->
-          (try Some (Int (Int.to_int (f (Int.of_int i) (Int.of_int j)))) with _ -> None)
+      let int_binop = match l with
+        | [Int i; Int j] -> fun f -> Some (Int (Int.to_int (f (Int.of_int i) (Int.of_int j))))
         | _ -> fun _ -> None in
-      let int2_1 = match l with
-        | [Int i; Int j] -> fun f ->
-          (try Some (Int (Int.to_int (f (Int.of_int i) j))) with _ -> None)
+      let shift = match l with
+        | [Int i; Int j] -> fun f -> Some (Int (Int.to_int (f (Int.of_int i) j)))
         | _ -> fun _ -> None in
-      let f2_aux =
-        try
-          let i,j = match l with
-            | [Float i; Float j]-> i,j
-            | [Int i ; Int j] -> float_of_int i,float_of_int j
-            | [Int i ; Float j] -> float_of_int i,j
-            | [Float i ; Int j] -> i,float_of_int j
-            | _ -> raise Not_found
-          in
-          fun f -> (try Some (f i j) with _ -> None)
-        with _ -> fun _ -> None in
-      let f2 f = f2_aux (fun i j -> Float (f i j)) in
-      let f1 = match l with
-        | [Float i] -> fun f -> (try Some (Float (f i)) with _ -> None)
-        | [Int i] -> fun f -> (try Some (Float (f (float_of_int i))) with _ -> None)
+      let float_binop_aux =
+        let args = match l with
+          | [Float i; Float j]-> Some (i,j)
+          | [Int i ; Int j] -> Some (float_of_int i,float_of_int j)
+          | [Int i ; Float j] -> Some(float_of_int i,j)
+          | [Float i ; Int j] -> Some(i,float_of_int j)
+          | _ -> None
+        in
+        match args with
+          | None -> (fun _ -> None)
+          | Some (i,j) -> fun f -> Some (f i j) in
+      let float_binop f = float_binop_aux (fun i j -> Float (f i j)) in
+      let float_unop = match l with
+        | [Float i] -> fun f -> Some (Float (f i))
+        | [Int i] -> fun f -> Some (Float (f (float_of_int i)))
         | _ -> fun _ -> None in
-      let f2b f = f2_aux (fun i j -> Int (if f i j then 1 else 0)) in
+      let float_binop_bool f = float_binop_aux (fun i j -> Int (if f i j then 1 else 0)) in
       (match name, l with
         (* int *)
-        | "%int_add", _ -> int2 (Int.add)
-        | "%int_sub", _ -> int2 (Int.sub)
-        | "%direct_int_mul", _ -> int2 (Int.mul )
-        | "%direct_int_div", _ -> int2 (Int.div)
-        | "%direct_int_mod", _ -> int2 (Int.rem)
-        | "%int_and", _ -> int2 (Int.logand)
-        | "%int_or", _  -> int2 (Int.logor)
-        | "%int_xor", _ -> int2 (Int.logxor)
-        | "%int_lsl", _ -> int2_1 (Int.shift_left)
-        | "%int_lsr", _ -> int2_1 (Int.shift_right_logical)
-        | "%int_asr", _ -> int2_1 (Int.shift_right)
+        | "%int_add", _ -> int_binop (Int.add)
+        | "%int_sub", _ -> int_binop (Int.sub)
+        | "%direct_int_mul", _ -> int_binop (Int.mul )
+        | "%direct_int_div", [_; Int 0] -> None
+        | "%direct_int_div", _ -> int_binop (Int.div)
+        | "%direct_int_mod", _ -> int_binop (Int.rem)
+        | "%int_and", _ -> int_binop (Int.logand)
+        | "%int_or", _  -> int_binop (Int.logor)
+        | "%int_xor", _ -> int_binop (Int.logxor)
+        | "%int_lsl", _ -> shift (Int.shift_left)
+        | "%int_lsr", _ -> shift (Int.shift_right_logical)
+        | "%int_asr", _ -> shift (Int.shift_right)
         | "%int_neg", [Int i] -> Some (Int (Int.to_int (Int.neg (Int.of_int i) )))
         (* float *)
-        | "caml_eq_float", _ -> f2b (=)
-        | "caml_neq_float", _ -> f2b (<>)
-        | "caml_ge_float", _ -> f2b (>=)
-        | "caml_le_float", _ -> f2b (<=)
-        | "caml_gt_float", _ -> f2b (>)
-        | "caml_lt_float", _ -> f2b (<)
-        | "caml_add_float",_ -> f2 (+.)
-        | "caml_sub_float",_ -> f2 (-.)
-        | "caml_mul_float",_ -> f2 ( *. )
-        | "caml_div_float",_ -> f2 ( /. )
-        | "caml_fmod_float",_ -> f2 mod_float
+        | "caml_eq_float", _ -> float_binop_bool (=)
+        | "caml_neq_float", _ -> float_binop_bool (<>)
+        | "caml_ge_float", _ -> float_binop_bool (>=)
+        | "caml_le_float", _ -> float_binop_bool (<=)
+        | "caml_gt_float", _ -> float_binop_bool (>)
+        | "caml_lt_float", _ -> float_binop_bool (<)
+        | "caml_add_float",_ -> float_binop (+.)
+        | "caml_sub_float",_ -> float_binop (-.)
+        | "caml_mul_float",_ -> float_binop ( *. )
+        | "caml_div_float",_ -> float_binop ( /. )
+        | "caml_fmod_float",_ -> float_binop mod_float
         | "caml_int_of_float",[Float f] -> Some (Int (int_of_float f))
         | "to_int",[Float f]  -> Some (Int (int_of_float f))
         | "to_int",[Int i] -> Some (Int i)
           (* Math *)
-        | "caml_abs_float",_ -> f1 abs_float
-        | "caml_acos_float",_ -> f1 acos
-        | "caml_asin_float",_ -> f1 asin
-        | "caml_atan_float",_ -> f1 atan
-        | "caml_atan2_float",_ -> f2 atan2
-        | "caml_ceil_float",_ -> f1 ceil
-        | "caml_cos_float",_ -> f1 cos
-        | "caml_exp_float",_ -> f1 exp
-        | "caml_floor_float",_ -> f1 floor
-        | "caml_log_float",_ -> f1 log
-        | "caml_power_float",_ -> f2 ( ** )
-        | "caml_sin_float",_ -> f1 sin
-        | "caml_sqrt_float",_ -> f1 sqrt
-        | "caml_tan_float",_ -> f1 tan
+        | "caml_abs_float",_ -> float_unop abs_float
+        | "caml_acos_float",_ -> float_unop acos
+        | "caml_asin_float",_ -> float_unop asin
+        | "caml_atan_float",_ -> float_unop atan
+        | "caml_atan2_float",_ -> float_binop atan2
+        | "caml_ceil_float",_ -> float_unop ceil
+        | "caml_cos_float",_ -> float_unop cos
+        | "caml_exp_float",_ -> float_unop exp
+        | "caml_floor_float",_ -> float_unop floor
+        | "caml_log_float",_ -> float_unop log
+        | "caml_power_float",_ -> float_binop ( ** )
+        | "caml_sin_float",_ -> float_unop sin
+        | "caml_sqrt_float",_ -> float_unop sqrt
+        | "caml_tan_float",_ -> float_unop tan
         | _ -> None)
     | _ -> None
 

From 61f0ab67b47af1e26ef5e45d1733c3a91f9a9df3 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Sat, 21 Sep 2013 16:38:20 -0700
Subject: [PATCH 47/60] COMPILER: more of js ast

add missing ast elt

COMPILER: missing ops

merge with more ast
---
 compiler/javascript.ml  | 26 ++++++++++++---------
 compiler/javascript.mli | 14 ++++--------
 compiler/js_output.ml   | 50 ++++++++++++++++++++++++++++++++++++++---
 compiler/js_simpl.ml    |  2 +-
 compiler/js_var.ml      |  4 ++++
 5 files changed, 71 insertions(+), 25 deletions(-)

diff --git a/compiler/javascript.ml b/compiler/javascript.ml
index 3913850021..f177d677e9 100644
--- a/compiler/javascript.ml
+++ b/compiler/javascript.ml
@@ -21,13 +21,20 @@
 
 module Label = struct
   open Util
-  type t = int
+  type t =
+    | L of int
+    | S of string
 
   let printer = VarPrinter.create ()
 
-  let zero = 0
-  let succ t = succ t
-  let to_string t = VarPrinter.to_string printer t
+  let zero = L 0
+  let succ = function
+    | L t -> L (succ t)
+    | S _ -> assert false
+  let to_string = function
+    | L t -> VarPrinter.to_string printer t
+    | S s -> s
+  let of_string s = S s
 end
 
 type node_pc = int option
@@ -49,13 +56,12 @@ and binop =
   | LslEq | AsrEq | LsrEq | BandEq | BxorEq | BorEq
   | Or | And | Bor | Bxor | Band
   | EqEq | NotEq | EqEqEq | NotEqEq
-  | Lt | Le | InstanceOf
+  | Lt | Le | Gt | Ge | InstanceOf | In
   | Lsl | Lsr | Asr
   | Plus | Minus
   | Mul | Div | Mod
 
-and unop = Not | Neg | Pl | Typeof | Delete | Bnot | IncrA | DecrA | IncrB | DecrB
-(*XXX*)
+and unop = Not | Neg | Pl | Typeof | Void | Delete | Bnot | IncrA | DecrA | IncrB | DecrB
 
 and arguments = expression list
 
@@ -91,13 +97,13 @@ and expression =
 and statement =
     Block of block
   | Variable_statement of variable_declaration list
-  (* | Empty_statement *)
+  | Empty_statement
   | Expression_statement of expression * node_pc
   | If_statement of expression * statement * statement option
   | Do_while_statement of statement * expression
   | While_statement of expression * statement
   | For_statement of  expression option * expression option * expression option * statement * node_pc
-  (* | Iteration_statement *)
+  | ForIn_statement of  expression * expression * statement * node_pc
   | Continue_statement of Label.t option
   | Break_statement of Label.t option
   | Return_statement of expression option
@@ -118,8 +124,6 @@ and case_clause = expression * statement_list
 
 and initialiser = expression
 
-(*... *)
-
 (****)
 
 (* A.5 Functions and programs *)
diff --git a/compiler/javascript.mli b/compiler/javascript.mli
index ed0b409aa8..9b19f1c1c1 100644
--- a/compiler/javascript.mli
+++ b/compiler/javascript.mli
@@ -23,6 +23,7 @@ module Label : sig
   val zero : t
   val succ : t -> t
   val to_string : t -> string
+  val of_string : string -> t
 end
 
 type node_pc = int option
@@ -44,13 +45,12 @@ and binop =
   | LslEq | AsrEq | LsrEq | BandEq | BxorEq | BorEq
   | Or | And | Bor | Bxor | Band
   | EqEq | NotEq | EqEqEq | NotEqEq
-  | Lt | Le | InstanceOf
+  | Lt | Le | Gt | Ge | InstanceOf | In
   | Lsl | Lsr | Asr
   | Plus | Minus
   | Mul | Div | Mod
 
-and unop = Not | Neg | Pl | Typeof | Delete | Bnot | IncrA | DecrA | IncrB | DecrB
-(*XXX*)
+and unop = Not | Neg | Pl | Typeof | Void | Delete | Bnot | IncrA | DecrA | IncrB | DecrB
 
 and arguments = expression list
 
@@ -86,18 +86,14 @@ and expression =
 and statement =
     Block of block
   | Variable_statement of variable_declaration list
-(*
   | Empty_statement
-*)
   | Expression_statement of expression * node_pc
   | If_statement of expression * statement * statement option
   | Do_while_statement of statement * expression
   | While_statement of expression * statement
   | For_statement of
       expression option * expression option * expression option * statement * node_pc
-(*
-  | Iteration_statement
-*)
+  | ForIn_statement of  expression * expression * statement * node_pc
   | Continue_statement of Label.t option
   | Break_statement of Label.t option
   | Return_statement of expression option
@@ -122,8 +118,6 @@ and case_clause = expression * statement_list
 
 and initialiser = expression
 
-(*... *)
-
 (****)
 
 (* A.5 Functions and programs *)
diff --git a/compiler/js_output.ml b/compiler/js_output.ml
index 8bc795e817..db9e1029c8 100644
--- a/compiler/js_output.ml
+++ b/compiler/js_output.ml
@@ -110,7 +110,7 @@ end) = struct
       | Bxor -> 6, 6, 6
       | Band -> 7, 7, 7
       | EqEq | NotEq | EqEqEq | NotEqEq -> 8, 8, 9
-      | Lt | Le | InstanceOf -> 9, 9, 10
+      | Gt | Ge | Lt | Le | InstanceOf | In -> 9, 9, 10
       | Lsl | Lsr | Asr -> 10, 10, 11
       | Plus | Minus -> 11, 11, 12
       | Mul | Div | Mod -> 12, 12, 13
@@ -140,6 +140,8 @@ end) = struct
       | BorEq   -> "|="
       | Lt      -> "<"
       | Le      -> "<="
+      | Gt      -> ">"
+      | Ge      -> ">="
       | Lsl     -> "<<"
       | Lsr     -> ">>>"
       | Asr     -> ">>"
@@ -148,7 +150,8 @@ end) = struct
       | Mul     -> "*"
       | Div     -> "/"
       | Mod     -> "%"
-      | InstanceOf -> assert false
+      | InstanceOf
+      | In -> assert false
 
   let unop_str op =
     match op with
@@ -157,7 +160,7 @@ end) = struct
       | Pl  -> "+"
       | Bnot -> "~"
       | IncrA | IncrB | DecrA | DecrB
-      | Typeof | Delete -> assert false
+      | Typeof | Void | Delete -> assert false
 
 (*XXX May need to be updated... *)
   let rec ends_with_if_without_else st =
@@ -321,6 +324,14 @@ end) = struct
         expression 13 f e;
         PP.end_group f;
         if l > 13 then begin PP.string f ")"; PP.end_group f end
+      | EUn (Void, e) ->
+        if l > 13 then begin PP.start_group f 1; PP.string f "(" end;
+        PP.start_group f 0;
+        PP.string f "void";
+        PP.space f;
+        expression 13 f e;
+        PP.end_group f;
+        if l > 13 then begin PP.string f ")"; PP.end_group f end
       | EUn (Delete, e) ->
         if l > 13 then begin PP.start_group f 1; PP.string f "(" end;
         PP.start_group f 0;
@@ -355,6 +366,17 @@ end) = struct
         expression rght f e2;
         PP.end_group f;
         if l > out then begin PP.string f ")"; PP.end_group f end
+      | EBin (In, e1, e2) ->
+        let (out, lft, rght) = op_prec InstanceOf in
+        if l > out then begin PP.start_group f 1; PP.string f "(" end;
+        PP.start_group f 0;
+        expression lft f e1;
+        PP.space f;
+        PP.string f "in";
+        PP.space f;
+        expression rght f e2;
+        PP.end_group f;
+        if l > out then begin PP.string f ")"; PP.end_group f end
       | EBin (op, e1, e2) ->
         let (out, lft, rght) = op_prec op in
         if l > out then begin PP.start_group f 1; PP.string f "(" end;
@@ -549,6 +571,7 @@ end) = struct
             PP.string f ";";
             PP.end_group f
         end
+      | Empty_statement -> ()
       | Expression_statement (EVar _, pc)-> ()
       | Expression_statement (e, pc) ->
       (* Parentheses are required when the expression
@@ -698,6 +721,27 @@ end) = struct
         statement f s;
         PP.end_group f;
         PP.end_group f
+      | ForIn_statement (e1, e2, s, pc) ->
+        output_debug_info f pc;
+        PP.start_group f 1;
+        PP.start_group f 0;
+        PP.string f "for";
+        PP.break f;
+        PP.start_group f 1;
+        PP.string f "(";
+        expression 0 f e1;
+        PP.space f;
+        PP.string f "in"; PP.break f;
+        PP.space f;
+        expression 0 f e2;
+        PP.string f ")";
+        PP.end_group f;
+        PP.end_group f;
+        PP.break f;
+        PP.start_group f 0;
+        statement f s;
+        PP.end_group f;
+        PP.end_group f
       | Continue_statement None ->
         PP.string f "continue;"
       | Continue_statement (Some s) ->
diff --git a/compiler/js_simpl.ml b/compiler/js_simpl.ml
index 6e370ccd94..734c9655cf 100644
--- a/compiler/js_simpl.ml
+++ b/compiler/js_simpl.ml
@@ -77,7 +77,7 @@ let rec enot_rec e =
         end
     | J.EUn (J.Not, e) ->
         (e, 0)
-    | J.EUn ((J.Neg | J.Pl | J.Typeof | J.Delete | J.Bnot ), _) ->
+    | J.EUn ((J.Neg | J.Pl | J.Typeof | J.Void | J.Delete | J.Bnot ), _) ->
         (J.EUn (J.Not, e), 0)
 
     | J.EBool b ->
diff --git a/compiler/js_var.ml b/compiler/js_var.ml
index f11f5d95fe..25ff70eb53 100644
--- a/compiler/js_var.ml
+++ b/compiler/js_var.ml
@@ -187,6 +187,7 @@ and statement t s = match s with
       match eopt with
         | None -> t
         | Some e -> expression t e) t l
+  | Empty_statement -> t
   | Expression_statement (e,_) -> expression t e
   | If_statement(e1,s2,e3opt) ->
     let t = statement (expression t e1) s2 in
@@ -204,6 +205,9 @@ and statement t s = match s with
         | None -> acc
         | Some e -> expression acc e ) t [e1;e2;e3] in
     statement t s
+  | ForIn_statement (e1,e2,s,_) ->
+    let t = List.fold_left expression t [e1;e2] in
+    statement t s
   | Continue_statement _
   | Break_statement _ -> t
   | Return_statement None -> t

From d7db7f7ec0f84da04f449f5534b95de745eee21f Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Sat, 21 Sep 2013 16:38:46 -0700
Subject: [PATCH 48/60] COMPILER: js parser (imported from pfff)

COMPILER: js parser
---
 compiler/lexer_js.mll  | 378 ++++++++++++++++++++
 compiler/parse_info.ml |   9 +
 compiler/parse_js.ml   | 311 +++++++++++++++++
 compiler/parser_js.mly | 770 +++++++++++++++++++++++++++++++++++++++++
 4 files changed, 1468 insertions(+)
 create mode 100644 compiler/lexer_js.mll
 create mode 100644 compiler/parse_info.ml
 create mode 100644 compiler/parse_js.ml
 create mode 100644 compiler/parser_js.mly

diff --git a/compiler/lexer_js.mll b/compiler/lexer_js.mll
new file mode 100644
index 0000000000..d9b68ac046
--- /dev/null
+++ b/compiler/lexer_js.mll
@@ -0,0 +1,378 @@
+{
+(* Yoann Padioleau
+ *
+ * Copyright (C) 2010 Facebook
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * version 2.1 as published by the Free Software Foundation, with the
+ * special exception on linking described in file license.txt.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the file
+ * license.txt for more details.
+ *)
+
+open Parser_js
+
+(*****************************************************************************)
+(* Helpers *)
+(*****************************************************************************)
+
+exception Lexical of string
+
+(* pad: hack around ocamllex to emulate the yyless of flex. It seems
+ * to work.
+ *)
+let yyless n lexbuf =
+  lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - n;
+  let currp = lexbuf.Lexing.lex_curr_p in
+  lexbuf.Lexing.lex_curr_p <- { currp with
+    Lexing.pos_cnum = currp.Lexing.pos_cnum - n;
+  }
+
+let tok     lexbuf  =
+  Lexing.lexeme lexbuf
+let tokinfo lexbuf  = Parse_info.t_of_lexbuf lexbuf
+  (* Parse_info.tokinfo_str_pos (Lexing.lexeme lexbuf) (Lexing.lexeme_start lexbuf) *)
+
+(* ---------------------------------------------------------------------- *)
+let keyword_table =
+  let h = Hashtbl.create 17 in
+  List.iter (fun (s,f) -> Hashtbl.add h s f ) [
+
+   (* todo? had some special handling in lexer of marcel *)
+  "catch",      (fun ii -> T_CATCH ii);
+  "finally",    (fun ii -> T_FINALLY ii);
+  "in",         (fun ii -> T_IN ii);
+  "instanceof", (fun ii -> T_INSTANCEOF ii);
+
+  (* todo? had some special handling in lexer of marcel *)
+  "else",       (fun ii -> T_ELSE ii);
+  "while",      (fun ii -> T_WHILE ii);
+
+  "break",      (fun ii -> T_BREAK ii);
+  "case",       (fun ii -> T_CASE ii);
+  "continue",   (fun ii -> T_CONTINUE ii);
+  "default",    (fun ii -> T_DEFAULT ii);
+  "delete",     (fun ii -> T_DELETE ii);
+  "do",         (fun ii -> T_DO ii);
+  "else",       (fun ii -> T_ELSE ii);
+  "for",        (fun ii -> T_FOR ii);
+  "function",   (fun ii -> T_FUNCTION ii);
+  "if",         (fun ii -> T_IF ii);
+  "new",        (fun ii -> T_NEW ii);
+  "return",     (fun ii -> T_RETURN ii);
+  "switch",     (fun ii -> T_SWITCH ii);
+  "this",       (fun ii -> T_THIS ii);
+  "throw",      (fun ii -> T_THROW ii);
+  "try",        (fun ii -> T_TRY ii);
+  "typeof",     (fun ii -> T_TYPEOF ii);
+  "var",        (fun ii -> T_VAR ii);
+  "void",       (fun ii -> T_VOID ii);
+  "while",      (fun ii -> T_WHILE ii);
+  "with",       (fun ii -> T_WITH ii);
+  "const",      (fun ii -> T_CONST ii);
+  "null",       (fun ii -> T_NULL ii);
+  "false",      (fun ii -> T_FALSE ii);
+  "true",       (fun ii -> T_TRUE ii);
+];
+  h
+
+(* ---------------------------------------------------------------------- *)
+
+type state_mode =
+  | INITIAL
+
+let default_state = INITIAL
+
+(* The logic to modify _last_non_whitespace_like_token is in the
+ * caller of the lexer, that is in Parse_js.tokens.
+ * Used for ambiguity between / as a divisor and start of regexp.
+ *)
+let _last_non_whitespace_like_token =
+  ref (None: Parser_js.token option)
+
+exception Token of Parser_js.token
+
+let reset () =
+   _last_non_whitespace_like_token := None;
+  ()
+
+}
+
+(*****************************************************************************)
+let _WHITESPACE = [' ' '\n' '\r' '\t']+
+let TABS_AND_SPACES = [' ''\t']*
+let NEWLINE = ("\r"|"\n"|"\r\n")
+
+(*****************************************************************************)
+
+rule initial = parse
+
+  (* ----------------------------------------------------------------------- *)
+  (* spacing/comments *)
+  (* ----------------------------------------------------------------------- *)
+  | "/*" {
+      let info = tokinfo lexbuf in
+      let com = st_comment lexbuf in
+      TComment(info)
+    }
+
+  | "//" {
+      let info = tokinfo lexbuf in
+      let com = st_one_line_comment lexbuf in
+      TComment(info)
+    }
+
+  | [' ' '\t' ]+            { TCommentSpace(tokinfo lexbuf) }
+  | NEWLINE {
+      lexbuf.Lexing.lex_curr_p <- { lexbuf.Lexing.lex_curr_p with
+                                      Lexing.pos_lnum = lexbuf.Lexing.lex_curr_p.Lexing.pos_lnum + 1 };
+      TCommentNewline(tokinfo lexbuf) }
+
+  (* ----------------------------------------------------------------------- *)
+  (* symbols *)
+  (* ----------------------------------------------------------------------- *)
+
+   (* todo? marcel does some stack push/pop on that *)
+  | "{" { T_LCURLY (tokinfo lexbuf); }
+  | "}" { T_RCURLY (tokinfo lexbuf); }
+
+   (* todo? marcel does some stack push/pop on that *)
+  | "(" { T_LPAREN (tokinfo lexbuf); }
+  | ")" { T_RPAREN (tokinfo lexbuf); }
+
+  | "[" { T_LBRACKET (tokinfo lexbuf); }
+  | "]" { T_RBRACKET (tokinfo lexbuf); }
+  | "." { T_PERIOD (tokinfo lexbuf); }
+  | ";" { T_SEMICOLON (tokinfo lexbuf); }
+  | "," { T_COMMA (tokinfo lexbuf); }
+  | ":" { T_COLON (tokinfo lexbuf); }
+  | "?" { T_PLING (tokinfo lexbuf); }
+  | "&&" { T_AND (tokinfo lexbuf); }
+  | "||" { T_OR (tokinfo lexbuf); }
+  | "===" { T_STRICT_EQUAL (tokinfo lexbuf); }
+  | "!==" { T_STRICT_NOT_EQUAL (tokinfo lexbuf); }
+  | "<=" { T_LESS_THAN_EQUAL (tokinfo lexbuf); }
+  | ">=" { T_GREATER_THAN_EQUAL (tokinfo lexbuf); }
+  | "==" { T_EQUAL (tokinfo lexbuf); }
+  | "!=" { T_NOT_EQUAL (tokinfo lexbuf); }
+  | "++" { T_INCR (tokinfo lexbuf); }
+  | "--" { T_DECR (tokinfo lexbuf); }
+  | "<<=" { T_LSHIFT_ASSIGN (tokinfo lexbuf); }
+  | "<<" { T_LSHIFT (tokinfo lexbuf); }
+  | ">>=" { T_RSHIFT_ASSIGN (tokinfo lexbuf); }
+  | ">>>=" { T_RSHIFT3_ASSIGN (tokinfo lexbuf); }
+  | ">>>" { T_RSHIFT3 (tokinfo lexbuf); }
+  | ">>" { T_RSHIFT (tokinfo lexbuf); }
+  | "+=" { T_PLUS_ASSIGN (tokinfo lexbuf); }
+  | "-=" { T_MINUS_ASSIGN (tokinfo lexbuf); }
+
+  | "*=" { T_MULT_ASSIGN (tokinfo lexbuf); }
+  | "%=" { T_MOD_ASSIGN (tokinfo lexbuf); }
+  | "&=" { T_BIT_AND_ASSIGN (tokinfo lexbuf); }
+  | "|=" { T_BIT_OR_ASSIGN (tokinfo lexbuf); }
+  | "^=" { T_BIT_XOR_ASSIGN (tokinfo lexbuf); }
+  | "<" { T_LESS_THAN (tokinfo lexbuf); }
+  | ">" { T_GREATER_THAN (tokinfo lexbuf); }
+  | "+" { T_PLUS (tokinfo lexbuf); }
+  | "-" { T_MINUS (tokinfo lexbuf); }
+  | "*" { T_MULT (tokinfo lexbuf); }
+  (* for '/' see below the regexp handling *)
+  | "%" { T_MOD (tokinfo lexbuf); }
+  | "|" { T_BIT_OR (tokinfo lexbuf); }
+  | "&" { T_BIT_AND (tokinfo lexbuf); }
+  | "^" { T_BIT_XOR (tokinfo lexbuf); }
+  | "!" { T_NOT (tokinfo lexbuf); }
+  | "~" { T_BIT_NOT (tokinfo lexbuf); }
+  | "=" { T_ASSIGN (tokinfo lexbuf); }
+
+  (* ----------------------------------------------------------------------- *)
+  (* Keywords and ident *)
+  (* ----------------------------------------------------------------------- *)
+  | ['a'-'z''A'-'Z''$''_']['a'-'z''A'-'Z''$''_''0'-'9']* {
+      let s = tok lexbuf in
+      let info = tokinfo lexbuf in
+      try
+        let f = Hashtbl.find keyword_table s in
+        f info (* need case insensitive ? *)
+      with
+        | Not_found -> T_IDENTIFIER (s, info)
+    }
+
+  (* ----------------------------------------------------------------------- *)
+  (* Constant *)
+  (* ----------------------------------------------------------------------- *)
+
+  | "0x"['a'-'f''A'-'F''0'-'9']+ {
+      let s = tok lexbuf in
+      let info = tokinfo lexbuf in
+      T_NUMBER (s, info)
+    }
+  | '0'['0'-'7']+ {
+      let s = tok lexbuf in
+      let info = tokinfo lexbuf in
+      T_NUMBER (s, info)
+    }
+
+  | ['0'-'9']*'.'?['0'-'9']+['e''E']['-''+']?['0'-'9']+ (* {1,3} *) {
+      let s = tok lexbuf in
+      let info = tokinfo lexbuf in
+      T_NUMBER (s, info)
+    }
+
+  | ['0'-'9']+'.'? |
+    ['0'-'9']*'.'['0'-'9']+ {
+      let s = tok lexbuf in
+      let info = tokinfo lexbuf in
+      T_NUMBER (s, info)
+    }
+
+  (* ----------------------------------------------------------------------- *)
+  (* Strings *)
+  (* ----------------------------------------------------------------------- *)
+  | "'" {
+      let info = tokinfo lexbuf in
+      let s = string_quote lexbuf in
+      (* s does not contain the enclosing "'" but the info does *)
+      T_STRING (s, info)
+    }
+
+  | '"' {
+      let info = tokinfo lexbuf in
+      let s = string_double_quote lexbuf in
+      T_STRING (s, info)
+    }
+
+  (* ----------------------------------------------------------------------- *)
+  (* Regexp *)
+  (* ----------------------------------------------------------------------- *)
+  (* take care of ambiguity with start of comment //, and with
+   * '/' as a divisor operator
+   *
+   * it can not be '/' [^ '/']* '/' because then
+   * comments will not be recognized as lex tries
+   * to find the longest match.
+   *
+   * It can not be
+   * '/' [^'*''/'] ([^'/''\n'])* '/' ['A'-'Z''a'-'z']*
+   * because a / (b/c)  will be recognized as a regexp.
+   *
+   *)
+
+  (* todo? marcel was changing of state context condition there *)
+  | "/=" { T_DIV_ASSIGN (tokinfo lexbuf); }
+
+  | "/" {
+      let info = tokinfo lexbuf in
+
+      match !_last_non_whitespace_like_token with
+      | Some (
+            T_IDENTIFIER _
+          | T_NUMBER _
+          | T_STRING _
+          | T_REGEX _
+          | T_INCR _ | T_DECR _
+          | T_RBRACKET _
+          | T_RPAREN _
+          | T_FALSE _ | T_TRUE _
+          | T_NULL _
+          | T_THIS _
+        ) ->
+          T_DIV (info);
+      | _ ->
+          (* raise (Token t); *)
+          let s = regexp lexbuf in
+          T_REGEX ("/" ^ s, info)
+    }
+
+  (* ----------------------------------------------------------------------- *)
+  (* Misc *)
+  (* ----------------------------------------------------------------------- *)
+
+  (* ----------------------------------------------------------------------- *)
+  (* eof *)
+  (* ----------------------------------------------------------------------- *)
+
+  | eof { EOF (tokinfo lexbuf) }
+
+  | _ {
+      Printf.eprintf "LEXER:unrecognised symbol, in token rule: %s" (tok lexbuf);
+      TUnknown (tokinfo lexbuf)
+    }
+(*****************************************************************************)
+and string_quote = parse
+  | "'"            { "" }
+  | (_ as x)       { String.make 1  x^string_quote lexbuf}
+  | ("\\" (_ as v)) as x {
+      (* check char ? *)
+      (match v with
+      | _ -> ()
+      );
+      x ^ string_quote lexbuf
+    }
+  | eof { Printf.eprintf  "LEXER: WIERD end of file in quoted string"; ""}
+
+and string_double_quote  = parse
+  | '"'            { "" }
+  | (_ as x)       { String.make 1  x^string_double_quote lexbuf}
+  | ("\\" (_ as v)) as x {
+      (* check char ? *)
+      (match v with
+      | _ -> ()
+      );
+      x ^ string_double_quote lexbuf
+    }
+  | eof { Printf.eprintf "LEXER: WIERD end of file in double quoted string"; ""}
+
+(*****************************************************************************)
+and regexp = parse
+  | '/'            { "/" ^ regexp_maybe_ident lexbuf }
+  | (_ as x)       { String.make 1 x^regexp lexbuf}
+  | ("\\" (_ as v)) as x {
+      (* check char ? *)
+      (match v with
+      | _ -> ()
+      );
+      x ^ regexp lexbuf
+    }
+  | eof { Printf.eprintf "LEXER: WIERD end of file in regexp"; ""}
+
+and regexp_maybe_ident = parse
+  | ['A'-'Z''a'-'z']* { tok lexbuf }
+
+(*****************************************************************************)
+
+and st_comment = parse
+  | "*/" { tok lexbuf }
+
+  (* noteopti: *)
+  | [^'*']+ { let s = tok lexbuf in s ^ st_comment lexbuf }
+  | "*"     { let s = tok lexbuf in s ^ st_comment lexbuf }
+
+  | eof { Printf.eprintf "LEXER: end of file in comment"; "*/"}
+  | _  {
+      let s = tok lexbuf in
+      Printf.eprintf "LEXER: unrecognised symbol in comment: %s" s;
+      s ^ st_comment lexbuf
+    }
+
+and st_one_line_comment = parse
+  | [^'\n' '\r']* {
+      let s = tok lexbuf in
+      s ^ st_one_line_comment lexbuf
+    }
+
+  | NEWLINE {
+      lexbuf.Lexing.lex_curr_p <- { lexbuf.Lexing.lex_curr_p with
+                                      Lexing.pos_lnum = lexbuf.Lexing.lex_curr_p.Lexing.pos_lnum + 1 };
+
+      tok lexbuf }
+
+  | eof { Printf.eprintf "LEXER: end of file in comment"; "\n" }
+  | _ {
+      Printf.eprintf "LEXER:unrecognised symbol, in st_one_line_comment rule: %s " (tok lexbuf);
+      tok lexbuf
+    }
diff --git a/compiler/parse_info.ml b/compiler/parse_info.ml
new file mode 100644
index 0000000000..f74b9d59e5
--- /dev/null
+++ b/compiler/parse_info.ml
@@ -0,0 +1,9 @@
+type t = int * int
+
+
+let t_of_lexbuf lexbuf : t =
+  let l = lexbuf.Lexing.lex_curr_p.Lexing.pos_lnum
+  and c = lexbuf.Lexing.lex_curr_p.Lexing.pos_bol
+  and b = lexbuf.Lexing.lex_curr_p.Lexing.pos_cnum in
+  (* Printf.printf "l%d c%d b%d" l c b; *)
+  l,c
diff --git a/compiler/parse_js.ml b/compiler/parse_js.ml
new file mode 100644
index 0000000000..be6e5986db
--- /dev/null
+++ b/compiler/parse_js.ml
@@ -0,0 +1,311 @@
+
+
+let is_comment = function
+  | Parser_js.TCommentSpace _
+  | Parser_js.TCommentNewline _
+  | Parser_js.TComment _ -> true
+  | _ -> false
+
+let make_lexer f =
+  (fun lexbuf ->
+    let t = f lexbuf in
+    if not(is_comment t)
+    then begin
+      Lexer_js._last_non_whitespace_like_token := Some t;
+    end;
+    t)
+
+let iter_with_previous_opt f = function
+  | [] -> ()
+  | e::l ->
+      f None e;
+      let rec iter_with_previous_ previous = function
+        | [] -> ()
+        | e::l -> f (Some previous) e ; iter_with_previous_ e l
+      in iter_with_previous_ e l
+
+let push v l = l := v :: !l
+let pop l =
+  let v = List.hd !l in
+  l := List.tl !l;
+  v
+
+
+let rparens_of_if toks =
+  let open Parser_js in
+  let toks = List.filter (fun x -> not (is_comment x)) toks in
+  let stack = ref [] in
+  let rparens_if = ref [] in
+  iter_with_previous_opt (fun prev x ->
+    (match x with
+      | T_LPAREN _ -> push prev stack;
+      | T_RPAREN info ->
+        if !stack <> []
+        then begin
+          match pop stack with
+            | Some (T_IF _) -> push info rparens_if
+            | _ -> ()
+        end
+      | _ -> ()
+    )
+  ) toks;
+  !rparens_if
+
+let info_of_tok t =
+  let open Parser_js in
+      match t with
+  | TUnknown ii -> ii
+  | TCommentSpace ii -> ii
+  | TCommentNewline ii -> ii
+  | TComment ii -> ii
+  | EOF ii -> ii
+
+  | T_NUMBER (s, ii) -> ii
+  | T_IDENTIFIER (s, ii) -> ii
+  | T_STRING (s, ii) -> ii
+  | T_REGEX (s, ii) -> ii
+
+  | T_FUNCTION ii -> ii
+  | T_IF ii -> ii
+  | T_IN ii -> ii
+  | T_INSTANCEOF ii -> ii
+  | T_RETURN ii -> ii
+  | T_SWITCH ii -> ii
+  | T_THIS ii -> ii
+  | T_THROW ii -> ii
+  | T_TRY ii -> ii
+  | T_VAR ii -> ii
+  | T_WHILE ii -> ii
+  | T_WITH ii -> ii
+  | T_CONST ii -> ii
+  | T_NULL ii -> ii
+  | T_FALSE ii -> ii
+  | T_TRUE ii -> ii
+  | T_BREAK ii -> ii
+  | T_CASE ii -> ii
+  | T_CATCH ii -> ii
+  | T_CONTINUE ii -> ii
+  | T_DEFAULT ii -> ii
+  | T_DO ii -> ii
+  | T_FINALLY ii -> ii
+  | T_FOR ii -> ii
+  | T_ELSE ii -> ii
+  | T_NEW ii -> ii
+  | T_LCURLY ii -> ii
+  | T_RCURLY ii -> ii
+  | T_LPAREN ii -> ii
+  | T_RPAREN ii -> ii
+  | T_LBRACKET ii -> ii
+  | T_RBRACKET ii -> ii
+  | T_SEMICOLON ii -> ii
+  | T_COMMA ii -> ii
+  | T_PERIOD ii -> ii
+  | T_RSHIFT3_ASSIGN ii -> ii
+  | T_RSHIFT_ASSIGN ii -> ii
+  | T_LSHIFT_ASSIGN ii -> ii
+  | T_BIT_XOR_ASSIGN ii -> ii
+  | T_BIT_OR_ASSIGN ii -> ii
+  | T_BIT_AND_ASSIGN ii -> ii
+  | T_MOD_ASSIGN ii -> ii
+  | T_DIV_ASSIGN ii -> ii
+  | T_MULT_ASSIGN ii -> ii
+  | T_MINUS_ASSIGN ii -> ii
+  | T_PLUS_ASSIGN ii -> ii
+  | T_ASSIGN ii -> ii
+  | T_PLING ii -> ii
+  | T_COLON ii -> ii
+  | T_OR ii -> ii
+  | T_AND ii -> ii
+  | T_BIT_OR ii -> ii
+  | T_BIT_XOR ii -> ii
+  | T_BIT_AND ii -> ii
+  | T_EQUAL ii -> ii
+  | T_NOT_EQUAL ii -> ii
+  | T_STRICT_EQUAL ii -> ii
+  | T_STRICT_NOT_EQUAL ii -> ii
+  | T_LESS_THAN_EQUAL ii -> ii
+  | T_GREATER_THAN_EQUAL ii -> ii
+  | T_LESS_THAN ii -> ii
+  | T_GREATER_THAN ii -> ii
+  | T_LSHIFT ii -> ii
+  | T_RSHIFT ii -> ii
+  | T_RSHIFT3 ii -> ii
+  | T_PLUS ii -> ii
+  | T_MINUS ii -> ii
+  | T_DIV ii -> ii
+  | T_MULT ii -> ii
+  | T_MOD ii -> ii
+  | T_NOT ii -> ii
+  | T_BIT_NOT ii -> ii
+  | T_INCR ii -> ii
+  | T_DECR ii -> ii
+  | T_DELETE ii -> ii
+  | T_TYPEOF ii -> ii
+  | T_VOID ii -> ii
+  | T_VIRTUAL_SEMICOLON ii -> ii
+
+let compute_line x prev : Parse_info.t option =
+  let (x,_) as tok = info_of_tok x in
+  let (prev,_) = info_of_tok prev in
+  if prev <> x
+  then Some tok
+  else None
+
+let rec adjust_tokens xs =
+  let open Parser_js in
+  let rparens_if = rparens_of_if xs in
+  let hrparens_if =
+    let h = Hashtbl.create 101 in
+    List.iter (fun s -> Hashtbl.add h s true) rparens_if;
+    h in
+
+  match xs with
+    | [] -> []
+    | y::ys ->
+      let res = ref [] in
+      push y res;
+      let rec aux prev f xs =
+        match xs with
+          | [] -> ()
+          | e::l ->
+            if is_comment e
+            then begin
+              push e res;
+              aux prev f l
+            end else begin
+              f prev e;
+              aux e f l
+            end
+      in
+      let f = (fun prev x ->
+        match prev, x with
+          | (T_LCURLY _ | T_SEMICOLON _ | T_VIRTUAL_SEMICOLON _),
+        T_RCURLY _ ->
+            push x res;
+          (* also one after ? *)
+          (* push (T.T_VIRTUAL_SEMICOLON (Ast.fakeInfo ())) res; *)
+
+          | _, T_RCURLY fake ->
+            push (T_VIRTUAL_SEMICOLON fake) res;
+            push x res;
+        (* also one after ? *)
+        (* push (T.T_VIRTUAL_SEMICOLON (Ast.fakeInfo ())) res; *)
+
+          | (T_SEMICOLON _ | T_VIRTUAL_SEMICOLON _),
+            EOF _ ->
+            push x res;
+          | _, EOF fake ->
+            push (T_VIRTUAL_SEMICOLON fake) res;
+            push x res;
+
+          | T_RCURLY _,
+            (T_IDENTIFIER _ |
+             T_IF _ | T_VAR _ | T_FOR _ | T_RETURN _ |
+             T_SWITCH _ |
+             T_FUNCTION _ | T_THIS _ |
+             T_BREAK _ | T_NEW _
+
+            )
+            ->
+            begin match compute_line x prev with
+              | None -> ()
+              | Some fake -> push (T_VIRTUAL_SEMICOLON fake) res;
+            end;
+            push x res;
+
+        (* this is valid only if the RPAREN is not the closing paren
+         * of a if
+         *)
+          | T_RPAREN info,
+              (T_VAR _ | T_IF _ | T_THIS _ | T_FOR _ | T_RETURN _ |
+                  T_IDENTIFIER _ | T_CONTINUE _
+              ) when not (Hashtbl.mem hrparens_if info)
+                  ->
+            begin match compute_line x prev with
+              | None -> ()
+              | Some fake -> push (T_VIRTUAL_SEMICOLON fake) res;
+            end;
+            push x res;
+
+
+          | T_RBRACKET _,
+              (T_FOR _ | T_IF _ | T_VAR _ | T_IDENTIFIER _)
+              ->
+            begin match compute_line x prev with
+              | None -> ()
+              | Some fake -> push (T_VIRTUAL_SEMICOLON fake) res;
+            end;
+            push x res;
+
+
+          | (T_IDENTIFIER _ | T_NULL _ | T_STRING _ | T_REGEX _
+                | T_FALSE _ | T_TRUE _
+          ),
+              (T_VAR _ | T_IDENTIFIER _ | T_IF _ | T_THIS _ |
+                  T_RETURN _ | T_BREAK _ | T_ELSE _
+              )
+              ->
+            begin match compute_line x prev with
+              | None -> ()
+              | Some fake -> push (T_VIRTUAL_SEMICOLON fake) res;
+            end;
+            push x res;
+
+          | _, _ -> push x res
+      )
+      in
+      aux y f ys;
+      List.rev !res
+
+type st = {
+  mutable rest : Parser_js.token list;
+  mutable current : Parser_js.token ;
+  mutable passed : Parser_js.token list }
+
+let lex file =
+  let open Parser_js in
+  let ic = open_in file in
+  Lexer_js.reset();
+  let lexbuf = Lexing.from_channel ic in
+  let f = make_lexer Lexer_js.initial in
+  let rec loop lexbuf acc =
+    let t = f lexbuf in
+    match t with
+      | EOF _ -> List.rev (t::acc)
+      | _ -> loop lexbuf (t :: acc)
+  in
+  let toks = loop lexbuf [] in
+  let toks = adjust_tokens toks in
+  let toks = List.filter (fun x -> not (is_comment x)) toks in
+  let cur = {
+    rest = toks;
+    passed = [];
+    current = List.hd toks
+  }
+  in
+  (fun lb ->
+    match cur.rest with
+      | [] -> assert false
+      | x::tl ->
+        cur.rest <- tl;
+        cur.current <- x;
+        cur.passed <- x::cur.passed;
+        x
+  ),lexbuf,cur
+let parse file =
+  let lexer_fun,lexbuf,state = lex file in
+  try
+    let p = Parser_js.program lexer_fun lexbuf  in
+    let buf = Buffer.create 1024 in
+    let f = Pretty_print.to_buffer buf in
+
+    Js_output.program f (fun _ -> None) (fun _ -> assert false) p;
+    Printf.printf "%s" (Buffer.contents buf)
+  with Parsing.Parse_error ->
+    let (l,c) = info_of_tok (List.hd state.rest) in
+    Printf.eprintf "error at l:%d col:%d\n" l c;
+
+    exit 1
+
+let _ =
+  parse (Sys.argv.(1))
diff --git a/compiler/parser_js.mly b/compiler/parser_js.mly
new file mode 100644
index 0000000000..1b8a825cc9
--- /dev/null
+++ b/compiler/parser_js.mly
@@ -0,0 +1,770 @@
+/* Yoann Padioleau
+ *
+ * Copyright (C) 2010 Facebook
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * version 2.1 as published by the Free Software Foundation, with the
+ * special exception on linking described in file license.txt.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the file
+ * license.txt for more details.
+ */
+%{
+(*
+ * src: ocamlyaccified from Marcel Laverdet 'fbjs2' via emacs macros, itself
+ * extracted from the official ECMAscript specification at:
+ *  http://www.ecma-international.org/publications/standards/ecma-262.htm
+ *
+ * see also http://en.wikipedia.org/wiki/ECMAScript_syntax
+ *
+ * related work:
+ *  - http://marijnhaverbeke.nl/parse-js/, js parser in common lisp
+ *    (which has been since ported to javascript by nodejs people)
+ *  - jslint
+ *)
+
+module J = Javascript
+
+let bop op a b= J.EBin(op,a,b)
+let uop op a = J.EUn(op,a)
+
+%}
+
+/*(*************************************************************************)*/
+/*(*1 Tokens *)*/
+/*(*************************************************************************)*/
+
+/*(*-----------------------------------------*)*/
+/*(*2 the comment tokens *)*/
+/*(*-----------------------------------------*)*/
+/*(* coupling: Token_helpers.is_real_comment *)*/
+%token <Parse_info.t> TCommentSpace TCommentNewline   TComment
+
+/*(*-----------------------------------------*)*/
+/*(*2 the normal tokens *)*/
+/*(*-----------------------------------------*)*/
+
+/*(* tokens with a value *)*/
+%token<string * Parse_info.t> T_NUMBER
+%token<string * Parse_info.t> T_IDENTIFIER
+%token<string * Parse_info.t> T_STRING
+%token<string * Parse_info.t> T_REGEX
+
+/*(* keywords tokens *)*/
+%token <Parse_info.t>
+ T_FUNCTION T_IF T_IN T_INSTANCEOF T_RETURN T_SWITCH T_THIS T_THROW T_TRY
+ T_VAR T_WHILE T_WITH T_CONST T_NULL T_FALSE T_TRUE
+ T_BREAK T_CASE T_CATCH T_CONTINUE T_DEFAULT T_DO T_FINALLY T_FOR
+
+%token <Parse_info.t> T_ELSE
+
+%token <Parse_info.t> T_NEW
+
+/*(* syntax *)*/
+%token <Parse_info.t>
+ T_LCURLY T_RCURLY
+ T_LPAREN T_RPAREN
+ T_LBRACKET T_RBRACKET
+ T_SEMICOLON
+ T_COMMA
+ T_PERIOD
+
+/*(* operators *)*/
+%token <Parse_info.t>
+ T_RSHIFT3_ASSIGN T_RSHIFT_ASSIGN T_LSHIFT_ASSIGN
+ T_BIT_XOR_ASSIGN T_BIT_OR_ASSIGN T_BIT_AND_ASSIGN T_MOD_ASSIGN T_DIV_ASSIGN
+ T_MULT_ASSIGN T_MINUS_ASSIGN T_PLUS_ASSIGN T_ASSIGN
+
+%token <Parse_info.t>
+ T_PLING T_COLON
+ T_OR
+ T_AND
+ T_BIT_OR
+ T_BIT_XOR
+ T_BIT_AND
+ T_EQUAL T_NOT_EQUAL T_STRICT_EQUAL T_STRICT_NOT_EQUAL
+ T_LESS_THAN_EQUAL T_GREATER_THAN_EQUAL T_LESS_THAN T_GREATER_THAN
+ T_IN T_INSTANCEOF
+ T_LSHIFT T_RSHIFT T_RSHIFT3
+ T_PLUS T_MINUS
+ T_DIV T_MULT T_MOD
+ T_NOT T_BIT_NOT T_INCR T_DECR T_DELETE T_TYPEOF T_VOID
+
+/*(*-----------------------------------------*)*/
+/*(*2 extra tokens: *)*/
+/*(*-----------------------------------------*)*/
+
+%token <Parse_info.t> T_VIRTUAL_SEMICOLON
+
+/*(* classic *)*/
+%token <Parse_info.t> TUnknown
+%token <Parse_info.t> EOF
+
+/*(*-----------------------------------------*)*/
+/*(*2 priorities *)*/
+/*(*-----------------------------------------*)*/
+
+/*(* must be at the top so that it has the lowest priority *)*/
+%nonassoc SHIFTHERE
+
+/*(* Special if / else associativity*)*/
+%nonassoc p_IF
+%nonassoc T_ELSE
+
+%nonassoc p_POSTFIX
+
+%right
+ T_RSHIFT3_ASSIGN T_RSHIFT_ASSIGN T_LSHIFT_ASSIGN
+ T_BIT_XOR_ASSIGN T_BIT_OR_ASSIGN T_BIT_AND_ASSIGN T_MOD_ASSIGN T_DIV_ASSIGN
+ T_MULT_ASSIGN T_MINUS_ASSIGN T_PLUS_ASSIGN T_ASSIGN
+
+%left T_OR
+%left T_AND
+%left T_BIT_OR
+%left T_BIT_XOR
+%left T_BIT_AND
+%left T_EQUAL T_NOT_EQUAL T_STRICT_EQUAL T_STRICT_NOT_EQUAL
+%left
+ T_LESS_THAN_EQUAL T_GREATER_THAN_EQUAL T_LESS_THAN T_GREATER_THAN
+ T_IN T_INSTANCEOF
+%left T_LSHIFT T_RSHIFT T_RSHIFT3
+%left T_PLUS T_MINUS
+%left T_DIV T_MULT T_MOD
+%right T_NOT T_BIT_NOT T_INCR T_DECR T_DELETE T_TYPEOF T_VOID
+
+/*(*************************************************************************)*/
+/*(*1 Rules type declaration *)*/
+/*(*************************************************************************)*/
+
+%start program
+%type <Javascript.source_elements> program
+
+%%
+
+/*(*************************************************************************)*/
+/*(*1 Toplevel *)*/
+/*(*************************************************************************)*/
+
+program:
+    | source_elements { $1 }
+    | { [] }
+source_element:
+ | statement            { J.Statement $1 }
+ | function_declaration { J.Function_declaration $1 }
+
+/*(*************************************************************************)*/
+/*(*1 statement *)*/
+/*(*************************************************************************)*/
+
+statement:
+ | block                { J.Block $1 }
+ | variable_statement   { $1 }
+ | empty_statement      { $1 }
+ | expression_statement { $1 }
+ | if_statement         { $1 }
+ | iteration_statement  { $1 }
+ | continue_statement   { $1 }
+ | break_statement      { $1 }
+ | return_statement     { $1 }
+ | with_statement       { $1 }
+ | labelled_statement   { $1 }
+ | switch_statement     { $1 }
+ | throw_statement      { $1 }
+ | try_statement        { $1 }
+
+
+block:
+ | T_LCURLY statement_list T_RCURLY { $2 }
+ | T_LCURLY T_RCURLY                { [] }
+
+
+variable_statement:
+ | T_VAR variable_declaration_list semicolon  { J.Variable_statement $2 }
+
+variable_declaration:
+ | identifier initializeur { J.S $1, Some $2 }
+ | identifier { J.S $1, None }
+
+initializeur:
+ | T_ASSIGN assignment_expression { $2 }
+
+
+empty_statement:
+ | semicolon { J.Empty_statement }
+
+expression_statement:
+ | expression_no_statement semicolon { J.Expression_statement ($1, None) }
+
+
+if_statement:
+ | T_IF T_LPAREN expression T_RPAREN statement T_ELSE statement
+     { J.If_statement ($3, $5, Some $7) }
+ | T_IF T_LPAREN expression T_RPAREN statement %prec p_IF
+     { J.If_statement ($3, $5, None) }
+
+
+iteration_statement:
+ | T_DO statement T_WHILE T_LPAREN expression T_RPAREN semicolon
+     { J.Do_while_statement ($2, $5) }
+ | T_WHILE T_LPAREN expression T_RPAREN statement
+     { J.While_statement ($3, $5) }
+ | T_FOR T_LPAREN
+     expression_no_in_opt T_SEMICOLON
+     expression_opt T_SEMICOLON
+     expression_opt
+     T_RPAREN statement
+     { J.For_statement ( $3, $5, $7, $9, None) }
+ | T_FOR T_LPAREN
+     T_VAR variable_declaration_list_no_in T_SEMICOLON
+     expression_opt T_SEMICOLON
+     expression_opt
+     T_RPAREN statement
+     { J.Block [
+          J.Variable_statement $4 ;
+          J.For_statement (None, $6, $8, $10, None)] }
+ | T_FOR T_LPAREN left_hand_side_expression T_IN expression T_RPAREN statement
+     { J.ForIn_statement ($3,$5,$7,None) }
+ | T_FOR T_LPAREN T_VAR variable_declaration_no_in T_IN expression T_RPAREN
+     statement
+     {
+       let (var,_) as vardecl = $4 in
+       J.Block [
+         J.Variable_statement [vardecl] ;
+         J.ForIn_statement ( J.EVar var, $6, $8, None)] }
+
+variable_declaration_no_in:
+ | identifier initializer_no_in { J.S $1, Some $2 }
+ | identifier { J.S $1, None }
+
+initializer_no_in:
+ | T_ASSIGN assignment_expression_no_in { $2 }
+
+
+continue_statement:
+ | T_CONTINUE identifier semicolon { J.Continue_statement (Some (J.Label.of_string $2)) }
+ | T_CONTINUE semicolon            { J.Continue_statement None }
+
+
+break_statement:
+ | T_BREAK identifier semicolon { J.Break_statement (Some (J.Label.of_string $2)) }
+ | T_BREAK semicolon            { J.Break_statement None }
+
+
+return_statement:
+ | T_RETURN expression semicolon { J.Return_statement (Some $2) }
+ | T_RETURN semicolon            { J.Return_statement  None }
+
+with_statement:
+ | T_WITH T_LPAREN expression T_RPAREN statement { assert false }
+
+switch_statement:
+ | T_SWITCH T_LPAREN expression T_RPAREN T_LCURLY case_clauses_opt T_RCURLY
+   { J.Switch_statement ($3, $6,None) }
+ | T_SWITCH T_LPAREN expression T_RPAREN T_LCURLY case_clauses_opt default_clause T_RCURLY
+   { J.Switch_statement ($3, $6,Some $7) }
+
+labelled_statement:
+ | identifier T_COLON statement { J.Labelled_statement (J.Label.of_string $1, $3) }
+
+
+throw_statement:
+ | T_THROW expression semicolon { J.Throw_statement $2 }
+
+
+try_statement:
+ | T_TRY block catch         { J.Try_statement ($2, Some $3, None, None)  }
+ | T_TRY block       finally { J.Try_statement ($2, None, Some $3,None) }
+ | T_TRY block catch finally { J.Try_statement ($2, Some $3, Some $4,None) }
+
+catch:
+ | T_CATCH T_LPAREN identifier T_RPAREN block { J.S $3, $5 }
+
+
+finally:
+ | T_FINALLY block { $2 }
+
+/*(*----------------------------*)*/
+/*(*2 auxillary statements *)*/
+/*(*----------------------------*)*/
+
+case_clause:
+ | T_CASE expression T_COLON statement_list { $2, $4 }
+ | T_CASE expression T_COLON { $2, [] }
+
+default_clause:
+ | T_DEFAULT T_COLON { [] }
+ | T_DEFAULT T_COLON statement_list { $3 }
+
+/*(*************************************************************************)*/
+/*(*1 function declaration *)*/
+/*(*************************************************************************)*/
+
+function_declaration:
+ | T_FUNCTION identifier T_LPAREN formal_parameter_list T_RPAREN
+     T_LCURLY function_body T_RCURLY
+     { J.S $2, $4, $7, None }
+ | T_FUNCTION identifier T_LPAREN T_RPAREN
+     T_LCURLY function_body T_RCURLY
+     { J.S $2, [],$6, None }
+
+
+function_expression:
+ | T_FUNCTION identifier T_LPAREN formal_parameter_list T_RPAREN
+     T_LCURLY function_body T_RCURLY
+     { J.EFun ((Some (J.S $2), $4, $7),None) }
+ | T_FUNCTION identifier T_LPAREN T_RPAREN
+     T_LCURLY function_body T_RCURLY
+     { J.EFun ((Some (J.S $2), [], $6),None) }
+ | T_FUNCTION T_LPAREN formal_parameter_list T_RPAREN
+     T_LCURLY function_body T_RCURLY
+     { J.EFun ((None, $3, $6),None) }
+ | T_FUNCTION T_LPAREN T_RPAREN
+     T_LCURLY function_body T_RCURLY
+     { J.EFun ((None, [], $5),None) }
+
+formal_parameter_list:
+ | identifier                                { [J.S $1] }
+ | formal_parameter_list T_COMMA identifier  { $1 @ [J.S $3] }
+
+function_body:
+ | /*(* empty *)*/ { [] }
+ | source_elements  { $1 }
+
+/*(*************************************************************************)*/
+/*(*1 expression *)*/
+/*(*************************************************************************)*/
+
+expression:
+ | assignment_expression { $1 }
+ | expression T_COMMA assignment_expression { J.ESeq ($1, $3) }
+
+assignment_expression:
+ | conditional_expression { $1 }
+ | left_hand_side_expression assignment_operator assignment_expression
+   { J.EBin ($2, $1, $3) }
+
+assignment_operator:
+ | T_ASSIGN         { J.Eq }
+ | T_MULT_ASSIGN    { J.StarEq }
+ | T_DIV_ASSIGN     { J.SlashEq }
+ | T_MOD_ASSIGN     { J.ModEq }
+ | T_PLUS_ASSIGN    { J.PlusEq }
+ | T_MINUS_ASSIGN   { J.MinusEq }
+ | T_LSHIFT_ASSIGN  { J.LslEq }
+ | T_RSHIFT_ASSIGN  { J.AsrEq }
+ | T_RSHIFT3_ASSIGN { J.LsrEq }
+ | T_BIT_AND_ASSIGN { J.BandEq }
+ | T_BIT_XOR_ASSIGN { J.BxorEq }
+ | T_BIT_OR_ASSIGN  { J.BorEq }
+
+left_hand_side_expression:
+ | new_expression  { $1 }
+ | call_expression { $1 }
+
+conditional_expression:
+ | post_in_expression { $1 }
+ | post_in_expression
+     T_PLING assignment_expression
+     T_COLON assignment_expression
+     { J.ECond ($1, $3, $5) }
+
+post_in_expression:
+ | pre_in_expression { $1 }
+ | post_in_expression T_LESS_THAN post_in_expression
+   { bop J.Lt $1 $3 }
+ | post_in_expression T_GREATER_THAN post_in_expression
+   { bop J.Gt $1 $3 }
+ | post_in_expression T_LESS_THAN_EQUAL post_in_expression
+   { bop J.Le $1 $3 }
+ | post_in_expression T_GREATER_THAN_EQUAL post_in_expression
+   { bop J.Ge $1 $3 }
+ | post_in_expression T_INSTANCEOF post_in_expression
+   { bop J.InstanceOf $1 $3 }
+ | post_in_expression T_IN post_in_expression
+   { bop J.In $1 $3 }
+ | post_in_expression T_EQUAL post_in_expression
+   { bop J.Eq $1 $3 }
+ | post_in_expression T_NOT_EQUAL post_in_expression
+   { bop J.NotEq $1 $3 }
+ | post_in_expression T_STRICT_EQUAL post_in_expression
+   { bop J.EqEq $1 $3 }
+ | post_in_expression T_STRICT_NOT_EQUAL post_in_expression
+   { bop J.NotEqEq $1 $3 }
+ | post_in_expression T_BIT_AND post_in_expression
+   { bop J.Band $1 $3 }
+ | post_in_expression T_BIT_XOR post_in_expression
+   { bop J.Bxor $1 $3 }
+ | post_in_expression T_BIT_OR post_in_expression
+   { bop J.Bor $1 $3 }
+ | post_in_expression T_AND post_in_expression
+   { bop J.And $1 $3 }
+ | post_in_expression T_OR post_in_expression
+   { bop J.Or $1 $3 }
+
+pre_in_expression:
+ | left_hand_side_expression
+   { $1 }
+ | pre_in_expression T_INCR %prec p_POSTFIX
+   { uop J.IncrA $1 }
+ | pre_in_expression T_DECR %prec p_POSTFIX
+   { uop J.DecrA $1 }
+ | T_DELETE pre_in_expression
+   { uop J.Delete $2 }
+ | T_VOID pre_in_expression
+   { uop J.Void $2 }
+ | T_TYPEOF pre_in_expression
+   { uop J.Typeof $2 }
+ | T_INCR pre_in_expression
+   { uop J.IncrB $2 }
+ | T_DECR pre_in_expression
+   { uop J.DecrB $2 }
+ | T_PLUS pre_in_expression
+   { uop J.Pl $2 }
+ | T_MINUS pre_in_expression
+   { uop J.Neg $2}
+ | T_BIT_NOT pre_in_expression
+   { uop J.Bnot $2 }
+ | T_NOT pre_in_expression
+   { uop J.Not $2 }
+
+ | pre_in_expression T_MULT pre_in_expression    { bop J.Mul $1 $3 }
+ | pre_in_expression T_DIV pre_in_expression     { bop J.Div $1 $3 }
+ | pre_in_expression T_MOD pre_in_expression     { bop J.Mod $1 $3 }
+ | pre_in_expression T_PLUS pre_in_expression    { bop J.Plus $1 $3 }
+ | pre_in_expression T_MINUS pre_in_expression   { bop J.Minus $1 $3 }
+ | pre_in_expression T_LSHIFT pre_in_expression  { bop J.Lsl $1 $3 }
+ | pre_in_expression T_RSHIFT pre_in_expression  { bop J.Asr $1 $3 }
+ | pre_in_expression T_RSHIFT3 pre_in_expression { bop J.Lsr $1 $3 }
+
+call_expression:
+ | member_expression arguments                      { J.ECall($1, $2) }
+ | call_expression arguments                        { J.ECall($1, $2) }
+ | call_expression T_LBRACKET expression T_RBRACKET { J.EAccess ($1, $3) }
+ | call_expression T_PERIOD identifier              { J.EDot ($1, $3) }
+
+new_expression:
+ | member_expression    { $1 }
+ | T_NEW new_expression { J.ENew ($2,None) }
+
+member_expression:
+ | primary_expression                                 { $1 }
+ | member_expression T_LBRACKET expression T_RBRACKET { J.EAccess ($1, $3) }
+ | member_expression T_PERIOD identifier              { J.EDot($1,$3) }
+ | T_NEW member_expression arguments
+     { J.ENew($2, Some $3) }
+
+primary_expression:
+ | primary_expression_no_statement { $1 }
+ | object_literal                  { J.EObj $1 }
+ | function_expression             { $1 }
+
+primary_expression_no_statement:
+ | T_THIS          { J.EVar (J.S "this") }
+ | identifier      { J.EVar (J.S $1) }
+
+ | null_literal    { J.EVar (J.S "null") }
+ | boolean_literal { J.EBool $1 }
+ | numeric_literal { J.ENum $1 }
+ | string_literal  { J.EStr ($1, `Bytes) }
+ /*(* marcel: this isn't an expansion of literal in ECMA-262... mistake? *)*/
+ | regex_literal                { $1 }
+ | array_literal                { $1 }
+ | T_LPAREN expression T_RPAREN { $2 }
+
+/*(*----------------------------*)*/
+/*(*2 no in *)*/
+/*(*----------------------------*)*/
+expression_no_in:
+ | assignment_expression_no_in { $1 }
+ | expression_no_in T_COMMA assignment_expression_no_in { J.ESeq ($1, $3) }
+
+assignment_expression_no_in:
+ | conditional_expression_no_in { $1 }
+ | left_hand_side_expression assignment_operator assignment_expression_no_in
+     { J.EBin($2,$1,$3) }
+
+conditional_expression_no_in:
+ | post_in_expression_no_in { $1 }
+ | post_in_expression_no_in
+     T_PLING assignment_expression_no_in
+     T_COLON assignment_expression_no_in
+     { J.ECond ($1, $3, $5) }
+
+post_in_expression_no_in:
+ | pre_in_expression { $1 }
+ | post_in_expression_no_in T_LESS_THAN post_in_expression
+   { bop J.Lt $1 $3 }
+ | post_in_expression_no_in T_GREATER_THAN post_in_expression
+   { bop J.Gt $1 $3 }
+ | post_in_expression_no_in T_LESS_THAN_EQUAL post_in_expression
+   { bop J.Le $1 $3 }
+ | post_in_expression_no_in T_GREATER_THAN_EQUAL post_in_expression
+   { bop J.Ge $1 $3 }
+ | post_in_expression_no_in T_INSTANCEOF post_in_expression
+   { bop J.InstanceOf $1 $3 }
+ | post_in_expression_no_in T_EQUAL post_in_expression
+   { bop J.Eq $1 $3 }
+ | post_in_expression_no_in T_NOT_EQUAL post_in_expression
+   { bop J.NotEq $1 $3 }
+ | post_in_expression_no_in T_STRICT_EQUAL post_in_expression
+   { bop J.EqEq $1 $3 }
+ | post_in_expression_no_in T_STRICT_NOT_EQUAL post_in_expression
+   { bop J.NotEqEq $1 $3 }
+ | post_in_expression_no_in T_BIT_AND post_in_expression
+   { bop J.Band $1 $3 }
+ | post_in_expression_no_in T_BIT_XOR post_in_expression
+   { bop J.Bxor $1 $3 }
+ | post_in_expression_no_in T_BIT_OR post_in_expression
+   { bop J.Bor $1 $3 }
+ | post_in_expression_no_in T_AND post_in_expression
+   { bop J.And $1 $3 }
+ | post_in_expression_no_in T_OR post_in_expression
+   { bop J.Or $1 $3 }
+
+/*(*----------------------------*)*/
+/*(*2 (no statement)*)*/
+/*(*----------------------------*)*/
+expression_no_statement:
+ | assignment_expression_no_statement { $1 }
+ | expression_no_statement T_COMMA assignment_expression { J.ESeq($1,$3) }
+
+assignment_expression_no_statement:
+ | conditional_expression_no_statement { $1 }
+ | left_hand_side_expression_no_statement assignment_operator assignment_expression
+     { J.EBin ($2,$1,$3) }
+
+conditional_expression_no_statement:
+ | post_in_expression_no_statement { $1 }
+ | post_in_expression_no_statement
+     T_PLING assignment_expression
+     T_COLON assignment_expression
+     { J.ECond ($1, $3, $5) }
+
+
+post_in_expression_no_statement:
+ | pre_in_expression_no_statement { $1 }
+ | post_in_expression_no_statement T_LESS_THAN post_in_expression
+   { bop J.Lt $1 $3 }
+ | post_in_expression_no_statement T_GREATER_THAN post_in_expression
+   { bop J.Gt $1 $3 }
+ | post_in_expression_no_statement T_LESS_THAN_EQUAL post_in_expression
+   { bop J.Le $1 $3 }
+ | post_in_expression_no_statement T_GREATER_THAN_EQUAL post_in_expression
+   { bop J.Ge $1 $3 }
+ | post_in_expression_no_statement T_INSTANCEOF post_in_expression
+   { bop J.InstanceOf $1 $3 }
+ | post_in_expression_no_statement T_IN post_in_expression
+   { bop J.In $1 $3 }
+ | post_in_expression_no_statement T_EQUAL post_in_expression
+   { bop J.Eq $1 $3 }
+ | post_in_expression_no_statement T_NOT_EQUAL post_in_expression
+   { bop J.NotEq $1 $3 }
+ | post_in_expression_no_statement T_STRICT_EQUAL post_in_expression
+   { bop J.EqEq $1 $3 }
+ | post_in_expression_no_statement T_STRICT_NOT_EQUAL post_in_expression
+   { bop J.NotEqEq $1 $3 }
+ | post_in_expression_no_statement T_BIT_AND post_in_expression
+   { bop J.Band $1 $3 }
+ | post_in_expression_no_statement T_BIT_XOR post_in_expression
+   { bop J.Bxor $1 $3 }
+ | post_in_expression_no_statement T_BIT_OR post_in_expression
+   { bop J.Bor $1 $3 }
+ | post_in_expression_no_statement T_AND post_in_expression
+   { bop J.And $1 $3 }
+ | post_in_expression_no_statement T_OR post_in_expression
+   { bop J.Or $1 $3 }
+
+
+pre_in_expression_no_statement:
+ | left_hand_side_expression_no_statement
+   { $1 }
+ | pre_in_expression_no_statement T_INCR
+   { uop J.IncrA $1 }
+ | pre_in_expression_no_statement T_DECR
+   { uop J.DecrA $1 }
+ | T_DELETE pre_in_expression
+   { uop J.Delete $2 }
+ | T_VOID pre_in_expression
+   { uop J.Void $2 }
+ | T_TYPEOF pre_in_expression
+   { uop J.Typeof $2 }
+ | T_INCR pre_in_expression
+   { uop J.IncrB $2 }
+ | T_DECR pre_in_expression
+   { uop J.DecrB $2 }
+ | T_PLUS pre_in_expression
+   { uop J.Pl $2 }
+ | T_MINUS pre_in_expression
+   { uop J.Neg $2}
+ | T_BIT_NOT pre_in_expression
+   { uop J.Bnot $2 }
+ | T_NOT pre_in_expression
+   { uop J.Not $2 }
+
+ | pre_in_expression_no_statement T_MULT pre_in_expression    { bop J.Mul $1 $3 }
+ | pre_in_expression_no_statement T_DIV pre_in_expression     { bop J.Div $1 $3 }
+ | pre_in_expression_no_statement T_MOD pre_in_expression     { bop J.Mod $1 $3 }
+ | pre_in_expression_no_statement T_PLUS pre_in_expression    { bop J.Plus $1 $3 }
+ | pre_in_expression_no_statement T_MINUS pre_in_expression   { bop J.Minus $1 $3 }
+ | pre_in_expression_no_statement T_LSHIFT pre_in_expression  { bop J.Lsl $1 $3 }
+ | pre_in_expression_no_statement T_RSHIFT pre_in_expression  { bop J.Asr $1 $3 }
+ | pre_in_expression_no_statement T_RSHIFT3 pre_in_expression { bop J.Lsr $1 $3 }
+
+left_hand_side_expression_no_statement:
+ | new_expression_no_statement { $1 }
+ | call_expression_no_statement { $1 }
+
+new_expression_no_statement:
+ | member_expression_no_statement { $1 }
+ | T_NEW new_expression { J.ENew ($2,None) }
+
+call_expression_no_statement:
+ | member_expression_no_statement arguments
+   { J.ECall($1, $2) }
+ | call_expression_no_statement arguments
+   { J.ECall($1, $2) }
+ | call_expression_no_statement T_LBRACKET expression T_RBRACKET
+   { J.EAccess($1, $3) }
+ | call_expression_no_statement T_PERIOD identifier
+   { J.EDot($1,$3) }
+
+member_expression_no_statement:
+ | primary_expression_no_statement                                 { $1 }
+ | member_expression_no_statement T_LBRACKET expression T_RBRACKET
+   { J.EAccess($1, $3) }
+ | member_expression_no_statement T_PERIOD identifier
+   { J.EDot($1, $3) }
+ | T_NEW member_expression arguments
+   { J.ENew($2,Some $3) }
+
+/*(*----------------------------*)*/
+/*(*2 scalar *)*/
+/*(*----------------------------*)*/
+null_literal:
+ | T_NULL { }
+
+boolean_literal:
+ | T_TRUE  { true }
+ | T_FALSE { false }
+
+numeric_literal:
+ | T_NUMBER { let s,_ = $1 in float_of_string s }
+
+regex_literal:
+ | T_REGEX { let s,_ = $1 in J.EStr (s,`Bytes) }
+
+string_literal:
+ | T_STRING { let s,_ = $1 in s}
+
+/*(*----------------------------*)*/
+/*(*2 array *)*/
+/*(*----------------------------*)*/
+
+array_literal:
+ | T_LBRACKET elison T_RBRACKET              { J.EArr $2 }
+ | T_LBRACKET        T_RBRACKET              { J.EArr [] }
+ | T_LBRACKET element_list T_RBRACKET        { J.EArr $2 }
+ | T_LBRACKET element_list elison T_RBRACKET { J.EArr ($2 @ $3) }
+
+
+element_list:
+ | elison   assignment_expression { $1 @ [Some $2] }
+ |          assignment_expression { [Some $1] }
+ | element_list   elison   assignment_expression { $1 @ $2 @ [Some $3] }
+
+
+object_literal:
+ | T_LCURLY T_RCURLY { [] }
+ | T_LCURLY property_name_and_value_list T_VIRTUAL_SEMICOLON T_RCURLY { $2 }
+
+
+property_name_and_value_list:
+ | property_name T_COLON assignment_expression
+     { [$1, $3] }
+ | property_name_and_value_list T_COMMA
+   property_name T_COLON assignment_expression
+   { $1 @ [$3,$5] }
+
+/*(*----------------------------*)*/
+/*(*2 variable *)*/
+/*(*----------------------------*)*/
+
+/*(*----------------------------*)*/
+/*(*2 function call *)*/
+/*(*----------------------------*)*/
+
+arguments:
+ | T_LPAREN               T_RPAREN { [] }
+ | T_LPAREN argument_list T_RPAREN { $2 }
+
+argument_list:
+ | assignment_expression
+     { [$1] }
+ | argument_list T_COMMA assignment_expression
+     { $1 @ [$3] }
+
+/*(*----------------------------*)*/
+/*(*2 auxillary bis *)*/
+/*(*----------------------------*)*/
+
+/*(*************************************************************************)*/
+/*(*1 Entities, names *)*/
+/*(*************************************************************************)*/
+identifier:
+ | T_IDENTIFIER { let s,_ = $1 in s  }
+
+property_name:
+ | identifier      { J.PNI $1 }
+ | string_literal  { J.PNS $1 }
+ | numeric_literal { J.PNN $1 }
+
+/*(*************************************************************************)*/
+/*(*1 xxx_opt, xxx_list *)*/
+/*(*************************************************************************)*/
+
+semicolon:
+ | T_SEMICOLON         { Some $1 }
+ | T_VIRTUAL_SEMICOLON { None }
+
+elison:
+ | T_COMMA { [] }
+ | elison T_COMMA { $1 @ [None] }
+
+source_elements:
+ | source_element { [$1] }
+ | source_elements source_element { $1 @ [$2] }
+
+statement_list:
+ | statement { [$1] }
+ | statement_list statement { $1 @ [$2] }
+
+case_clauses:
+ | case_clause { [$1] }
+ | case_clauses case_clause { $1 @ [$2] }
+
+variable_declaration_list:
+ | variable_declaration
+     { [$1]  }
+ | variable_declaration_list T_COMMA variable_declaration
+     { $1 @ [$3] }
+
+variable_declaration_list_no_in:
+ | variable_declaration_no_in
+     { [$1] }
+ | variable_declaration_list_no_in T_COMMA variable_declaration_no_in
+     { $1 @ [$3] }
+
+expression_opt:
+ | /*(* empty *)*/ { None }
+ | expression      { Some $1 }
+
+expression_no_in_opt:
+ | /*(* empty *)*/  { None }
+ | expression_no_in { Some $1 }
+
+case_clauses_opt:
+ | /*(* empty *)*/ { [] }
+ | case_clauses    { $1 }

From 9654f9423309fb6ebc1493a8b884804582a1e373 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Mon, 23 Sep 2013 10:22:26 -0700
Subject: [PATCH 49/60] PARSER: handle regexp properly

---
 compiler/parse_js.ml   |  2 +-
 compiler/parser_js.mly | 12 +++++++++++-
 2 files changed, 12 insertions(+), 2 deletions(-)

diff --git a/compiler/parse_js.ml b/compiler/parse_js.ml
index be6e5986db..e79458146a 100644
--- a/compiler/parse_js.ml
+++ b/compiler/parse_js.ml
@@ -298,7 +298,7 @@ let parse file =
     let p = Parser_js.program lexer_fun lexbuf  in
     let buf = Buffer.create 1024 in
     let f = Pretty_print.to_buffer buf in
-
+    Pretty_print.set_compact f true;
     Js_output.program f (fun _ -> None) (fun _ -> assert false) p;
     Printf.printf "%s" (Buffer.contents buf)
   with Parsing.Parse_error ->
diff --git a/compiler/parser_js.mly b/compiler/parser_js.mly
index 1b8a825cc9..2bcd80b521 100644
--- a/compiler/parser_js.mly
+++ b/compiler/parser_js.mly
@@ -654,7 +654,17 @@ numeric_literal:
  | T_NUMBER { let s,_ = $1 in float_of_string s }
 
 regex_literal:
- | T_REGEX { let s,_ = $1 in J.EStr (s,`Bytes) }
+ | T_REGEX {
+   let s,_ = $1 in
+   let len = String.length s in
+   let args =
+     if s.[len - 1] = '/'
+     then [String.sub s 1 (len - 2)]
+     else
+       let i = String.rindex s '/' in
+       [String.sub s 1 (i - 1) ; String.sub s (i+1) (len - i - 1)]
+   in
+   J.ENew(J.EVar (J.S "RegExp"), Some (List.map (fun s -> J.EStr (s,`Bytes)) args)) }
 
 string_literal:
  | T_STRING { let s,_ = $1 in s}

From 47e304e6883afcf9d0e41ffb2ff237a5a1df57e5 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Tue, 24 Sep 2013 10:17:49 -0700
Subject: [PATCH 50/60] PARSERJS: typo

---
 compiler/parser_js.mly | 12 ++++++------
 1 file changed, 6 insertions(+), 6 deletions(-)

diff --git a/compiler/parser_js.mly b/compiler/parser_js.mly
index 2bcd80b521..bac7e5a107 100644
--- a/compiler/parser_js.mly
+++ b/compiler/parser_js.mly
@@ -386,11 +386,11 @@ post_in_expression:
  | post_in_expression T_IN post_in_expression
    { bop J.In $1 $3 }
  | post_in_expression T_EQUAL post_in_expression
-   { bop J.Eq $1 $3 }
+   { bop J.EqEq $1 $3 }
  | post_in_expression T_NOT_EQUAL post_in_expression
    { bop J.NotEq $1 $3 }
  | post_in_expression T_STRICT_EQUAL post_in_expression
-   { bop J.EqEq $1 $3 }
+   { bop J.EqEqEq $1 $3 }
  | post_in_expression T_STRICT_NOT_EQUAL post_in_expression
    { bop J.NotEqEq $1 $3 }
  | post_in_expression T_BIT_AND post_in_expression
@@ -506,11 +506,11 @@ post_in_expression_no_in:
  | post_in_expression_no_in T_INSTANCEOF post_in_expression
    { bop J.InstanceOf $1 $3 }
  | post_in_expression_no_in T_EQUAL post_in_expression
-   { bop J.Eq $1 $3 }
+   { bop J.EqEq $1 $3 }
  | post_in_expression_no_in T_NOT_EQUAL post_in_expression
    { bop J.NotEq $1 $3 }
  | post_in_expression_no_in T_STRICT_EQUAL post_in_expression
-   { bop J.EqEq $1 $3 }
+   { bop J.EqEqEq $1 $3 }
  | post_in_expression_no_in T_STRICT_NOT_EQUAL post_in_expression
    { bop J.NotEqEq $1 $3 }
  | post_in_expression_no_in T_BIT_AND post_in_expression
@@ -559,11 +559,11 @@ post_in_expression_no_statement:
  | post_in_expression_no_statement T_IN post_in_expression
    { bop J.In $1 $3 }
  | post_in_expression_no_statement T_EQUAL post_in_expression
-   { bop J.Eq $1 $3 }
+   { bop J.EqEq $1 $3 }
  | post_in_expression_no_statement T_NOT_EQUAL post_in_expression
    { bop J.NotEq $1 $3 }
  | post_in_expression_no_statement T_STRICT_EQUAL post_in_expression
-   { bop J.EqEq $1 $3 }
+   { bop J.EqEqEq $1 $3 }
  | post_in_expression_no_statement T_STRICT_NOT_EQUAL post_in_expression
    { bop J.NotEqEq $1 $3 }
  | post_in_expression_no_statement T_BIT_AND post_in_expression

From 2123858d43f6367051a49d406a7e7ee3f2fb7755 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Tue, 24 Sep 2013 10:34:02 -0700
Subject: [PATCH 51/60] COMPILER: compact mode for regexp

---
 compiler/js_output.ml | 10 ++++++++++
 1 file changed, 10 insertions(+)

diff --git a/compiler/js_output.ml b/compiler/js_output.ml
index db9e1029c8..924b1bfcb3 100644
--- a/compiler/js_output.ml
+++ b/compiler/js_output.ml
@@ -223,6 +223,12 @@ end) = struct
     done;
     Buffer.contents b
 
+  let regexp_compact s o =
+    not ( s = ""
+       || s.[0] = '*'
+       || s.[0] = '/'
+       ||s.[0] = '[' )
+
   let rec expression l f e =
     match e with
         EVar v ->
@@ -419,6 +425,10 @@ end) = struct
         PP.string f "()";
         PP.end_group f;
         if l > 15 then begin PP.string f ")"; PP.end_group f end
+      | ENew (EVar (S "RegExp"), Some [EStr (s,_)]) when regexp_compact s None ->
+        PP.string f (Printf.sprintf "/%s/" s)
+      | ENew (EVar (S "RegExp"), Some [EStr (s,_);EStr (s',_)]) when regexp_compact s (Some s')->
+        PP.string f (Printf.sprintf "/%s/%s" s s')
       | ENew (e, Some el) ->
         if l > 15 then begin PP.start_group f 1; PP.string f "(" end;
         PP.start_group f 1;

From 17c097a84cb57815c999430706a6c9a533b4dab7 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Tue, 1 Oct 2013 08:57:09 -0700
Subject: [PATCH 52/60] restore pretty var

---
 compiler/code.ml   | 2 +-
 compiler/driver.ml | 4 ++--
 compiler/util.ml   | 4 ++--
 compiler/util.mli  | 2 +-
 4 files changed, 6 insertions(+), 6 deletions(-)

diff --git a/compiler/code.ml b/compiler/code.ml
index fbcaaf1c24..8b41ed51bf 100644
--- a/compiler/code.ml
+++ b/compiler/code.ml
@@ -43,7 +43,7 @@ end = struct
   open Util
   type t = int
 
-  let printer = VarPrinter.create ()
+  let printer = VarPrinter.create ~pretty:(Option.Optim.pretty ()) ()
 
   let last_var = ref 0
 
diff --git a/compiler/driver.ml b/compiler/driver.ml
index b4c51915f5..94262ce7c4 100644
--- a/compiler/driver.ml
+++ b/compiler/driver.ml
@@ -163,7 +163,7 @@ let header formatter ~standalone js =
   end;
   js
 
-let link formatter ~standalone ?linkall pretty js =
+let link formatter ~standalone ?linkall js =
   if standalone
   then
     begin
@@ -203,7 +203,7 @@ let f ?(standalone=true) ?linkall formatter d =
   coloring >>
 
   header formatter ~standalone >>
-  link formatter ~standalone ?linkall false >>
+  link formatter ~standalone ?linkall >>
 
   output formatter d
 
diff --git a/compiler/util.ml b/compiler/util.ml
index e4fa5d541b..083074f9d3 100644
--- a/compiler/util.ml
+++ b/compiler/util.ml
@@ -136,12 +136,12 @@ module VarPrinter = struct
   let reset t =
     Hashtbl.clear t.names; Hashtbl.clear t.known; t.last <- -1
 
-  let create () =
+  let create ?(pretty=false) () =
     let t = {
       names = Hashtbl.create 107;
       known = Hashtbl.create 1001;
       last = -1;
-      pretty = false;
+      pretty;
     } in
     reset t; t
 end
diff --git a/compiler/util.mli b/compiler/util.mli
index 6e4b0e3fac..0cfe0b6ede 100644
--- a/compiler/util.mli
+++ b/compiler/util.mli
@@ -42,7 +42,7 @@ end
 module VarPrinter : sig
   type t
 
-  val create : unit -> t
+  val create : ?pretty:bool -> unit -> t
   val reset : t -> unit
   val to_string : t -> int -> string
   val name : t -> int -> string -> unit

From f5277733a9cf8d79bd04ee9a279a4b836fb56221 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Thu, 3 Oct 2013 11:02:51 -0700
Subject: [PATCH 53/60] COMPILER: disable short var optim

---
 compiler/js_var.ml | 33 ++++++++++++++++++---------------
 compiler/option.ml |  2 +-
 2 files changed, 19 insertions(+), 16 deletions(-)

diff --git a/compiler/js_var.ml b/compiler/js_var.ml
index 25ff70eb53..6761f83e56 100644
--- a/compiler/js_var.ml
+++ b/compiler/js_var.ml
@@ -85,21 +85,24 @@ let get_free t = S.diff t.use t.def
 let get_free_name t = StringSet.diff t.use_name t.def_name
 
 let mark g =
-  let u = S.union g.def g.use in
-  S.iter (fun u -> G.add_vertex g.g (vertex g u)) u;
-  let _ = S.fold (fun u1 set ->
-    let set = S.remove u1 set in
-    S.iter (fun u2 ->
-      if u1 <> u2
-      then
-        G.add_edge
-          g.g
-          (vertex g u1)
-          (vertex g u2)
-    ) set;
-    set
-  ) u u in
-  {g with biggest = max g.biggest (S.cardinal u)}
+  if Option.Optim.shortvar ()
+  then
+    let u = S.union g.def g.use in
+    S.iter (fun u -> G.add_vertex g.g (vertex g u)) u;
+    let _ = S.fold (fun u1 set ->
+        let set = S.remove u1 set in
+        S.iter (fun u2 ->
+            if u1 <> u2
+            then
+              G.add_edge
+                g.g
+                (vertex g u1)
+                (vertex g u2)
+          ) set;
+        set
+      ) u u in
+    {g with biggest = max g.biggest (S.cardinal u)}
+  else g
 
 let create () = (* empty (G.make (Code.Var.count ())) *)
   {
diff --git a/compiler/option.ml b/compiler/option.ml
index 8f8b0584ff..c5698418e5 100644
--- a/compiler/option.ml
+++ b/compiler/option.ml
@@ -68,7 +68,7 @@ module Optim = struct
   let pretty =     o ~name:"pretty" ~default:false
   let debuginfo =  o ~name:"debuginfo" ~default:false
   let deadcode =   o ~name:"deadcode" ~default:true
-  let shortvar =  o ~name:"shortvar" ~default:true
+  let shortvar =  o ~name:"shortvar" ~default:false
   let compact =    o ~name:"compact" ~default:true
   let optcall =    o ~name:"optcall" ~default:true
   let inline =     o ~name:"inline" ~default:true

From ff33da6a3c0e2a1b2432de0c28585febc0c9a9c3 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Thu, 3 Oct 2013 11:24:57 -0700
Subject: [PATCH 54/60] RUNTIME: fix typo

---
 compiler/generate.ml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/compiler/generate.ml b/compiler/generate.ml
index ad665cebc4..25e0d1c7cd 100644
--- a/compiler/generate.ml
+++ b/compiler/generate.ml
@@ -532,7 +532,7 @@ let _ =
      "caml_int32_of_float", "caml_int_of_float";
      "caml_int32_to_float", "%identity";
      "caml_int32_format", "caml_format_int";
-     "caml_int32_of_string", "caml_int_of_amlstring";
+     "caml_int32_of_string", "caml_int_of_string";
      "caml_int32_compare", "caml_int_compare";
      "caml_nativeint_neg", "%int_neg";
      "caml_nativeint_add", "%int_add";

From 8ce6afbcd6aa1012ccc03ee7284a7c4537db9077 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Thu, 3 Oct 2013 12:09:33 -0700
Subject: [PATCH 55/60] COMPILER: fix static eval of shift functions

---
 compiler/eval.ml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/compiler/eval.ml b/compiler/eval.ml
index 11bce47aa6..68860f30ad 100644
--- a/compiler/eval.ml
+++ b/compiler/eval.ml
@@ -19,7 +19,7 @@ let eval_prim x =
         | [Int i; Int j] -> fun f -> Some (Int (Int.to_int (f (Int.of_int i) (Int.of_int j))))
         | _ -> fun _ -> None in
       let shift = match l with
-        | [Int i; Int j] -> fun f -> Some (Int (Int.to_int (f (Int.of_int i) j)))
+        | [Int i; Int j] -> fun f -> Some (Int (Int.to_int (f (Int.of_int i) (j land 0x1f))))
         | _ -> fun _ -> None in
       let float_binop_aux =
         let args = match l with

From e2e5287aea1fe5b1745c05a32523b080407ef50c Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Thu, 3 Oct 2013 12:17:37 -0700
Subject: [PATCH 56/60] COMPILER: missing provided symbol

---
 compiler/reserved.ml | 1 +
 1 file changed, 1 insertion(+)

diff --git a/compiler/reserved.ml b/compiler/reserved.ml
index 4928a270ce..ad3f2ecfe0 100644
--- a/compiler/reserved.ml
+++ b/compiler/reserved.ml
@@ -13,6 +13,7 @@ let provided = [
   "Date";
   "Math";
   "JSON";
+  "Object";
   "RegExp";
   "String";
   "XMLHttpRequest";

From 3fcc4c9a0334cce257d548eba1a8680840f860e9 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Thu, 3 Oct 2013 13:34:39 -0700
Subject: [PATCH 57/60] COMPILER: cleaning js_simpl

---
 compiler/js_simpl.ml | 48 +++++++++++++++++++++++---------------------
 1 file changed, 25 insertions(+), 23 deletions(-)

diff --git a/compiler/js_simpl.ml b/compiler/js_simpl.ml
index 734c9655cf..d7419f3035 100644
--- a/compiler/js_simpl.ml
+++ b/compiler/js_simpl.ml
@@ -109,7 +109,7 @@ let source_elements l =
            J.Statement st :: rem)
     l []
 
-let tr = function
+let translate_assign_op = function
   | J.Div -> J.SlashEq
   | J.Mod -> J.ModEq
   | J.Lsl -> J.LslEq
@@ -123,35 +123,37 @@ let tr = function
   | J.Minus -> J.MinusEq
   | _ -> assert false
 
-let var isint = function
-  | (x,Some (J.EBin (J.Plus,y, J.EVar x')))
-  | (x,Some (J.EBin (J.Plus, J.EVar x',y))) when x = x' ->
+let assign_op' force_int = function
+  | (exp,Some (J.EBin (J.Plus,y, exp')))
+  | (exp,Some (J.EBin (J.Plus, exp',y))) when exp = exp' ->
     if y = J.ENum 1.
-    then Some (J.EUn (J.IncrB,J.EVar x))
-    else Some (J.EBin (J.PlusEq, J.EVar x,y))
-  | (x,Some (J.EBin (J.Minus, J.EVar x',y))) when x = x' ->
+    then Some (J.EUn (J.IncrB,exp))
+    else Some (J.EBin (J.PlusEq,exp,y))
+  | (exp,Some (J.EBin (J.Minus, exp',y))) when exp = exp' ->
     if y = J.ENum 1.
-    then Some (J.EUn (J.DecrB,J.EVar x))
-    else Some (J.EBin (J.MinusEq, J.EVar x,y))
-  | (x,Some (J.EBin (J.Mul,y, J.EVar x')))
-  | (x,Some (J.EBin (J.Mul, J.EVar x',y))) when x = x' ->
-    Some (J.EBin (J.StarEq, J.EVar x,y))
-  | (x,Some (J.EBin (J.Div | J.Mod | J.Lsl | J.Asr | J. Lsr | J.Band | J.Bxor | J.Bor as unop, J.EVar x',y))) when x = x' && not isint ->
-    Some (J.EBin (tr unop, J.EVar x,y))
-  | x -> None
+    then Some (J.EUn (J.DecrB, exp))
+    else Some (J.EBin (J.MinusEq, exp,y))
+  | (exp,Some (J.EBin (J.Mul,y, exp')))
+  | (exp,Some (J.EBin (J.Mul, exp',y))) when exp = exp' ->
+    Some (J.EBin (J.StarEq, exp,y))
+  | (exp,Some (J.EBin (J.Div | J.Mod | J.Lsl | J.Asr | J. Lsr | J.Band | J.Bxor | J.Bor as unop, exp',y))) when exp = exp' && not force_int ->
+    Some (J.EBin (translate_assign_op unop, exp,y))
+  | _ -> None
 
-let var = function
-  | (x,Some (J.EBin (J.Bor,e,J.ENum 0.))) -> var true (x,Some e)
-  | x -> var false x
+let assign_op = function
+  (* unsafe, could be optionnaly enabled *)
+  (* x+=1 <> x = (x + 1) | 0 *)
+  (* | (exp,Some (J.EBin (J.Bor,e,J.ENum 0.))) -> assign_op' true (exp,Some e) *)
+  | x -> assign_op' false x
 
-let optim_hh l =
+let assign_opt_pass l =
   List.fold_right (fun st rem ->
     match st with
       | J.Variable_statement l1 ->
-        let x = List.map (function x ->
-            match var x with
+        let x = List.map (function (ident,exp) ->
+            match assign_op (J.EVar ident,exp) with
               | Some e -> J.Expression_statement (e,None)
-              | None -> J.Variable_statement [x]) l1 in
+              | None -> J.Variable_statement [(ident,exp)]) l1 in
         x@rem
       | _ -> st::rem
   ) l []
@@ -164,7 +166,7 @@ let statement_list l =
            J.Variable_statement (l1 @ l2) :: rem'
        | _ ->
            st :: rem)
-    (optim_hh l) []
+    (assign_opt_pass l) []
 
 let block l = match l with [s] -> s | _ -> J.Block (statement_list l)
 

From 180b4515039ced896a6b09f1785bd7dc7af0485e Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Thu, 3 Oct 2013 13:51:06 -0700
Subject: [PATCH 58/60] COMPILER: use InrA

---
 compiler/generate.ml | 7 +++++++
 1 file changed, 7 insertions(+)

diff --git a/compiler/generate.ml b/compiler/generate.ml
index 25e0d1c7cd..45527eb436 100644
--- a/compiler/generate.ml
+++ b/compiler/generate.ml
@@ -1098,6 +1098,13 @@ and translate_instr ctx expr_queue pc instr =
             flush_queue expr_queue mutator_p
               [J.Expression_statement
                   ((J.EBin (J.Eq, J.EAccess (cx, int (n + 1)), cy)), Some pc)]
+        | Offset_ref (x, 1) ->
+          (* FIX: may overflow.. *)
+            let ((px, cx), expr_queue) = access_queue expr_queue x in
+            flush_queue expr_queue mutator_p
+              [J.Expression_statement
+                  ((J.EUn (J.IncrA, (J.EAccess (cx, J.ENum 1.)))),
+                  Some pc)]
         | Offset_ref (x, n) ->
           (* FIX: may overflow.. *)
             let ((px, cx), expr_queue) = access_queue expr_queue x in

From 93a99c1b9406abe3d5c1bb98423ce3bc9831390c Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Thu, 3 Oct 2013 14:28:01 -0700
Subject: [PATCH 59/60] CHANGES: update

---
 CHANGES | 35 +++++++++++++++++++++++++++++++++++
 1 file changed, 35 insertions(+)

diff --git a/CHANGES b/CHANGES
index 995d90920f..8dba4b9994 100644
--- a/CHANGES
+++ b/CHANGES
@@ -2,6 +2,41 @@
 
  * Features/Changes
  ** Add -linkall option to keep all provided primitives
+ ** Compiler: Add javascript file lookup using findlib
+    (+mypkg/myfile.js will read myfile.js from mypkg findlib directory)
+    (by Hugo Heuzard)
+ ** Compiler: Add compilation profiles -opt 1 (2 or 3)
+    (1 -> as before ; 2 -> loop until fixpoint ; 3 -> enable experimental optim 
+    (by Hugo Heuzard)
+ ** Compiler: Improve missing primitives & reserved name detection
+    (by Hugo Heuzard)
+ ** Compiler: Add variable renaming (Based on graph coloring)
+    can be enable with -enable shortvar
+    (by Hugo Heuzard)
+ ** Compiler: static evaluation of constant ("staticeval" optimisation)
+    (by Hugo Heuzard)
+ ** Compiler: Share string constant (by Hugo Heuzard)
+ ** Compiler: Alias primitives (by Hugo Heuzard)
+ ** Compiler: Complete javacript ast (by Hugo Heuzard)
+ ** Compiler: 'caml_format_int %d x' compiles to ""+x (by Hugo Heuzard)
+ ** add javascript file in META (to be used with ocamlfind)
+    (by Hugo Heuzard)
+ ** add Ocamlbuild plugin js_of_ocaml.ocamlbuild
+    (by Jacques-Pascal Deplaix)
+ ** Add/Install unix.js, classlist.js, weak.js
+ ** Add Url.Current.protocol (by Vicent Balat)
+ ** Dependency: deriving instead of deriving-ocsigen
+ ** Log in case of wrong string encoding (by Hugo Heuzard)
+ ** Add compiler_libs (by Pierre Chambart)
+ ** Add Application Cache (by Marc Simon)
+ ** Compile native syntax extension (by Hugo Heuzard)
+ ** Add a javascript parser (extracted from facebook/pfff)
+   (to be use later)
+
+ * BugFixes
+ ** Compiler: js file is not create in case of error (by Hugo Heuzard)
+ ** Fix compatibility when using type conv (by Hugo Heuzard)
+ ** Fix setTimeout overflow (by Hugo Heuzard)
 
 ===== 1.3 (2012-11-28) =====
 

From b6fdf6be5a91c9d17b4e9f8b5d089885858ab3b1 Mon Sep 17 00:00:00 2001
From: Hugo Heuzard <hugo.heuzard@gmail.com>
Date: Thu, 3 Oct 2013 16:17:44 -0700
Subject: [PATCH 60/60] COMPILER: fix move_file

---
 compiler/main.ml  |  2 +-
 compiler/util.ml  | 23 +++++++++++++++++++++++
 compiler/util.mli |  2 ++
 3 files changed, 26 insertions(+), 1 deletion(-)

diff --git a/compiler/main.ml b/compiler/main.ml
index f152e2710b..3419295cb8 100644
--- a/compiler/main.ml
+++ b/compiler/main.ml
@@ -47,7 +47,7 @@ let f linkall paths js_files input_file output_file =
         output_program (Pretty_print.to_out_channel ch);
         close_out ch;
         (try Sys.remove f with _ -> ());
-        Sys.rename f_tmp f
+        Util.move_file f_tmp f
       with exc ->
         Sys.remove f_tmp;
         Format.eprintf "compilation error: %s@." (Printexc.to_string exc);
diff --git a/compiler/util.ml b/compiler/util.ml
index 083074f9d3..d91aa99bf5 100644
--- a/compiler/util.ml
+++ b/compiler/util.ml
@@ -53,6 +53,29 @@ let read_file f =
   close_in ch;
   Buffer.contents b
 
+
+let move_file source dest =
+  try Sys.rename source dest with
+    | Sys_error _ ->
+      (* it may fail if not on the same device
+         copy file instead *)
+      let oc = open_out dest in
+      let ic = open_in source in
+      let buff = String.create (1024 * 1024) in
+      let maxlen = String.length buff in
+      let rec copy () =
+        let count = input ic buff 0 maxlen in
+        match count with
+          | 0 -> ()
+          | _ ->
+            output oc buff 0 count;
+            copy ()
+      in
+      copy ();
+      close_out oc;
+      close_in ic;
+      Sys.remove source
+
 module Timer = struct
   type t = float
   let timer = ref (fun _ -> 0.)
diff --git a/compiler/util.mli b/compiler/util.mli
index 0cfe0b6ede..8dfe06c4b0 100644
--- a/compiler/util.mli
+++ b/compiler/util.mli
@@ -31,6 +31,8 @@ val opt_iter : ('a -> unit) -> 'a option -> unit
 val find_in_paths : string list -> string -> string
 val read_file : string -> string
 
+val move_file : string -> string -> unit
+
 module Timer : sig
   type t
   val init : (unit -> float) -> unit