Merge pull request #440 from bloomberg/bs_lambda

provide indirection for lambda -> bs_lambda

Author: bobzhang

jscomp/bin/compiler.ml

@@ -7,9 +7,9 @@ config_util
 
 
 
-
+lam
 lam_mk
-lam_comb
+lam_print
 lam_compile_env
 lam_dispatch_primitive
 lam_stats

jscomp/compiler.odocl

@@ -32,7 +32,7 @@
 (* TODO: add a magic number *)
 type cmj_value = {
   arity : Lam_stats.function_arities ;
-  closed_lambda : Lambda.lambda option ; 
+  closed_lambda : Lam.t option ; 
   (** Either constant or closed functor *)
 }
 

jscomp/core.mllib

@@ -54,7 +54,7 @@
 
 type cmj_value = {
   arity : Lam_stats.function_arities ;
-  closed_lambda : Lambda.lambda option ; 
+  closed_lambda : Lam.t option ; 
   (* Either constant or closed functor *)
 }
 

jscomp/js_cmj_format.ml

@@ -76,7 +76,7 @@ let implementation ppf sourcefile outputprefix =
           match           
           Lam_compile_group.lambda_as_module
             finalenv current_signature 
-            sourcefile  outputprefix lambda with
+            sourcefile  outputprefix ((* Obj.magic *) lambda ) with
           | e -> e 
           | exception e -> 
             (* Save to a file instead so that it will not scare user *)            

jscomp/js_cmj_format.mli

@@ -80,7 +80,7 @@ let handle_name_tail
 let handle_block_return 
     (st : st) 
     (should_return : Lam_compile_defs.return_type)
-    (lam : Lambda.lambda) (block : J.block) exp : t = 
+    (lam : Lam.t) (block : J.block) exp : t = 
   match st, should_return with 
   | Declare (kind,n), False -> 
     make (block @ [ S.define ~kind  n exp])

jscomp/js_implementation.ml

@@ -68,12 +68,12 @@ val dummy : t
 val handle_name_tail :
     Lam_compile_defs.st ->
     Lam_compile_defs.return_type ->
-    Lambda.lambda ->  J.expression -> t
+    Lam.t ->  J.expression -> t
 
 val handle_block_return : 
     Lam_compile_defs.st ->
     Lam_compile_defs.return_type ->
-    Lambda.lambda ->
+    Lam.t ->
     J.block -> J.expression -> t
 
 val concat : t list -> t

jscomp/js_output.ml

@@ -347,7 +347,7 @@ let try_ ?comment   ?with_ ?finally body : t =
     comment
   }
 
-let unknown_lambda ?(comment="unknown")  (lam : Lambda.lambda ) : t = 
+let unknown_lambda ?(comment="unknown")  (lam : Lam.t ) : t = 
   exp @@ E.str ~comment ~pure:false (Lam_util.string_of_lambda lam) 
 
 (* TODO: 

jscomp/js_output.mli

@@ -95,7 +95,7 @@ val exp : ?comment:string  -> J.expression -> t
 
 val return : ?comment:string  -> J.expression -> t
 
-val unknown_lambda : ?comment:string  -> Lambda.lambda -> t
+val unknown_lambda : ?comment:string  -> Lam.t -> t
 
 val return_unit : ?comment:string -> unit -> t
 (** for ocaml function which returns unit 

jscomp/js_stmt_make.ml

@@ -22,24 +22,40 @@
  * along with this program; if not, write to the Free Software
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
 
-
-
-
-
-type t = Lambda.lambda
-
-type binop = t -> t -> t 
-
-type triop = t -> t -> t -> t 
-
-type unop = t -> t 
-
+type primitive = Lambda.primitive
+type switch = Lambda.lambda_switch = 
+  { sw_numconsts: int;
+    sw_consts: (int * t) list;
+    sw_numblocks: int;
+    sw_blocks: (int * t) list;
+    sw_failaction : t option}
+and t = Lambda.lambda = 
+  | Lvar of Ident.t
+  | Lconst of Lambda.structured_constant
+  | Lapply of t * t list * Lambda.apply_info
+  | Lfunction of Lambda.function_kind * Ident.t list * t
+  | Llet of Lambda.let_kind * Ident.t * t * t
+  | Lletrec of (Ident.t * t) list * t
+  | Lprim of primitive * t list
+  | Lswitch of t * switch
+  | Lstringswitch of t * (string * t) list * t option
+  | Lstaticraise of int * t list
+  | Lstaticcatch of t * (int * Ident.t list) * t
+  | Ltrywith of t * Ident.t * t
+  | Lifthenelse of t * t * t
+  | Lsequence of t * t
+  | Lwhile of t * t
+  | Lfor of Ident.t * t * t * Asttypes.direction_flag * t
+  | Lassign of Ident.t * t
+  | Lsend of Lambda.meth_kind * t * t * t list * Location.t
+  | Levent of t * Lambda.lambda_event
+  | Lifused of Ident.t * t
 
 
 module Prim = struct 
-  type t = Lambda.primitive
+  type t = primitive
   let js_is_nil : t = 
-    Lambda.Pccall{ prim_name = "js_is_nil";
+    Pccall{ prim_name = "js_is_nil";
                    prim_arity = 1 ;
                    prim_alloc = false;
                    prim_native_name = "js_is_nil";
@@ -49,7 +65,7 @@ module Prim = struct
                  }
 
   let js_is_undef : t = 
-    Lambda.Pccall{ prim_name = "js_is_undef";
+    Pccall{ prim_name = "js_is_undef";
                    prim_arity = 1 ;
                    prim_alloc = false;
                    prim_native_name = "js_is_undef";
@@ -59,7 +75,7 @@ module Prim = struct
                  }
 
   let js_is_nil_undef : t  = 
-    Lambda.Pccall{ prim_name = "js_is_nil_undef";
+    Pccall{ prim_name = "js_is_nil_undef";
                    prim_arity = 1 ;
                    prim_alloc = false;
                    prim_native_name = "js_is_nil_undef";
@@ -70,6 +86,29 @@ module Prim = struct
 
 end
 
+
+
+
+
+
+type binop = t -> t -> t 
+
+type triop = t -> t -> t -> t 
+
+type unop = t -> t 
+
+
+let var id : t = Lvar id
+let const ct : t = Lconst ct 
+let apply fn args info : t = Lapply(fn,args, info)
+let function_ kind ids body : t = 
+  Lfunction(kind, ids, body)
+
+let let_ kind id e body :  t 
+  = Llet (kind,id,e,body)
+let letrec bindings body : t = 
+  Lletrec(bindings,body)
+
 let if_ (a : t) (b : t) c = 
   match a with
   | Lconst v ->
@@ -328,3 +367,8 @@ let prim (prim : Prim.t) (ll : t list) : t =
 
 let not x : t = 
   prim Pnot [x]
+
+
+let free_variables  = Lambda.free_variables
+
+let subst_lambda = Lambda.subst_lambda

jscomp/js_stmt_make.mli

@@ -22,17 +22,60 @@
  * along with this program; if not, write to the Free Software
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
 
+type primitive = Lambda.primitive
+
+
+type switch = Lambda.lambda_switch =
+  { sw_numconsts: int;
+    sw_consts: (int * t) list;
+    sw_numblocks: int;
+    sw_blocks: (int * t) list;
+    sw_failaction : t option}
+and  t = Lambda.lambda =  private
+  | Lvar of Ident.t
+  | Lconst of Lambda.structured_constant
+  | Lapply of t * t list * Lambda.apply_info
+  | Lfunction of Lambda.function_kind * Ident.t list * t
+  | Llet of Lambda.let_kind * Ident.t * t * t
+  | Lletrec of (Ident.t * t) list * t
+  | Lprim of primitive * t list
+  | Lswitch of t * switch
+  | Lstringswitch of t * (string * t) list * t option
+  | Lstaticraise of int * t list
+  | Lstaticcatch of t * (int * Ident.t list) * t
+  | Ltrywith of t * Ident.t * t
+  | Lifthenelse of t * t * t
+  | Lsequence of t * t
+  | Lwhile of t * t
+  | Lfor of Ident.t * t * t * Asttypes.direction_flag * t
+  | Lassign of Ident.t * t
+  | Lsend of Lambda.meth_kind * t * t * t list * Location.t
+  | Levent of t * Lambda.lambda_event
+  | Lifused of Ident.t * t
+
+
+module Prim : sig 
+  type t = primitive
+  val js_is_nil : t
+  val js_is_undef : t 
+  val js_is_nil_undef : t 
+end
 
-type t = Lambda.lambda 
 
 type binop = t -> t -> t 
 
 type triop = t -> t -> t -> t 
 
 type unop = t ->  t
 
+val var : Ident.t -> t
+val const : Lambda.structured_constant -> t
+val apply : t -> t list -> Lambda.apply_info -> t
+val function_ : Lambda.function_kind -> Ident.t list -> t -> t
+val let_ : Lambda.let_kind -> Ident.t -> t -> t -> t
+val letrec : (Ident.t * t) list -> t -> t
 val if_ : triop
-val switch : t -> Lambda.lambda_switch  -> t 
+val switch : t -> switch  -> t 
 val stringswitch : t -> (string * t) list -> t option -> t 
 
 val true_ : t 
@@ -65,9 +108,6 @@ val for_ :
   t  ->
   t -> Asttypes.direction_flag -> t -> t 
 
-module Prim : sig 
-  type t = Lambda.primitive
-  val js_is_nil : t 
-  val js_is_undef : t 
-  val js_is_nil_undef : t 
-end
+val free_variables : t -> Lambda.IdentSet.t
+
+val subst_lambda : t Ident.tbl -> t -> t

jscomp/lam_comb.ml renamed to jscomp/lam.ml

@@ -27,7 +27,7 @@
 
 
 
-let rec no_side_effects (lam : Lambda.lambda) : bool = 
+let rec no_side_effects (lam : Lam.t) : bool = 
   match lam with 
   | Lvar _ 
   | Lconst _ 
@@ -227,7 +227,7 @@ let really_big () = raise Too_big_to_inline
 
 let big_lambda = 1000
 
-let rec size (lam : Lambda.lambda) = 
+let rec size (lam : Lam.t) = 
   try 
     match lam with 
     | Lvar _ ->  1
@@ -277,7 +277,7 @@ and size_constant x =
     ->  List.fold_left (fun acc x -> acc + size_constant x ) 0 str
   | Const_float_array xs  -> List.length xs
 
-and size_lams acc (lams : Lambda.lambda list) = 
+and size_lams acc (lams : Lam.t list) = 
   List.fold_left (fun acc l -> acc  + size l ) acc lams
 
 let exit_inline_size = 7 
@@ -286,7 +286,7 @@ let small_inline_size = 5
     Actually this patten is quite common in GADT, people have to write duplicated code 
     due to the type system restriction
 *)
-let rec eq_lambda (l1 : Lambda.lambda) (l2 : Lambda.lambda) =
+let rec eq_lambda (l1 : Lam.t) (l2 : Lam.t) =
   match (l1, l2) with
   | Lvar i1, Lvar i2 -> Ident.same i1 i2
   | Lconst c1, Lconst c2 -> c1 = c2 (* *)
@@ -393,7 +393,7 @@ let free_variables (export_idents : Ident_set.t ) (params : stats Ident_map.t )
       else { env with top = false}
     else env      
   in    
-  let rec iter (top : env) (lam : Lambda.lambda) =
+  let rec iter (top : env) (lam : Lam.t) =
     match lam with 
     | Lvar v -> map_use top v 
     | Lconst _ -> ()
@@ -495,7 +495,7 @@ let is_closed_with_map exports params body =
 (* TODO:  We can relax this a bit later,
     but decide whether to inline it later in the call site
  *)
-let safe_to_inline (lam : Lambda.lambda) = 
+let safe_to_inline (lam : Lam.t) = 
   match lam with 
   | Lfunction _ ->  true
   | Lconst (Const_pointer _  | Const_immstring _ ) -> true

jscomp/lam_comb.mli renamed to jscomp/lam.mli

@@ -30,21 +30,21 @@
 (** A module which provides some basic analysis over lambda expression *)
 
 (** No side effect, but it might depend on data store *)
-val no_side_effects : Lambda.lambda -> bool 
+val no_side_effects : Lam.t -> bool 
 
-val size : Lambda.lambda -> int
+val size : Lam.t -> int
 
-val eq_lambda : Lambda.lambda -> Lambda.lambda -> bool 
+val eq_lambda : Lam.t -> Lam.t -> bool 
 (** a conservative version of comparing two lambdas, mostly 
     for looking for similar cases in switch
  *)
 
 (** [is_closed_by map lam]
     return [true] if all unbound variables
     belongs to the given [map] *)
-val is_closed_by : (* Lambda. *) Ident_set.t -> Lambda.lambda -> bool
+val is_closed_by : (* Lambda. *) Ident_set.t -> Lam.t -> bool
 
-val is_closed : Lambda.lambda -> bool
+val is_closed : Lam.t -> bool
 
 
 
@@ -67,14 +67,14 @@ type stats =
 
 val is_closed_with_map : 
   Ident_set.t ->
-  Ident.t list -> Lambda.lambda -> bool * stats Ident_map.t
+  Ident.t list -> Lam.t -> bool * stats Ident_map.t
 
 val param_map_of_list : Ident.t list -> stats Ident_map.t
 
-val free_variables : Ident_set.t -> stats Ident_map.t -> Lambda.lambda -> stats Ident_map.t
+val free_variables : Ident_set.t -> stats Ident_map.t -> Lam.t -> stats Ident_map.t
 
 val small_inline_size : int 
 val exit_inline_size : int 
 
 
-val safe_to_inline : Lambda.lambda -> bool
+val safe_to_inline : Lam.t -> bool