Merge pull request #4206 from BuckleScript/more_performant_structure_support

Author: bobzhang

jscomp/core/bs_conditional_initial.ml

@@ -27,6 +27,7 @@
 (* Clflags.keep_locs := false; *)
 let setup_env () =
   Env.Persistent_signature.load := Bs_cmi_load.load_cmi;    
+  Typemod.should_hide := Typemod_hide.should_hide;
   Clflags.no_std_include := true;
   Warnings.parse_options false Bsc_warnings.defaults_w;
   Warnings.parse_options true Bsc_warnings.defaults_warn_error;

jscomp/ext/ext_list.ml

@@ -364,8 +364,10 @@ let init n f =
 
 let rec rev_append l1 l2 =
   match l1 with
-    [] -> l2
-  | a :: l -> rev_append l   (a :: l2)
+  | [] -> l2
+  | [a0] -> a0::l2 (* single element is common *)
+  | [a0 ; a1] -> a1 :: a0 :: l2 
+  |  a0::a1::a2::rest -> rev_append rest (a2::a1::a0::l2) 
 
 let rev l = rev_append l []      
 
@@ -442,7 +444,16 @@ let rec rev_map_append l1 l2 f =
 let rec flat_map_aux f acc append lx =
   match lx with
   | [] -> rev_append acc  append
-  | a0::rest -> flat_map_aux f (rev_append (f a0)  acc ) append rest 
+  | a0::rest -> 
+    let new_acc = 
+      match f a0 with 
+      | [] -> acc 
+      | [a0] -> a0::acc
+      | [a0;a1] -> a1::a0::acc
+      | a0::a1::a2::rest -> 
+        rev_append rest (a2::a1::a0::acc)  
+    in 
+    flat_map_aux f  new_acc append rest 
 
 let flat_map lx f  =
   flat_map_aux f [] [] lx

jscomp/syntax/bs_builtin_ppx.ml

@@ -270,19 +270,16 @@ let signature_item_mapper (self : mapper) (sigi : Parsetree.signature_item) =
           )
       | _ -> default_mapper.signature_item self sigi
 
-
+let local_module_name =     
+  let v = ref 0 in       
+  fun  () -> 
+    incr v ;
+  "local_" ^ (string_of_int !v) 
 
 let structure_item_mapper (self : mapper) (str : Parsetree.structure_item) =
   match str.pstr_desc with
-  | Pstr_extension ( ({txt = ("bs.raw"| "raw") ; loc}, payload), _attrs)
-    ->
-    Ast_exp_handle_external.handle_raw_structure loc payload
-  | Pstr_extension (({txt = ("bs.debugger.chrome" | "debugger.chrome") ;loc}, payload),_)
-    ->          
-    Location.prerr_warning loc (Preprocessor "this extension can be safely removed");
-    Ast_structure.dummy_item loc
   | Pstr_type (
-          _rf, 
+          _rf, (* FIXME *)
           (_ :: _ as tdcls )) (* [ {ptype_attributes} as tdcl ] *)->
           Ast_tdcls.handleTdclsInStru self str tdcls
    | Pstr_primitive prim when Ast_attributes.external_needs_to_be_encoded prim.pval_attributes
@@ -341,15 +338,60 @@ let structure_item_mapper (self : mapper) (str : Parsetree.structure_item) =
   | _ -> default_mapper.structure_item self str
 
 
-    
+let rec 
+  structure_mapper (self : mapper) stru =     
+  match stru with 
+  | [] -> []  
+  | item::rest -> 
+    let new_x = self.structure_item self item in 
+    match new_x.pstr_desc with 
+    | Pstr_extension (({txt = ("bs.debugger.chrome" | "debugger.chrome") ;loc}, _),_)
+      -> 
+      Location.prerr_warning loc (Preprocessor "this extension can be safely removed");
+      (structure_mapper self rest)
+    | Pstr_extension ( ({txt = ("bs.raw"| "raw") ; loc}, payload), _attrs)
+      ->
+      Ast_exp_handle_external.handle_raw_structure loc payload :: (structure_mapper self rest)     
+    | Pstr_extension (({txt = "local"; loc}, payload),_)
+      -> 
+      begin match payload with 
+        | PStr stru -> 
+          (* check no module, no type allowed *)
+          (* let stru = self.structure self stru in  *)
+          Ext_list.iter stru Typemod_hide.check; 
+          let local_module_name = local_module_name () in 
+          let open Ast_helper in 
+            Str.module_         
+              ~loc
+              { pmb_name = {txt = local_module_name; loc}; 
+                pmb_expr = {
+                  pmod_desc= Pmod_structure stru;
+                  pmod_loc = loc; 
+                  pmod_attributes = [] };
+                pmb_attributes = Typemod_hide.attrs; pmb_loc = loc} ::
+            Str.open_ ~loc {
+              popen_lid = {txt = Lident local_module_name; loc};
+              popen_override = Override;
+              popen_loc = loc;
+              popen_attributes = []
+            } :: structure_mapper self rest          
+        | PSig _ 
+        | PTyp _
+        | PPat _ ->
+          Location.raise_errorf ~loc "local extension is not support"
+      end  
+    | _ ->    
+      new_x :: (structure_mapper self rest)
+  
 let  unsafe_mapper : mapper =
   { default_mapper with
     expr = expr_mapper;
     typ = typ_mapper ;
     class_type = class_type_mapper;      
     signature_item =  signature_item_mapper ;
     value_bindings = Ast_tuple_pattern_flatten.value_bindings_mapper;
-    structure_item = structure_item_mapper
+    structure_item = structure_item_mapper;
+    structure = structure_mapper
   }
 
 

jscomp/syntax/typemod_hide.ml

@@ -0,0 +1,46 @@
+(* Copyright (C) 2020 Authors of BuckleScript
+ *
+ * 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, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * In addition to the permissions granted to you by the LGPL, you may combine
+ * or link a "work that uses the Library" with a publicly distributed version
+ * of this file to produce a combined library or application, then distribute
+ * that combined work under the terms of your choosing, with no requirement
+ * to comply with the obligations normally placed on you by section 4 of the
+ * LGPL version 3 (or the corresponding section of a later version of the LGPL
+ * should you choose to use a 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. *)
+
+
+let  should_hide ( x : Typedtree.module_binding) = 
+    match x.mb_attributes with 
+    | [] -> false
+    | ({txt = "internal.local";_},_) :: rest -> true
+    | _ :: rest -> 
+      Ext_list.exists rest (fun (x,_) -> x.txt = "internal.local")
+
+let attrs : Parsetree.attributes = 
+  [{txt = "internal.local";loc = Location.none}, PStr []]
+
+let check (x : Parsetree.structure_item) =
+   match x.pstr_desc with 
+   | Pstr_eval _
+   | Pstr_value _
+   | Pstr_primitive _
+   | Pstr_typext _
+   | Pstr_exception _
+     -> ()
+   |  _ -> 
+    Location.raise_errorf ~loc:x.pstr_loc 
+      "the structure is not supported in local extension"

jscomp/test/build.ninja

@@ -364,6 +364,7 @@ build test/int_hashtbl_test.cmi test/int_hashtbl_test.cmj : cc test/int_hashtbl_
 build test/int_map.cmi test/int_map.cmj : cc test/int_map.ml | $stdlib
 build test/int_overflow_test.cmi test/int_overflow_test.cmj : cc test/int_overflow_test.ml | test/mt.cmj $stdlib
 build test/int_switch_test.cmi test/int_switch_test.cmj : cc test/int_switch_test.ml | test/mt.cmj $stdlib
+build test/internal_unused_test.cmi test/internal_unused_test.cmj : cc test/internal_unused_test.ml | $stdlib
 build test/io_test.cmi test/io_test.cmj : cc test/io_test.ml | $stdlib
 build test/js_array_test.cmi test/js_array_test.cmj : cc test/js_array_test.ml | test/mt.cmj $stdlib
 build test/js_bool_test.cmi test/js_bool_test.cmj : cc test/js_bool_test.ml | test/mt.cmj $stdlib

jscomp/test/internal_unused_test.js

@@ -0,0 +1,24 @@
+'use strict';
+
+var Caml_exceptions = require("../../lib/js/caml_exceptions.js");
+
+console.log(3);
+
+var A = Caml_exceptions.create("Internal_unused_test.P1.A");
+
+function f(param) {
+  throw A;
+}
+
+var c = 5;
+
+function h(a, b) {
+  return a + b | 0;
+}
+
+console.log(c);
+
+console.log(h(1, 2));
+
+exports.f = f;
+/*  Not a pure module */

jscomp/test/internal_unused_test.ml

@@ -0,0 +1,33 @@
+[@@@warning "A"]
+[@@@warnerror "a"]
+;; module [@internal.local] P0 = struct 
+  let a = 3 in 
+  Js.log a ; a + 2
+end  
+open! P0
+
+;; module [@internal.local] P1 = struct 
+  exception A
+  let _a = 2
+end  
+open! P1
+
+let f () = raise A
+
+let%local b = 3
+
+let%local c = b + 2
+
+[%%local
+let d = c 
+let f = d 
+let h = fun[@bs] a b -> a + b
+]
+
+
+
+;; Js.log f 
+
+;; Js.log (h 1 2 [@bs])
+
+(* [%%debugger.chrome] *)

lib/4.06.1/bsb.ml

@@ -1286,8 +1286,10 @@ let init n f =
 
 let rec rev_append l1 l2 =
   match l1 with
-    [] -> l2
-  | a :: l -> rev_append l   (a :: l2)
+  | [] -> l2
+  | [a0] -> a0::l2 (* single element is common *)
+  | [a0 ; a1] -> a1 :: a0 :: l2 
+  |  a0::a1::a2::rest -> rev_append rest (a2::a1::a0::l2) 
 
 let rev l = rev_append l []      
 
@@ -1364,7 +1366,16 @@ let rec rev_map_append l1 l2 f =
 let rec flat_map_aux f acc append lx =
   match lx with
   | [] -> rev_append acc  append
-  | a0::rest -> flat_map_aux f (rev_append (f a0)  acc ) append rest 
+  | a0::rest -> 
+    let new_acc = 
+      match f a0 with 
+      | [] -> acc 
+      | [a0] -> a0::acc
+      | [a0;a1] -> a1::a0::acc
+      | a0::a1::a2::rest -> 
+        rev_append rest (a2::a1::a0::acc)  
+    in 
+    flat_map_aux f  new_acc append rest 
 
 let flat_map lx f  =
   flat_map_aux f [] [] lx

lib/4.06.1/bsb_helper.ml

@@ -1278,8 +1278,10 @@ let init n f =
 
 let rec rev_append l1 l2 =
   match l1 with
-    [] -> l2
-  | a :: l -> rev_append l   (a :: l2)
+  | [] -> l2
+  | [a0] -> a0::l2 (* single element is common *)
+  | [a0 ; a1] -> a1 :: a0 :: l2 
+  |  a0::a1::a2::rest -> rev_append rest (a2::a1::a0::l2) 
 
 let rev l = rev_append l []      
 
@@ -1356,7 +1358,16 @@ let rec rev_map_append l1 l2 f =
 let rec flat_map_aux f acc append lx =
   match lx with
   | [] -> rev_append acc  append
-  | a0::rest -> flat_map_aux f (rev_append (f a0)  acc ) append rest 
+  | a0::rest -> 
+    let new_acc = 
+      match f a0 with 
+      | [] -> acc 
+      | [a0] -> a0::acc
+      | [a0;a1] -> a1::a0::acc
+      | a0::a1::a2::rest -> 
+        rev_append rest (a2::a1::a0::acc)  
+    in 
+    flat_map_aux f  new_acc append rest 
 
 let flat_map lx f  =
   flat_map_aux f [] [] lx

lib/4.06.1/unstable/all_ounit_tests.ml

@@ -5963,8 +5963,10 @@ let init n f =
 
 let rec rev_append l1 l2 =
   match l1 with
-    [] -> l2
-  | a :: l -> rev_append l   (a :: l2)
+  | [] -> l2
+  | [a0] -> a0::l2 (* single element is common *)
+  | [a0 ; a1] -> a1 :: a0 :: l2 
+  |  a0::a1::a2::rest -> rev_append rest (a2::a1::a0::l2) 
 
 let rev l = rev_append l []      
 
@@ -6041,7 +6043,16 @@ let rec rev_map_append l1 l2 f =
 let rec flat_map_aux f acc append lx =
   match lx with
   | [] -> rev_append acc  append
-  | a0::rest -> flat_map_aux f (rev_append (f a0)  acc ) append rest 
+  | a0::rest -> 
+    let new_acc = 
+      match f a0 with 
+      | [] -> acc 
+      | [a0] -> a0::acc
+      | [a0;a1] -> a1::a0::acc
+      | a0::a1::a2::rest -> 
+        rev_append rest (a2::a1::a0::acc)  
+    in 
+    flat_map_aux f  new_acc append rest 
 
 let flat_map lx f  =
   flat_map_aux f [] [] lx