Merge pull request #3810 from BuckleScript/names_of_constructors

Track the names of constructors when compiling switch statements.

Author: cristianoc

jscomp/core/j.ml

@@ -329,6 +329,7 @@ and 'a case_clause = {
   switch_case : 'a ; 
   switch_body : block ;
   should_break :  bool ;  (* true means break *)
+  comment : string option ;
 }
 
 (* TODO: For efficency: block should not be a list, it should be able to 

jscomp/core/js_dump.ml

@@ -499,12 +499,13 @@ and  pp_function is_method
 and pp_one_case_clause : 'a .
   _ -> P.t -> (P.t -> 'a -> unit) -> 'a J.case_clause -> _
   = fun cxt f  pp_cond
-    ({switch_case; switch_body ; should_break } : _ J.case_clause) ->
+    ({switch_case; switch_body ; should_break; comment; } : _ J.case_clause) ->
     let cxt =
       P.group f 1  (fun _ ->
           P.group f 1 (fun _ ->
               P.string f L.case;
               P.space f ;
+              pp_comment_option f comment;
               pp_cond  f switch_case; (* could be integer or string *)
               P.space f ;
               P.string f L.colon  );

jscomp/core/js_map.ml

@@ -444,12 +444,12 @@ class virtual map =
   *)
         'a 'a_out.
         ('self_type -> 'a -> 'a_out) -> 'a case_clause -> 'a_out case_clause =
-      fun _f_a { switch_case = _x; switch_body = _x_i1; should_break = _x_i2
+      fun _f_a { switch_case = _x; switch_body = _x_i1; should_break = _x_i2; comment
         } ->
         let _x = _f_a o _x in
         let _x_i1 = o#block _x_i1 in
         let _x_i2 = o#bool _x_i2
-        in { switch_case = _x; switch_body = _x_i1; should_break = _x_i2; }
+        in { switch_case = _x; switch_body = _x_i1; should_break = _x_i2; comment }
     method block : block -> block = (* true means break *)
       (* TODO: For efficency: block should not be a list, it should be able to 
    be concatenated in both ways 

jscomp/core/js_of_lam_variant.ml

@@ -42,7 +42,8 @@ let eval (arg : J.expression) (dispatches : (int * string) list ) : E.t =
       (Ext_list.map dispatches (fun (i,r) ->
               {J.switch_case = i ;
                switch_body = [S.return_stmt (E.str r)];
-               should_break = false (* FIXME: if true, still print break*)
+               should_break = false; (* FIXME: if true, still print break*)
+               comment = None;
               })))]
 
 (** invariant: optional is not allowed in this case *)
@@ -61,7 +62,8 @@ let eval_as_event (arg : J.expression) (dispatches : (int * string) list ) =
       (Ext_list.map dispatches (fun (i,r) ->
               {J.switch_case = i ;
                switch_body = [S.return_stmt (E.str r)];
-               should_break = false (* FIXME: if true, still print break*)
+               should_break = false; (* FIXME: if true, still print break*)
+               comment = None;
               }) ))]
       , (* TODO: improve, one dispatch later,
            the problem is that we can not create bindings
@@ -89,7 +91,8 @@ let eval_as_int (arg : J.expression) (dispatches : (int * int) list ) : E.t  =
       (Ext_list.map dispatches (fun (i,r) ->
               {J.switch_case = i ;
                switch_body = [S.return_stmt (E.int (Int32.of_int  r))];
-               should_break = false (* FIXME: if true, still print break*)
+               should_break = false; (* FIXME: if true, still print break*)
+               comment = None;
               }) ))]
 
 let eval_as_unwrap (arg : J.expression) : E.t =

jscomp/core/lam.ml

@@ -31,12 +31,14 @@ type apply_status =
 
 
 module Types = struct
-  type switch =
+
+  type lambda_switch =
     { sw_numconsts: bool; (* TODO: refine its representation *)
       sw_consts: (int * t) list;
       sw_numblocks: bool;
       sw_blocks: (int * t) list;
-      sw_failaction : t option}
+      sw_failaction : t option;
+      sw_names : Lambda.switch_names option }
   (* 
     Invariant: 
     length (sw_consts) <= sw_numconsts 
@@ -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 * lambda_switch
     | Lstringswitch of t * (string * t) list * t option
     | Lstaticraise of int * t list
     | Lstaticcatch of t * (int * ident list) * t
@@ -106,14 +108,16 @@ module Types = struct
 end
 
 module X = struct
-  type switch
-    = Types.switch
+
+  type lambda_switch
+    = Types.lambda_switch
     =
       { sw_numconsts: bool;
         sw_consts: (int * t) list;
         sw_numblocks: bool;
         sw_blocks: (int * t) list;
-        sw_failaction : t option}
+        sw_failaction: t option;
+        sw_names: Lambda.switch_names option }
   and prim_info
     =  Types.prim_info
     =
@@ -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 * lambda_switch
       | 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; sw_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; sw_names})
   | Lstringswitch (arg,cases,default) ->
     let arg = f arg  in
     let cases = Ext_list.map_snd  cases f in
@@ -382,7 +386,7 @@ 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 : lambda_switch) : t =
   match lam with
   | Lconst ((Const_pointer (i,_) |  (Const_int i)))
     ->
@@ -733,7 +737,7 @@ let if_ (a : t) (b : t) (c : t) : t =
                && 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; })
            |  _ -> Lifthenelse(a,b,c)      
          end
        | _ ->  Lifthenelse (a,b,c))

jscomp/core/lam.mli

@@ -28,13 +28,13 @@
 
 type ident = Ident.t
 
-
-type switch  =
+type lambda_switch  =
   { sw_numconsts: bool;
     sw_consts: (int * t) list;
     sw_numblocks: bool;
     sw_blocks: (int * t) list;
-    sw_failaction : t option}
+    sw_failaction: t option;
+    sw_names: Lambda.switch_names option }
 and apply_status =
   | App_na
   | App_ml_full
@@ -65,7 +65,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 * lambda_switch
   | Lstringswitch of t * (string * t) list * t option
   | Lstaticraise of int * t list
   | Lstaticcatch of t * (int * ident list) * t
@@ -115,7 +115,7 @@ val letrec : (ident * t) list -> t -> t
 val if_ : t -> t -> t -> t 
 
 (** constant folding*)
-val switch : t -> switch  -> t 
+val switch : t -> lambda_switch -> t 
 (** constant folding*)
 val stringswitch : t -> (string * t) list -> t option -> t 
 

jscomp/core/lam_analysis.ml

@@ -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) 

jscomp/core/lam_bounded_vars.ml

@@ -120,6 +120,7 @@ let rewrite (map :   _ Ident_hashtbl.t)
                   sw_blocks;
                   sw_numblocks;
                   sw_numconsts;
+                  sw_names;
                  }) ->
       let l = aux l in
       Lam.switch l
@@ -128,7 +129,8 @@ let rewrite (map :   _ Ident_hashtbl.t)
                sw_blocks = Ext_list.map_snd  sw_blocks aux;
                sw_numconsts = sw_numconsts;
                sw_numblocks = sw_numblocks;
-               sw_failaction =  option_map sw_failaction
+               sw_failaction = option_map sw_failaction;
+               sw_names;
               }
     | Lstringswitch(l, sw, d) ->
       let l = aux  l in

jscomp/core/lam_compile.ml

@@ -93,6 +93,38 @@ type default_case =
 let no_effects_const  = lazy true
 let has_effects_const = lazy false
 
+let names_from_construct_pattern (pat: Typedtree.pattern) =
+  let names_from_type_variant cstrs =
+    let (consts, blocks) = List.fold_left
+      (fun (consts, blocks) cstr ->
+        if cstr.Types.cd_args = []
+        then (Ident.name cstr.Types.cd_id :: consts, blocks)
+        else (consts, Ident.name cstr.Types.cd_id :: blocks))
+      ([], []) cstrs in
+    Some {Lambda.consts = consts |> List.rev |> Array.of_list;
+          blocks = blocks |> List.rev |> Array.of_list } in
+
+  let rec resolve_path n path =
+    match Env.find_type path pat.pat_env with
+    | {type_kind = Type_variant cstrs} ->
+      names_from_type_variant cstrs
+    | {type_kind = Type_abstract; type_manifest = Some t} ->
+      ( match (Ctype.unalias t).desc with
+        | Tconstr (pathn, _, _) ->
+          (* Format.eprintf "XXX path%d:%s path%d:%s@." n (Path.name path) (n+1) (Path.name pathn); *)
+          resolve_path (n+1) pathn
+        | _ -> None)
+    | {type_kind = Type_abstract; type_manifest = None} ->
+      None
+    | {type_kind = Type_record _ | Type_open (* Exceptions *) } ->          
+      None in
+
+  match (Btype.repr pat.pat_type).desc with
+    | Tconstr (path, _, _) -> resolve_path 0 path
+    | _ -> assert false
+
+ let () = Matching.names_from_construct_pattern := names_from_construct_pattern
+
 (** We drop the ability of cross-compiling
         the compiler has to be the same running
 *)
@@ -412,6 +444,7 @@ and compile_recursive_lets cxt id_args : Js_output.t  =
 and compile_general_cases
  :
   'a .
+  ('a -> string option) ->
   ('a -> J.expression) ->
   (J.expression -> J.expression -> J.expression) ->
   Lam_compile_context.t ->
@@ -421,6 +454,7 @@ and compile_general_cases
   _ ->
   ('a * Lam.t) list -> default_case -> J.block
   = fun
+  (make_comment : _ -> string option)
   (make_exp : _ -> J.expression)
   (eq_exp : J.expression -> J.expression -> J.expression)
   (cxt : Lam_compile_context.t)
@@ -499,10 +533,11 @@ and compile_general_cases
                               should_break && Lam_exit_code.has_exit lam in
                         {J.switch_case ;
                             switch_body;
-                            should_break
+                            should_break;
+                            comment = make_comment switch_case;
                         }
                       else
-                        { switch_case; switch_body = []; should_break = false }
+                        { switch_case; switch_body = []; should_break = false; comment = make_comment switch_case; }
                     )                   
 
               (* TODO: we should also group default *)
@@ -512,9 +547,10 @@ and compile_general_cases
           [switch ?default ?declaration switch_exp body]
         )
 
-and compile_cases cxt switch_exp table default =
+and compile_cases cxt switch_exp table default get_name =
   compile_general_cases
-    E.small_int
+    get_name
+    (fun i -> {(E.small_int i) with comment = get_name i})
     E.int_equal
     cxt
     (fun  ?default ?declaration e clauses    ->
@@ -534,7 +570,8 @@ and compile_switch switch_arg sw (lambda_cxt : Lam_compile_context.t) =
         sw_consts;
         sw_numblocks;
         sw_blocks;
-        sw_failaction } : Lam.switch) = sw in 
+        sw_failaction;
+        sw_names } : Lam.lambda_switch) = sw in 
   let  sw_num_default  =
     match sw_failaction with
     | None -> Complete
@@ -549,6 +586,11 @@ and compile_switch switch_arg sw (lambda_cxt : Lam_compile_context.t) =
       if sw_numblocks
       then Complete
       else Default x in
+  let get_name is_const i =
+    match sw_names with
+    | None -> None
+    | Some {blocks; consts} ->
+      Some (if is_const then consts.(i) else blocks.(i)) in
   let compile_whole  (cxt  : Lam_compile_context.t ) =
     match compile_lambda 
             {cxt with  continuation = NeedValue Not_tail}
@@ -558,20 +600,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 cxt (E.tag e)  sw_blocks sw_blocks_default (get_name false)
        else if sw_numblocks && sw_blocks = [] then
-         compile_cases cxt e  sw_consts sw_num_default
+         compile_cases cxt e  sw_consts sw_num_default (get_name true)
        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 cxt e sw_consts sw_num_default (get_name true)
              )
              (* default still needed, could simplified*)
              ~else_:
-               (compile_cases  cxt (E.tag e ) sw_blocks
-                  sw_blocks_default) in
+               (compile_cases cxt (E.tag e ) sw_blocks
+                  sw_blocks_default (get_name false)) in
            match e.expression_desc with
            | J.Var _  -> [ dispatch e]
            | _ ->
@@ -597,6 +639,7 @@ and compile_switch switch_arg sw (lambda_cxt : Lam_compile_context.t) =
 
 and compile_string_cases cxt switch_exp table default =
   compile_general_cases
+    (fun s -> None)
     E.str
     E.string_equal
     cxt
@@ -752,15 +795,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 new_cxt exit_expr handlers  NonComplete (fun _ -> None))  ~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 new_cxt exit_expr handlers NonComplete (fun _ -> None))))
                               (* place holder -- tell the compiler that
                                  we don't know if it's complete
                               *)                           
@@ -769,13 +812,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 new_cxt exit_expr handlers NonComplete (fun _ -> None))))
     | 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 new_cxt exit_expr handlers NonComplete (fun _ -> None))))
 
 and compile_sequand 
       (l : Lam.t) (r : Lam.t) (lambda_cxt : Lam_compile_context.t) =     
@@ -1588,7 +1631,7 @@ and compile_lambda
     | Lstringswitch(l, cases, default) ->
       compile_stringswitch l cases default lambda_cxt
     | Lswitch(switch_arg, sw) ->
-      compile_switch switch_arg sw lambda_cxt 
+      compile_switch switch_arg sw lambda_cxt
     | Lstaticraise(i, largs) ->  
       compile_staticraise i largs lambda_cxt 
     | Lstaticcatch _  ->