complete -- except we need a convert function from ocaml lambda to bs lambda

Author: Hongbo Zhang

jscomp/core.mllib

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

jscomp/js_implementation.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/lam.ml

@@ -23,16 +23,21 @@
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
 
 type primitive = Lambda.primitive
-
-type t = Lambda.lambda = 
+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 * Lambda.lambda_switch
+  | 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
@@ -93,7 +98,16 @@ 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
@@ -353,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/lam.mli

@@ -23,15 +23,23 @@
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
 
 type primitive = Lambda.primitive
-type t = Lambda.lambda = 
+
+
+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 * Lambda.lambda_switch
+  | 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
@@ -60,8 +68,14 @@ 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 
@@ -94,3 +108,6 @@ val for_ :
   t  ->
   t -> Asttypes.direction_flag -> t -> t 
 
+val free_variables : t -> Lambda.IdentSet.t
+
+val subst_lambda : t Ident.tbl -> t -> t

jscomp/lam_beta_reduce.ml

@@ -73,7 +73,7 @@ let rewrite (map :   (Ident.t, _) Hashtbl.t)
 
   let rebind i = 
     let i' = Ident.rename i in 
-    Hashtbl.add map i (Lambda.Lvar i');
+    Hashtbl.add map i (Lam.var i');
     i' in
   (* order matters, especially for let bindings *)
   let rec 
@@ -92,17 +92,17 @@ let rewrite (map :   (Ident.t, _) Hashtbl.t)
       let v = rebind v in
       let l1 = aux l1 in      
       let l2 = aux l2 in
-      Llet(str, v,  l1,  l2 )
+      Lam.let_ str v  l1  l2 
     | Lletrec(bindings, body) ->
       (*order matters see GPR #405*)
       let vars = List.map (fun (k, _) -> rebind k) bindings in 
       let bindings = List.map2 (fun var (_,l) -> var, aux l) vars bindings in 
       let body = aux body in       
-      Lletrec(bindings, body) 
+      Lam.letrec bindings body
     | Lfunction(kind, params, body) -> 
       let params =  List.map rebind params in
       let body = aux body in      
-      Lfunction (kind, params, body)
+      Lam.function_ kind params body
     | Lstaticcatch(l1, (i,xs), l2) -> 
       let l1 = aux l1 in
       let xs = List.map rebind xs in
@@ -121,7 +121,7 @@ let rewrite (map :   (Ident.t, _) Hashtbl.t)
     | Lapply(fn, args, info) ->
       let fn = aux fn in       
       let args = List.map aux  args in 
-      Lapply(fn, args, info)
+      Lam.apply fn  args info
     | Lswitch(l, {sw_failaction; 
                   sw_consts; 
                   sw_blocks;
@@ -219,7 +219,7 @@ let propogate_beta_reduce
          | Lvar _  -> rest_bindings , arg :: acc 
          | _ -> 
            let p = Ident.rename old_param in 
-           (p,arg) :: rest_bindings , (Lambda.Lvar p) :: acc 
+           (p,arg) :: rest_bindings , (Lam.var p) :: acc 
       )  ([],[]) params args in
   let new_body = rewrite (Ext_hashtbl.of_list2 (List.rev params) (rev_new_params)) body in
   List.fold_right
@@ -261,7 +261,7 @@ let propogate_beta_reduce_with_map
            (* TODO: we can pass Global, but you also need keep track of it*)
            ->
            let p = Ident.rename old_param in 
-           (p,arg) :: rest_bindings , (Lambda.Lvar p) :: acc 
+           (p,arg) :: rest_bindings , (Lam.var p) :: acc 
 
          | _ -> 
            if  Lam_analysis.no_side_effects arg then
@@ -273,11 +273,11 @@ let propogate_beta_reduce_with_map
                  rest_bindings, arg :: acc                
                | _  ->  
                  let p = Ident.rename old_param in 
-                 (p,arg) :: rest_bindings , (Lambda.Lvar p) :: acc 
+                 (p,arg) :: rest_bindings , (Lam.var p) :: acc 
              end
            else
              let p = Ident.rename old_param in 
-             (p,arg) :: rest_bindings , (Lambda.Lvar p) :: acc 
+             (p,arg) :: rest_bindings , (Lam.var p) :: acc 
       )  ([],[]) params args in
   let new_body = rewrite (Ext_hashtbl.of_list2 (List.rev params) (rev_new_params)) body in
   List.fold_right

jscomp/lam_beta_reduce_util.ml

@@ -106,7 +106,7 @@ let simple_beta_reduce params body args =
                if not used then 
                  Lam.seq lambda code
                else code )
-            param_hash (Lambda.Lapply ( f, us , info)) in
+            param_hash (Lam.apply  f us  info) in
         Hashtbl.clear param_hash;
         Some result 
       | exception _ -> 

jscomp/lam_compile.ml

@@ -312,7 +312,7 @@ and compile_recursive_let
           E.fun_ params (Js_output.to_block output )
       ), [] 
   | Lprim (Pmakeblock (0, _, _) , ls)
-    when List.for_all (function  | Lambda.Lvar _  -> true | _ -> false) ls 
+    when List.for_all (function  | Lam.Lvar _  -> true | _ -> false) ls 
     ->
     (* capture cases like for {!Queue}
        {[let rec cell = { content = x; next = cell} ]}
@@ -321,7 +321,7 @@ and compile_recursive_let
       S.define ~kind:Variable id (E.arr Mutable []) :: 
       (List.mapi (fun i x -> 
           match x with  
-          | Lambda.Lvar lid
+          | Lam.Lvar lid
             -> S.exp 
                  (Js_array.set_array (E.var id) (E.int (Int32.of_int i)) (E.var lid))
           | _ -> assert false
@@ -509,7 +509,7 @@ and
          see {!Ari_regress_test}         
       *)      
       compile_lambda  cxt  
-        (Lapply (an, (args' @ args), (Lam_util.mk_apply_info App_na)))
+        (Lam.apply an (args' @ args) (Lam_util.mk_apply_info App_na))
     (* External function calll *)
     | Lapply(Lprim(Pfield (n,_), [ Lprim(Pgetglobal id,[])]), args_lambda,
              {apply_status = App_na | App_ml_full}) ->
@@ -856,9 +856,10 @@ and
               {block = block1; value = Some value}, Public (Some setter) 
               ->
               if not @@ Ext_string.ends_with setter Literals.setter_suffix then 
-                compile_lambda cxt @@ Lapply (fn, [arg] , 
-                                              {apply_loc = Location.none;
-                                               apply_status = App_js_full})
+                compile_lambda cxt @@ 
+                Lam.apply fn [arg]  
+                  {apply_loc = Location.none;
+                   apply_status = App_js_full}
               else 
                 let property =
                   String.sub setter 0 
@@ -877,9 +878,9 @@ and
 
         | fn :: rest -> 
           compile_lambda cxt 
-            (Lapply (fn, rest , 
+            (Lam.apply fn rest 
                      {apply_loc = Location.none;
-                      apply_status = App_js_full}))
+                      apply_status = App_js_full})
         | _ -> assert false 
       else 
         begin match args_lambda with 
@@ -904,27 +905,28 @@ and
               begin 
                 match fn with 
                 | Lfunction (_, [_], body)
-                  -> compile_lambda cxt (Lfunction (Curried, [], body))
+                  -> compile_lambda cxt (Lam.function_ Curried [] body)
                 | _ -> 
                   compile_lambda cxt  
-                    (Lfunction (Lambda.Curried, [],
-                                Lambda.Lapply(fn,
-                                              [Lam.unit],
-                                              Lam_util.default_apply_info
-                                             )))
+                    (Lam.function_ Lambda.Curried [] 
+                     @@ 
+                       Lam.apply fn
+                         [Lam.unit]
+                     Lam_util.default_apply_info
+                    )
               end
             else 
               begin match fn with
-                | Lambda.Lfunction(kind,args, body) 
+                | Lam.Lfunction(kind,args, body) 
                   ->
                   let len =  List.length args in 
                   if len = arity then
                     compile_lambda cxt fn 
                   else if len > arity then 
                     let first, rest  = Ext_list.take arity args  in 
                     compile_lambda cxt 
-                      (Lambda.Lfunction 
-                         (kind, first, Lambda.Lfunction (kind, rest, body)))
+                      (Lam.function_
+                         kind first (Lam.function_ kind rest body))
                   else 
                     compile_lambda cxt 
                       (Lam_util.eta_conversion arity Lam_util.default_apply_info  
@@ -1488,7 +1490,7 @@ and
                       cont, _reraise )
         )) when Ident.same id id2 
       -> 
-      compile_lambda cxt (Ltrywith(body, id, cont))
+      compile_lambda cxt (Lam.try_ body id cont)
     | Ltrywith(lam,id, catch) ->  (* generate documentation *)
       (* 
          tail --> should be renamed to `shouldReturn`  

jscomp/lam_dce.ml

@@ -39,7 +39,8 @@ let remove export_idents (rest : Lam_group.t list) : Lam_group.t list  =
       match x with
       | Single(kind, id,lam) -> (* assert false *)
           begin
-            Hashtbl.add ident_free_vars id (Lambda.free_variables lam);
+            Hashtbl.add ident_free_vars id 
+              (Lam.free_variables  lam);
             match kind with
             | Alias | StrictOpt -> []
             | Strict | Variable -> [id]
@@ -48,7 +49,7 @@ let remove export_idents (rest : Lam_group.t list) : Lam_group.t list  =
           begin
             bindings |> Ext_list.flat_map (fun (id,lam) ->
               begin
-                Hashtbl.add ident_free_vars id (Lambda.free_variables lam);
+                Hashtbl.add ident_free_vars id (Lam.free_variables lam);
                 match (lam : Lam.t) with
                 | Lfunction _ -> []
                 | _ -> [id]
@@ -58,7 +59,7 @@ let remove export_idents (rest : Lam_group.t list) : Lam_group.t list  =
           if Lam_analysis.no_side_effects lam then []
           else 
             (** its free varaibles here will be defined above *)
-            I.elements ( Lambda.free_variables lam)) rest  @ export_idents
+            I.elements ( Lam.free_variables lam)) rest  @ export_idents
   in
   let current_ident_sets = 
     Idents_analysis.calculate_used_idents ident_free_vars