Track the names of constructors when compining switch statements.

Author: cristianoc

jscomp/core/lam.ml

@@ -31,6 +31,8 @@ type apply_status =
 
 
 module Types = struct
+  type switch_names = {consts: string array; blocks: string array}
+
   type switch =
     { sw_numconsts: bool; (* TODO: refine its representation *)
       sw_consts: (int * t) list;
@@ -92,7 +94,7 @@ module Types = struct
     | Llet of Lam_compat.let_kind * ident * t * t
     | Lletrec of (ident * t) list * t
     | Lprim of prim_info
-    | Lswitch of t * switch
+    | Lswitch of t * switch * switch_names
     | Lstringswitch of t * (string * t) list * t option
     | Lstaticraise of int * t list
     | Lstaticcatch of t * (int * ident list) * t
@@ -106,6 +108,8 @@ module Types = struct
 end
 
 module X = struct
+  type switch_names = Types.switch_names = {consts: string array; blocks: string array}
+
   type switch
     = Types.switch
     =
@@ -148,7 +152,7 @@ module X = struct
       | Llet of Lam_compat.let_kind * ident * t * t
       | Lletrec of (ident * t) list * t
       | Lprim of prim_info
-      | Lswitch of t * switch
+      | Lswitch of t * switch * switch_names
       | Lstringswitch of t * (string * t) list * t option
       | Lstaticraise of int * t list
       | Lstaticcatch of t * (int * ident list) * t
@@ -192,12 +196,12 @@ let inner_map
     let args = Ext_list.map args f in
     Lprim { args; primitive; loc}
 
-  | Lswitch(arg, {sw_consts; sw_numconsts; sw_blocks; sw_numblocks; sw_failaction}) ->
+  | Lswitch(arg, {sw_consts; sw_numconsts; sw_blocks; sw_numblocks; sw_failaction}, names) ->
     let arg = f arg in
     let sw_consts = Ext_list.map_snd  sw_consts f in
     let sw_blocks = Ext_list.map_snd  sw_blocks f in
     let sw_failaction = Ext_option.map sw_failaction f in
-    Lswitch(arg, { sw_consts; sw_blocks; sw_failaction; sw_numblocks; sw_numconsts})
+    Lswitch(arg, { sw_consts; sw_blocks; sw_failaction; sw_numblocks; sw_numconsts}, names)
   | Lstringswitch (arg,cases,default) ->
     let arg = f arg  in
     let cases = Ext_list.map_snd  cases f in
@@ -382,15 +386,15 @@ and eq_approx_list ls ls1 =  Ext_list.for_all2_no_exn ls ls1 eq_approx
 
 
 
-let switch lam (lam_switch : switch) : t =
+let switch lam (lam_switch : switch) names : t =
   match lam with
   | Lconst ((Const_pointer (i,_) |  (Const_int i)))
     ->
     Ext_list.assoc_by_int   lam_switch.sw_consts i lam_switch.sw_failaction
   | Lconst (Const_block (i,_,_)) ->
     Ext_list.assoc_by_int lam_switch.sw_blocks i lam_switch.sw_failaction 
   | _ ->
-    Lswitch(lam,lam_switch)
+    Lswitch(lam,lam_switch,names)
 
 let stringswitch (lam : t) cases default : t =
   match lam with
@@ -727,13 +731,15 @@ let if_ (a : t) (b : t) (c : t) : t =
          begin match c with 
            | Lswitch ( Lvar yy as switch_arg, 
                        ({sw_blocks = []; sw_numblocks = true; sw_consts ;
-                         sw_numconsts; sw_failaction = None} as body)
+                         sw_numconsts; sw_failaction = None} as body),
+                       names
                      )
              when Ident.same xx yy 
                && complete_range sw_consts ~start:0 ~finish:range
              ->  
              Lswitch(switch_arg, 
-                     { body with sw_failaction = Some b; sw_numconsts = false })
+                     { body with sw_failaction = Some b; sw_numconsts = false },
+                     names)
            |  _ -> Lifthenelse(a,b,c)      
          end
        | _ ->  Lifthenelse (a,b,c))

jscomp/core/lam.mli

@@ -28,6 +28,7 @@
 
 type ident = Ident.t
 
+type switch_names = {consts: string array; blocks: string array}
 
 type switch  =
   { sw_numconsts: bool;
@@ -65,7 +66,7 @@ and  t =  private
   | Llet of Lam_compat.let_kind * ident * t * t
   | Lletrec of (ident * t) list * t
   | Lprim of prim_info
-  | Lswitch of t * switch
+  | Lswitch of t * switch * switch_names
   | Lstringswitch of t * (string * t) list * t option
   | Lstaticraise of int * t list
   | Lstaticcatch of t * (int * ident list) * t
@@ -115,7 +116,7 @@ val letrec : (ident * t) list -> t -> t
 val if_ : t -> t -> t -> t 
 
 (** constant folding*)
-val switch : t -> switch  -> t 
+val switch : t -> switch -> switch_names -> t 
 (** constant folding*)
 val stringswitch : t -> (string * t) list -> t option -> t 
 

jscomp/core/lam_analysis.ml

@@ -217,7 +217,7 @@ let rec no_side_effects (lam : Lam.t) : bool =
         -> false 
     )
   | Llet (_,_, arg,body) -> no_side_effects arg && no_side_effects body 
-  | Lswitch (_,_) -> false 
+  | Lswitch _ -> false 
   | Lstringswitch (_,_,_) -> false
   | Lstaticraise _ -> false
   | Lstaticcatch _ -> false 
@@ -302,7 +302,7 @@ let rec size (lam : Lam.t) =
              args; _} -> size_lams (size fn) args
     (* | Lfunction(_, params, l) -> really_big () *)
     | Lfunction {body} -> size body 
-    | Lswitch(_, _) -> really_big ()
+    | Lswitch _ -> really_big ()
     | Lstringswitch(_,_,_) -> really_big ()
     | Lstaticraise (i,ls) -> 
         Ext_list.fold_left ls 1 (fun acc x -> size x + acc) 
@@ -361,11 +361,11 @@ let destruct_pattern (body : Lam.t) params args =
     | x::xs, [] -> assert false                  
   in   
   match body with
-  | Lswitch (Lvar v , switch)
+  | Lswitch (Lvar v , switch, names)
     ->
     begin match aux v params args with
       | Some (Lam.Lconst _ as lam) ->
-        size (Lam.switch lam switch) < small_inline_size
+        size (Lam.switch lam switch names) < small_inline_size
       | Some _ | None -> false
     end        
   | Lifthenelse(Lvar v, then_, else_)

jscomp/core/lam_arity_analysis.ml

@@ -110,7 +110,7 @@ let rec get_arity (meta : Lam_stats.t) (lam : Lam.t) :  Lam_arity.t =
                 sw_blocks;
                 sw_numblocks = _;
                 sw_numconsts = _;
-               }) -> 
+               }, _names) -> 
     all_lambdas meta (
       let rest = 
         Ext_list.map_append sw_consts

jscomp/core/lam_bounded_vars.ml

@@ -120,7 +120,7 @@ let rewrite (map :   _ Ident_hashtbl.t)
                   sw_blocks;
                   sw_numblocks;
                   sw_numconsts;
-                 }) ->
+                 }, names) ->
       let l = aux l in
       Lam.switch l
               {sw_consts = 
@@ -130,6 +130,7 @@ let rewrite (map :   _ Ident_hashtbl.t)
                sw_numblocks = sw_numblocks;
                sw_failaction =  option_map sw_failaction
               }
+              names
     | Lstringswitch(l, sw, d) ->
       let l = aux  l in
       Lam.stringswitch l 

jscomp/core/lam_check.ml

@@ -74,7 +74,7 @@ let check file lam =
       | Lletrec(decl, body) ->
         check_list_snd  decl cxt;
         check_staticfails body cxt
-      | Lswitch(arg, sw) ->
+      | Lswitch(arg, sw, _names) ->
         check_staticfails arg cxt ;
         check_list_snd sw.sw_consts cxt;
         check_list_snd sw.sw_blocks cxt;
@@ -127,7 +127,7 @@ let check file lam =
         iter_list_snd  decl;
         iter body
 
-      | Lswitch(arg, sw) ->
+      | Lswitch(arg, sw, _names) ->
         iter arg;
         iter_list_snd sw.sw_consts;
         iter_list_snd sw.sw_blocks;

jscomp/core/lam_closure.ml

@@ -104,7 +104,7 @@ let free_variables
                 sw_failaction;
                 sw_numconsts;
                 sw_numblocks
-               })) ->
+               }), _names) ->
       iter top arg; 
       let top = Lam_var_stats.new_position_after_lam arg top  in       
       List.iter (fun (_, case) -> iter top case) sw_consts;

jscomp/core/lam_compile.ml

@@ -512,17 +512,21 @@ and compile_general_cases
           [switch ?default ?declaration switch_exp body]
         )
 
-and compile_cases cxt switch_exp table default =
+and compile_cases ~is_tag cxt switch_exp table default names =
   compile_general_cases
-    E.small_int
+    (fun i ->
+      let comment = match (if is_tag then names.Lam.blocks.(i) else names.consts.(i)) with
+        | s -> Some s 
+        | exception Invalid_argument _ -> Some "NotFound" in
+      {(E.small_int i) with comment})
     E.int_equal
     cxt
     (fun  ?default ?declaration e clauses    ->
        S.int_switch ?default  ?declaration e clauses)
     switch_exp
     table
     default
-and compile_switch switch_arg sw (lambda_cxt : Lam_compile_context.t) = 
+and compile_switch switch_arg sw (lambda_cxt : Lam_compile_context.t) names = 
   (* TODO: if default is None, we can do some optimizations
       Use switch vs if/then/else
 
@@ -558,20 +562,20 @@ and compile_switch switch_arg sw (lambda_cxt : Lam_compile_context.t) =
     | { block; value = Some e } ->
       block @
       (if sw_numconsts && sw_consts = [] then
-         compile_cases cxt (E.tag e)  sw_blocks sw_blocks_default
+         compile_cases ~is_tag:true cxt (E.tag e)  sw_blocks sw_blocks_default names
        else if sw_numblocks && sw_blocks = [] then
-         compile_cases cxt e  sw_consts sw_num_default
+         compile_cases ~is_tag:false cxt e  sw_consts sw_num_default names
        else
          (* [e] will be used twice  *)
          let dispatch e =
            S.if_
              (E.is_type_number e )
-             (compile_cases cxt e sw_consts sw_num_default
+             (compile_cases ~is_tag:false cxt e sw_consts sw_num_default names
              )
              (* default still needed, could simplified*)
              ~else_:
-               (compile_cases  cxt (E.tag e ) sw_blocks
-                  sw_blocks_default) in
+               (compile_cases ~is_tag:true cxt (E.tag e ) sw_blocks
+                  sw_blocks_default names) in
            match e.expression_desc with
            | J.Var _  -> [ dispatch e]
            | _ ->
@@ -752,15 +756,15 @@ and compile_staticcatch (lam : Lam.t) (lambda_cxt  : Lam_compile_context.t)=
       Js_output.append_output
         (Js_output.make  (S.declare_variable ~kind:Variable v  :: declares) )
         (Js_output.append_output lbody (Js_output.make (
-             compile_cases new_cxt exit_expr handlers  NonComplete)  ~value:(E.var v )))
+             compile_cases ~is_tag:false new_cxt exit_expr handlers  NonComplete {consts=[||]; blocks=[||]})  ~value:(E.var v )))
     | Declare (kind, id)
       (* declare first this we will do branching*) ->
       let declares = S.declare_variable ~kind id  :: declares in
       let new_cxt = {lambda_cxt with jmp_table = jmp_table; continuation = Assign id } in 
       let lbody = compile_lambda new_cxt body in
       Js_output.append_output (Js_output.make  declares)
         (Js_output.append_output lbody
-           (Js_output.make (compile_cases new_cxt exit_expr handlers NonComplete)))
+           (Js_output.make (compile_cases ~is_tag:false new_cxt exit_expr handlers NonComplete {consts=[||]; blocks=[||]})))
                               (* place holder -- tell the compiler that
                                  we don't know if it's complete
                               *)                           
@@ -769,13 +773,13 @@ and compile_staticcatch (lam : Lam.t) (lambda_cxt  : Lam_compile_context.t)=
       let lbody = compile_lambda new_cxt body in
       Js_output.append_output (Js_output.make declares)
         (Js_output.append_output lbody
-           (Js_output.make (compile_cases new_cxt exit_expr handlers NonComplete)))
+           (Js_output.make (compile_cases ~is_tag:false new_cxt exit_expr handlers NonComplete {consts=[||]; blocks=[||]})))
     | Assign _  ->
       let new_cxt = {lambda_cxt with jmp_table = jmp_table } in 
       let lbody = compile_lambda new_cxt body in
       Js_output.append_output (Js_output.make declares)
         (Js_output.append_output lbody
-           (Js_output.make (compile_cases new_cxt exit_expr handlers NonComplete)))
+           (Js_output.make (compile_cases ~is_tag:false new_cxt exit_expr handlers NonComplete {consts=[||]; blocks=[||]})))
 
 and compile_sequand 
       (l : Lam.t) (r : Lam.t) (lambda_cxt : Lam_compile_context.t) =     
@@ -1587,8 +1591,11 @@ and compile_lambda
       compile_ifthenelse predicate t_branch f_branch lambda_cxt  
     | Lstringswitch(l, cases, default) ->
       compile_stringswitch l cases default lambda_cxt
-    | Lswitch(switch_arg, sw) ->
-      compile_switch switch_arg sw lambda_cxt 
+    | Lswitch(switch_arg, sw, names) ->
+      (* Format.eprintf "XXX Lswitch consts:%d blocks:%d@."
+        (Array.length names.consts)
+        (Array.length names.blocks); *)
+      compile_switch switch_arg sw lambda_cxt names
     | Lstaticraise(i, largs) ->  
       compile_staticraise i largs lambda_cxt 
     | Lstaticcatch _  ->

jscomp/core/lam_convert.ml

@@ -96,7 +96,7 @@ let exception_id_destructed (l : Lam.t) (fv : Ident.t): bool  =
       hit fn || hit_list args
     | Lglobal_module _  (* global persistent module, play safe *)
       -> false
-    | Lswitch(arg, sw) ->
+    | Lswitch(arg, sw, _names) ->
       hit arg ||
       hit_list_snd sw.sw_consts ||
       hit_list_snd sw.sw_blocks ||
@@ -623,9 +623,10 @@ let convert (exports : Ident_set.t) (lam : Lambda.lambda) : Lam.t * Lam_module_i
 #if OCAML_VERSION =~ ">4.03.0" then
       (e,s, _loc)
 #else
-      (e,s) 
+      (e,s, names) 
 #end      
-      -> convert_switch e s 
+      ->
+       convert_switch e s names
     | Lstringswitch (e, cases, default, _ ) ->
       Lam.stringswitch 
       (convert_aux e) 
@@ -726,7 +727,8 @@ let convert (exports : Ident_set.t) (lam : Lambda.lambda) : Lam.t * Lam_module_i
                    sw_consts ;
                    sw_blocks = []; sw_numblocks = true;
                    sw_failaction = Some ifso
-                 } as px)
+                 } as px),
+                 names
                 ) 
         when Ident.same switcher3 id    &&
              not (Lam_hit.hit_variable id ifso ) && 
@@ -738,6 +740,7 @@ let convert (exports : Ident_set.t) (lam : Lambda.lambda) : Lam.t * Lam_module_i
              Ext_list.map sw_consts 
                (fun (i,act) -> i - offset, act)
           }
+          names
       | _ -> 
         Lam.let_ kind id new_e new_body
   and convert_pipe (f : Lambda.lambda) (x : Lambda.lambda) outer_loc =        
@@ -756,8 +759,9 @@ let convert (exports : Ident_set.t) (lam : Lambda.lambda) : Lam.t * Lam_module_i
         Lam.apply fn (Ext_list.append_one args x) outer_loc App_na
       | _ ->
         Lam.apply f [x] outer_loc App_na
-    and convert_switch (e : Lambda.lambda) (s : Lambda.lambda_switch) = 
+    and convert_switch (e : Lambda.lambda) (s : Lambda.lambda_switch) (names : Lambda.switch_names) = 
         let  e = convert_aux e in
+        let names = {Lam.consts=names.consts; blocks = names.blocks} in
         match s with
         | {
           sw_failaction = None ;
@@ -783,14 +787,16 @@ let convert (exports : Ident_set.t) (lam : Lambda.lambda) : Lam.t * Lam_module_i
                  sw_numconsts = 
                    Ext_list.length_ge sw_consts sw_numconsts
                 }
+                names
           end
         | _ -> 
           Lam.switch  e   
             { sw_numconsts =  Ext_list.length_ge s.sw_consts s.sw_numconsts ;
               sw_consts = Ext_list.map_snd  s.sw_consts convert_aux;
               sw_numblocks = Ext_list.length_ge s.sw_blocks s.sw_numblocks;
               sw_blocks = Ext_list.map_snd s.sw_blocks convert_aux;
-              sw_failaction =Ext_option.map s.sw_failaction convert_aux } in
+              sw_failaction =Ext_option.map s.sw_failaction convert_aux }
+            names in
   convert_aux lam , may_depends
 
 

jscomp/core/lam_exit_count.ml

@@ -75,7 +75,7 @@ let count_helper  (lam : Lam.t) : collection =
       Ext_list.iter_snd bindings count;
       count body    
     | Lprim {args;  _} -> List.iter count args
-    | Lswitch(l, sw) ->
+    | Lswitch(l, sw, _names) ->
       count_default sw ;
       count l;
       Ext_list.iter_snd sw.sw_consts count;