Move one more case.

Author: cristianoc

jscomp/core/js_exp_make.ml

@@ -776,7 +776,7 @@ let tag_type = function
     (* TODO: this should not happen *)
     assert false
 
-let rec emit_check (check : t Ast_untagged_variants.DynamiChecks.t) = match check with
+let rec emit_check (check : t Ast_untagged_variants.DynamicChecks.t) = match check with
   | TagType t -> tag_type t
   | BinOp(op, x, y) ->
     let op = match op with
@@ -792,11 +792,11 @@ let rec emit_check (check : t Ast_untagged_variants.DynamiChecks.t) = match chec
   | Expr x -> x
 
 let is_a_literal_case ~literal_cases ~block_cases (e:t) =
-  let check = Ast_untagged_variants.DynamiChecks.is_a_literal_case ~literal_cases ~block_cases (Expr e) in
+  let check = Ast_untagged_variants.DynamicChecks.is_a_literal_case ~literal_cases ~block_cases (Expr e) in
   emit_check check
 
 let is_int_tag ?has_null_undefined_other e =
-    let check = Ast_untagged_variants.DynamiChecks.is_int_tag ?has_null_undefined_other (Expr e) in
+    let check = Ast_untagged_variants.DynamicChecks.is_int_tag ?has_null_undefined_other (Expr e) in
     emit_check check
 
 let is_type_string ?comment (e : t) : t =

jscomp/core/js_exp_make.mli

@@ -188,6 +188,8 @@ val assign : ?comment:string -> t -> t -> t
 
 val tag_type : Ast_untagged_variants.tag_type -> t
 
+val emit_check : t Ast_untagged_variants.DynamicChecks.t -> t
+
 val triple_equal : ?comment:string -> t -> t -> t
 (* TODO: reduce [triple_equal] use *)
 

jscomp/core/lam_compile.ml

@@ -750,22 +750,16 @@ and compile_string_cases ~cxt ~switch_exp ~default cases: initialization  =
     ~switch_exp
     ~default
 and compile_untagged_cases ~cxt ~switch_exp ~default cases =
-  let add_runtime_type_check (literal: Ast_untagged_variants.tag_type) x y = match literal with
-  | Untagged IntType
-  | Untagged StringType
-  | Untagged FloatType
-  | Untagged ObjectType -> E.string_equal (E.typeof y) x 
-  | Untagged ArrayType -> E.is_array y
-  | Untagged UnknownType ->
-    (* This should not happen because unknown must be the only non-literal case *)
-    assert false 
-  | Bool _ | Float _ | Int _ | String _ | Null | Undefined -> x in
-  let mk_eq (i : Ast_untagged_variants.tag_type option) x j y = match i, j with
-    | Some literal, _ ->
-      add_runtime_type_check literal x y
-    | _, Some literal ->
-      add_runtime_type_check literal y x
-    | _ -> E.string_equal x y
+  let mk_eq (i : Ast_untagged_variants.tag_type option) x j y =
+    let check =  match i, j with
+    | Some tag_type, _ ->
+      Ast_untagged_variants.DynamicChecks.add_runtime_type_check ~tag_type (Expr x) (Expr y)
+    | _, Some tag_type ->
+      Ast_untagged_variants.DynamicChecks.add_runtime_type_check ~tag_type (Expr y) (Expr x)
+    | _ ->
+      Ast_untagged_variants.DynamicChecks.(==) (Expr x) (Expr y)
+    in
+    E.emit_check check
   in
   let is_array (l, _) = l = Ast_untagged_variants.Untagged ArrayType in
   let switch ?default ?declaration e clauses =
@@ -780,7 +774,7 @@ and compile_untagged_cases ~cxt ~switch_exp ~default cases =
     | _ ->
       S.string_switch ?default ?declaration (E.typeof e) clauses in
   cases |> compile_general_cases
-    ~make_exp:E.tag_type
+    ~make_exp: E.tag_type
     ~eq_exp: mk_eq
     ~cxt
     ~switch

jscomp/ml/ast_untagged_variants.ml

@@ -242,7 +242,7 @@ let names_from_type_variant ?(isUntaggedDef=false) ~env (cstrs : Types.construct
 let check_well_formed ~env ~isUntaggedDef (cstrs: Types.constructor_declaration list) =
   ignore (names_from_type_variant ~env ~isUntaggedDef cstrs)
 
-module DynamiChecks = struct
+module DynamicChecks = struct
 
   type op = EqEqEq | NotEqEq | Or | And
   type 'a t = BinOp of op * 'a t * 'a t | TagType of tag_type | TypeOf of 'a t | IsArray of 'a t | Not of 'a t | Expr of 'a
@@ -327,4 +327,15 @@ module DynamiChecks = struct
       e == nil ||| typeof e != object_
     else (* (undefiled + other) || other *)
       typeof e != object_
+
+  let add_runtime_type_check ~tag_type x y = match tag_type with
+    | Untagged IntType
+    | Untagged StringType
+    | Untagged FloatType
+    | Untagged ObjectType -> typeof y == x 
+    | Untagged ArrayType -> is_array y
+    | Untagged UnknownType ->
+      (* This should not happen because unknown must be the only non-literal case *)
+      assert false 
+    | Bool _ | Float _ | Int _ | String _ | Null | Undefined -> x
 end