Skip to content

Commit a66e2d3

Browse files
cristianoccristianoc
authored
Move logic for dynamic check inside untagged variants file. (#6216)
* Move logic for dynamic check inside untagged variants file. * cleanup * Move one more case.
1 parent e46118b commit a66e2d3

File tree

4 files changed

+133
-91
lines changed

4 files changed

+133
-91
lines changed

‎jscomp/core/js_exp_make.ml‎

Lines changed: 22 additions & 74 deletions
Original file line numberDiff line numberDiff line change
@@ -776,80 +776,28 @@ let tag_type = function
776776
(* TODO: this should not happen *)
777777
assert false
778778

779-
let rec is_a_literal_case ~(literal_cases : Ast_untagged_variants.tag_type list) ~block_cases (e:t) : t =
780-
let literals_overlaps_with_string () =
781-
Ext_list.exists literal_cases (function
782-
| String _ -> true
783-
| l -> false ) in
784-
let literals_overlaps_with_number () =
785-
Ext_list.exists literal_cases (function
786-
| Int _ | Float _ -> true
787-
| l -> false ) in
788-
let literals_overlaps_with_object () =
789-
Ext_list.exists literal_cases (function
790-
| Null -> true
791-
| l -> false ) in
792-
let (==) x y = bin EqEqEq x y in
793-
let (!=) x y = bin NotEqEq x y in
794-
let (||) x y = bin Or x y in
795-
let (&&) x y = bin And x y in
796-
let is_literal_case (t: Ast_untagged_variants.tag_type) : t = e == (tag_type t) in
797-
let is_not_block_case (c: Ast_untagged_variants.block_type) : t = match c with
798-
| StringType when literals_overlaps_with_string () = false (* No overlap *) ->
799-
(typeof e) != (str "string")
800-
| IntType when literals_overlaps_with_number () = false ->
801-
(typeof e) != (str "number")
802-
| FloatType when literals_overlaps_with_number () = false ->
803-
(typeof e) != (str "number")
804-
| ArrayType ->
805-
not (is_array e)
806-
| ObjectType when literals_overlaps_with_object () = false ->
807-
(typeof e) != (str "object")
808-
| ObjectType (* overlap *) ->
809-
e == nil || (typeof e) != (str "object")
810-
| StringType (* overlap *)
811-
| IntType (* overlap *)
812-
| FloatType (* overlap *)
813-
| UnknownType ->
814-
(* We don't know the type of unknown, so we need to express:
815-
this is not one of the literals *)
816-
(match literal_cases with
817-
| [] ->
818-
(* this should not happen *)
819-
assert false
820-
| l1 :: others ->
821-
let is_literal_1 = is_literal_case l1 in
822-
Ext_list.fold_right others is_literal_1 (fun literal_n acc ->
823-
(is_literal_case literal_n) || acc
824-
)
825-
)
826-
in
827-
match block_cases with
828-
| [c] -> is_not_block_case c
829-
| c1 :: (_::_ as rest) ->
830-
(is_not_block_case c1) && (is_a_literal_case ~literal_cases ~block_cases:rest e)
831-
| [] -> assert false
832-
833-
let is_int_tag ?(has_null_undefined_other=(false, false, false)) (e : t) : t =
834-
let (has_null, has_undefined, has_other) = has_null_undefined_other in
835-
if has_null && (has_undefined = false) && (has_other = false) then (* null *)
836-
{ expression_desc = Bin (EqEqEq, e, nil); comment=None }
837-
else if has_null && has_undefined && has_other=false then (* null + undefined *)
838-
{ J.expression_desc = Bin
839-
(Or,
840-
{ expression_desc = Bin (EqEqEq, e, nil); comment=None },
841-
{ expression_desc = Bin (EqEqEq, e, undefined); comment=None }
842-
); comment=None }
843-
else if has_null=false && has_undefined && has_other=false then (* undefined *)
844-
{ expression_desc = Bin (EqEqEq, e, undefined); comment=None }
845-
else if has_null then (* (null + undefined + other) || (null + other) *)
846-
{ J.expression_desc = Bin
847-
(Or,
848-
{ expression_desc = Bin (EqEqEq, e, nil); comment=None },
849-
{ expression_desc = Bin (NotEqEq, typeof e, str "object"); comment=None }
850-
); comment=None }
851-
else (* (undefiled + other) || other *)
852-
{ expression_desc = Bin (NotEqEq, typeof e, str "object"); comment=None }
779+
let rec emit_check (check : t Ast_untagged_variants.DynamicChecks.t) = match check with
780+
| TagType t -> tag_type t
781+
| BinOp(op, x, y) ->
782+
let op = match op with
783+
| EqEqEq -> Js_op.EqEqEq
784+
| NotEqEq -> NotEqEq
785+
| And -> And
786+
| Or -> Or
787+
in
788+
bin op (emit_check x) (emit_check y)
789+
| TypeOf x -> typeof (emit_check x)
790+
| IsArray x -> is_array (emit_check x)
791+
| Not x -> not (emit_check x)
792+
| Expr x -> x
793+
794+
let is_a_literal_case ~literal_cases ~block_cases (e:t) =
795+
let check = Ast_untagged_variants.DynamicChecks.is_a_literal_case ~literal_cases ~block_cases (Expr e) in
796+
emit_check check
797+
798+
let is_int_tag ?has_null_undefined_other e =
799+
let check = Ast_untagged_variants.DynamicChecks.is_int_tag ?has_null_undefined_other (Expr e) in
800+
emit_check check
853801

854802
let is_type_string ?comment (e : t) : t =
855803
string_equal ?comment (typeof e) (str "string")

‎jscomp/core/js_exp_make.mli‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -188,6 +188,8 @@ val assign : ?comment:string -> t -> t -> t
188188

189189
val tag_type : Ast_untagged_variants.tag_type -> t
190190

191+
val emit_check : t Ast_untagged_variants.DynamicChecks.t -> t
192+
191193
val triple_equal : ?comment:string -> t -> t -> t
192194
(* TODO: reduce [triple_equal] use *)
193195

‎jscomp/core/lam_compile.ml‎

Lines changed: 11 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -750,22 +750,16 @@ and compile_string_cases ~cxt ~switch_exp ~default cases: initialization =
750750
~switch_exp
751751
~default
752752
and compile_untagged_cases ~cxt ~switch_exp ~default cases =
753-
let add_runtime_type_check (literal: Ast_untagged_variants.tag_type) x y = match literal with
754-
| Untagged IntType
755-
| Untagged StringType
756-
| Untagged FloatType
757-
| Untagged ObjectType -> E.string_equal (E.typeof y) x
758-
| Untagged ArrayType -> E.is_array y
759-
| Untagged UnknownType ->
760-
(* This should not happen because unknown must be the only non-literal case *)
761-
assert false
762-
| Bool _ | Float _ | Int _ | String _ | Null | Undefined -> x in
763-
let mk_eq (i : Ast_untagged_variants.tag_type option) x j y = match i, j with
764-
| Some literal, _ ->
765-
add_runtime_type_check literal x y
766-
| _, Some literal ->
767-
add_runtime_type_check literal y x
768-
| _ -> E.string_equal x y
753+
let mk_eq (i : Ast_untagged_variants.tag_type option) x j y =
754+
let check = match i, j with
755+
| Some tag_type, _ ->
756+
Ast_untagged_variants.DynamicChecks.add_runtime_type_check ~tag_type (Expr x) (Expr y)
757+
| _, Some tag_type ->
758+
Ast_untagged_variants.DynamicChecks.add_runtime_type_check ~tag_type (Expr y) (Expr x)
759+
| _ ->
760+
Ast_untagged_variants.DynamicChecks.(==) (Expr x) (Expr y)
761+
in
762+
E.emit_check check
769763
in
770764
let is_array (l, _) = l = Ast_untagged_variants.Untagged ArrayType in
771765
let switch ?default ?declaration e clauses =
@@ -780,7 +774,7 @@ and compile_untagged_cases ~cxt ~switch_exp ~default cases =
780774
| _ ->
781775
S.string_switch ?default ?declaration (E.typeof e) clauses in
782776
cases |> compile_general_cases
783-
~make_exp:E.tag_type
777+
~make_exp: E.tag_type
784778
~eq_exp: mk_eq
785779
~cxt
786780
~switch

‎jscomp/ml/ast_untagged_variants.ml‎

Lines changed: 98 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -241,3 +241,101 @@ let names_from_type_variant ?(isUntaggedDef=false) ~env (cstrs : Types.construct
241241

242242
let check_well_formed ~env ~isUntaggedDef (cstrs: Types.constructor_declaration list) =
243243
ignore (names_from_type_variant ~env ~isUntaggedDef cstrs)
244+
245+
module DynamicChecks = struct
246+
247+
type op = EqEqEq | NotEqEq | Or | And
248+
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
249+
250+
let bin op x y = BinOp(op, x, y)
251+
let tag_type t = TagType t
252+
let typeof x = TypeOf x
253+
let str s = String s |> tag_type
254+
let is_array x = IsArray x
255+
let not x = Not x
256+
let nil = Null |> tag_type
257+
let undefined = Undefined |> tag_type
258+
let object_ = Untagged ObjectType |> tag_type
259+
let string = Untagged StringType |> tag_type
260+
let number = Untagged IntType |> tag_type
261+
262+
let (==) x y = bin EqEqEq x y
263+
let (!=) x y = bin NotEqEq x y
264+
let (|||) x y = bin Or x y
265+
let (&&&) x y = bin And x y
266+
267+
268+
let rec is_a_literal_case ~(literal_cases : tag_type list) ~block_cases (e: _ t) =
269+
let literals_overlaps_with_string () =
270+
Ext_list.exists literal_cases (function
271+
| String _ -> true
272+
| _ -> false ) in
273+
let literals_overlaps_with_number () =
274+
Ext_list.exists literal_cases (function
275+
| Int _ | Float _ -> true
276+
| _ -> false ) in
277+
let literals_overlaps_with_object () =
278+
Ext_list.exists literal_cases (function
279+
| Null -> true
280+
| _ -> false ) in
281+
let is_literal_case (t: tag_type) : _ t = e == (tag_type t) in
282+
let is_not_block_case (c: block_type) : _ t = match c with
283+
| StringType when literals_overlaps_with_string () = false (* No overlap *) ->
284+
typeof e != string
285+
| IntType when literals_overlaps_with_number () = false ->
286+
typeof e != number
287+
| FloatType when literals_overlaps_with_number () = false ->
288+
typeof e != number
289+
| ArrayType ->
290+
not (is_array e)
291+
| ObjectType when literals_overlaps_with_object () = false ->
292+
typeof e != object_
293+
| ObjectType (* overlap *) ->
294+
e == nil ||| (typeof e != object_)
295+
| StringType (* overlap *)
296+
| IntType (* overlap *)
297+
| FloatType (* overlap *)
298+
| UnknownType ->
299+
(* We don't know the type of unknown, so we need to express:
300+
this is not one of the literals *)
301+
(match literal_cases with
302+
| [] ->
303+
(* this should not happen *)
304+
assert false
305+
| l1 :: others ->
306+
let is_literal_1 = is_literal_case l1 in
307+
Ext_list.fold_right others is_literal_1 (fun literal_n acc ->
308+
(is_literal_case literal_n) ||| acc
309+
)
310+
)
311+
in
312+
match block_cases with
313+
| [c] -> is_not_block_case c
314+
| c1 :: (_::_ as rest) ->
315+
(is_not_block_case c1) &&& (is_a_literal_case ~literal_cases ~block_cases:rest e)
316+
| [] -> assert false
317+
318+
let is_int_tag ?(has_null_undefined_other=(false, false, false)) (e : _ t) : _ t =
319+
let (has_null, has_undefined, has_other) = has_null_undefined_other in
320+
if has_null && (has_undefined = false) && (has_other = false) then (* null *)
321+
bin EqEqEq e nil
322+
else if has_null && has_undefined && has_other=false then (* null + undefined *)
323+
e == nil ||| e == undefined
324+
else if has_null=false && has_undefined && has_other=false then (* undefined *)
325+
e == undefined
326+
else if has_null then (* (null + undefined + other) || (null + other) *)
327+
e == nil ||| typeof e != object_
328+
else (* (undefiled + other) || other *)
329+
typeof e != object_
330+
331+
let add_runtime_type_check ~tag_type x y = match tag_type with
332+
| Untagged IntType
333+
| Untagged StringType
334+
| Untagged FloatType
335+
| Untagged ObjectType -> typeof y == x
336+
| Untagged ArrayType -> is_array y
337+
| Untagged UnknownType ->
338+
(* This should not happen because unknown must be the only non-literal case *)
339+
assert false
340+
| Bool _ | Float _ | Int _ | String _ | Null | Undefined -> x
341+
end

0 commit comments

Comments
 (0)