fix rescript-lang#83 tail call with same arguments

Author: bobzhang

.gitignore

@@ -48,5 +48,6 @@ ocaml/man
 jscomp/bench/*.js
 *.bak
 .vscode
+*.jsx
 osc
 jscomp/pre_load.js

jscomp/compiler.mllib

@@ -73,7 +73,7 @@ js_fun_env
 js_pass_flatten_and_mark_dead
 js_pass_scope
 js_call_info
-
+js_pass_debug
 js_of_lam_float_record
 js_of_lam_record
 js_of_lam_tuple

jscomp/config_util.ml

@@ -44,7 +44,7 @@ let find_cmj file =
       -> Lazy.force v 
     | exception Not_found 
       ->     
-      Ext_log.warn __LOC__ "@[%s not found @]@." file ;
+      Ext_log.warn __LOC__ "@[%s not found @]" file ;
       Js_cmj_format.dummy  (); (* FIXME *)
     end
   end

jscomp/ext_log.ml

@@ -21,41 +21,42 @@
 
 
 
-type ('a,'b) logging =  
-  ('a -> 'b, Format.formatter, unit, unit, unit, unit) format6 -> 'a -> 'b
 
-let err str f v =
-  Format.fprintf Format.err_formatter ("%s " ^^ f) str  v 
+type 'a logging =  ('a, Format.formatter, unit, unit, unit, unit) format6 -> 'a
 
-let ierr b str f v =
+let err str f  =
+  Format.fprintf Format.err_formatter ("%s " ^^ f) str  
+
+let ierr b str f  =
   if b then 
-    Format.fprintf Format.err_formatter ("%s " ^^ f) str  v 
+    Format.fprintf Format.err_formatter ("%s " ^^ f) str  
   else
-    Format.ifprintf Format.err_formatter ("%s " ^^ f) str  v 
+    Format.ifprintf Format.err_formatter ("%s " ^^ f) str  
 
-let warn str f v =
-  Format.fprintf Format.err_formatter ("WARN: %s " ^^ f) str  v 
+let warn str f  =
+  Format.fprintf Format.err_formatter ("WARN: %s " ^^ f ^^ "@.") str  
 
 
 
-let iwarn b str f v = 
+let iwarn b str f  = 
   if b then 
-    Format.fprintf Format.err_formatter ("WARN: %s " ^^ f) str  v 
+    Format.fprintf Format.err_formatter ("WARN: %s " ^^ f) str  
   else 
-    Format.ifprintf Format.err_formatter ("WARN: %s " ^^ f) str  v 
+    Format.ifprintf Format.err_formatter ("WARN: %s " ^^ f) str 
 
-let dwarn str f v = 
+(* TODO: add {[@.]} later for all *)
+let dwarn str f  = 
   if Lam_current_unit.is_same_file () then   
-    Format.fprintf Format.err_formatter ("WARN: %s " ^^ f) str  v 
+    Format.fprintf Format.err_formatter ("WARN: %s " ^^ f ^^ "@.") str  
   else 
-    Format.ifprintf Format.err_formatter ("WARN: %s " ^^ f) str  v 
+    Format.ifprintf Format.err_formatter ("WARN: %s " ^^ f ^^ "@.") str  
 
-let info str f v =
-  Format.fprintf Format.err_formatter ("INFO: %s " ^^ f) str  v 
+let info str f  =
+  Format.fprintf Format.err_formatter ("INFO: %s " ^^ f) str  
 
-let iinfo b str f v =
+let iinfo b str f  =
   if b then 
-    Format.fprintf Format.err_formatter ("INFO: %s " ^^ f) str  v 
+    Format.fprintf Format.err_formatter ("INFO: %s " ^^ f) str  
   else
-    Format.fprintf Format.err_formatter ("INFO: %s " ^^ f) str  v 
+    Format.fprintf Format.err_formatter ("INFO: %s " ^^ f) str  
 

jscomp/ext_log.mli

@@ -29,18 +29,14 @@
  *)
 
 
-type ('a,'b) logging =   ('a -> 'b, Format.formatter, unit, unit, unit, unit) format6 -> 'a -> 'b
-
-(* FIXM: below does not work 
-   {[
-     err __LOC__ "hi"     
-   ]}   
-   
-*)
-val err : string -> ('a,'b) logging
-val ierr : bool -> string -> ('a,'b) logging 
-val warn : string -> ('a,'b) logging
-val iwarn : bool -> string -> ('a,'b) logging 
-val dwarn : string -> ('a,'b) logging 
-val info : string -> ('a,'b) logging
-val iinfo : bool -> string -> ('a,'b) logging
+
+type 'a logging =  ('a, Format.formatter, unit, unit, unit, unit) format6 -> 'a
+
+
+val err : string -> 'a logging
+val ierr : bool -> string -> 'a logging 
+val warn : string -> 'a logging
+val iwarn : bool -> string -> 'a logging 
+val dwarn : string -> 'a logging 
+val info : string -> 'a logging
+val iinfo : bool -> string -> 'a logging

jscomp/js_dump.ml

@@ -1317,46 +1317,46 @@ let exports cxt f (idents : Ident.t list) =
   outer_cxt  
 
 
-let node_program f ( {program ; modules ; } : J.deps_program) = 
-  let cxt = Ext_pp_scope.empty in
-  (* Node style *)
-  let requires cxt f (modules : (Ident.t * string) list ) =
-    P.newline f ; 
-    (* the context used to print the following program *)  
-    let outer_cxt, reversed_list, margin  =
-      List.fold_left
-        (fun (cxt, acc, len) (id,s) ->
-           let str, cxt = str_of_ident cxt id  in
-           cxt, ((str,s) :: acc), (max len (String.length str))
-        )
-        (cxt, [], 0)  modules in
-    P.force_newline f ;    
-    Ext_list.rev_iter (fun (s,file) ->
-        P.string f L.var;
-        P.space f ;
-        P.string f s ;
-        P.nspace f (margin - String.length s + 1) ;
-        P.string f L.eq;
-        P.space f;
-        P.string f L.require;
-        P.paren_group f 0 @@ (fun _ ->
-            pp_string f ~utf:true ~quote:(best_string_quote s) file  );
-        semi f ;
-        P.newline f ;
-      ) reversed_list;
-    outer_cxt
-  in
-
-  let cxt = requires cxt  f modules in
+(* Node style *)
+let requires cxt f (modules : (Ident.t * string) list ) =
+  P.newline f ; 
+  (* the context used to print the following program *)  
+  let outer_cxt, reversed_list, margin  =
+    List.fold_left
+      (fun (cxt, acc, len) (id,s) ->
+         let str, cxt = str_of_ident cxt id  in
+         cxt, ((str,s) :: acc), (max len (String.length str))
+      )
+      (cxt, [], 0)  modules in
+  P.force_newline f ;    
+  Ext_list.rev_iter (fun (s,file) ->
+      P.string f L.var;
+      P.space f ;
+      P.string f s ;
+      P.nspace f (margin - String.length s + 1) ;
+      P.string f L.eq;
+      P.space f;
+      P.string f L.require;
+      P.paren_group f 0 @@ (fun _ ->
+          pp_string f ~utf:true ~quote:(best_string_quote s) file  );
+      semi f ;
+      P.newline f ;
+    ) reversed_list;
+  outer_cxt
 
+let program f cxt   ( x : J.program ) = 
   let () = P.force_newline f in
-  let cxt =  statement_list true cxt f program.block  in
+  let cxt =  statement_list true cxt f x.block  in
   let () = P.force_newline f in
-  exports cxt f program.exports
+  exports cxt f x.exports
 
+let node_program f ( x : J.deps_program) = 
+  let cxt = requires ( Ext_pp_scope.empty)  f x.modules in
+  program f cxt x.program  
+  
 
 let amd_program f 
-    ( {program ; modules ; _} : J.deps_program)
+    (  x : J.deps_program)
   = 
   P.newline f ; 
   let cxt = Ext_pp_scope.empty in
@@ -1369,7 +1369,7 @@ let amd_program f
       P.string f L.comma ;
       P.space f; 
       pp_string f ~utf:true ~quote:(best_string_quote s) s;
-    ) modules ;
+    ) x.modules ;
   P.string f "]";
   P.string f L.comma;
   P.newline f;
@@ -1382,33 +1382,30 @@ let amd_program f
         P.string f L.comma;
         P.space f ; 
         ident cxt f id
-      ) cxt modules     
+      ) cxt x.modules     
   in
   P.string f ")";
-  P.brace_vgroup f 1 @@ (fun _ -> 
+  let v = P.brace_vgroup f 1 @@ (fun _ -> 
       let () = P.string f L.strict_directive in 
-      let () = P.newline f in
-      let cxt =  statement_list true cxt f  program.block in 
-      (* FIXME AMD : use {[ function xx ]} or {[ var x = function ..]} *)
-      P.newline f;
-      P.force_newline f;
-      ignore (exports cxt f program.exports));
+      program f cxt x.program
+    ) in
   P.string f ")";
+  v
 ;;
 
-let pp_program ( program  : J.deps_program) (f : Ext_pp.t) = 
+let pp_deps_program ( program  : J.deps_program) (f : Ext_pp.t) = 
   begin
     P.string f "// Generated CODE, PLEASE EDIT WITH CARE";
     P.newline f; 
     P.string f L.strict_directive; 
     P.newline f ;    
-    (match Js_config.get_env () with 
+    ignore (match Js_config.get_env () with 
      | Browser ->
-       ignore (node_program f program)
+        (node_program f program)
      | NodeJS -> 
        begin match Sys.getenv "OCAML_AMD_MODULE" with 
          | exception Not_found -> 
-           ignore (node_program f program)
+            (node_program f program)
            (* amd_program f program *)
          | _ -> amd_program f program
        end ) ;
@@ -1420,7 +1417,25 @@ let pp_program ( program  : J.deps_program) (f : Ext_pp.t) =
     P.newline f;
     P.flush f ()
   end
-let dump_program 
-    (program : J.deps_program)
+
+let dump_program (x : J.program) oc = 
+  ignore (program (P.from_channel oc)  Ext_pp_scope.empty  x )
+
+let dump_deps_program 
+    x 
     (oc : out_channel) = 
-  pp_program program (P.from_channel oc)
+  pp_deps_program x (P.from_channel oc)
+
+let string_of_block  block  
+  = 
+  let buffer  = Buffer.create 50 in
+  begin
+    let f = P.from_buffer buffer in
+    let _scope =  statement_list true Ext_pp_scope.empty  f block in
+    P.flush  f ();
+    Buffer.contents buffer     
+  end
+
+
+
+ 

jscomp/js_dump.mli

@@ -25,6 +25,12 @@
 (** Print JS IR to vanilla Javascript code *)
 
 
-val pp_program : J.deps_program -> Ext_pp.t -> unit
 
-val dump_program : J.deps_program -> out_channel -> unit
+
+
+val dump_deps_program : J.deps_program -> out_channel -> unit
+
+(** 2 functions Only used for debugging *)
+val string_of_block : J.block -> string
+
+val dump_program : J.program -> out_channel -> unit

jscomp/js_helper.ml

@@ -1175,7 +1175,7 @@ module Stmt = struct
   (* TODO: 
       actually, only loops can be labelled
    *)    
-  let continue  ?comment   label : t = 
+  let continue  ?comment   ?(label="") unit  : t = 
     { 
       statement_desc = J.Continue  label;
       comment;

jscomp/js_helper.mli

@@ -298,6 +298,7 @@ module Stmt : sig
 
   val break : ?comment:string  -> unit -> t
 
-  val continue : ?comment:string  -> J.label -> t
+  (** if [label] is not set, it will default to empty *)  
+  val continue : ?comment:string  -> ?label:J.label -> unit  -> t
 end
 

jscomp/js_output.ml

@@ -166,3 +166,5 @@ end
 let concat (xs : t list) : t = 
   List.fold_right (fun x acc -> append x  acc) xs dummy
 
+let to_string x   = 
+  Js_dump.string_of_block (to_block x)

jscomp/js_output.mli

@@ -63,3 +63,5 @@ val handle_block_return :
     Lam_compile_defs.st -> Lam_compile_defs.return_type -> Lambda.lambda -> J.block -> J.expression -> t
 
 val concat : t list -> t
+
+val to_string : t -> string

jscomp/js_pass_debug.ml

@@ -0,0 +1,40 @@
+(* OCamlScript compiler
+ * Copyright (C) 2015-2016 Bloomberg Finance L.P.
+ *
+ * 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.
+ *)
+
+(* Author: Hongbo Zhang  *)
+
+let log_counter = ref 0 
+
+let dump  (prog : J.program) = 
+  begin
+    let () = 
+      if Js_config.get_env () != Browser 
+      (* TODO: when no [Browser] detection, it will go through.. bug in js_of_ocaml? *)
+      && Lam_current_unit.is_same_file ()
+      then 
+        begin
+          incr log_counter ; 
+          Ext_pervasives.with_file_as_chan       
+            (Ext_filename.chop_extension ~loc:__LOC__ (Lam_current_unit.get_file()) ^
+             (Printf.sprintf ".%02d.jsx" !log_counter)
+            ) (fun chan -> Js_dump.dump_program prog chan )
+        end in
+    prog    
+  end
+
+ 

jscomp/js_pass_debug.mli

@@ -0,0 +1,21 @@
+(* OCamlScript compiler
+ * Copyright (C) 2015-2016 Bloomberg Finance L.P.
+ *
+ * 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.
+ *)
+
+(* Author: Hongbo Zhang  *)
+
+val dump : J.program -> J.program 

jscomp/js_pass_flatten_and_mark_dead.ml

@@ -88,7 +88,7 @@ let mark_dead = object (self)
         (** check [camlinternlFormat,box_type] inlined twice 
             FIXME: seems we have redeclared identifiers
          *)
-        Ext_log.warn __LOC__ "@[%s$%d in %s@]@." ident.name ident.stamp name
+        Ext_log.warn __LOC__ "@[%s$%d in %s@]" ident.name ident.stamp name
         (* assert false *)
     | exception Not_found ->  (* First time *)
         Hashtbl.add ident_use_stats ident (`Info ident_info);