Move logic for dynamic check inside untagged variants file.

jscomp/core/js_exp_make.ml

@@ -776,80 +776,28 @@ let tag_type = function
     (* TODO: this should not happen *)
     assert false
 
-let rec is_a_literal_case ~(literal_cases : Ast_untagged_variants.tag_type list) ~block_cases (e:t) : t =
-  let literals_overlaps_with_string () = 
-    Ext_list.exists literal_cases (function
-      | String _ -> true
-      | l -> false ) in
-  let literals_overlaps_with_number () = 
-    Ext_list.exists literal_cases (function
-      | Int _ | Float _ -> true
-      | l -> false ) in
-  let literals_overlaps_with_object () = 
-    Ext_list.exists literal_cases (function
-      | Null -> true
-      | l -> false ) in
-  let (==) x y = bin EqEqEq x y in
-  let (!=) x y = bin NotEqEq x y in
-  let (||) x y = bin Or x y in
-  let (&&) x y = bin And x y in
-  let is_literal_case (t: Ast_untagged_variants.tag_type) : t =  e == (tag_type t) in
-  let is_not_block_case (c: Ast_untagged_variants.block_type) : t = match c with
-  | StringType when literals_overlaps_with_string () = false  (* No overlap *) -> 
-    (typeof e) != (str "string")
-  | IntType when literals_overlaps_with_number () = false ->
-    (typeof e) != (str "number")
-  | FloatType when literals_overlaps_with_number () = false ->
-    (typeof e) != (str "number")
-  | ArrayType -> 
-    not (is_array e)
-  | ObjectType when literals_overlaps_with_object () = false ->
-    (typeof e) != (str "object")
-  | ObjectType (* overlap *) ->
-    e == nil || (typeof e) != (str "object")
-  | StringType (* overlap *)
-  | IntType (* overlap *)
-  | FloatType (* overlap *)
-  | UnknownType ->
-    (* We don't know the type of unknown, so we need to express:
-       this is not one of the literals *)
-    (match literal_cases with
-      | [] ->
-        (* this should not happen *)
-        assert false
-      | l1 :: others ->
-        let is_literal_1 = is_literal_case l1 in
-        Ext_list.fold_right others is_literal_1 (fun literal_n acc ->
-          (is_literal_case literal_n) || acc
-        )
-    )
-  in
-  match block_cases with
-  | [c] -> is_not_block_case c
-  | c1 :: (_::_ as rest) ->
-    (is_not_block_case c1) && (is_a_literal_case ~literal_cases ~block_cases:rest e)
-  | [] -> assert false
-
-let is_int_tag ?(has_null_undefined_other=(false, false, false)) (e : t) : t =
-  let (has_null, has_undefined, has_other) = has_null_undefined_other in
-  if has_null && (has_undefined = false) && (has_other = false) then (* null *)
-    { expression_desc = Bin (EqEqEq, e, nil); comment=None }
-  else if has_null && has_undefined && has_other=false then (* null + undefined *)
-    { J.expression_desc = Bin
-      (Or,
-        { expression_desc = Bin (EqEqEq, e, nil); comment=None },
-        { expression_desc = Bin (EqEqEq, e, undefined); comment=None }
-      ); comment=None }
-  else if has_null=false && has_undefined && has_other=false then (* undefined *)
-    { expression_desc = Bin (EqEqEq, e, undefined); comment=None }
-  else if has_null then (* (null + undefined + other) || (null + other) *)
-    { J.expression_desc = Bin
-      (Or,
-        { expression_desc = Bin (EqEqEq, e, nil); comment=None },
-        { expression_desc = Bin (NotEqEq, typeof e, str "object"); comment=None }
-      ); comment=None }
-  else (* (undefiled + other) || other *)
-    { expression_desc = Bin (NotEqEq, typeof e, str "object"); comment=None }
+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
+      | EqEqEq -> Js_op.EqEqEq
+      | NotEqEq -> NotEqEq
+      | And -> And
+      | Or -> Or
+    in
+    bin op (emit_check x) (emit_check y)
+  | TypeOf x -> typeof (emit_check x)
+  | IsArray x -> is_array (emit_check x)
+  | Not x -> not (emit_check x)
+  | Expr x -> x
+
+let is_a_literal_case ~literal_cases ~block_cases (e:t) =
+  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.DynamicChecks.is_int_tag ?has_null_undefined_other (Expr e) in
+    emit_check check
 
 let is_type_string ?comment (e : t) : t =
   string_equal ?comment (typeof e) (str "string")

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

@@ -241,3 +241,101 @@ 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 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
+
+  let bin op x y = BinOp(op, x, y)
+  let tag_type t = TagType t
+  let typeof x = TypeOf x
+  let str s = String s |> tag_type
+  let is_array x = IsArray x
+  let not x = Not x
+  let nil = Null |> tag_type
+  let undefined = Undefined |> tag_type
+  let object_ = Untagged ObjectType |> tag_type
+  let string = Untagged StringType |> tag_type
+  let number = Untagged IntType |> tag_type
+
+  let (==) x y = bin EqEqEq x y
+  let (!=) x y = bin NotEqEq x y
+  let (|||) x y = bin Or x y
+  let (&&&) x y = bin And x y
+
+
+  let rec is_a_literal_case ~(literal_cases : tag_type list) ~block_cases (e: _ t) =
+    let literals_overlaps_with_string () = 
+      Ext_list.exists literal_cases (function
+        | String _ -> true
+        | _ -> false ) in
+    let literals_overlaps_with_number () = 
+      Ext_list.exists literal_cases (function
+        | Int _ | Float _ -> true
+        | _ -> false ) in
+    let literals_overlaps_with_object () = 
+      Ext_list.exists literal_cases (function
+        | Null -> true
+        | _ -> false ) in
+    let is_literal_case (t: tag_type) : _ t =  e == (tag_type t) in
+    let is_not_block_case (c: block_type) : _ t = match c with
+    | StringType when literals_overlaps_with_string () = false  (* No overlap *) -> 
+      typeof e != string
+    | IntType when literals_overlaps_with_number () = false ->
+      typeof e != number
+    | FloatType when literals_overlaps_with_number () = false ->
+      typeof e != number
+    | ArrayType -> 
+      not (is_array e)
+    | ObjectType when literals_overlaps_with_object () = false ->
+      typeof e != object_
+    | ObjectType (* overlap *) ->
+      e == nil ||| (typeof e != object_)
+    | StringType (* overlap *)
+    | IntType (* overlap *)
+    | FloatType (* overlap *)
+    | UnknownType ->
+      (* We don't know the type of unknown, so we need to express:
+        this is not one of the literals *)
+      (match literal_cases with
+        | [] ->
+          (* this should not happen *)
+          assert false
+        | l1 :: others ->
+          let is_literal_1 = is_literal_case l1 in
+          Ext_list.fold_right others is_literal_1 (fun literal_n acc ->
+            (is_literal_case literal_n) ||| acc
+          )
+      )
+    in
+    match block_cases with
+    | [c] -> is_not_block_case c
+    | c1 :: (_::_ as rest) ->
+      (is_not_block_case c1) &&& (is_a_literal_case ~literal_cases ~block_cases:rest e)
+    | [] -> assert false
+
+  let is_int_tag ?(has_null_undefined_other=(false, false, false)) (e : _ t) : _ t =
+    let (has_null, has_undefined, has_other) = has_null_undefined_other in
+    if has_null && (has_undefined = false) && (has_other = false) then (* null *)
+      bin EqEqEq e nil
+    else if has_null && has_undefined && has_other=false then (* null + undefined *)
+      e == nil ||| e == undefined
+    else if has_null=false && has_undefined && has_other=false then (* undefined *)
+       e == undefined
+    else if has_null then (* (null + undefined + other) || (null + other) *)
+      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