[refact] using smart constructors for all lambda construction

Author: Hongbo Zhang

.travis-ci-before-script.sh

@@ -6,4 +6,4 @@ cd ocaml &&  ./configure -prefix $(dirname $(pwd))  -no-ocamldoc -no-ocamlbuild
 
 export PATH=$(pwd)/bin:$PATH
 
-cd jscomp && make world-test
+cd jscomp && make travis-world-test

jscomp/Makefile

@@ -120,7 +120,14 @@ world-test:
 	@echo "Making test"
 	cd test && make all
 	@echo "Making test finsihed"
- 
+
+travis-world-test:./bin/ocaml_pack
+	@echo "Generating the compiler"
+	rm -f bin/compiler.ml 	
+	./bin/ocaml_pack ./compiler.mllib > bin/compiler.ml
+	@echo "Generating the compiler finished"	
+	make world-test
+
 .PHONY: stdlib
 .PHONY: test  quicktest release snapshot snapshotcmj
 

jscomp/lam_beta_reduce.ml

@@ -109,17 +109,17 @@ let rewrite (map :   (Ident.t, _) Hashtbl.t)
       let l1 = aux l1 in
       let xs = List.map rebind xs in
       let l2 = aux l2 in
-      Lstaticcatch(l1, (i,xs), l2)
+      Lam_comb.staticcatch l1 (i,xs) l2
     | Lfor(ident, l1, l2, dir, l3) ->
       let ident = rebind ident in 
       let l1 = aux l1 in
       let l2 = aux l2 in
       let l3 = aux l3 in
-      Lfor(ident,aux  l1,  l2, dir,  l3)
+      Lam_comb.for_ ident (aux  l1)  l2 dir  l3
     | Lconst _ -> lam
     | Lprim(prim, ll) ->
       (* here it makes sure that global vars are not rebound *)      
-      Lprim(prim, List.map aux  ll)
+      Lam_comb.prim prim (List.map aux  ll)
     | Lapply(fn, args, info) ->
       let fn = aux fn in       
       let args = List.map aux  args in 
@@ -131,25 +131,26 @@ let rewrite (map :   (Ident.t, _) Hashtbl.t)
                   sw_numconsts;
                  }) ->
       let l = aux l in
-      Lswitch(l,
+      Lam_comb.switch l
               {sw_consts = 
                  List.map (fun (v, l) -> v, aux  l) sw_consts;
                sw_blocks = List.map (fun (v, l) -> v, aux  l) sw_blocks;
                sw_numconsts = sw_numconsts;
                sw_numblocks = sw_numblocks;
                sw_failaction =  option_map sw_failaction
-              })
+              }
     | Lstringswitch(l, sw, d) ->
       let l = aux  l in
       Lam_comb.stringswitch l 
                      (List.map (fun (i, l) -> i,aux  l) sw)
                      (option_map d)
-    | Lstaticraise (i,ls) -> Lstaticraise(i, List.map aux  ls)
+    | Lstaticraise (i,ls) 
+      -> Lam_comb.staticraise i (List.map aux  ls)
     | Ltrywith(l1, v, l2) -> 
       let l1 = aux l1 in
       let v = rebind v in
       let l2 = aux l2 in
-      Ltrywith(l1,v, l2)
+      Lam_comb.try_ l1 v l2
     | Lifthenelse(l1, l2, l3) -> 
       let l1 = aux l1 in
       let l2 = aux l2 in
@@ -158,23 +159,25 @@ let rewrite (map :   (Ident.t, _) Hashtbl.t)
     | Lsequence(l1, l2) -> 
       let l1 = aux l1 in
       let l2 = aux l2 in
-      Lsequence(  l1,   l2)
+      Lam_comb.seq l1 l2
     | Lwhile(l1, l2) -> 
       let l1 = aux l1 in
       let l2 = aux l2 in
-      Lwhile(  l1,  l2)
-    | Lassign(v, l) -> Lassign(v,aux  l)
+      Lam_comb.while_  l1  l2
+    | Lassign(v, l) 
+      -> Lam_comb.assign v (aux  l)
     | Lsend(u, m, o, ll, v) ->
       let m = aux m in 
       let o = aux o in 
       let ll = List.map aux ll in
-      Lsend(u,  m,  o,  ll,v)
+      Lam_comb.send u  m  o  ll v
     | Levent(l, event) ->
       let l = aux l in
-      Levent(  l, event)
+      Lam_comb.event  l event
     | Lifused(v, l) -> 
       let l = aux l in 
-      Lifused(v,  l) in 
+      Lam_comb.ifused v  l
+  in 
   aux lam
 
 

jscomp/lam_beta_reduce_util.ml

@@ -79,8 +79,8 @@ let simple_beta_reduce params body args =
       let result = 
         Hashtbl.fold (fun _param {lambda; used} code -> 
             if not used then
-              Lambda.Lsequence(lambda, code)
-            else code) param_hash (Lambda.Lprim (primitive, us)) in 
+              Lam_comb.seq lambda code
+            else code) param_hash (Lam_comb.prim primitive us) in 
       Hashtbl.clear param_hash;
       Some result 
     | exception _ -> 
@@ -104,7 +104,7 @@ let simple_beta_reduce params body args =
           Hashtbl.fold 
             (fun _param {lambda; used} code -> 
                if not used then 
-                 Lambda.Lsequence(lambda, code)
+                 Lam_comb.seq lambda code
                else code )
             param_hash (Lambda.Lapply ( f, us , info)) in
         Hashtbl.clear param_hash;

jscomp/lam_comb.ml

@@ -27,14 +27,18 @@
 
 
 type t = Lambda.lambda
+
 type binop = t -> t -> t 
+
 type triop = t -> t -> t -> t 
+
 type unop = t -> t 
-let if_ a (b : t) c = 
+
+let if_ (a : t) (b : t) c = 
   match a with
-  | Lambda.Lconst v ->
+  | Lconst v ->
     begin match v with
-    | Const_pointer (x, _)  | Lambda.Const_base(Const_int x)
+    | Const_pointer (x, _)  | Const_base(Const_int x)
       ->
       if x <> 0 then b else c
     | Const_base (Const_char x) ->
@@ -50,14 +54,14 @@ let if_ a (b : t) c =
     | Const_float_array _
     | Const_immstring _ -> b
     end
-  | _ ->  Lambda.Lifthenelse (a,b,c)
+  | _ ->  Lifthenelse (a,b,c)
 
-let switch lam lam_switch = 
-  Lambda.Lswitch(lam,lam_switch)
+let switch lam lam_switch : t = 
+  Lswitch(lam,lam_switch)
 
-let stringswitch lam cases default = 
+let stringswitch (lam : t) cases default : t = 
   match lam with
-  | Lambda.Lconst (Lambda.Const_base (Const_string (a,_))) ->
+  | Lconst (Const_base (Const_string (a,_))) ->
     begin
       try List.assoc a cases with Not_found ->
         begin
@@ -66,27 +70,56 @@ let stringswitch lam cases default =
           | None -> assert false
         end
     end
-  | _ -> Lambda.Lstringswitch(lam, cases, default)
+  | _ -> Lstringswitch(lam, cases, default)
 
 
-let true_ : Lambda.lambda =
+let true_ : t =
   Lconst (Const_pointer ( 1, Pt_constructor "true")) 
 
-let false_ : Lambda.lambda =
+let false_ : t =
   Lconst (Const_pointer( 0, Pt_constructor "false"))
 
-let unit : Lambda.lambda = 
+let unit : t = 
   Lconst (Const_pointer( 0, Pt_constructor "()"))
 
-let not x : t = 
-  Lambda.Lprim (Pnot, [x])
 
 (** [l || r ] *)
 let sequor l r = if_ l true_ r 
 
 (** [l && r ] *)
 let sequand l r = if_ l r false_
 
+let seq a b : t = 
+  Lsequence (a, b)
+
+let while_ a b : t  = 
+  Lwhile(a,b)
+
+let try_  body id  handler : t = 
+  Ltrywith(body,id,handler)
+
+let for_ v e1 e2 dir e3 : t  = 
+  Lfor(v,e1,e2,dir,e3)
+
+let event l (_event : Lambda.lambda_event) = l 
+
+let ifused v l : t  = 
+  Lifused (v,l)
+
+let assign v l : t = Lassign(v,l)
+
+let send u m o ll v : t = 
+  Lsend(u, m, o, ll, v)
+
+let staticcatch  a b c : t = Lstaticcatch(a,b,c)
+
+let staticraise a b : t = Lstaticraise(a,b)
+
+let prim prim ll : t = Lprim(prim,ll)
+
+let not x : t = 
+  prim Pnot [x]
+
 module Prim = struct 
   type t = Lambda.primitive
   let js_is_nil : t = 

jscomp/lam_comb.mli

@@ -42,6 +42,28 @@ val unit : t
 val sequor : binop
 val sequand : binop
 val not : unop
+val seq : binop
+val while_ : binop
+val event : t -> Lambda.lambda_event -> t  
+val try_ : t -> Ident.t -> t  -> t 
+val ifused : Ident.t -> t -> t
+val assign : Ident.t -> t -> t 
+
+val send : 
+  Lambda.meth_kind ->
+  t -> t -> t list -> 
+  Location.t -> t 
+val prim : Lambda.primitive -> t list -> t
+val staticcatch : 
+  t -> int * Ident.t list -> t -> t
+
+val staticraise : 
+  int -> t list -> t
+
+val for_ : 
+  Ident.t ->
+  t  ->
+  t -> Asttypes.direction_flag -> t -> t 
 
 module Prim : sig 
   type t = Lambda.primitive

jscomp/lam_compile_global.ml

@@ -38,18 +38,22 @@ open Js_output.Ops
    Make(S), S can not be an exception
  *)
 
+
+(* TODO: add module into taginfo*)
+(* let len = List.length sigs in  *)
+(* TODO: could be optimized *)
+
 let query_lambda id env = 
   Lam_compile_env.query_and_add_if_not_exist (Lam_module_ident.of_ml id) 
     (Has_env env)
     ~not_found:(fun id -> assert false)
     ~found:(fun {signature = sigs; _} -> 
-        (* TODO: add module into taginfo*)
-        (* let len = List.length sigs in  *)
-        (* TODO: could be optimized *)
-        Lambda.Lprim (Pmakeblock(0, Blk_na, Immutable) , 
+        Lam_comb.prim (Pmakeblock(0, Blk_na, Immutable))  
                       (List.mapi (fun i _ -> 
-                           Lambda.Lprim(Pfield (i, Lambda.Fld_na), [Lprim(Pgetglobal id,[])])))
-                        sigs))
+                           Lam_comb.prim (Pfield (i, Lambda.Fld_na)) 
+                             [Lam_comb.prim (Pgetglobal id) [] ])
+                        sigs)
+      )
 
 
 (* Given an module name and position, find its corresponding name  *)  

jscomp/lam_group.ml

@@ -100,7 +100,7 @@ let rec flatten
 let lambda_of_groups result groups = 
   List.fold_left (fun acc x -> 
       match x with 
-      | Nop l -> Lambda.Lsequence(l,acc)
+      | Nop l -> Lam_comb.seq l acc
       | Single(kind,ident,lam) -> Lam_util.refine_let ~kind ident lam acc
       | Recursive bindings -> Lletrec (bindings,acc)) 
     result groups
@@ -138,7 +138,9 @@ let deep_flatten
                             [arg]), body)
       -> 
       let id' = Ident.rename id in 
-      flatten acc (Llet (str, id', arg, Llet(Alias, id, Lprim(Pccall p , [Lvar id']), body)))
+      flatten acc (Llet (str, id', arg, 
+                         Llet(Alias, id, Lam_comb.prim (Pccall p)  [Lvar id'], body)
+                        ))
     | Llet (str,id,arg,body) -> 
       let (res,l) = flatten acc arg  in
       flatten (Single(str, id, res ) :: l) body
@@ -268,7 +270,7 @@ let deep_flatten
             result 
             (* List.map (fun (id,lam) -> (id, aux lam )) bind_args *), 
             aux body)) (List.rev wrap)
-    | Lsequence (l,r) -> Lsequence(aux l, aux r)
+    | Lsequence (l,r) -> Lam_comb.seq (aux l) (aux r)
     | Lconst _ -> lam
     | Lvar _ -> lam 
     (* | Lapply(Lfunction(Curried, params, body), args, _) *)
@@ -310,7 +312,7 @@ let deep_flatten
         | Pdirapply loc, [Levent (Lapply (f, args, _),_); x] ->
           Lapply (f, args@[x], Lambda.default_apply_info ~loc ())
         | Pdirapply loc, [f; x] -> Lapply (f, [x], Lambda.default_apply_info ~loc ())
-        | _ -> Lprim(p,ll)
+        | _ -> Lam_comb.prim p ll
       end
     | Lfunction(kind, params, l) -> Lfunction (kind, params , aux  l)
     | Lswitch(l, {sw_failaction; 
@@ -319,7 +321,7 @@ let deep_flatten
                   sw_numblocks;
                   sw_numconsts;
                  }) ->
-      Lswitch(aux  l,
+      Lam_comb.switch (aux  l)
               {sw_consts = 
                  List.map (fun (v, l) -> v, aux  l) sw_consts;
                sw_blocks = List.map (fun (v, l) -> v, aux  l) sw_blocks;
@@ -330,26 +332,36 @@ let deep_flatten
                    match sw_failaction with 
                    | None -> None
                    | Some x -> Some (aux x)
-                 end})
+                 end}
     | Lstringswitch(l, sw, d) ->
       Lam_comb.stringswitch (aux  l) 
                     (List.map (fun (i, l) -> i,aux  l) sw)
                     (match d with
                      | Some d -> Some (aux d )
                      | None -> None)
 
-    | Lstaticraise (i,ls) -> Lstaticraise(i, List.map (aux ) ls)
-    | Lstaticcatch(l1, (i,x), l2) -> Lstaticcatch(aux  l1, (i,x), aux  l2)
-    | Ltrywith(l1, v, l2) -> Ltrywith(aux  l1,v, aux  l2)
-    | Lifthenelse(l1, l2, l3) -> 
+    | Lstaticraise (i,ls) 
+      -> Lam_comb.staticraise i (List.map aux  ls)
+    | Lstaticcatch(l1, ids, l2) 
+      -> 
+      Lam_comb.staticcatch (aux  l1) ids (aux  l2)
+    | Ltrywith(l1, v, l2) ->
+      Lam_comb.try_ (aux  l1) v (aux  l2)
+    | Lifthenelse(l1, l2, l3) 
+      -> 
       Lam_comb.if_ (aux  l1) (aux l2) (aux l3)
-    | Lwhile(l1, l2) -> Lwhile(aux  l1, aux l2)
-    | Lfor(flag, l1, l2, dir, l3) -> Lfor(flag,aux  l1, aux  l2, dir, aux  l3)
+    | Lwhile(l1, l2) 
+      -> 
+      Lam_comb.while_ (aux  l1) (aux l2)
+    | Lfor(flag, l1, l2, dir, l3) 
+      -> 
+      Lam_comb.for_ flag (aux  l1) (aux  l2) dir (aux  l3)
     | Lassign(v, l) ->
       (* Lalias-bound variables are never assigned, so don't increase
          v's refaux *)
-      Lassign(v,aux  l)
-    | Lsend(u, m, o, ll, v) -> Lsend(u, aux m, aux o, List.map aux ll,v)
+      Lam_comb.assign v (aux  l)
+    | Lsend(u, m, o, ll, v) -> 
+      Lam_comb.send u (aux m) (aux o) (List.map aux ll) v
 
     (* Levent(aux  l, event) *)
     | Lifused(v, l) -> Lifused(v,aux  l)