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) ===== 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 diff --git a/compiler/.depend b/compiler/.depend index b2de2f58f6..2a7288690d 100644 --- a/compiler/.depend +++ b/compiler/.depend @@ -1,61 +1,79 @@ -code.cmo : util.cmi code.cmi -code.cmx : util.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 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 phisimpl.cmi parse_bytecode.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 -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 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 -inline.cmo : util.cmi deadcode.cmi code.cmi inline.cmi -inline.cmx : util.cmx deadcode.cmx code.cmx inline.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 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 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 +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 : subst.cmi code.cmi inline.cmi +inline.cmx : subst.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 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 js_simpl.cmi -js_simpl.cmx : javascript.cmx js_simpl.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 \ +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 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 \ + 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 -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 +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 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 @@ -65,12 +83,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 : javascript.cmi code.cmi inline.cmi : code.cmi instr.cmi : -javascript.cmi : -js_output.cmi : pretty_print.cmi parse_bytecode.cmi javascript.cmi -js_simpl.cmi : javascript.cmi +javascript.cmi : code.cmi +js_output.cmi : pretty_print.cmi parse_bytecode.cmi javascript.cmi code.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 phisimpl.cmi : code.cmi diff --git a/compiler/Makefile b/compiler/Makefile index c01e293a4b..c6597d4316 100644 --- a/compiler/Makefile +++ b/compiler/Makefile @@ -5,13 +5,14 @@ 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 \ - javascript.cmx js_output.cmx js_simpl.cmx \ - instr.cmx code.cmx primitive.cmx subst.cmx pure_fun.cmx deadcode.cmx \ - flow.cmx inline.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 \ + js_var.cmx \ linker.cmx generate.cmx parse_bytecode.cmx driver.cmx COMPOBJS=$(OBJS) main.cmx @@ -40,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 602ac4dfe8..8b41ed51bf 100644 --- a/compiler/code.ml +++ b/compiler/code.ml @@ -18,101 +18,14 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -(*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 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 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) - - 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 pretty = ref false - - let format_var i x = - let s = format_ident x in - if !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 Hashtbl.mem reserved 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 - -let string_of_ident = VarPrinter.format_ident - -let add_reserved_name = VarPrinter.add_reserved module Var : sig type t + val print : Format.formatter -> t -> unit val idx : t -> int 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 @@ -121,56 +34,39 @@ module Var : sig val name : t -> string -> unit val propagate_name : t -> t -> unit - val set_pretty : unit -> unit val reset : unit -> unit val dummy : t end = struct - type t = int * int + open Util + type t = int - let last_var = ref 0 + let printer = VarPrinter.create ~pretty:(Option.Optim.pretty ()) () - let reset () = last_var := 0; VarPrinter.reset () - - type stream = int - - let c = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_$" + let last_var = ref 0 - 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 reset () = + last_var := 0; + VarPrinter.reset printer -(* - 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 to_string i = VarPrinter.to_string printer i let print f x = Format.fprintf f "%s" (to_string x) - let make_stream () = 1 - - let next current = - incr last_var; - ((current, !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 set_pretty () = VarPrinter.pretty := true + let name i nm = VarPrinter.name printer i nm + let propagate_name i j = VarPrinter.propagate_name printer i j - let dummy = (-1 , -1) + let dummy = -1 end module VarSet = Set.Make (Var) @@ -215,6 +111,7 @@ type prim = type constant = String of string + | IString of string | Float of float | Float_array of float array | Int32 of int32 @@ -279,6 +176,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 892f2126fa..e9ff9c4d0a 100644 --- a/compiler/code.mli +++ b/compiler/code.mli @@ -22,11 +22,8 @@ module Var : sig type t val print : Format.formatter -> t -> unit val idx : t -> int - val to_string : t -> string - type stream - val make_stream : unit -> stream - val next : stream -> t * stream + val to_string : t -> string val fresh : unit -> t @@ -36,12 +33,9 @@ module Var : sig val name : t -> string -> unit val propagate_name : t -> t -> unit - val set_pretty : unit -> unit - val reset : unit -> unit end -val string_of_ident : int -> string module VarSet : Set.S with type elt = Var.t module VarMap : Map.S with type key = Var.t @@ -82,6 +76,7 @@ type prim = type constant = String of string + | IString of string | Float of float | Float_array of float array | Int32 of int32 @@ -142,7 +137,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/deadcode.ml b/compiler/deadcode.ml index b19e03ccb1..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 () (****) @@ -254,4 +252,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..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 +val f : Code.program -> Code.program * int array * int array diff --git a/compiler/driver.ml b/compiler/driver.ml index 2d5f8a48fb..94262ce7c4 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 @@ -29,21 +29,40 @@ 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 - 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 -*) + 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 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,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...@."; Flow.f p @@ -63,7 +82,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,39 +97,49 @@ let identity x = x (* o1 *) -let o1 = +let o1 : 'a -> 'a= print >> tailcall >> phi >> flow >> + specialize >> inline >> deadcode >> print >> flow >> + specialize >> inline >> deadcode >> phi >> flow >> + specialize >> identity (* 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 >> + (* deadcode required before flow simple -> provided by constant *) flow_simple >> (* flow simple to keep information for furture tailcall opt *) + specialize' >> + eval >> identity let round2 = - constant >> o1 + flow >> + specialize' >> + eval >> + deadcode >> + o1 let o3 = loop 10 "tailcall+inline" round1 1 >> @@ -120,20 +149,67 @@ 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 generate ~standalone (p,live_vars,_) = + if times () + then Format.eprintf "Start Generation...@."; + Generate.f ~standalone p live_vars + + +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 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 coloring js = + if times () + then Format.eprintf "Start Coloring...@."; + js,Js_var.program js + + +let output formatter d (js,to_string) = + if times () + 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 >> + coloring >> -let from_string prims s = - let p = Parse_bytecode.from_string prims s in - f ~standalone:false p + header formatter ~standalone >> + link formatter ~standalone ?linkall >> -let set_pretty () = Generate.set_pretty (); Parse_bytecode.set_pretty () + output formatter d -let set_debug_info () = Js_output.set_debug_info () +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/eval.ml b/compiler/eval.ml new file mode 100644 index 0000000000..68860f30ad --- /dev/null +++ b/compiler/eval.ml @@ -0,0 +1,169 @@ +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 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 shift = match l with + | [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 + | [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 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", _ -> 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", _ -> 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",_ -> 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 + +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)) when false -> + begin + 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 + +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 208c91ca2f..b339666ddd 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 @@ -30,6 +29,14 @@ 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 @@ -246,8 +253,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 -> @@ -285,199 +291,41 @@ 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 = +let the_def_of info x = match x with | Pv x -> get_approx info - (fun x -> match defs.(Var.idx x) with Expr e -> Some e | _ -> None) + (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 ((defs, _, _) as info) x = +let the_int info x = match x with | Pv x -> get_approx info - (fun x -> match defs.(Var.idx x) with Expr (Const i) -> Some i | _ -> None) + (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 ((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 not (disable_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) | _ -> @@ -491,20 +339,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 @@ -538,9 +386,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..0437386263 100644 --- a/compiler/flow.mli +++ b/compiler/flow.mli @@ -37,4 +37,20 @@ 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 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/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 564074a14f..45527eb436 100644 --- a/compiler/generate.ml +++ b/compiler/generate.ml @@ -33,16 +33,11 @@ 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 set_pretty () = compact := false - -(****) +let debug = Option.Debug.find "gen" +let times = Option.Debug.find "times" open Code +open Util module J = Javascript @@ -66,40 +61,153 @@ 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 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 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 + 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 + (* hack to shared "number" string *) + let count = add_string "number" count 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 + 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 _ -> + Printf.eprintf "missed %S\n%!" s; + 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 = - { 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}) + mutated_vars : VarSet.t AddrMap.t; + share: Share.t } - let initial b l v = - { var_stream = Var.make_stream (); blocks = b; live = l; mutated_vars = v } + let initial b l v share = + { blocks = b; live = l; mutated_vars = v; share } - let used_once ctx x = ctx.live.(Var.idx x) <= 1 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]*) @@ -109,11 +217,14 @@ let float_val e = e (*J.EAccess (e, one)*) let float_const f = val_float (J.ENum f) -let rec constant x = +let rec constant ~ctx x = match x with String s -> - Primitive.mark_used "MlString"; - J.ENew (J.EVar ("MlString"), Some [J.EStr (s, `Bytes)]) + 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 -> + Share.get_string (fun s -> J.EStr (s,`Bytes)) s ctx.Ctx.share | Float f -> float_const f | Float_array a -> @@ -130,7 +241,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 @@ -157,39 +268,74 @@ 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' ~ctx queue x = + match x with + | Pc c -> (const_p,constant ~ctx 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 - [Var.to_string x, Some ce]) instrs + [J.V x, Some elt.ce]) instrs in (List.rev_append instrs l, 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 [] - 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) -> + if Code.VarSet.mem ( x') deps + then Code.VarSet.union elt.deps deps + else deps) deps expr_queue in - (instrs, (x, (prop, ce)) :: expr_queue) + (instrs, (x, {prop; ce; cardinal; deps}) :: expr_queue) (****) @@ -199,7 +345,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 * (J.Label.t * bool ref)) list; mutable visited_blocks : AddrSet.t; mutable interm_idx : int; ctx : Ctx.t; mutable blocks : Code.block AddrMap.t } @@ -256,9 +402,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 @@ -283,26 +426,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 @@ -353,58 +479,32 @@ 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 [Var.to_string 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 (****) -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 = 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 = Var.to_string (Var.fresh ()) in - let params = - Array.to_list (Array.init n (fun _ -> Var.to_string (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, - [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", - [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) (****) @@ -483,47 +583,59 @@ 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 - [Pv x] -> - let ((px, cx), queue) = access_queue queue x in + [x] -> + let ((px, cx), queue) = access_queue' ~ctx queue x in (f cx, or_p (kind k) px, queue) - | _ -> + | _ -> + 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 -> + (fun l queue ctx -> 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' ~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) + | _ -> assert false) let register_tern_prim name f = register_prim name `Mutator - (fun l queue -> + (fun l queue ctx -> 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' ~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) 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"; + 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 @@ -607,9 +719,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 "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 @@ -650,12 +760,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 @@ -687,8 +797,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 (Var.to_string 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) = @@ -711,16 +821,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 = @@ -732,32 +842,30 @@ 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, [Pv x] -> - let ((px, cx), queue) = access_queue queue x in + Vectlength, [x] -> + let ((px, cx), queue) = access_queue' ~ctx 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' ~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)] -> - 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 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' ~ctx queue x in + (cx :: args, or_p prop prop', queue) + ) l ([], mutator_p, queue) in (J.ECall (J.EDot (cf, "call"), co :: args), @@ -767,8 +875,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' ~ctx queue x in (cx :: args, or_p prop prop', queue)) l ([], mutator_p, queue) in @@ -778,8 +885,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' ~ctx queue x in (cx :: args, or_p prop prop', queue)) l ([], mutator_p, queue) in @@ -789,8 +895,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' ~ctx queue x in (cx :: args, or_p prop prop', queue)) l ([], mutator_p, queue) in @@ -813,7 +918,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 @@ -833,59 +938,53 @@ 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 -> - Primitive.mark_used name; - Code.add_reserved_name name; (*XXX HACK *) - (* FIX: this is done at the wrong time... *) + match internal_prim name with + | Some f -> f l queue ctx + | None -> + 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 (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' ~ctx queue x in + (cx :: args, or_p prop prop', queue)) l ([], prim_kind, queue) in - (J.ECall (J.EVar name, args), prop, queue) - end - | Not, [Pv x] -> - let ((px, cx), queue) = access_queue queue x in + (J.ECall (prim, args), prop, queue) + end + | Not, [x] -> + let ((px, cx), queue) = access_queue' ~ctx 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' ~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, [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' ~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, [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' ~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, [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' ~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, [Pv x] -> - let ((px, cx), queue) = access_queue queue x in - (J.EBin(J.EqEqEq, J.EUn (J.Typeof, cx), J.EStr ("number", `Bytes)), + | IsInt, [x] -> + let ((px, cx), queue) = access_queue' ~ctx queue x in + (J.EBin(J.EqEqEq, J.EUn (J.Typeof, cx), (Share.get_string (fun s -> J.EStr (s,`Bytes)) "number" ctx.Ctx.share)), 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 + | Ult, [x; y] -> + 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, [Pv x] -> - let ((px, cx), queue) = access_queue queue x in + | WrapInt, [x] -> + 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), _ -> @@ -900,7 +999,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 @@ -912,9 +1011,9 @@ 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 [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 +1026,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 +1037,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, @@ -979,12 +1078,19 @@ 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 [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 @@ -992,8 +1098,15 @@ 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.. *) + (* FIX: may overflow.. *) let ((px, cx), expr_queue) = access_queue expr_queue x in flush_queue expr_queue mutator_p [J.Expression_statement @@ -1016,14 +1129,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 @@ -1036,7 +1141,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, _)) :: _ -> 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 @@ -1050,11 +1155,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 = @@ -1074,9 +1174,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 @@ -1092,24 +1189,16 @@ 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) :: 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 @@ -1117,11 +1206,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 @@ -1156,25 +1240,17 @@ 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 = 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 = @@ -1192,10 +1268,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 (label, st)] end else body end @@ -1203,9 +1278,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) @@ -1314,7 +1386,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))) + (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) @@ -1337,20 +1409,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 @@ -1380,7 +1441,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 @@ -1390,24 +1450,20 @@ 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 *) 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 [Var.to_string y, Some cx]] + [J.Variable_statement [J.V y, Some cx]] in st @ loop continuation old args params queue end | _ -> 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 = @@ -1424,7 +1480,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 lab end in if debug () then begin @@ -1444,7 +1500,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 -> [] @@ -1472,43 +1528,39 @@ 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 = let res = compile_closure ctx (pc, []) in + let res = generate_shared_value ctx @ 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, [Var.to_string (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=true) ?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 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 !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 res = Js_output.program ch p dl in if times () then Format.eprintf " code gen.: %a@." Util.Timer.print t'; - res - + p diff --git a/compiler/generate.mli b/compiler/generate.mli index ece2e2c356..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 set_pretty : unit -> unit - -val f : Pretty_print.t -> ?standalone:bool -> ?linkall:bool -> - Code.program -> Parse_bytecode.debug_loc -> int array -> unit +val f : standalone:bool -> Code.program -> int array -> Javascript.program diff --git a/compiler/inline.ml b/compiler/inline.ml index 0d265f07e4..6ef1f83340 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 -> @@ -123,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)) @@ -131,18 +129,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/javascript.ml b/compiler/javascript.ml index dfa23b4661..f177d677e9 100644 --- a/compiler/javascript.ml +++ b/compiler/javascript.ml @@ -18,17 +18,32 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -(* - variable_declaration_list_no_in - variable_declaration_no_in - initialiser_no_in -... +module Label = struct + open Util + type t = + | L of int + | S of string -*) -type foo = unit + let printer = VarPrinter.create () -and node_pc = int option + 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 + +type identifier = string + +type ident = + | S of identifier + | V of Code.Var.t (* A.3 Expressions *) @@ -41,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 @@ -67,7 +81,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 @@ -82,60 +96,45 @@ and expression = and statement = Block of block - | Variable_statement of variable_declaration_list -(* + | 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 -*) - | Continue_statement of identifier option - | Break_statement of identifier option + | For_statement of expression option * expression option * expression option * statement * node_pc + | 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 -(* - | With_statement -*) - | Labelled_statement of identifier * statement + (* | With_statement of expression * 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 * (identifier * block) option * block option * node_pc -(* - | Debugger_statement -*) + | Try_statement of block * (ident * block) option * block option * node_pc + (* | Debugger_statement *) 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 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 @@ -147,4 +146,9 @@ and source_element = Statement of statement | Function_declaration of function_declaration -and identifier = string +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 diff --git a/compiler/javascript.mli b/compiler/javascript.mli index ef7dbf55f1..9b19f1c1c1 100644 --- a/compiler/javascript.mli +++ b/compiler/javascript.mli @@ -18,19 +18,23 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -(* - variable_declaration_list_no_in - variable_declaration_no_in - initialiser_no_in -... +module Label : sig + type t + val zero : t + val succ : t -> t + val to_string : t -> string + val of_string : string -> t +end +type node_pc = int option -*) -type foo = unit +(* A.3 Expressions *) -and node_pc = int option +type identifier = string -(* A.3 Expressions *) +type ident = + | S of identifier + | V of Code.Var.t and array_litteral = element_list @@ -41,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 @@ -67,7 +70,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 @@ -82,29 +85,25 @@ and expression = and statement = Block of block - | Variable_statement of variable_declaration_list -(* + | 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 -*) - | Continue_statement of string option - | Break_statement of string option + | 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 (* | With_statement *) - | Labelled_statement of identifier * 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 * (identifier * block) option * block option * node_pc + | Try_statement of block * (ident * block) option * block option * node_pc (* | Debugger_statement *) @@ -113,29 +112,23 @@ 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 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 @@ -146,5 +139,3 @@ and source_elements = source_element list and source_element = Statement of statement | Function_declaration of function_declaration - -and identifier = string diff --git a/compiler/js_output.ml b/compiler/js_output.ml index 44ba74475b..924b1bfcb3 100644 --- a/compiler/js_output.ml +++ b/compiler/js_output.ml @@ -33,857 +33,918 @@ open Javascript module PP = Pretty_print -let enable_debug = ref false -let debug_info = ref None - -let set_debug_info () = enable_debug := true - -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 opt_identifier f i = - match i with - None -> () - | Some i -> PP.space f; PP.string f 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; - formal_parameter_list f r +module Make(D : sig + val debug_info : Parse_bytecode.debug_loc + val to_string : Code.Var.t -> string +end) = struct -(* - 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 output_debug_info f pc = + if Option.Optim.debuginfo () + 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 + | 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 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 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 + 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 *) - | 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 + | 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 + + 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 -> "<=" + | Gt -> ">" + | Ge -> ">=" + | Lsl -> "<<" + | Lsr -> ">>>" + | Asr -> ">>" + | Plus -> "+" + | Minus -> "-" + | Mul -> "*" + | Div -> "/" + | Mod -> "%" + | InstanceOf + | In -> assert false + + let unop_str op = + match op with + Not -> "!" + | Neg -> "-" + | Pl -> "+" + | Bnot -> "~" + | IncrA | IncrB | DecrA | DecrB + | Typeof | Void | 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 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 + 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 regexp_compact s o = + not ( s = "" + || s.[0] = '*' + || s.[0] = '/' + ||s.[0] = '[' ) + + 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 - 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 - | 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 i - | Some e -> - PP.start_group f 1; - PP.string f 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 - [] -> + 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 (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; + 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 (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; + 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 (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; + 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 + [] -> () - | [(i, None)] -> + | [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)] -> + 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 + | Empty_statement -> () + | 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 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 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.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 + | 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) -> + PP.string f "continue "; + 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 (Javascript.Label.to_string 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 (Javascript.Label.to_string 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 - 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 - (* 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 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 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 - -let statement f s dl = - debug_info := Some dl; - 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 + (* 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 ffd5bd8f19..69c717074e 100644 --- a/compiler/js_output.mli +++ b/compiler/js_output.mli @@ -18,10 +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.function_body -> Parse_bytecode.debug_loc -> unit - -val set_debug_info : unit -> unit +val program : Pretty_print.t -> Parse_bytecode.debug_loc -> (Code.Var.t -> string) -> Javascript.program -> unit diff --git a/compiler/js_simpl.ml b/compiler/js_simpl.ml index 4a26af0b26..d7419f3035 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. -> @@ -75,19 +77,19 @@ 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.Void | J.Delete | J.Bnot ), _) -> (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.EUn (J.Not, e), 1) in if cost <= 1 then res else (J.EUn (J.Not, e), 1) @@ -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' @@ -107,6 +109,55 @@ let source_elements l = J.Statement st :: rem) l [] +let translate_assign_op = 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 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,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, 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 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 assign_opt_pass l = + List.fold_right (fun st rem -> + match st with + | J.Variable_statement l1 -> + 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 [(ident,exp)]) l1 in + x@rem + | _ -> st::rem + ) l [] + let statement_list l = List.fold_right (fun st rem -> @@ -115,7 +166,7 @@ let statement_list l = J.Variable_statement (l1 @ l2) :: rem' | _ -> st :: rem) - l [] + (assign_opt_pass l) [] let block l = match l with [s] -> s | _ -> J.Block (statement_list l) @@ -156,7 +207,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 [] -> @@ -171,7 +232,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 @@ -188,12 +253,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'), _ @@ -213,3 +274,35 @@ let rec if_statement e iftrue truestop (iffalse : J.statement) falsestop = iftrue truestop iftrue' falsestop | _ -> if_statement_2 e iftrue truestop iffalse falsestop + + +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..e543638a4c 100644 --- a/compiler/js_simpl.mli +++ b/compiler/js_simpl.mli @@ -30,3 +30,5 @@ val statement_list : statement_list -> statement_list val block : statement_list -> statement val if_statement : expression -> statement -> bool -> statement -> bool -> statement list + +val get_variable : Code.VarSet.t -> expression -> Code.VarSet.t diff --git a/compiler/js_var.ml b/compiler/js_var.ml new file mode 100644 index 0000000000..6761f83e56 --- /dev/null +++ b/compiler/js_var.ml @@ -0,0 +1,313 @@ +open Util +open Javascript + +let debug = Option.Debug.find "shortvar" + +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; + 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 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 s -> def_name 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; + def_name = StringSet.empty; + use_name = StringSet.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 get_free_name t = StringSet.diff t.use_name t.def_name + +let mark g = + 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 ())) *) + { + def = S.empty; + use = S.empty; + count = VM.empty; + biggest = 0; + vertex = Hashtbl.create 17; + 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_name = StringSet.union into.use_name free_name} + +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 + | Empty_statement -> t + | 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 + | 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 + | 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 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 + | Some block -> statements t block + in t + +module M = Graph.Coloring.Mark(G) + + +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 + let percent x all = + float_of_int x /. float_of_int all *. 100. in + let nb_vertex = (G.nb_vertex t.g) in + + 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 + if debug () + then Printf.eprintf "try coloring with %d\n%!" k; + M.coloring t.g k + with M.NoColoring -> loop rem in + 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 M.find color map with _ -> S.empty) in + let map = M.add color varset map in + map + ) 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 map (_,varset) -> + (* let count = S.cardinal varset in *) + let name = V.to_string (S.choose varset) in + S.fold(fun var map -> + 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; *) + 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/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) 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/linker.ml b/compiler/linker.ml index 18259fa77c..fb2ea4f02e 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; @@ -178,7 +176,6 @@ let add_file f = let id = !last_code_id in List.iter (fun (loc, nm, kind) -> - Code.add_reserved_name nm; let kind = match kind with "pure" | "const" -> `Pure @@ -220,7 +217,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) @@ -242,13 +239,3 @@ let resolve_deps ?(linkall = false) compact 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"] -*) 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..3419295cb8 100644 --- a/compiler/main.ml +++ b/compiler/main.ml @@ -18,16 +18,14 @@ * 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 let t1 = Util.Timer.make () in - let p = + let p,d = match input_file with None -> Parse_bytecode.from_channel ~paths stdin @@ -38,15 +36,22 @@ 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 = 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 -> - let ch = open_out_bin f in - output_program (Pretty_print.to_out_channel ch); - close_out ch + | Some f -> + 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); + close_out ch; + (try Sys.remove f with _ -> ()); + Util.move_file f_tmp f + with exc -> + Sys.remove f_tmp; + Format.eprintf "compilation error: %s@." (Printexc.to_string exc); + raise exc end; if times () then Format.eprintf "compilation: %a@." Util.Timer.print t @@ -57,15 +62,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, " debug module "); + [("-debug", Arg.String Option.Debug.set, " debug module "); ("-disable", - Arg.String Util.set_disabled, " disable optimization "); - ("-pretty", Arg.Unit Driver.set_pretty, " pretty print the output"); - ("-debuginfo", Arg.Unit Driver.set_debug_info, " output debug info"); + Arg.String Option.Optim.disable, " disable optimization "); + ("-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, " 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"); @@ -86,7 +92,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..c5698418e5 --- /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:false + 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:true + let constant = o ~name:"constant" ~default:true +end diff --git a/compiler/parse_bytecode.ml b/compiler/parse_bytecode.ml index 0d27610ab5..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,10 +226,6 @@ module Debug = struct end -let keep_variable_names = ref false - -let set_pretty () = keep_variable_names := true; Code.Var.set_pretty () - (****) type globals = @@ -270,12 +266,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 @@ -350,18 +345,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) @@ -387,7 +382,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 @@ -1767,7 +1762,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 Option.Optim.pretty () 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/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..e79458146a --- /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 + 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 -> + 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..bac7e5a107 --- /dev/null +++ b/compiler/parser_js.mly @@ -0,0 +1,780 @@ +/* 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 TCommentSpace TCommentNewline TComment + +/*(*-----------------------------------------*)*/ +/*(*2 the normal tokens *)*/ +/*(*-----------------------------------------*)*/ + +/*(* tokens with a value *)*/ +%token T_NUMBER +%token T_IDENTIFIER +%token T_STRING +%token T_REGEX + +/*(* keywords tokens *)*/ +%token + 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 T_ELSE + +%token T_NEW + +/*(* syntax *)*/ +%token + T_LCURLY T_RCURLY + T_LPAREN T_RPAREN + T_LBRACKET T_RBRACKET + T_SEMICOLON + T_COMMA + T_PERIOD + +/*(* operators *)*/ +%token + 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 + 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 T_VIRTUAL_SEMICOLON + +/*(* classic *)*/ +%token TUnknown +%token 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 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.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.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 + { 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.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.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 + { 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.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.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 + { 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 + 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} + +/*(*----------------------------*)*/ +/*(*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 } 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/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..ad3f2ecfe0 --- /dev/null +++ b/compiler/reserved.ml @@ -0,0 +1,44 @@ + + + +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"; + "Object"; + "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/specialize.ml b/compiler/specialize.ml new file mode 100644 index 0000000000..5fd1b0095d --- /dev/null +++ b/compiler/specialize.ml @@ -0,0 +1,33 @@ +open Code +open Flow + +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)) + | _ -> + 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 diff --git a/compiler/specialize_js.ml b/compiler/specialize_js.ml new file mode 100644 index 0000000000..e6a926dbf5 --- /dev/null +++ b/compiler/specialize_js.ml @@ -0,0 +1,155 @@ +open Code +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)) -> + 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 (specialize_instr info) block.body; + }) + blocks + in + (pc, blocks, free_pc) + +(****) + +let f p info = + let p = specialize_instrs info p in + p 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 6b69acdf8d..d91aa99bf5 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 @@ -52,38 +53,28 @@ 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 s = - let state = ref false in - 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 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 @@ -93,3 +84,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 ?(pretty=false) () = + let t = { + names = Hashtbl.create 107; + known = Hashtbl.create 1001; + last = -1; + pretty; + } in + reset t; t +end diff --git a/compiler/util.mli b/compiler/util.mli index 4b2d66ed8a..8dfe06c4b0 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 @@ -30,11 +31,7 @@ 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 : string -> unit -> bool -val set_disabled : string -> unit +val move_file : string -> string -> unit module Timer : sig type t @@ -43,3 +40,15 @@ module Timer : sig val get : t -> float val print : Format.formatter -> t -> unit end + +module VarPrinter : sig + type t + + val create : ?pretty:bool -> 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 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 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" ] diff --git a/runtime/mlString.js b/runtime/mlString.js index abaffd5112..55ba96cd14 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 (); @@ -253,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); @@ -305,3 +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: caml_new_string +//Requires: MlString +function caml_new_string(x){return new MlString(x);} 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