From 607e0b7d573067bc0ff83d474521b4711e2e1525 Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Mon, 31 Jul 2023 10:57:53 +0200 Subject: [PATCH 1/6] Test: test static evaluation of switches --- compiler/tests-compiler/static_eval.ml | 33 ++++++++++++++++++++++++++ 1 file changed, 33 insertions(+) diff --git a/compiler/tests-compiler/static_eval.ml b/compiler/tests-compiler/static_eval.ml index d904da2cca..d2600f4df3 100644 --- a/compiler/tests-compiler/static_eval.ml +++ b/compiler/tests-compiler/static_eval.ml @@ -157,3 +157,36 @@ let%expect_test "static eval of string get" = } } //end |}] + +let%expect_test "static eval of tags" = + let program = + compile_and_parse + {| + + type t = A | B | C of t | D of t + + let foobar = + let x = C (D A) in + match x with + | A -> 1 + | B -> 2 + | C _ -> 2 + | D _ -> 3 + + let export = [|foobar;foobar|] + |} + in + print_program program; + [%expect + {| + (function(globalThis){ + "use strict"; + var + runtime = globalThis.jsoo_runtime, + export$0 = [0, 2, 2], + Test = [0, 2, export$0]; + runtime.caml_register_global(1, Test, "Test"); + return; + } + (globalThis)); + //end |}] From 820dab44ac3b4683c5ed95761862e0d93a8d17c7 Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Thu, 27 Jul 2023 18:07:37 +0200 Subject: [PATCH 2/6] Compiler: lower level switch --- compiler/lib/code.ml | 12 +- compiler/lib/code.mli | 2 +- compiler/lib/deadcode.ml | 16 +- compiler/lib/effects.ml | 9 +- compiler/lib/eval.ml | 72 ++--- compiler/lib/flow.ml | 5 +- compiler/lib/freevars.ml | 5 +- compiler/lib/generate.ml | 61 +---- compiler/lib/global_flow.ml | 7 +- compiler/lib/inline.ml | 5 +- compiler/lib/parse_bytecode.ml | 69 ++++- compiler/lib/phisimpl.ml | 5 +- compiler/lib/subst.ml | 6 +- compiler/lib/tailcall.ml | 3 +- compiler/tests-full/stdlib.cma.expected.js | 294 +++++++++++---------- 15 files changed, 274 insertions(+), 297 deletions(-) diff --git a/compiler/lib/code.ml b/compiler/lib/code.ml index 4ca07e2f8c..36c7e75d93 100644 --- a/compiler/lib/code.ml +++ b/compiler/lib/code.ml @@ -354,7 +354,7 @@ type last = | Stop | Branch of cont | Cond of Var.t * cont * cont - | Switch of Var.t * cont array * cont array + | Switch of Var.t * cont array | Pushtrap of cont * Var.t * cont * Addr.Set.t | Poptrap of cont @@ -499,10 +499,9 @@ module Print = struct | Branch c -> Format.fprintf f "branch %a" cont c | Cond (x, cont1, cont2) -> Format.fprintf f "if %a then %a else %a" Var.print x cont cont1 cont cont2 - | Switch (x, a1, a2) -> + | Switch (x, a1) -> Format.fprintf f "switch %a {" Var.print x; Array.iteri a1 ~f:(fun i c -> Format.fprintf f "int %d -> %a; " i cont c); - Array.iteri a2 ~f:(fun i c -> Format.fprintf f "tag %d -> %a; " i cont c); Format.fprintf f "}" | Pushtrap (cont1, x, cont2, pcs) -> Format.fprintf @@ -598,9 +597,8 @@ let fold_children blocks pc f accu = let accu = f pc1 accu in let accu = f pc2 accu in accu - | Switch (_, a1, a2) -> + | Switch (_, a1) -> let accu = Array.fold_right ~init:accu ~f:(fun (pc, _) accu -> f pc accu) a1 in - let accu = Array.fold_right ~init:accu ~f:(fun (pc, _) accu -> f pc accu) a2 in accu type 'c fold_blocs = block Addr.Map.t -> Addr.t -> (Addr.t -> 'c -> 'c) -> 'c -> 'c @@ -726,9 +724,7 @@ let invariant { blocks; start; _ } = | Cond (_x, cont1, cont2) -> check_cont cont1; check_cont cont2 - | Switch (_x, a1, a2) -> - Array.iteri a1 ~f:(fun _ cont -> check_cont cont); - Array.iteri a2 ~f:(fun _ cont -> check_cont cont) + | Switch (_x, a1) -> Array.iteri a1 ~f:(fun _ cont -> check_cont cont) | Pushtrap (cont1, _x, cont2, _pcs) -> check_cont cont1; check_cont cont2 diff --git a/compiler/lib/code.mli b/compiler/lib/code.mli index 4f72ee7e68..53dacdb048 100644 --- a/compiler/lib/code.mli +++ b/compiler/lib/code.mli @@ -201,7 +201,7 @@ type last = | Stop | Branch of cont | Cond of Var.t * cont * cont - | Switch of Var.t * cont array * cont array + | Switch of Var.t * cont array | Pushtrap of cont * Var.t * cont * Addr.Set.t | Poptrap of cont diff --git a/compiler/lib/deadcode.ml b/compiler/lib/deadcode.ml index 5468232a64..bdafbd9219 100644 --- a/compiler/lib/deadcode.ml +++ b/compiler/lib/deadcode.ml @@ -97,10 +97,9 @@ and mark_reachable st pc = mark_var st x; mark_cont_reachable st cont1; mark_cont_reachable st cont2 - | Switch (x, a1, a2) -> + | Switch (x, a1) -> mark_var st x; - Array.iter a1 ~f:(fun cont -> mark_cont_reachable st cont); - Array.iter a2 ~f:(fun cont -> mark_cont_reachable st cont) + Array.iter a1 ~f:(fun cont -> mark_cont_reachable st cont) | Pushtrap (cont1, _, cont2, _) -> mark_cont_reachable st cont1; mark_cont_reachable st cont2) @@ -136,11 +135,8 @@ let filter_live_last blocks st (l, loc) = | Branch cont -> Branch (filter_cont blocks st cont) | Cond (x, cont1, cont2) -> Cond (x, filter_cont blocks st cont1, filter_cont blocks st cont2) - | Switch (x, a1, a2) -> - Switch - ( x - , Array.map a1 ~f:(fun cont -> filter_cont blocks st cont) - , Array.map a2 ~f:(fun cont -> filter_cont blocks st cont) ) + | Switch (x, a1) -> + Switch (x, Array.map a1 ~f:(fun cont -> filter_cont blocks st cont)) | Pushtrap (cont1, x, cont2, pcs) -> Pushtrap ( filter_cont blocks st cont1 @@ -204,9 +200,7 @@ let f ({ blocks; _ } as p : Code.program) = | Cond (_, cont1, cont2) -> add_cont_dep blocks defs cont1; add_cont_dep blocks defs cont2 - | Switch (_, a1, a2) -> - Array.iter a1 ~f:(fun cont -> add_cont_dep blocks defs cont); - Array.iter a2 ~f:(fun cont -> add_cont_dep blocks defs cont) + | Switch (_, a1) -> Array.iter a1 ~f:(fun cont -> add_cont_dep blocks defs cont) | Pushtrap (cont, _, cont_h, _) -> add_cont_dep blocks defs cont_h; add_cont_dep blocks defs cont diff --git a/compiler/lib/effects.ml b/compiler/lib/effects.ml index 2854550fe9..794bd491b7 100644 --- a/compiler/lib/effects.ml +++ b/compiler/lib/effects.ml @@ -418,13 +418,11 @@ let cps_last ~st ~alloc_jump_closures pc ((last, last_loc) : last * loc) ~k : , cps_jump_cont ~st ~src:pc cont1 last_loc , cps_jump_cont ~st ~src:pc cont2 last_loc ) , last_loc ) ) - | Switch (x, c1, c2) -> + | Switch (x, c1) -> (* To avoid code duplication during JavaScript generation, we need to create a single block per continuation *) let cps_jump_cont = Fun.memoize (fun x -> cps_jump_cont ~st ~src:pc x last_loc) in - ( alloc_jump_closures - , ( Switch (x, Array.map c1 ~f:cps_jump_cont, Array.map c2 ~f:cps_jump_cont) - , last_loc ) ) + alloc_jump_closures, (Switch (x, Array.map c1 ~f:cps_jump_cont), last_loc) | Pushtrap (body_cont, exn, ((handler_pc, _) as handler_cont), _) -> ( assert (Hashtbl.mem st.is_continuation handler_pc); match Addr.Set.mem handler_pc st.blocks_to_transform with @@ -911,8 +909,7 @@ let remove_empty_blocks ~live_vars (p : Code.program) : Code.program = match branch with | Branch cont -> Branch (resolve cont) | Cond (x, cont1, cont2) -> Cond (x, resolve cont1, resolve cont2) - | Switch (x, a1, a2) -> - Switch (x, Array.map ~f:resolve a1, Array.map ~f:resolve a2) + | Switch (x, a1) -> Switch (x, Array.map ~f:resolve a1) | Pushtrap (cont1, x, cont2, s) -> Pushtrap (resolve cont1, x, resolve cont2, s) | Poptrap cont -> Poptrap (resolve cont) diff --git a/compiler/lib/eval.ml b/compiler/lib/eval.ml index 6e1f09a7e8..11f52885ab 100644 --- a/compiler/lib/eval.ml +++ b/compiler/lib/eval.ml @@ -189,6 +189,34 @@ let is_int info x = | Pc (Int _) -> Y | Pc _ -> N +type case_of = + | CConst of int + | CTag of int + | Unknown + +let the_case_of info x = + match x with + | Pv x -> + get_approx + info + (fun x -> + match info.info_defs.(Var.idx x) with + | Expr (Constant (Int i)) -> CConst (Int32.to_int i) + | Expr (Block (j, _, _)) -> + if Var.ISet.mem info.info_possibly_mutable x then Unknown else CTag j + | Expr (Constant (Tuple (j, _, _))) -> CTag j + | _ -> Unknown) + Unknown + (fun u v -> + match u, v with + | CTag i, CTag j when i = j -> u + | CConst i, CConst j when i = j -> u + | _ -> Unknown) + x + | Pc (Int i) -> CConst (Int32.to_int i) + | Pc (Tuple (j, _, _)) -> CTag j + | _ -> Unknown + let eval_instr info ((x, loc) as i) = match x with | Let (x, Prim (Extern ("caml_js_equals" | "caml_equal"), [ y; z ])) -> ( @@ -228,6 +256,13 @@ let eval_instr info ((x, loc) as i) = let c = Constant (Int b) in Flow.update_def info x c; [ Let (x, c), loc ]) + | Let (x, Prim (Extern "%direct_obj_tag", [ y ])) -> ( + match the_case_of info y with + | CTag tag -> + let c = Constant (Int (Int32.of_int tag)) in + Flow.update_def info x c; + [ Let (x, c), loc ] + | CConst _ | Unknown -> [ i ]) | Let (x, Prim (Extern "caml_sys_const_backend_type", [ _ ])) -> let jsoo = Code.Var.fresh () in [ Let (jsoo, Constant (String "js_of_ocaml")), noloc @@ -271,34 +306,6 @@ let eval_instr info ((x, loc) as i) = ]) | _ -> [ i ] -type case_of = - | CConst of int - | CTag of int - | Unknown - -let the_case_of info x = - match x with - | Pv x -> - get_approx - info - (fun x -> - match info.info_defs.(Var.idx x) with - | Expr (Constant (Int i)) -> CConst (Int32.to_int i) - | Expr (Block (j, _, _)) -> - if Var.ISet.mem info.info_possibly_mutable x then Unknown else CTag j - | Expr (Constant (Tuple (j, _, _))) -> CTag j - | _ -> Unknown) - Unknown - (fun u v -> - match u, v with - | CTag i, CTag j when i = j -> u - | CConst i, CConst j when i = j -> u - | _ -> Unknown) - x - | Pc (Int i) -> CConst (Int32.to_int i) - | Pc (Tuple (j, _, _)) -> CTag j - | _ -> Unknown - type cond_of = | Zero | Non_zero @@ -341,14 +348,13 @@ let eval_branch info (l, loc) = | Zero -> Branch ffalse | Non_zero -> Branch ftrue | Unknown -> b) - | Switch (x, const, tags) as b -> ( + | Switch (x, const) as b -> ( (* [the_case_of info (Pv x)] might be meaningless when we're inside a dead code. The proper fix would be to remove the deadcode entirely. Meanwhile, add guards to prevent Invalid_argument("index out of bounds") see https://github.com/ocsigen/js_of_ocaml/issues/485 *) match the_case_of info (Pv x) with | CConst j when j >= 0 && j < Array.length const -> Branch const.(j) - | CTag j when j >= 0 && j < Array.length tags -> Branch tags.(j) | CConst _ | CTag _ | Unknown -> b) | _ as b -> b in @@ -380,15 +386,11 @@ let rec do_not_raise pc visited blocks = let visited = do_not_raise pc1 visited blocks in let visited = do_not_raise pc2 visited blocks in visited - | Switch (_, a1, a2) -> + | Switch (_, a1) -> let visited = Array.fold_left a1 ~init:visited ~f:(fun visited (pc, _) -> do_not_raise pc visited blocks) in - let visited = - Array.fold_left a2 ~init:visited ~f:(fun visited (pc, _) -> - do_not_raise pc visited blocks) - in visited | Pushtrap _ -> raise May_raise diff --git a/compiler/lib/flow.ml b/compiler/lib/flow.ml index 74f1499d8d..abf8c522ce 100644 --- a/compiler/lib/flow.ml +++ b/compiler/lib/flow.ml @@ -119,9 +119,8 @@ let program_deps { blocks; _ } = | Cond (_, cont1, cont2) -> cont_deps blocks vars deps defs cont1; cont_deps blocks vars deps defs cont2 - | Switch (_, a1, a2) -> - Array.iter a1 ~f:(fun cont -> cont_deps blocks vars deps defs cont); - Array.iter a2 ~f:(fun cont -> cont_deps blocks vars deps defs cont) + | Switch (_, a1) -> + Array.iter a1 ~f:(fun cont -> cont_deps blocks vars deps defs cont) | Pushtrap (cont, x, cont_h, _) -> add_param_def vars defs x; cont_deps blocks vars deps defs cont_h; diff --git a/compiler/lib/freevars.ml b/compiler/lib/freevars.ml index 2301ddebd6..b96d47a61d 100644 --- a/compiler/lib/freevars.ml +++ b/compiler/lib/freevars.ml @@ -64,10 +64,9 @@ let iter_last_free_var f l = f x; iter_cont_free_vars f cont1; iter_cont_free_vars f cont2 - | Switch (x, a1, a2) -> + | Switch (x, a1) -> f x; - Array.iter a1 ~f:(fun c -> iter_cont_free_vars f c); - Array.iter a2 ~f:(fun c -> iter_cont_free_vars f c) + Array.iter a1 ~f:(fun c -> iter_cont_free_vars f c) | Pushtrap (cont1, _, cont2, _) -> iter_cont_free_vars f cont1; iter_cont_free_vars f cont2 diff --git a/compiler/lib/generate.ml b/compiler/lib/generate.ml index 367e2041f2..ca3797b3fa 100644 --- a/compiler/lib/generate.ml +++ b/compiler/lib/generate.ml @@ -760,10 +760,9 @@ let fold_children blocks pc f accu = let accu = f pc2 accu in accu | Cond (_, cont1, cont2) -> DTree.fold_cont f (DTree.build_if cont1 cont2) accu - | Switch (_, a1, a2) -> - let a1 = DTree.build_switch a1 and a2 = DTree.build_switch a2 in + | Switch (_, a1) -> + let a1 = DTree.build_switch a1 in let accu = DTree.fold_cont f a1 accu in - let accu = DTree.fold_cont f a2 accu in accu let build_graph ctx pc = @@ -1099,6 +1098,7 @@ let _ = register_un_prim_ctx "%caml_format_int_special" `Pure (fun ctx cx loc -> let s = J.EBin (J.Plus, str_js_utf8 "", cx) in ocaml_string ~ctx ~loc s); + register_un_prim "%direct_obj_tag" `Mutator (fun cx _loc -> Mlvalue.Block.tag cx); register_bin_prim "caml_array_unsafe_get" `Mutable (fun cx cy _ -> Mlvalue.Array.field cx cy); register_bin_prim "%int_add" `Pure (fun cx cy _ -> to_int (plus_int cx cy)); @@ -1769,7 +1769,7 @@ and colapse_frontier name st (new_frontier' : Addr.Set.t) interm = let branch = let cases = Array.of_list (List.map a ~f:(fun pc -> pc, [])) in if Array.length cases > 2 - then Code.Switch (x, cases, [||]), Code.noloc + then Code.Switch (x, cases), Code.noloc else Code.Cond (x, cases.(1), cases.(0)), Code.noloc in ( [ J.variable_declaration [ J.V x, (int default, J.N) ], J.N ] @@ -1850,7 +1850,7 @@ and compile_conditional st queue last loop_stack backs frontier interm = | Raise _ -> Format.eprintf "raise;@;" | Stop -> Format.eprintf "stop;@;" | Cond (x, _, _) -> Format.eprintf "@[cond(%a){@;" Code.Var.print x - | Switch (x, _, _) -> Format.eprintf "@[switch(%a){@;" Code.Var.print x); + | Switch (x, _) -> Format.eprintf "@[switch(%a){@;" Code.Var.print x); let loc = source_location st.ctx pc in let res = match last with @@ -1912,21 +1912,7 @@ and compile_conditional st queue last loop_stack backs frontier interm = (DTree.build_if c1 c2) in never, flush_all queue b - | Switch (x, [||], a2) -> - let (_px, cx), queue = access_queue queue x in - let never, code = - compile_decision_tree - st - loop_stack - backs - frontier - interm - loc - (Mlvalue.Block.tag cx) - (DTree.build_switch a2) - in - never, flush_all queue code - | Switch (x, a1, [||]) -> + | Switch (x, a1) -> let (_px, cx), queue = access_queue queue x in let never, code = compile_decision_tree @@ -1940,41 +1926,6 @@ and compile_conditional st queue last loop_stack backs frontier interm = (DTree.build_switch a1) in never, flush_all queue code - | Switch (x, a1, a2) -> - (* The variable x is accessed several times, so we can directly - refer to it *) - let never1, b1 = - compile_decision_tree - st - loop_stack - backs - frontier - interm - loc - (var x) - (DTree.build_switch a1) - in - let never2, b2 = - compile_decision_tree - st - loop_stack - backs - frontier - interm - loc - (Mlvalue.Block.tag (var x)) - (DTree.build_switch a2) - in - let code = - Js_simpl.if_statement - (Mlvalue.is_immediate (var x)) - loc - (Js_simpl.block b1) - never1 - (Js_simpl.block b2) - never2 - in - never1 && never2, flush_all queue code in (if debug () then diff --git a/compiler/lib/global_flow.ml b/compiler/lib/global_flow.ml index 17e84d54b4..99589264db 100644 --- a/compiler/lib/global_flow.ml +++ b/compiler/lib/global_flow.ml @@ -245,14 +245,9 @@ let program_deps st { blocks; _ } = | Cond (x, cont1, cont2) -> cont_deps blocks st cont1; cont_deps blocks st ~ignore:x cont2 - | Switch (x, a1, a2) -> + | Switch (x, a1) -> Array.iter a1 ~f:(fun cont -> cont_deps blocks st cont); - Array.iter a2 ~f:(fun cont -> cont_deps blocks st cont); let h = Hashtbl.create 16 in - Array.iteri - ~f:(fun i (pc, _) -> - Hashtbl.replace h pc (i :: (try Hashtbl.find h pc with Not_found -> []))) - a2; if not st.fast then Hashtbl.iter diff --git a/compiler/lib/inline.ml b/compiler/lib/inline.ml index d567b0725c..d3235088cd 100644 --- a/compiler/lib/inline.ml +++ b/compiler/lib/inline.ml @@ -38,7 +38,7 @@ let optimizable blocks pc _ = + match fst branch with | Cond _ -> 2 - | Switch (_, a1, a2) -> Array.length a1 + Array.length a2 + | Switch (_, a1) -> Array.length a1 | _ -> 0) in let optimizable = @@ -112,9 +112,8 @@ let fold_children blocks pc f accu = let accu = f pc1 accu in let accu = f pc2 accu in accu - | Switch (_, a1, a2) -> + | Switch (_, a1) -> let accu = Array.fold_right a1 ~init:accu ~f:(fun (pc, _) accu -> f pc accu) in - let accu = Array.fold_right a2 ~init:accu ~f:(fun (pc, _) accu -> f pc accu) in accu let rewrite_closure blocks cont_pc clos_pc = diff --git a/compiler/lib/parse_bytecode.ml b/compiler/lib/parse_bytecode.ml index e042ea86f6..de63754ad5 100644 --- a/compiler/lib/parse_bytecode.ml +++ b/compiler/lib/parse_bytecode.ml @@ -850,10 +850,9 @@ let rec compile_block blocks debug_data code pc state = | Cond (_, (pc1, _), (pc2, _)) -> compile_block blocks debug_data code pc1 state'; compile_block blocks debug_data code pc2 state' - | Switch (_, l1, l2) -> - Array.iter l1 ~f:(fun (pc', _) -> compile_block blocks debug_data code pc' state'); - Array.iter l2 ~f:(fun (pc', _) -> compile_block blocks debug_data code pc' state') - | Pushtrap _ | Raise _ | Return _ | Stop -> ()) + | Switch (_, _) -> () + | Pushtrap _ -> () + | Raise _ | Return _ | Stop -> ()) and compile infos pc state instrs = if debug_parser () then State.print state; @@ -1630,20 +1629,62 @@ and compile infos pc state instrs = let x, _ = State.accu state in let args = State.stack_vars state in instrs, (Cond (x, (pc + 2, args), (pc + offset + 1, args)), loc), state - | SWITCH -> + | SWITCH -> ( if debug_parser () then Format.printf "switch ...@."; - let sz = getu code (pc + 1) in let x, _ = State.accu state in let args = State.stack_vars state in - let l = sz land 0xFFFF in - let it = - Array.init (sz land 0XFFFF) ~f:(fun i -> pc + 2 + gets code (pc + 2 + i), args) - in - let bt = - Array.init (sz lsr 16) ~f:(fun i -> pc + 2 + gets code (pc + 2 + l + i), args) - in - instrs, (Switch (x, it, bt), loc), state + let isize = sz land 0XFFFF in + let bsize = sz lsr 16 in + let base = pc + 2 in + let it = Array.init isize ~f:(fun i -> base + gets code (base + i)) in + let bt = Array.init bsize ~f:(fun i -> base + gets code (base + isize + i)) in + Array.iter it ~f:(fun pc' -> + compile_block infos.blocks infos.debug code pc' state); + Array.iter bt ~f:(fun pc' -> + compile_block infos.blocks infos.debug code pc' state); + match isize, bsize with + | _, 0 -> instrs, (Switch (x, Array.map it ~f:(fun pc -> pc, args)), loc), state + | 0, _ -> + let x_tag = Var.fresh () in + let instrs = + (Let (x_tag, Prim (Extern "%direct_obj_tag", [ Pv x ])), loc) :: instrs + in + instrs, (Switch (x_tag, Array.map bt ~f:(fun pc -> pc, args)), loc), state + | _, _ -> + let isint_branch = pc + 1 in + let isblock_branch = pc + 2 in + let () = + tagged_blocks := Addr.Set.add isint_branch !tagged_blocks; + let i_state = State.start_block isint_branch state in + let i_args = State.stack_vars i_state in + compiled_blocks := + Addr.Map.add + isint_branch + (i_state, [], (Switch (x, Array.map it ~f:(fun pc -> pc, i_args)), loc)) + !compiled_blocks + in + let () = + tagged_blocks := Addr.Set.add isblock_branch !tagged_blocks; + let x_tag = Var.fresh () in + let b_state = State.start_block isblock_branch state in + let b_args = State.stack_vars b_state in + let instrs = + [ Let (x_tag, Prim (Extern "%direct_obj_tag", [ Pv x ])), loc ] + in + compiled_blocks := + Addr.Map.add + isblock_branch + ( b_state + , instrs + , (Switch (x_tag, Array.map bt ~f:(fun pc -> pc, b_args)), loc) ) + !compiled_blocks + in + let isint_var = Var.fresh () in + let instrs = (Let (isint_var, Prim (IsInt, [ Pv x ])), loc) :: instrs in + ( instrs + , (Cond (isint_var, (isint_branch, args), (isblock_branch, args)), loc) + , state )) | BOOLNOT -> let y, _ = State.accu state in let x, state = State.fresh_var state loc in diff --git a/compiler/lib/phisimpl.ml b/compiler/lib/phisimpl.ml index d4a481ef7a..bd1b472e92 100644 --- a/compiler/lib/phisimpl.ml +++ b/compiler/lib/phisimpl.ml @@ -77,9 +77,8 @@ let program_deps { blocks; _ } = | Cond (_, cont1, cont2) -> cont_deps blocks vars deps defs cont1; cont_deps blocks vars deps defs cont2 - | Switch (_, a1, a2) -> - Array.iter a1 ~f:(fun cont -> cont_deps blocks vars deps defs cont); - Array.iter a2 ~f:(fun cont -> cont_deps blocks vars deps defs cont) + | Switch (_, a1) -> + Array.iter a1 ~f:(fun cont -> cont_deps blocks vars deps defs cont) | Pushtrap (cont, _, cont_h, _) -> cont_deps blocks vars deps defs cont_h; cont_deps blocks vars deps defs cont diff --git a/compiler/lib/subst.ml b/compiler/lib/subst.ml index d6a03a7a81..1aa85fa739 100644 --- a/compiler/lib/subst.ml +++ b/compiler/lib/subst.ml @@ -59,11 +59,7 @@ let last s (l, loc) = | Return x -> Return (s x) | Raise (x, k) -> Raise (s x, k) | Cond (x, cont1, cont2) -> Cond (s x, subst_cont s cont1, subst_cont s cont2) - | Switch (x, a1, a2) -> - Switch - ( s x - , Array.map a1 ~f:(fun cont -> subst_cont s cont) - , Array.map a2 ~f:(fun cont -> subst_cont s cont) ) + | Switch (x, a1) -> Switch (s x, Array.map a1 ~f:(fun cont -> subst_cont s cont)) | Poptrap cont -> Poptrap (subst_cont s cont) in l, loc diff --git a/compiler/lib/tailcall.ml b/compiler/lib/tailcall.ml index b37ff698cb..c02c7079c3 100644 --- a/compiler/lib/tailcall.ml +++ b/compiler/lib/tailcall.ml @@ -68,9 +68,8 @@ let fold_children blocks pc f accu = let accu = f pc1 accu in let accu = f pc2 accu in accu - | Switch (_, a1, a2) -> + | Switch (_, a1) -> let accu = Array.fold_right a1 ~init:accu ~f:(fun (pc, _) accu -> f pc accu) in - let accu = Array.fold_right a2 ~init:accu ~f:(fun (pc, _) accu -> f pc accu) in accu let rec traverse f pc visited blocks = diff --git a/compiler/tests-full/stdlib.cma.expected.js b/compiler/tests-full/stdlib.cma.expected.js index 498240028e..4da3b8f047 100644 --- a/compiler/tests-full/stdlib.cma.expected.js +++ b/compiler/tests-full/stdlib.cma.expected.js @@ -14778,12 +14778,13 @@ ([0, Assert_failure, _b_], 1); } } - else + else{ + var switch$1 = 0; switch(ty1[0]){ case 0: - var rest1 = ty1[1], switch$1 = 0; + var rest1 = ty1[1], switch$2 = 0; if(typeof ty2 === "number") - switch$1 = 1; + switch$2 = 1; else switch(ty2[0]){ case 0: @@ -14791,26 +14792,26 @@ /*<>*/ return [0, trans(rest1, rest2)]; case 8: - switch$0 = 5; break; + switch$0 = 5; switch$1 = 1; break; case 9: - switch$0 = 6; break; - case 10: break; + switch$0 = 6; switch$1 = 1; break; + case 10: + switch$1 = 1; break; case 11: - switch$0 = 1; break; + switch$0 = 1; switch$1 = 1; break; case 12: - switch$0 = 2; break; + switch$0 = 2; switch$1 = 1; break; case 13: - switch$0 = 3; break; + switch$0 = 3; switch$1 = 1; break; case 14: - switch$0 = 4; break; - default: switch$1 = 1; + switch$0 = 4; switch$1 = 1; break; + default: switch$2 = 1; } - if(switch$1) switch$0 = 7; break; case 1: - var rest1$0 = ty1[1], switch$2 = 0; + var rest1$0 = ty1[1], switch$3 = 0; if(typeof ty2 === "number") - switch$2 = 1; + switch$3 = 1; else switch(ty2[0]){ case 1: @@ -14818,26 +14819,26 @@ /*<>*/ return [1, trans(rest1$0, rest2$0)]; case 8: - switch$0 = 5; break; + switch$0 = 5; switch$1 = 1; break; case 9: - switch$0 = 6; break; - case 10: break; + switch$0 = 6; switch$1 = 1; break; + case 10: + switch$1 = 1; break; case 11: - switch$0 = 1; break; + switch$0 = 1; switch$1 = 1; break; case 12: - switch$0 = 2; break; + switch$0 = 2; switch$1 = 1; break; case 13: - switch$0 = 3; break; + switch$0 = 3; switch$1 = 1; break; case 14: - switch$0 = 4; break; - default: switch$2 = 1; + switch$0 = 4; switch$1 = 1; break; + default: switch$3 = 1; } - if(switch$2) switch$0 = 7; break; case 2: - var rest1$1 = ty1[1], switch$3 = 0; + var rest1$1 = ty1[1], switch$4 = 0; if(typeof ty2 === "number") - switch$3 = 1; + switch$4 = 1; else switch(ty2[0]){ case 2: @@ -14845,26 +14846,26 @@ /*<>*/ return [2, trans(rest1$1, rest2$1)]; case 8: - switch$0 = 5; break; + switch$0 = 5; switch$1 = 1; break; case 9: - switch$0 = 6; break; - case 10: break; + switch$0 = 6; switch$1 = 1; break; + case 10: + switch$1 = 1; break; case 11: - switch$0 = 1; break; + switch$0 = 1; switch$1 = 1; break; case 12: - switch$0 = 2; break; + switch$0 = 2; switch$1 = 1; break; case 13: - switch$0 = 3; break; + switch$0 = 3; switch$1 = 1; break; case 14: - switch$0 = 4; break; - default: switch$3 = 1; + switch$0 = 4; switch$1 = 1; break; + default: switch$4 = 1; } - if(switch$3) switch$0 = 7; break; case 3: - var rest1$2 = ty1[1], switch$4 = 0; + var rest1$2 = ty1[1], switch$5 = 0; if(typeof ty2 === "number") - switch$4 = 1; + switch$5 = 1; else switch(ty2[0]){ case 3: @@ -14872,26 +14873,26 @@ /*<>*/ return [3, trans(rest1$2, rest2$2)]; case 8: - switch$0 = 5; break; + switch$0 = 5; switch$1 = 1; break; case 9: - switch$0 = 6; break; - case 10: break; + switch$0 = 6; switch$1 = 1; break; + case 10: + switch$1 = 1; break; case 11: - switch$0 = 1; break; + switch$0 = 1; switch$1 = 1; break; case 12: - switch$0 = 2; break; + switch$0 = 2; switch$1 = 1; break; case 13: - switch$0 = 3; break; + switch$0 = 3; switch$1 = 1; break; case 14: - switch$0 = 4; break; - default: switch$4 = 1; + switch$0 = 4; switch$1 = 1; break; + default: switch$5 = 1; } - if(switch$4) switch$0 = 7; break; case 4: - var rest1$3 = ty1[1], switch$5 = 0; + var rest1$3 = ty1[1], switch$6 = 0; if(typeof ty2 === "number") - switch$5 = 1; + switch$6 = 1; else switch(ty2[0]){ case 4: @@ -14899,26 +14900,26 @@ /*<>*/ return [4, trans(rest1$3, rest2$3)]; case 8: - switch$0 = 5; break; + switch$0 = 5; switch$1 = 1; break; case 9: - switch$0 = 6; break; - case 10: break; + switch$0 = 6; switch$1 = 1; break; + case 10: + switch$1 = 1; break; case 11: - switch$0 = 1; break; + switch$0 = 1; switch$1 = 1; break; case 12: - switch$0 = 2; break; + switch$0 = 2; switch$1 = 1; break; case 13: - switch$0 = 3; break; + switch$0 = 3; switch$1 = 1; break; case 14: - switch$0 = 4; break; - default: switch$5 = 1; + switch$0 = 4; switch$1 = 1; break; + default: switch$6 = 1; } - if(switch$5) switch$0 = 7; break; case 5: - var rest1$4 = ty1[1], switch$6 = 0; + var rest1$4 = ty1[1], switch$7 = 0; if(typeof ty2 === "number") - switch$6 = 1; + switch$7 = 1; else switch(ty2[0]){ case 5: @@ -14926,26 +14927,26 @@ /*<>*/ return [5, trans(rest1$4, rest2$4)]; case 8: - switch$0 = 5; break; + switch$0 = 5; switch$1 = 1; break; case 9: - switch$0 = 6; break; - case 10: break; + switch$0 = 6; switch$1 = 1; break; + case 10: + switch$1 = 1; break; case 11: - switch$0 = 1; break; + switch$0 = 1; switch$1 = 1; break; case 12: - switch$0 = 2; break; + switch$0 = 2; switch$1 = 1; break; case 13: - switch$0 = 3; break; + switch$0 = 3; switch$1 = 1; break; case 14: - switch$0 = 4; break; - default: switch$6 = 1; + switch$0 = 4; switch$1 = 1; break; + default: switch$7 = 1; } - if(switch$6) switch$0 = 7; break; case 6: - var rest1$5 = ty1[1], switch$7 = 0; + var rest1$5 = ty1[1], switch$8 = 0; if(typeof ty2 === "number") - switch$7 = 1; + switch$8 = 1; else switch(ty2[0]){ case 6: @@ -14953,26 +14954,26 @@ /*<>*/ return [6, trans(rest1$5, rest2$5)]; case 8: - switch$0 = 5; break; + switch$0 = 5; switch$1 = 1; break; case 9: - switch$0 = 6; break; - case 10: break; + switch$0 = 6; switch$1 = 1; break; + case 10: + switch$1 = 1; break; case 11: - switch$0 = 1; break; + switch$0 = 1; switch$1 = 1; break; case 12: - switch$0 = 2; break; + switch$0 = 2; switch$1 = 1; break; case 13: - switch$0 = 3; break; + switch$0 = 3; switch$1 = 1; break; case 14: - switch$0 = 4; break; - default: switch$7 = 1; + switch$0 = 4; switch$1 = 1; break; + default: switch$8 = 1; } - if(switch$7) switch$0 = 7; break; case 7: - var rest1$6 = ty1[1], switch$8 = 0; + var rest1$6 = ty1[1], switch$9 = 0; if(typeof ty2 === "number") - switch$8 = 1; + switch$9 = 1; else switch(ty2[0]){ case 7: @@ -14980,26 +14981,26 @@ /*<>*/ return [7, trans(rest1$6, rest2$6)]; case 8: - switch$0 = 5; break; + switch$0 = 5; switch$1 = 1; break; case 9: - switch$0 = 6; break; - case 10: break; + switch$0 = 6; switch$1 = 1; break; + case 10: + switch$1 = 1; break; case 11: - switch$0 = 1; break; + switch$0 = 1; switch$1 = 1; break; case 12: - switch$0 = 2; break; + switch$0 = 2; switch$1 = 1; break; case 13: - switch$0 = 3; break; + switch$0 = 3; switch$1 = 1; break; case 14: - switch$0 = 4; break; - default: switch$8 = 1; + switch$0 = 4; switch$1 = 1; break; + default: switch$9 = 1; } - if(switch$8) switch$0 = 7; break; case 8: - var rest1$7 = ty1[2], ty1$0 = ty1[1], switch$9 = 0; + var rest1$7 = ty1[2], ty1$0 = ty1[1], switch$10 = 0; if(typeof ty2 === "number") - switch$9 = 1; + switch$10 = 1; else switch(ty2[0]){ case 8: @@ -15011,29 +15012,30 @@ /*<>*/ return [8, trans(ty1$0, ty2$0), _de_]; - case 10: break; + case 10: + switch$1 = 1; break; case 11: - switch$0 = 1; break; + switch$0 = 1; switch$1 = 1; break; case 12: - switch$0 = 2; break; + switch$0 = 2; switch$1 = 1; break; case 13: - switch$0 = 3; break; + switch$0 = 3; switch$1 = 1; break; case 14: - switch$0 = 4; break; - default: switch$9 = 1; + switch$0 = 4; switch$1 = 1; break; + default: switch$10 = 1; } - if(switch$9) + if(switch$10) /*<>*/ throw /*<>*/ caml_maybe_attach_backtrace ([0, Assert_failure, _k_], 1); break; case 9: - var rest1$8 = ty1[3], ty12 = ty1[2], ty11 = ty1[1], switch$10 = 0; + var rest1$8 = ty1[3], ty12 = ty1[2], ty11 = ty1[1], switch$11 = 0; if(typeof ty2 === "number") - switch$10 = 1; + switch$11 = 1; else switch(ty2[0]){ case 8: - switch$0 = 5; break; + switch$0 = 5; switch$1 = 1; break; case 9: /*<>*/ var rest2$8 = ty2[3], @@ -15050,18 +15052,19 @@ ty11, ty22, trans(rest1$8, rest2$8)]; - case 10: break; + case 10: + switch$1 = 1; break; case 11: - switch$0 = 1; break; + switch$0 = 1; switch$1 = 1; break; case 12: - switch$0 = 2; break; + switch$0 = 2; switch$1 = 1; break; case 13: - switch$0 = 3; break; + switch$0 = 3; switch$1 = 1; break; case 14: - switch$0 = 4; break; - default: switch$10 = 1; + switch$0 = 4; switch$1 = 1; break; + default: switch$11 = 1; } - if(switch$10) + if(switch$11) /*<>*/ throw /*<>*/ caml_maybe_attach_backtrace ([0, Assert_failure, _l_], 1); break; @@ -15075,85 +15078,93 @@ /*<>*/ throw /*<>*/ caml_maybe_attach_backtrace ([0, Assert_failure, _m_], 1); case 11: - var rest1$10 = ty1[1], switch$11 = 0; + var rest1$10 = ty1[1], switch$12 = 0; if(typeof ty2 === "number") - switch$11 = 1; + switch$12 = 1; else switch(ty2[0]){ - case 10: break; + case 10: + switch$1 = 1; break; case 11: var rest2$10 = ty2[1]; /*<>*/ return [11, trans(rest1$10, rest2$10)]; - default: switch$11 = 1; + default: switch$12 = 1; } - if(switch$11) + if(switch$12) /*<>*/ throw /*<>*/ caml_maybe_attach_backtrace ([0, Assert_failure, _n_], 1); break; case 12: - var rest1$11 = ty1[1], switch$12 = 0; + var rest1$11 = ty1[1], switch$13 = 0; if(typeof ty2 === "number") - switch$12 = 1; + switch$13 = 1; else switch(ty2[0]){ - case 10: break; + case 10: + switch$1 = 1; break; case 11: - switch$0 = 1; break; + switch$0 = 1; switch$1 = 1; break; case 12: var rest2$11 = ty2[1]; /*<>*/ return [12, trans(rest1$11, rest2$11)]; - default: switch$12 = 1; + default: switch$13 = 1; } - if(switch$12) + if(switch$13) /*<>*/ throw /*<>*/ caml_maybe_attach_backtrace ([0, Assert_failure, _o_], 1); break; case 13: - var rest1$12 = ty1[1], switch$13 = 0; + var rest1$12 = ty1[1], switch$14 = 0; if(typeof ty2 === "number") - switch$13 = 1; + switch$14 = 1; else switch(ty2[0]){ - case 10: break; + case 10: + switch$1 = 1; break; case 11: - switch$0 = 1; break; + switch$0 = 1; switch$1 = 1; break; case 12: - switch$0 = 2; break; + switch$0 = 2; switch$1 = 1; break; case 13: var rest2$12 = ty2[1]; /*<>*/ return [13, trans(rest1$12, rest2$12)]; - default: switch$13 = 1; + default: switch$14 = 1; } - if(switch$13) + if(switch$14) /*<>*/ throw /*<>*/ caml_maybe_attach_backtrace ([0, Assert_failure, _p_], 1); break; default: - var rest1$13 = ty1[1], switch$14 = 0; + var rest1$13 = ty1[1], switch$15 = 0; if(typeof ty2 === "number") - switch$14 = 1; + switch$15 = 1; else switch(ty2[0]){ - case 10: break; + case 10: + switch$1 = 1; break; case 11: - switch$0 = 1; break; + switch$0 = 1; switch$1 = 1; break; case 12: - switch$0 = 2; break; + switch$0 = 2; switch$1 = 1; break; case 13: - switch$0 = 3; break; + switch$0 = 3; switch$1 = 1; break; case 14: var rest2$13 = ty2[1]; /*<>*/ return [14, trans(rest1$13, rest2$13)]; - default: switch$14 = 1; + default: switch$15 = 1; } - if(switch$14) + if(switch$15) /*<>*/ throw /*<>*/ caml_maybe_attach_backtrace ([0, Assert_failure, _q_], 1); } + if(! switch$1) + /*<>*/ throw /*<>*/ caml_maybe_attach_backtrace + ([0, Assert_failure, _j_], 1); + } switch(switch$0){ case 0: /*<>*/ throw /*<>*/ caml_maybe_attach_backtrace @@ -15173,12 +15184,9 @@ case 5: /*<>*/ throw /*<>*/ caml_maybe_attach_backtrace ([0, Assert_failure, _c_], 1); - case 6: + default: /*<>*/ throw /*<>*/ caml_maybe_attach_backtrace ([0, Assert_failure, _d_], 1); - default: - /*<>*/ throw /*<>*/ caml_maybe_attach_backtrace - ([0, Assert_failure, _j_], 1); } /*<>*/ } function fmtty_of_padding_fmtty(pad, fmtty){ @@ -26407,8 +26415,9 @@ } /*<>*/ } function output_acc(ppf, acc){ - /*<>*/ var switch$0 = 0; - if(typeof acc === "number") /*<>*/ return 0; + /*<>*/ if(typeof acc === "number") + /*<>*/ return 0; + var switch$0 = 0; switch(acc[0]){ case 0: var f = acc[2], p = acc[1]; @@ -26520,8 +26529,9 @@ } /*<>*/ } function strput_acc(ppf, acc){ - /*<>*/ var switch$0 = 0; - if(typeof acc === "number") /*<>*/ return 0; + /*<>*/ if(typeof acc === "number") + /*<>*/ return 0; + var switch$0 = 0; switch(acc[0]){ case 0: var f = acc[2], p = acc[1]; From 67b31b84201db5bceae4009a46b1c549c0b89af9 Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Mon, 31 Jul 2023 11:40:27 +0200 Subject: [PATCH 3/6] Compiler: restore optim --- compiler/lib/global_flow.ml | 38 ++++++++++++++++++++++++------------- 1 file changed, 25 insertions(+), 13 deletions(-) diff --git a/compiler/lib/global_flow.ml b/compiler/lib/global_flow.ml index 99589264db..6c9f673247 100644 --- a/compiler/lib/global_flow.ml +++ b/compiler/lib/global_flow.ml @@ -245,22 +245,34 @@ let program_deps st { blocks; _ } = | Cond (x, cont1, cont2) -> cont_deps blocks st cont1; cont_deps blocks st ~ignore:x cont2 - | Switch (x, a1) -> + | Switch (x, a1) -> ( Array.iter a1 ~f:(fun cont -> cont_deps blocks st cont); - let h = Hashtbl.create 16 in if not st.fast then - Hashtbl.iter - (fun pc tags -> - let block = Addr.Map.find pc blocks in - List.iter - ~f:(fun (i, _) -> - match i with - | Let (y, Field (x', _)) when Var.equal x x' -> - Hashtbl.add st.known_cases y tags - | _ -> ()) - block.body) - h + (* looking up the def of x is fine here, because the tag + we're looking for is at addr [pc - 2] (see + parse_bytecode.ml) and [Addr.Map.iter] iterate in + increasing order *) + match st.defs.(Code.Var.idx x) with + | Expr (Prim (Extern "%direct_obj_tag", [ Pv b ])) -> + let h = Hashtbl.create 16 in + Array.iteri a1 ~f:(fun i (pc, _) -> + Hashtbl.replace + h + pc + (i :: (try Hashtbl.find h pc with Not_found -> []))); + Hashtbl.iter + (fun pc tags -> + let block = Addr.Map.find pc blocks in + List.iter + ~f:(fun (i, _) -> + match i with + | Let (y, Field (x', _)) when Var.equal b x' -> + Hashtbl.add st.known_cases y tags + | _ -> ()) + block.body) + h + | Expr _ | Phi _ -> ()) | Pushtrap (cont, x, cont_h, _) -> add_var st x; st.defs.(Var.idx x) <- Phi { known = Var.Set.empty; others = true }; From 6130d3bf141589b87d84a120e1134376b08f8d10 Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Mon, 31 Jul 2023 12:39:42 +0200 Subject: [PATCH 4/6] simplify --- compiler/lib/eval.ml | 42 ++++++++++++++++++------------------------ 1 file changed, 18 insertions(+), 24 deletions(-) diff --git a/compiler/lib/eval.ml b/compiler/lib/eval.ml index 11f52885ab..58c63a3e43 100644 --- a/compiler/lib/eval.ml +++ b/compiler/lib/eval.ml @@ -189,33 +189,25 @@ let is_int info x = | Pc (Int _) -> Y | Pc _ -> N -type case_of = - | CConst of int - | CTag of int - | Unknown - -let the_case_of info x = +let the_tag_of info x = match x with | Pv x -> get_approx info (fun x -> match info.info_defs.(Var.idx x) with - | Expr (Constant (Int i)) -> CConst (Int32.to_int i) | Expr (Block (j, _, _)) -> - if Var.ISet.mem info.info_possibly_mutable x then Unknown else CTag j - | Expr (Constant (Tuple (j, _, _))) -> CTag j - | _ -> Unknown) - Unknown + if Var.ISet.mem info.info_possibly_mutable x then None else Some j + | Expr (Constant (Tuple (j, _, _))) -> Some j + | _ -> None) + None (fun u v -> match u, v with - | CTag i, CTag j when i = j -> u - | CConst i, CConst j when i = j -> u - | _ -> Unknown) + | Some i, Some j when i = j -> u + | _ -> None) x - | Pc (Int i) -> CConst (Int32.to_int i) - | Pc (Tuple (j, _, _)) -> CTag j - | _ -> Unknown + | Pc (Tuple (j, _, _)) -> Some j + | _ -> None let eval_instr info ((x, loc) as i) = match x with @@ -257,12 +249,12 @@ let eval_instr info ((x, loc) as i) = Flow.update_def info x c; [ Let (x, c), loc ]) | Let (x, Prim (Extern "%direct_obj_tag", [ y ])) -> ( - match the_case_of info y with - | CTag tag -> + match the_tag_of info y with + | Some tag -> let c = Constant (Int (Int32.of_int tag)) in Flow.update_def info x c; [ Let (x, c), loc ] - | CConst _ | Unknown -> [ i ]) + | None -> [ i ]) | Let (x, Prim (Extern "caml_sys_const_backend_type", [ _ ])) -> let jsoo = Code.Var.fresh () in [ Let (jsoo, Constant (String "js_of_ocaml")), noloc @@ -349,13 +341,15 @@ let eval_branch info (l, loc) = | Non_zero -> Branch ftrue | Unknown -> b) | Switch (x, const) as b -> ( - (* [the_case_of info (Pv x)] might be meaningless when we're inside a dead code. + (* The value of [x] might be meaningless when we're inside a dead code. The proper fix would be to remove the deadcode entirely. Meanwhile, add guards to prevent Invalid_argument("index out of bounds") see https://github.com/ocsigen/js_of_ocaml/issues/485 *) - match the_case_of info (Pv x) with - | CConst j when j >= 0 && j < Array.length const -> Branch const.(j) - | CConst _ | CTag _ | Unknown -> b) + match the_int info (Pv x) with + | Some j -> + let j = Int32.to_int j in + if j >= 0 && j < Array.length const then Branch const.(j) else b + | None -> b) | _ as b -> b in l, loc From 121f6938765fa9bde17bb8ca8736c2050a3dde48 Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Mon, 31 Jul 2023 12:57:14 +0200 Subject: [PATCH 5/6] test --- compiler/tests-compiler/static_eval.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/compiler/tests-compiler/static_eval.ml b/compiler/tests-compiler/static_eval.ml index d2600f4df3..0daf9128d8 100644 --- a/compiler/tests-compiler/static_eval.ml +++ b/compiler/tests-compiler/static_eval.ml @@ -166,11 +166,11 @@ let%expect_test "static eval of tags" = type t = A | B | C of t | D of t let foobar = - let x = C (D A) in + let x = if Random.int 3 > 1 then C (D A) else D (A) in match x with | A -> 1 | B -> 2 - | C _ -> 2 + | C _ | D _ -> 3 let export = [|foobar;foobar|] From c581ed93c686ba36cf6334d8846bf8672f3b69bc Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Mon, 31 Jul 2023 13:02:06 +0200 Subject: [PATCH 6/6] more --- compiler/lib/eval.ml | 44 +++++++++++++++++--------- compiler/tests-compiler/static_eval.ml | 23 ++++++++++---- 2 files changed, 46 insertions(+), 21 deletions(-) diff --git a/compiler/lib/eval.ml b/compiler/lib/eval.ml index 58c63a3e43..7599535dea 100644 --- a/compiler/lib/eval.ml +++ b/compiler/lib/eval.ml @@ -189,7 +189,7 @@ let is_int info x = | Pc (Int _) -> Y | Pc _ -> N -let the_tag_of info x = +let the_tag_of info x get = match x with | Pv x -> get_approx @@ -197,18 +197,38 @@ let the_tag_of info x = (fun x -> match info.info_defs.(Var.idx x) with | Expr (Block (j, _, _)) -> - if Var.ISet.mem info.info_possibly_mutable x then None else Some j - | Expr (Constant (Tuple (j, _, _))) -> Some j + if Var.ISet.mem info.info_possibly_mutable x then None else get j + | Expr (Constant (Tuple (j, _, _))) -> get j | _ -> None) None (fun u v -> match u, v with - | Some i, Some j when i = j -> u + | Some i, Some j when Poly.(i = j) -> u | _ -> None) x - | Pc (Tuple (j, _, _)) -> Some j + | Pc (Tuple (j, _, _)) -> get j | _ -> None +let the_cont_of info x (a : cont array) = + (* The value of [x] might be meaningless when we're inside a dead code. + The proper fix would be to remove the deadcode entirely. + Meanwhile, add guards to prevent Invalid_argument("index out of bounds") + see https://github.com/ocsigen/js_of_ocaml/issues/485 *) + let get i = if i >= 0 && i < Array.length a then Some a.(i) else None in + get_approx + info + (fun x -> + match info.info_defs.(Var.idx x) with + | Expr (Prim (Extern "%direct_obj_tag", [ b ])) -> the_tag_of info b get + | Expr (Constant (Int j)) -> get (Int32.to_int j) + | _ -> None) + None + (fun u v -> + match u, v with + | Some i, Some j when Poly.(i = j) -> u + | _ -> None) + x + let eval_instr info ((x, loc) as i) = match x with | Let (x, Prim (Extern ("caml_js_equals" | "caml_equal"), [ y; z ])) -> ( @@ -249,7 +269,7 @@ let eval_instr info ((x, loc) as i) = Flow.update_def info x c; [ Let (x, c), loc ]) | Let (x, Prim (Extern "%direct_obj_tag", [ y ])) -> ( - match the_tag_of info y with + match the_tag_of info y (fun x -> Some x) with | Some tag -> let c = Constant (Int (Int32.of_int tag)) in Flow.update_def info x c; @@ -340,15 +360,9 @@ let eval_branch info (l, loc) = | Zero -> Branch ffalse | Non_zero -> Branch ftrue | Unknown -> b) - | Switch (x, const) as b -> ( - (* The value of [x] might be meaningless when we're inside a dead code. - The proper fix would be to remove the deadcode entirely. - Meanwhile, add guards to prevent Invalid_argument("index out of bounds") - see https://github.com/ocsigen/js_of_ocaml/issues/485 *) - match the_int info (Pv x) with - | Some j -> - let j = Int32.to_int j in - if j >= 0 && j < Array.length const then Branch const.(j) else b + | Switch (x, a) as b -> ( + match the_cont_of info x a with + | Some cont -> Branch cont | None -> b) | _ as b -> b in diff --git a/compiler/tests-compiler/static_eval.ml b/compiler/tests-compiler/static_eval.ml index 0daf9128d8..204d45b3ee 100644 --- a/compiler/tests-compiler/static_eval.ml +++ b/compiler/tests-compiler/static_eval.ml @@ -163,15 +163,16 @@ let%expect_test "static eval of tags" = compile_and_parse {| - type t = A | B | C of t | D of t + type t = A | B | C of t | D of t | E of t let foobar = let x = if Random.int 3 > 1 then C (D A) else D (A) in match x with | A -> 1 | B -> 2 - | C _ + | C _ | D _ -> 3 + | E _ -> 5 let export = [|foobar;foobar|] |} @@ -181,11 +182,21 @@ let%expect_test "static eval of tags" = {| (function(globalThis){ "use strict"; + var runtime = globalThis.jsoo_runtime; + function caml_call1(f, a0){ + return (f.l >= 0 ? f.l : f.l = f.length) == 1 + ? f(a0) + : runtime.caml_call_gen(f, [a0]); + } var - runtime = globalThis.jsoo_runtime, - export$0 = [0, 2, 2], - Test = [0, 2, export$0]; - runtime.caml_register_global(1, Test, "Test"); + global_data = runtime.caml_get_global_data(), + Stdlib_Random = global_data.Stdlib__Random, + _a_ = [0, [1, 0]], + _b_ = [1, 0], + x = 1 < caml_call1(Stdlib_Random[5], 3) ? _a_ : _b_; + x[0]; + var export$0 = [0, 3, 3], Test = [0, 3, export$0]; + runtime.caml_register_global(3, Test, "Test"); return; } (globalThis));