Merge pull request #612 from bloomberg/fix_string_get

better handling of predefined exception

jscomp/gen_slots.ml

@@ -23,4 +23,12 @@ let code_of_array files =
     ATTENTION: we need re-run the code when we upgrade the compiler
     We do this to avoid dependencies
 *)
-let _ = print_endline (code_of_array ["pervasives.cmi"; "camlinternalOO.cmi"; "camlinternalMod.cmi"])
+let _ = print_endline
+    (code_of_array
+       ["pervasives.cmi";
+        "camlinternalOO.cmi";
+        "camlinternalMod.cmi";
+        "string.cmi";
+        "array.cmi";
+        "list.cmi"        
+       ])

jscomp/lam.ml

@@ -46,6 +46,7 @@ type primitive =
   (* Globals *)
   | Pgetglobal of ident
   | Psetglobal of ident
+  | Pglobal_exception of ident       
   (* Operations on heap blocks *)
   | Pmakeblock of int * tag_info * mutable_flag
   | Pfield of int * field_dbg_info
@@ -553,7 +554,11 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args  : t =
     | _ -> assert false 
     end
   | Ploc loc -> assert false (* already compiled away here*)
-  | Pgetglobal id -> prim ~primitive:(Pgetglobal id) ~args
+  | Pgetglobal id ->
+    if Ident.is_predef_exn id then
+      prim ~primitive:(Pglobal_exception id) ~args      
+    else       
+      prim ~primitive:(Pgetglobal id) ~args
   | Psetglobal id -> prim ~primitive:(Psetglobal id) ~args
   | Pmakeblock (tag,info, mutable_flag) 
     -> prim ~primitive:(Pmakeblock (tag,info,mutable_flag)) ~args
@@ -592,7 +597,7 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args  : t =
       begin match args with 
         | [Lprim {primitive = Pmakeblock (0, _, _) ; 
                   args = [ 
-                    Lprim {primitive = Pgetglobal ({name = "Assert_failure"} as id); args =  []}; 
+                    Lprim {primitive = Pglobal_exception ({name = "Assert_failure"} as id); args =  []}; 
                     _
                   ]
                  } ] when Ident.global id

jscomp/lam.mli

@@ -51,6 +51,7 @@ type primitive =
   | Pbytes_of_string
   | Pgetglobal of ident
   | Psetglobal of ident
+  | Pglobal_exception of ident             
   | Pmakeblock of int * Lambda.tag_info * Asttypes.mutable_flag
   | Pfield of int * Lambda.field_dbg_info
   | Psetfield of int * bool * Lambda.set_field_dbg_info

jscomp/lam_analysis.ml

@@ -72,7 +72,8 @@ let rec no_side_effects (lam : Lam.t) : bool =
 
 
 
-      | Pgetglobal _ 
+      | Pgetglobal _
+      | Pglobal_exception _
       | Pmakeblock _  (* whether it's mutable or not *)
       | Pfield _
       | Pfloatfield _ 
@@ -188,7 +189,7 @@ let rec no_side_effects (lam : Lam.t) : bool =
                     args = [Lconst _]; _},exn,
               Lifthenelse(Lprim{args =  
                                   [Lvar exn1; 
-                                   Lprim {primitive = Pgetglobal ({name="Not_found"}); args = []; _}]
+                                   Lprim {primitive = Pglobal_exception ({name="Not_found"}); args = []; _}]
                                ; _},
                           then_, _)) when Ident.same exn1 exn
     (** we might put this in an optimization pass 

jscomp/lam_beta_reduce.ml

@@ -232,7 +232,9 @@ let propogate_beta_reduce
            end;
            arg 
          | Lprim {primitive = Pgetglobal ident;  args = [];  _} -> 
-           (* It's not completeness, its to make it sound.. *)
+           (* It's not completeness, its to make it sound.. 
+              Pass global module as an argument
+           *)
            Lam_compile_global.query_lambda ident meta.env 
          (* alias meta param ident (Module (Global ident)) Strict *)
          | Lprim {primitive = Pmakeblock (_, _, Immutable) ;args ; _} -> 

jscomp/lam_compile.ml

@@ -1464,7 +1464,7 @@ and
         Lifthenelse
           (Lprim{primitive = Pintcomp(Ceq);
                  args = [Lvar id2 ; 
-                         Lprim{primitive = Pgetglobal {name = "Not_found"}; _}]},
+                         Lprim{primitive = Pglobal_exception {name = "Not_found"}; _}]},
            cont, _reraise )
       )
       | Ltrywith(
@@ -1473,7 +1473,7 @@ and
           id, 
           Lifthenelse(Lprim{primitive = Pintcomp(Ceq);
                             args = [ 
-                              Lprim { primitive = Pgetglobal {name = "Not_found"; _}; _}; Lvar id2 ]},
+                              Lprim { primitive = Pglobal_exception {name = "Not_found"; _}; _}; Lvar id2 ]},
                       cont, _reraise )
         )) when Ident.same id id2 
       -> 

jscomp/lam_compile_global.ml

@@ -63,10 +63,7 @@ let query_lambda id env =
 let get_exp (key : Lam_compile_env.key) : J.expression = 
   match key with 
    (id, env, expand) -> 
-    if Ident.is_predef_exn id 
-    then Js_of_lam_exception.get_builtin_by_name id.name
-    else 
-      Lam_compile_env.query_and_add_if_not_exist 
+    Lam_compile_env.query_and_add_if_not_exist 
         (Lam_module_ident.of_ml id) 
         (Has_env env)
         ~not_found:(fun id -> assert false)

jscomp/lam_compile_primitive.ml

@@ -54,6 +54,8 @@ let translate
   | Pjs_fn_runmethod _ 
     -> assert false (* already handled by {!Lam_compile} *)
   | Pjs_fn_method _ -> assert false
+  | Pglobal_exception id ->
+    Js_of_lam_exception.get_builtin_by_name id.name    
   | Pstringadd ->
     begin match args with      
       | [a;b] ->

jscomp/lam_pass_collect.ml

@@ -131,10 +131,7 @@ let collect_helper  (meta : Lam_stats.meta) (lam : Lam.t)  =
 
   and collect  (lam : Lam.t)  =
     match lam with 
-    (* | Lprim (Pgetglobal ident,[]) *)
-    (*   -> *)
-    (*     if not @@ Ident.is_predef_exn ident  then *)
-    (*       Lam_util.add_required_module ident meta *)
+
         (** TODO: 
             how about module aliases..
             record dependency

jscomp/lam_print.ml

@@ -111,6 +111,8 @@ let primitive ppf (prim : Lam.primitive) = match prim with
   | Pjs_fn_runmethod i -> fprintf ppf "js_fn_runmethod_%i" i 
   | Pdebugger -> fprintf ppf "debugger"
   | Pgetglobal id -> fprintf ppf "global %a" Ident.print id
+  | Pglobal_exception id ->
+    fprintf ppf "global exception %a" Ident.print id                       
   | Psetglobal id -> fprintf ppf "setglobal %a" Ident.print id
   | Pmakeblock(tag, _, Immutable) -> fprintf ppf "makeblock %i" tag
   | Pmakeblock(tag, _, Mutable) -> fprintf ppf "makemutable %i" tag

jscomp/lam_util.ml

@@ -65,16 +65,12 @@ let sort_dag_args  param_args =
 
 
 let add_required_module (x : Ident.t) (meta : Lam_stats.meta) = 
-  if not @@ Ident.is_predef_exn x then   
-    meta.required_modules <- Lam_module_ident.of_ml x :: meta.required_modules 
+  meta.required_modules <- Lam_module_ident.of_ml x :: meta.required_modules 
 
 let add_required_modules ( x : Ident.t list) (meta : Lam_stats.meta) = 
   let required_modules = 
-    Ext_list.filter_map 
-      (fun x ->
-         if Ident.is_predef_exn x then
-           None 
-         else Some ( Lam_module_ident.of_ml x))  x
+    List.map 
+      (fun x -> Lam_module_ident.of_ml x)  x
     @ meta.required_modules in
   meta.required_modules <- required_modules
 

jscomp/ocaml_stdlib_slots.ml

@@ -1,3 +1,6 @@
 let pervasives = [| "invalid_arg";"failwith";"Exit";"min";"max";"abs";"max_int";"min_int";"lnot";"infinity";"neg_infinity";"nan";"max_float";"min_float";"epsilon_float";"^";"char_of_int";"string_of_bool";"bool_of_string";"string_of_int";"string_of_float";"@";"stdin";"stdout";"stderr";"print_char";"print_string";"print_bytes";"print_int";"print_float";"print_endline";"print_newline";"prerr_char";"prerr_string";"prerr_bytes";"prerr_int";"prerr_float";"prerr_endline";"prerr_newline";"read_line";"read_int";"read_float";"open_out";"open_out_bin";"open_out_gen";"flush";"flush_all";"output_char";"output_string";"output_bytes";"output";"output_substring";"output_byte";"output_binary_int";"output_value";"seek_out";"pos_out";"out_channel_length";"close_out";"close_out_noerr";"set_binary_mode_out";"open_in";"open_in_bin";"open_in_gen";"input_char";"input_line";"input";"really_input";"really_input_string";"input_byte";"input_binary_int";"input_value";"seek_in";"pos_in";"in_channel_length";"close_in";"close_in_noerr";"set_binary_mode_in";"LargeFile";"string_of_format";"^^";"exit";"at_exit";"valid_float_lexem";"unsafe_really_input";"do_at_exit" |]
 let camlinternalOO = [| "public_method_label";"new_method";"new_variable";"new_methods_variables";"get_variable";"get_variables";"get_method_label";"get_method_labels";"get_method";"set_method";"set_methods";"narrow";"widen";"add_initializer";"dummy_table";"create_table";"init_class";"inherits";"make_class";"make_class_store";"dummy_class";"copy";"create_object";"create_object_opt";"run_initializers";"run_initializers_opt";"create_object_and_run_initializers";"lookup_tables";"params";"stats" |]
 let camlinternalMod = [| "init_mod";"update_mod" |]
+let string = [| "make";"init";"copy";"sub";"fill";"blit";"concat";"iter";"iteri";"map";"mapi";"trim";"escaped";"index";"rindex";"index_from";"rindex_from";"contains";"contains_from";"rcontains_from";"uppercase";"lowercase";"capitalize";"uncapitalize";"compare" |]
+let array = [| "init";"make_matrix";"create_matrix";"append";"concat";"sub";"copy";"fill";"blit";"to_list";"of_list";"iter";"map";"iteri";"mapi";"fold_left";"fold_right";"sort";"stable_sort";"fast_sort" |]
+let list = [| "length";"hd";"tl";"nth";"rev";"append";"rev_append";"concat";"flatten";"iter";"iteri";"map";"mapi";"rev_map";"fold_left";"fold_right";"iter2";"map2";"rev_map2";"fold_left2";"fold_right2";"for_all";"exists";"for_all2";"exists2";"mem";"memq";"find";"filter";"find_all";"partition";"assoc";"assq";"mem_assoc";"mem_assq";"remove_assoc";"remove_assq";"split";"combine";"sort";"stable_sort";"fast_sort";"sort_uniq";"merge" |]

jscomp/test/test_trywith.js

@@ -1,6 +1,102 @@
 'use strict';
 
 var Caml_builtin_exceptions = require("../../lib/js/caml_builtin_exceptions");
+var Curry                   = require("../../lib/js/curry");
+
+function ff(g, x) {
+  try {
+    Curry._1(g, x);
+  }
+  catch (exn){
+    if (exn !== Caml_builtin_exceptions.not_found) {
+      throw exn;
+    }
+
+  }
+  try {
+    Curry._1(g, x);
+  }
+  catch (exn$1){
+    if (exn$1 !== Caml_builtin_exceptions.out_of_memory) {
+      throw exn$1;
+    }
+
+  }
+  try {
+    Curry._1(g, x);
+  }
+  catch (exn$2){
+    if (exn$2[0] !== Caml_builtin_exceptions.sys_error) {
+      throw exn$2;
+    }
+
+  }
+  try {
+    Curry._1(g, x);
+  }
+  catch (exn$3){
+    if (exn$3[0] !== Caml_builtin_exceptions.invalid_argument) {
+      throw exn$3;
+    }
+
+  }
+  try {
+    Curry._1(g, x);
+  }
+  catch (exn$4){
+    if (exn$4 !== Caml_builtin_exceptions.end_of_file) {
+      throw exn$4;
+    }
+
+  }
+  try {
+    Curry._1(g, x);
+  }
+  catch (exn$5){
+    if (exn$5[0] !== Caml_builtin_exceptions.match_failure) {
+      throw exn$5;
+    }
+
+  }
+  try {
+    Curry._1(g, x);
+  }
+  catch (exn$6){
+    if (exn$6 !== Caml_builtin_exceptions.stack_overflow) {
+      throw exn$6;
+    }
+
+  }
+  try {
+    Curry._1(g, x);
+  }
+  catch (exn$7){
+    if (exn$7 !== Caml_builtin_exceptions.sys_blocked_io) {
+      throw exn$7;
+    }
+
+  }
+  try {
+    Curry._1(g, x);
+  }
+  catch (exn$8){
+    if (exn$8[0] !== Caml_builtin_exceptions.assert_failure) {
+      throw exn$8;
+    }
+
+  }
+  try {
+    return Curry._1(g, x);
+  }
+  catch (exn$9){
+    if (exn$9[0] === Caml_builtin_exceptions.undefined_recursive_module) {
+      return /* () */0;
+    }
+    else {
+      throw exn$9;
+    }
+  }
+}
 
 function u() {
   throw Caml_builtin_exceptions.not_found;
@@ -19,7 +115,7 @@ function f(x) {
                 Caml_builtin_exceptions.assert_failure,
                 [
                   "test_trywith.ml",
-                  24,
+                  51,
                   9
                 ]
               ];
@@ -33,6 +129,7 @@ var u1 = "bad character decimal encoding \\";
 
 var v = "bad character decimal encoding \\%c%c%c";
 
+exports.ff = ff;
 exports.u  = u;
 exports.u1 = u1;
 exports.v  = v;

jscomp/test/test_trywith.ml

@@ -1,6 +1,33 @@
-let f g x = 
-  try g x 
-  with Not_found -> 0 
+let ff g x =
+  (
+    try g x 
+    with Not_found -> ());
+  (try g x
+   with
+     Out_of_memory  -> ();   
+  );
+  (try g x
+   with
+     Sys_error _ -> ();   
+  );
+  (try g x with
+     Invalid_argument _ -> ();   
+  );
+  (try g x with
+     End_of_file -> ()  );
+  (try g x with
+     Match_failure _ -> ()   
+  );
+  (try g x with
+   |Stack_overflow  -> ()  )  ;
+  (try g x with
+     Sys_blocked_io  -> ()  );
+
+  (try g x with
+     Assert_failure _ -> ()  );
+  (try g x with
+     Undefined_recursive_module _ -> ()  )
+
 
 [@@@warning "-21"]