diff --git a/AGENTS.md b/AGENTS.md index dd3038a995..efdae76bad 100644 --- a/AGENTS.md +++ b/AGENTS.md @@ -292,11 +292,15 @@ The compiler is designed for fast feedback loops and scales to large codebases: ### Stacked pull requests -When a PR depends on another unmerged PR, create a native GitHub stack with -`gh stack` rather than only targeting the preceding feature branch. Keep the -branches linear and in the same repository, and list branches or PRs from -bottom to top. For existing PRs, use `gh stack link BOTTOM_PR [NEXT_PR...]`, -then verify that GitHub reports stack metadata and runs CI for every PR. +When a PR depends on another unmerged PR, make a native GitHub stack. Keep the +branches linear and in the same repository, then run `gh stack link BOTTOM +[NEXT...]`, listing the stack bottom to top. Each argument is a branch name or +a PR number: the command pushes each branch, reuses the PR that already exists +for it, and opens one where there is none, so branches alone are enough. Open +the PRs yourself first if you want to write their titles and descriptions. + +Linking sets each PR's base to the branch below it, leaving only the bottom PR +on `master`. CI runs on every PR in the stack. ### Code Quality diff --git a/CHANGELOG.md b/CHANGELOG.md index 0570947a2f..5f4034ef92 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -78,6 +78,7 @@ - Split `lambda.ml` into the IR and its traversals, static exits and path translation, so the module defining `Lambda.t` no longer reaches into `Env` or `Path`. https://github.com/rescript-lang/rescript/pull/8618 - Record a record field's `@as` rename on the declaration instead of re-reading the attribute, so every place that needs the runtime name reads one field. https://github.com/rescript-lang/rescript/pull/8619 - Record a variant constructor's `@as` tag on the declaration instead of re-interpreting its attributes, keeping the source spelling for printing. https://github.com/rescript-lang/rescript/pull/8619 +- Optimization passes now return the term they were given when they change nothing, rather than rebuilding an identical one. https://github.com/rescript-lang/rescript/pull/8620 - Merge the duplicate Lam intermediate representation into Lambda, removing the conversion layer and obsolete supporting infrastructure. Lambda is now a single private, normalized representation, with generated JavaScript remaining semantically unchanged. https://github.com/rescript-lang/rescript/pull/8608 - Add genType and source map controls and output to the developer playground. https://github.com/rescript-lang/rescript/pull/8448 - Rework the object-type representation end to end: object rows are plain field chains carrying a per-field mutability state (no phantom setter members), object literals are typed directly and property access and assignment are first-class AST and Lambda nodes shared between the Lambda and JS pipelines, and dead class-system remnants (the field-presence lattice, the class-abbreviation memo on object types, method-send typing) are removed. https://github.com/rescript-lang/rescript/pull/8597 diff --git a/compiler/core/README.md b/compiler/core/README.md index 021e56764f..ef168b7d80 100644 --- a/compiler/core/README.md +++ b/compiler/core/README.md @@ -10,15 +10,37 @@ Typedtree translation in `compiler/ml/translcore.ml` and `compiler/ml/translmod.ml` produces the `Lambda` representation defined in `compiler/ml/lambda.mli`. -[`lam_convert.ml`](lam_convert.ml) -: Collects the modules a compilation unit depends on, read off the Lambda - term. - `lam_pass_*.ml` and the other `lam_*.ml` modules : Analyze and transform Lambda. [`lam_compile_main.ml`](lam_compile_main.ml) coordinates the backend pass sequence; read it before inserting or reordering a pass. + The sequence is hand-unrolled rather than iterated to a fixed point. Only + `simplify_alias` reads the statistics, and a fresh `collect_info` runs + immediately before each of its three rounds. `simplify_lets` and `sroa` + compute what they need themselves. Each `-debug-ir` dump is named after the + pass whose output it holds. + + | # | pass | statistics | + |---|---|---| + | 1 | `collapse_var_aliases` | | + | 2 | `deep_flatten` | | + | 3 | `simplify_exits` | | + | 4 | `simplify_alias` | reads a snapshot taken just before | + | 5 | `deep_flatten` | | + | 6 | `simplify_alias` | reads a snapshot taken just before | + | 7 | `deep_flatten` | | + | 8 | `simplify_exits` | | + | 9 | `simplify_alias` | reads a snapshot taken just before | + | 10 | `simplify_lets` | own occurrence count | + | 11 | `sroa` | own field-use classification | + | 12 | `simplify_exits` | | + | 13 | `guard_raises` | | + + A snapshot is fresh when its pass starts, but `simplify_alias` also mutates + the table as it rewrites, so entries can describe an earlier version of the + term by the time the pass finishes. + [`lam_compile.ml`](lam_compile.ml) : Lowers Lambda to JavaScript IR. Primitive-specific and FFI lowering is split into `lam_compile_primitive.ml`, `lam_compile_external_call.ml`, and related @@ -35,7 +57,8 @@ Typedtree translation in `compiler/ml/translcore.ml` and ## Changing a representation `Lambda.t` is private: every term is built through the constructors in -[`../ml/lambda.mli`](../ml/lambda.mli), six of which normalize as they build. +[`../ml/lambda.mli`](../ml/lambda.mli), seven of which normalize as they +build: `apply`, `prim`, `switch`, `stringswitch`, `if_`, `seq` and `not_`. A constructor may replace a node with an equivalent one, but may not move code between branches - that is what a pass is for. When adding or changing a constructor, search every producer, traversal, optimizer, printer, serializer, diff --git a/compiler/core/lam_compile_main.ml b/compiler/core/lam_compile_main.ml index 22ca829f68..4aee81b8c0 100644 --- a/compiler/core/lam_compile_main.ml +++ b/compiler/core/lam_compile_main.ml @@ -290,17 +290,17 @@ let compile (output_prefix : string) export_idents hoisted (lam : Lambda.t) = Lam_compile_env.reset () in let may_required_modules = required_modules lam in + let lam = d "initial" lam in let lam = Lam_pass_collapse_var_aliases.collapse ~exports:export_ident_sets lam in - - let lam = d "initial" lam in + let lam = d "collapse_var_aliases" lam in let lam = Lam_pass_deep_flatten.deep_flatten lam in - let lam = d "flatten0" lam in + let lam = d "deep_flatten 1" lam in let meta : Lam_stats.t = Lam_stats.make ~export_idents ~export_ident_sets in let lam = let lam = - lam |> d "flatten1" |> Lam_pass_exits.simplify_exits |> d "simplify_exits" + lam |> Lam_pass_exits.simplify_exits |> d "simplify_exits 1" |> (fun lam -> Lam_pass_collect.collect_info meta lam; if debug_ir then @@ -308,30 +308,26 @@ let compile (output_prefix : string) export_idents hoisted (lam : Lambda.t) = meta; lam) |> Lam_pass_remove_alias.simplify_alias meta - |> d "simplify_alias" |> Lam_pass_deep_flatten.deep_flatten - |> d "flatten2" + |> d "simplify_alias 1" |> Lam_pass_deep_flatten.deep_flatten + |> d "deep_flatten 2" in - (* Inling happens*) - + (* Inlining happens *) let () = Lam_pass_collect.collect_info meta lam in let lam = Lam_pass_remove_alias.simplify_alias meta lam in + let lam = d "simplify_alias 2" lam in let lam = Lam_pass_deep_flatten.deep_flatten lam in + let lam = d "deep_flatten 3" lam in let lam = lam |> Lam_pass_exits.simplify_exits in let () = Lam_pass_collect.collect_info meta lam in - lam |> d "simplify_alias_before" + lam |> d "simplify_exits 2" |> Lam_pass_remove_alias.simplify_alias meta - |> d "before-simplify_lets" + |> d "simplify_alias 3" (* we should investigate a better way to put different passes : )*) |> Lam_pass_lets_dce.simplify_lets |> d "simplify_lets" |> Lam_pass_sroa.simplify |> d "sroa" - |> d "before-simplify-exits" - (* |> (fun lam -> Lam_pass_collect.collect_info meta lam - ; Lam_pass_remove_alias.simplify_alias meta lam) *) - (* |> Lam_group_pass.scc_pass - |> d "scc" *) - |> Lam_pass_exits.simplify_exits - |> Lam_pass_guard_raises.guard_raises |> d "simplify_lets" + |> Lam_pass_exits.simplify_exits |> d "simplify_exits 3" + |> Lam_pass_guard_raises.guard_raises |> d "guard_raises" |> fun lam -> if debug_ir then Ext_log.dwarn ~__POS__ "Before coercion: %a@." Lam_stats.print meta; diff --git a/compiler/core/lam_exit_count.ml b/compiler/core/lam_exit_count.ml index 17d07b8d90..cfda12c69e 100644 --- a/compiler/core/lam_exit_count.ml +++ b/compiler/core/lam_exit_count.ml @@ -30,6 +30,14 @@ let count_exit (exits : collection) i = Hash_int.find_default exits i 0 let incr_exit (exits : collection) i = Hash_int.add_or_update exits i 1 ~update:succ +(* Whether [Lam_pass_exits] could rewrite anything here. It names the two + nodes that pass touches, so a new case there that rewrites something else + has to be added here too, or the pass will silently stop firing. *) +let rec has_static_exit (lam : Lambda.t) = + match lam with + | Lstaticraise _ | Lstaticcatch _ -> true + | _ -> Lambda_traverse.shallow_exists has_static_exit lam + (** This funcition counts how each [exit] is used, it will affect how the following optimizations performed. @@ -48,70 +56,72 @@ let incr_exit (exits : collection) i = For Lswitch, if it is not exhuastive pattern match, default will be counted twice. Since for pattern match, we will test whether it is an integer or block, both have default cases predicate: [sw_consts_full] vs nconsts *) -let count_helper (lam : Lambda.t) : collection = - let exits : collection = Hash_int.create 17 in - let rec count (lam : Lambda.t) = - match lam with - | Lstaticraise (i, ls) -> - incr_exit exits i; - Ext_list.iter ls count - | Lstaticcatch (l1, (i, _), l2) -> - count l1; - if count_exit exits i > 0 then count l2 - | Lstringswitch (l, sw, d) -> - count l; - Ext_list.iter_snd sw count; - Ext_option.iter d count - | Lglobal_module _ | Lvar _ | Lconst _ -> () - | Lapply {ap_func; ap_args; _} -> - count ap_func; - Ext_list.iter ap_args count - | Lfunction {body} -> count body - | Llet (_, _, l1, l2) -> - count l2; - count l1 - | Lletrec (bindings, body) -> - Ext_list.iter_snd bindings count; - count body - | Lprim {args; _} -> List.iter count args - | Lswitch (l, sw) -> - count_default sw; - count l; - Ext_list.iter_snd sw.sw_consts count; - Ext_list.iter_snd sw.sw_blocks count - | Ltrywith (l1, _v, l2) -> - count l1; - count l2 - | Lifthenelse (l1, l2, l3) -> - count l1; - count l2; - count l3 - | Lsequence (l1, l2) -> - count l1; - count l2 - | Lbreak | Lcontinue -> () - | Lwhile (l1, l2) -> - count l1; - count l2 - | Lfor (_, l1, l2, _dir, l3) -> - count l1; - count l2; - count l3 - | Lfor_of (_, l1, l2) -> - count l1; - count l2 - | Lfor_await_of (_, l1, l2) -> - count l1; - count l2 - | Lassign (_, l) -> count l - and count_default sw = - match sw.sw_failaction with - | None -> () - | Some al -> - if (not sw.sw_consts_full) && not sw.sw_blocks_full then ( - count al; - count al) - else count al - in - count lam; - exits +let count_helper (lam : Lambda.t) : collection option = + if not (has_static_exit lam) then None + else + let exits : collection = Hash_int.create 17 in + let rec count (lam : Lambda.t) = + match lam with + | Lstaticraise (i, ls) -> + incr_exit exits i; + Ext_list.iter ls count + | Lstaticcatch (l1, (i, _), l2) -> + count l1; + if count_exit exits i > 0 then count l2 + | Lstringswitch (l, sw, d) -> + count l; + Ext_list.iter_snd sw count; + Ext_option.iter d count + | Lglobal_module _ | Lvar _ | Lconst _ -> () + | Lapply {ap_func; ap_args; _} -> + count ap_func; + Ext_list.iter ap_args count + | Lfunction {body} -> count body + | Llet (_, _, l1, l2) -> + count l2; + count l1 + | Lletrec (bindings, body) -> + Ext_list.iter_snd bindings count; + count body + | Lprim {args; _} -> List.iter count args + | Lswitch (l, sw) -> + count_default sw; + count l; + Ext_list.iter_snd sw.sw_consts count; + Ext_list.iter_snd sw.sw_blocks count + | Ltrywith (l1, _v, l2) -> + count l1; + count l2 + | Lifthenelse (l1, l2, l3) -> + count l1; + count l2; + count l3 + | Lsequence (l1, l2) -> + count l1; + count l2 + | Lbreak | Lcontinue -> () + | Lwhile (l1, l2) -> + count l1; + count l2 + | Lfor (_, l1, l2, _dir, l3) -> + count l1; + count l2; + count l3 + | Lfor_of (_, l1, l2) -> + count l1; + count l2 + | Lfor_await_of (_, l1, l2) -> + count l1; + count l2 + | Lassign (_, l) -> count l + and count_default sw = + match sw.sw_failaction with + | None -> () + | Some al -> + if (not sw.sw_consts_full) && not sw.sw_blocks_full then ( + count al; + count al) + else count al + in + count lam; + Some exits diff --git a/compiler/core/lam_exit_count.mli b/compiler/core/lam_exit_count.mli index 71f632ca1c..dbffe581fc 100644 --- a/compiler/core/lam_exit_count.mli +++ b/compiler/core/lam_exit_count.mli @@ -24,6 +24,7 @@ type collection -val count_helper : Lambda.t -> collection +val count_helper : Lambda.t -> collection option +(** [None] when the term holds no static exit, so nothing needs rewriting. *) val count_exit : collection -> int -> int diff --git a/compiler/core/lam_pass_collapse_var_aliases.ml b/compiler/core/lam_pass_collapse_var_aliases.ml index 279a1d2842..4dbb766e82 100644 --- a/compiler/core/lam_pass_collapse_var_aliases.ml +++ b/compiler/core/lam_pass_collapse_var_aliases.ml @@ -11,51 +11,20 @@ let rec resolve tbl id = | Some id' -> resolve tbl id' let collapse ~exports (lam : Lambda.t) : Lambda.t = - let tbl = Hash_ident.create 64 in + let tbl = Hash_ident.create 16 in let rec go (lam : Lambda.t) : Lambda.t = match lam with - | Lvar x -> Lambda.var (resolve tbl x) - | Lglobal_module _ | Lconst _ | Lbreak | Lcontinue -> lam - | Lapply {ap_func; ap_args; ap_info; ap_transformed_jsx} -> - Lambda.apply (go ap_func) (Ext_list.map ap_args go) ap_info - ~ap_transformed_jsx - | Lfunction {params; body; attr; loc} -> - Lambda.function_ ~loc ~attr ~params ~body:(go body) + | Lvar x -> + let x' = resolve tbl x in + if x' == x then lam else Lambda.var x' | Llet (Alias, id, Lvar u, body) -> let u = resolve tbl u in Hash_ident.add tbl id u; + (* The binding is dropped unless the name is exported, in which case it + has to survive under its own name. *) if Set_ident.mem exports id then Lambda.let_ Alias id (Lambda.var u) (go body) else go body - | Llet (kind, id, arg, body) -> Lambda.let_ kind id (go arg) (go body) - | Lletrec (bindings, body) -> - Lambda.letrec (Ext_list.map_snd bindings go) (go body) - | Lprim {primitive; args; loc} -> - Lambda.prim ~primitive ~args:(Ext_list.map args go) loc - | Lswitch (arg, sw) -> - Lambda.switch (go arg) - { - sw with - sw_consts = Ext_list.map_snd sw.sw_consts go; - sw_blocks = Ext_list.map_snd sw.sw_blocks go; - sw_failaction = Ext_option.map sw.sw_failaction go; - } - | Lstringswitch (arg, cases, default) -> - Lambda.stringswitch (go arg) - (Ext_list.map_snd cases go) - (Ext_option.map default go) - | Lstaticraise (i, args) -> Lambda.staticraise i (Ext_list.map args go) - | Lstaticcatch (body, ids, handler) -> - Lambda.staticcatch (go body) ids (go handler) - | Ltrywith (body, id, handler) -> Lambda.try_ (go body) id (go handler) - | Lifthenelse (b, t, e) -> Lambda.if_ (go b) (go t) (go e) - | Lsequence (a, b) -> Lambda.seq (go a) (go b) - | Lwhile (b, body) -> Lambda.while_ (go b) (go body) - | Lfor (id, lo, hi, dir, body) -> - Lambda.for_ id (go lo) (go hi) dir (go body) - | Lfor_of (id, iterable, body) -> Lambda.for_of id (go iterable) (go body) - | Lfor_await_of (id, iterable, body) -> - Lambda.for_await_of id (go iterable) (go body) - | Lassign (id, e) -> Lambda.assign id (go e) + | _ -> Lambda_traverse.shallow_map_sharing go lam in go lam diff --git a/compiler/core/lam_pass_count.ml b/compiler/core/lam_pass_count.ml index 7f3ce84b1e..f2d8dde559 100644 --- a/compiler/core/lam_pass_count.ml +++ b/compiler/core/lam_pass_count.ml @@ -42,7 +42,7 @@ let absorb_info (x : used_info) (y : used_info) = so uses of outer bindings are marked as captured. The optimizer uses the captured flag to restrict inlining without inflating the occurrence count. *) let collect_occurs lam : occ_tbl = - let occ : occ_tbl = Hash_ident.create 83 in + let occ : occ_tbl = Hash_ident.create 16 in (* Current use count of a variable. *) let used v = diff --git a/compiler/core/lam_pass_deep_flatten.ml b/compiler/core/lam_pass_deep_flatten.ml index d4bdab9e42..a061800717 100644 --- a/compiler/core/lam_pass_deep_flatten.ml +++ b/compiler/core/lam_pass_deep_flatten.ml @@ -128,6 +128,32 @@ let rec rhs_is_beta_residue (lam : Lambda.t) = | Lapply _ -> true | _ -> false +(* [flatten] restructures a binding only when it hoists something out of the + right hand side, splits a null conversion, or eliminates a tuple. Every + other binding comes back as the same binding, so it can be rebuilt in place + and shared instead of taken apart and reassembled. + + This mirrors [flatten]'s own cases one for one, including why a null + conversion of a variable is left alone while any other one is split, so a + case added there that restructures has to be added here too. Drifting apart + costs the flattening, silently: the binding takes the fast path and is never + handed to [flatten] at all. *) +let regroups_binding (str : Lambda.let_kind) (id : Ident.t) (arg : Lambda.t) = + if rhs_is_beta_residue arg then false + else + match arg with + | Lambda.Llet _ | Lsequence _ | Lletrec _ -> true + | Lprim {primitive = Pnull_to_opt | Pnull_undefined_to_opt; args = [Lvar _]} + -> + false + | Lprim {primitive = Pnull_to_opt | Pnull_undefined_to_opt} -> true + | Lprim {primitive = Pmakeblock info} -> + (match (id.name, str) with + | ("match" | "include" | "param"), (Alias | Strict | StrictOpt) -> true + | _ -> false) + && Lambda.is_immutable_block info + | _ -> false + let deep_flatten (lam : Lambda.t) : Lambda.t = let rec flatten (acc : Lam_group.t list) (lam : Lambda.t) : Lambda.t * Lam_group.t list = @@ -198,18 +224,20 @@ let deep_flatten (lam : Lambda.t) : Lambda.t = | x -> (aux x, acc) and aux (lam : Lambda.t) : Lambda.t = match lam with + | Llet (str, id, arg, body) when not (regroups_binding str id arg) -> + Lam_util.refine_let ~original:lam ~kind:str id (aux arg) (aux body) | Llet _ -> let res, groups = flatten [] lam in lambda_of_groups res ~rev_bindings:groups - | Lletrec (bind_args, body) -> + | Lletrec (bind_args, body) -> ( (* Attention: don't mess up with internal {let rec} *) - let rec iter bind_args groups set = - match bind_args with - | [] -> (List.rev groups, set) - | (id, arg) :: rest -> - iter rest ((id, aux arg) :: groups) (Set_ident.add set id) + (* Keep the mapped list so a group from which nothing can be extracted + remains physically shared when neither its bindings nor body change. *) + let groups = Ext_list.map_snd_sharing bind_args aux in + let collections = + Ext_list.fold_left groups Set_ident.empty (fun set (id, _) -> + Set_ident.add set id) in - let groups, collections = iter bind_args [] Set_ident.empty in (* Try to extract some value definitions from recursive values as [wrap], it will stop whenever it find it could not move forward {[ @@ -219,76 +247,23 @@ let deep_flatten (lam : Lambda.t) : Lambda.t = ... ]} *) - let rev_bindings, rev_wrap, _ = - Ext_list.fold_left groups ([], [], false) - (fun (inner_recursive_bindings, wrap, stop) (id, lam) -> - if stop || Lam_hit.hit_variables collections lam then - ((id, lam) :: inner_recursive_bindings, wrap, true) - else - ( inner_recursive_bindings, - Lam_group.Single (Strict, id, lam) :: wrap, - false )) + let rec extract rev_wrap = function + | [] -> (rev_wrap, []) + | (_, binding) :: _ as bindings + when Lam_hit.hit_variables collections binding -> + (rev_wrap, bindings) + | (id, binding) :: rest -> + extract (Lam_group.Single (Strict, id, binding) :: rev_wrap) rest in - lambda_of_groups - ~rev_bindings:rev_wrap (* These bindings are extracted from [letrec] *) - (Lambda.letrec (List.rev rev_bindings) (aux body)) - | Lsequence (l, r) -> Lambda.seq (aux l) (aux r) - | Lconst _ -> lam - | Lvar _ -> lam - (* | Lapply(Lfunction(Curried, params, body), args, _) *) - (* when List.length params = List.length args -> *) - (* aux (beta_reduce params body args) *) - (* | Lapply(Lfunction(Tupled, params, body), [Lprim(Pmakeblock _, args)], _) *) - (* (\** TODO: keep track of this parameter in ocaml trunk, *) - (* can we switch to the tupled backend? *\) *) - (* when List.length params = List.length args -> *) - (* aux (beta_reduce params body args) *) - | Lapply {ap_func = l1; ap_args = ll; ap_info; ap_transformed_jsx} -> - Lambda.apply (aux l1) (Ext_list.map ll aux) ap_info ~ap_transformed_jsx - (* This kind of simple optimizations should be done each time - and as early as possible *) - | Lglobal_module _ -> lam - | Lprim {primitive; args; loc} -> - let args = Ext_list.map args aux in - Lambda.prim ~primitive ~args loc - | Lfunction {params; body; attr; loc} -> - Lambda.function_ ~loc ~params ~body:(aux body) ~attr - | Lswitch - ( l, - { - sw_failaction; - sw_consts; - sw_blocks; - sw_blocks_full; - sw_consts_full; - sw_dispatch; - } ) -> - Lambda.switch (aux l) - { - sw_consts = Ext_list.map_snd sw_consts aux; - sw_blocks = Ext_list.map_snd sw_blocks aux; - sw_consts_full; - sw_blocks_full; - sw_failaction = Ext_option.map sw_failaction aux; - sw_dispatch; - } - | Lstringswitch (l, sw, d) -> - Lambda.stringswitch (aux l) (Ext_list.map_snd sw aux) - (Ext_option.map d aux) - | Lstaticraise (i, ls) -> Lambda.staticraise i (Ext_list.map ls aux) - | Lstaticcatch (l1, ids, l2) -> Lambda.staticcatch (aux l1) ids (aux l2) - | Ltrywith (l1, v, l2) -> Lambda.try_ (aux l1) v (aux l2) - | Lifthenelse (l1, l2, l3) -> Lambda.if_ (aux l1) (aux l2) (aux l3) - | Lbreak -> Lambda.break - | Lcontinue -> Lambda.continue - | Lwhile (l1, l2) -> Lambda.while_ (aux l1) (aux l2) - | Lfor (flag, l1, l2, dir, l3) -> - Lambda.for_ flag (aux l1) (aux l2) dir (aux l3) - | Lfor_of (flag, l1, l2) -> Lambda.for_of flag (aux l1) (aux l2) - | Lfor_await_of (flag, l1, l2) -> Lambda.for_await_of flag (aux l1) (aux l2) - | Lassign (v, l) -> - (* Lalias-bound variables are never assigned, so don't increase - v's refaux *) - Lambda.assign v (aux l) + let rev_wrap, recursive_bindings = extract [] groups in + let body' = aux body in + match rev_wrap with + | [] when groups == bind_args && body' == body -> lam + | [] -> Lambda.letrec groups body' + | _ -> + lambda_of_groups + ~rev_bindings:rev_wrap (* Extracted bindings from [letrec]. *) + (Lambda.letrec recursive_bindings body')) + | _ -> Lambda_traverse.shallow_map_sharing aux lam in aux lam diff --git a/compiler/core/lam_pass_exits.ml b/compiler/core/lam_pass_exits.ml index 04439ca2e5..24b12988bb 100644 --- a/compiler/core/lam_pass_exits.ml +++ b/compiler/core/lam_pass_exits.ml @@ -168,27 +168,30 @@ let subst_helper (subst : subst_tbl) (query : int -> int) (lam : Lambda.t) : Hash_int.add subst i (xs, Id (simplif l2)); simplif l1 (* l1 will inline *) | _ -> - let l2 = simplif l2 in + let l2' = simplif l2 in (* we only inline when [l2] does not contain bound variables no need to refresh *) let ok_to_inline = - i >= 0 && no_bounded_variables l2 + i >= 0 && no_bounded_variables l2' && - let lam_size = Lam_analysis.size l2 in + let lam_size = Lam_analysis.size l2' in (i_occur <= 2 && lam_size < Lam_analysis.exit_inline_size) || lam_size < 5 in if ok_to_inline then ( - Hash_int.add subst i (xs, Id l2); + Hash_int.add subst i (xs, Id l2'); simplif l1) - else Lambda.staticcatch (simplif l1) (i, xs) l2) + else + let l1' = simplif l1 in + if l1' == l1 && l2' == l2 then lam + else Lambda.staticcatch l1' (i, xs) l2') | Lstaticraise (i, []) -> ( match Hash_int.find_opt subst i with | Some (_, handler) -> to_lam handler | None -> lam) | Lstaticraise (i, ls) -> ( - let ls = Ext_list.map ls simplif in + let ls' = Ext_list.map_sharing ls simplif in match Hash_int.find_opt subst i with | Some (xs, handler) -> let handler = to_lam handler in @@ -197,58 +200,18 @@ let subst_helper (subst : subst_tbl) (query : int -> int) (lam : Lambda.t) : Ext_list.fold_right2 xs ys Ident.empty (fun x y t -> Ident.add x (Lambda.var y) t) in - Ext_list.fold_right2 ys ls (Lambda_traverse.subst_lambda env handler) + Ext_list.fold_right2 ys ls' (Lambda_traverse.subst_lambda env handler) (fun y l r -> Lambda.let_ Strict y l r) - | None -> Lambda.staticraise i ls) - | Lvar _ | Lconst _ -> lam - | Lapply {ap_func; ap_args; ap_info; ap_transformed_jsx} -> - Lambda.apply (simplif ap_func) - (Ext_list.map ap_args simplif) - ap_info ~ap_transformed_jsx - | Lfunction {params; body; attr; loc} -> - Lambda.function_ ~loc ~params ~body:(simplif body) ~attr - | Llet (kind, v, l1, l2) -> Lambda.let_ kind v (simplif l1) (simplif l2) - | Lletrec (bindings, body) -> - Lambda.letrec (Ext_list.map_snd bindings simplif) (simplif body) - | Lglobal_module _ -> lam - | Lprim {primitive; args; loc} -> - let args = Ext_list.map args simplif in - Lambda.prim ~primitive ~args loc - | Lswitch (l, sw) -> - let new_l = simplif l in - let new_consts = Ext_list.map_snd sw.sw_consts simplif in - let new_blocks = Ext_list.map_snd sw.sw_blocks simplif in - let new_fail = Ext_option.map sw.sw_failaction simplif in - Lambda.switch new_l - { - sw with - sw_consts = new_consts; - sw_blocks = new_blocks; - sw_failaction = new_fail; - } - | Lstringswitch (l, sw, d) -> - Lambda.stringswitch (simplif l) - (Ext_list.map_snd sw simplif) - (Ext_option.map d simplif) - | Ltrywith (l1, v, l2) -> Lambda.try_ (simplif l1) v (simplif l2) - | Lifthenelse (l1, l2, l3) -> - Lambda.if_ (simplif l1) (simplif l2) (simplif l3) - | Lsequence (l1, l2) -> Lambda.seq (simplif l1) (simplif l2) - | Lbreak -> Lambda.break - | Lcontinue -> Lambda.continue - | Lwhile (l1, l2) -> Lambda.while_ (simplif l1) (simplif l2) - | Lfor (v, l1, l2, dir, l3) -> - Lambda.for_ v (simplif l1) (simplif l2) dir (simplif l3) - | Lfor_of (v, l1, l2) -> Lambda.for_of v (simplif l1) (simplif l2) - | Lfor_await_of (v, l1, l2) -> - Lambda.for_await_of v (simplif l1) (simplif l2) - | Lassign (v, l) -> Lambda.assign v (simplif l) + | None -> if ls' == ls then lam else Lambda.staticraise i ls') + | _ -> Lambda_traverse.shallow_map_sharing simplif lam in simplif lam let simplify_exits (lam : Lambda.t) = - let exits = Lam_exit_count.count_helper lam in - subst_helper (Hash_int.create 17) (Lam_exit_count.count_exit exits) lam + match Lam_exit_count.count_helper lam with + | None -> lam + | Some exits -> + subst_helper (Hash_int.create 17) (Lam_exit_count.count_exit exits) lam (* Compile-time beta-reduction of functions immediately applied: Lapply(Lfunction(Curried, params, body), args, loc) -> diff --git a/compiler/core/lam_pass_lets_dce.ml b/compiler/core/lam_pass_lets_dce.ml index e7a6004278..729fc4882e 100644 --- a/compiler/core/lam_pass_lets_dce.ml +++ b/compiler/core/lam_pass_lets_dce.ml @@ -13,8 +13,8 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lambda.t = - let subst : Lambda.t Hash_ident.t = Hash_ident.create 32 in - let string_table : string Hash_ident.t = Hash_ident.create 32 in + let subst : Lambda.t Hash_ident.t = Hash_ident.create 16 in + let string_table : string Hash_ident.t = Hash_ident.create 16 in let used v = (count_var v).times > 0 in let rec simplif (lam : Lambda.t) = match lam with @@ -50,7 +50,12 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lambda.t Lambda.let_ Alias v l1 (simplif l2) (* we need move [simplif l2] later, since adding Hash does have side effect *) | _ -> - Lambda.let_ Alias v (simplif l1) (simplif l2) + (* [simplif] records substitutions as it goes, and the body was + already being simplified before the bound expression here, so keep + that order explicit. *) + let l2' = simplif l2 in + let l1' = simplif l1 in + if l1' == l1 && l2' == l2 then lam else Lambda.let_ Alias v l1' l2' (* for Alias, in most cases [l1] is already simplified *)) | Llet ((StrictOpt as kind), v, l1, lbody) -> ( if @@ -79,7 +84,7 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lambda.t Hash_ident.add string_table v s; (* we need move [simplif lbody] later, since adding Hash does have side effect *) Lambda.let_ Alias v l1 (simplif lbody) - | _ -> Lam_util.refine_let ~kind v l1 (simplif lbody) + | _ -> Lam_util.refine_let ~original:lam ~kind v l1 (simplif lbody) (* TODO: check if it is correct rollback to [StrictOpt]? *)) | Llet (((Strict | Variable) as kind), v, l1, l2) -> ( if not (used v) then @@ -93,8 +98,7 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lambda.t | Strict, Lconst (Const_string s) -> Hash_ident.add string_table v s; Lambda.let_ Alias v l1 (simplif l2) - | _ -> Lam_util.refine_let ~kind v l1 (simplif l2)) - | Lsequence (l1, l2) -> Lambda.seq (simplif l1) (simplif l2) + | _ -> Lam_util.refine_let ~original:lam ~kind v l1 (simplif l2)) | Lapply {ap_func = Lfunction ({params; body} as lfunction); ap_args = args; _} when Ext_list.same_length params args @@ -107,14 +111,6 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lambda.t (* *\) *) (* when Ext_list.same_length params args -> *) (* simplif (Lam_beta_reduce.beta_reduce params body args) *) - | Lapply {ap_func = l1; ap_args = ll; ap_info; ap_transformed_jsx} -> - Lambda.apply (simplif l1) (Ext_list.map ll simplif) ap_info - ~ap_transformed_jsx - | Lfunction {params; body; attr; loc} -> - Lambda.function_ ~loc ~params ~body:(simplif body) ~attr - | Lconst _ -> lam - | Lletrec (bindings, body) -> - Lambda.letrec (Ext_list.map_snd bindings simplif) (simplif body) | Lprim {primitive = Pstringadd; args = [l; r]; loc} -> ( let l' = simplif l in let r' = simplif r in @@ -136,40 +132,7 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lambda.t match opt_r with | None -> Lambda.prim ~primitive:Pstringadd ~args:[l'; r'] loc | Some r_s -> Lambda.const (Const_string (l_s ^ r_s)))) - | Lglobal_module _ -> lam - | Lprim {primitive; args; loc} -> - Lambda.prim ~primitive ~args:(Ext_list.map args simplif) loc - | Lswitch (l, sw) -> - let new_l = simplif l - and new_consts = Ext_list.map_snd sw.sw_consts simplif - and new_blocks = Ext_list.map_snd sw.sw_blocks simplif - and new_fail = Ext_option.map sw.sw_failaction simplif in - Lambda.switch new_l - { - sw with - sw_consts = new_consts; - sw_blocks = new_blocks; - sw_failaction = new_fail; - } - | Lstringswitch (l, sw, d) -> - Lambda.stringswitch (simplif l) - (Ext_list.map_snd sw simplif) - (Ext_option.map d simplif) - | Lstaticraise (i, ls) -> Lambda.staticraise i (Ext_list.map ls simplif) - | Lstaticcatch (l1, (i, args), l2) -> - Lambda.staticcatch (simplif l1) (i, args) (simplif l2) - | Ltrywith (l1, v, l2) -> Lambda.try_ (simplif l1) v (simplif l2) - | Lifthenelse (l1, l2, l3) -> - Lambda.if_ (simplif l1) (simplif l2) (simplif l3) - | Lbreak -> Lambda.break - | Lcontinue -> Lambda.continue - | Lwhile (l1, l2) -> Lambda.while_ (simplif l1) (simplif l2) - | Lfor (v, l1, l2, dir, l3) -> - Lambda.for_ v (simplif l1) (simplif l2) dir (simplif l3) - | Lfor_of (v, l1, l2) -> Lambda.for_of v (simplif l1) (simplif l2) - | Lfor_await_of (v, l1, l2) -> - Lambda.for_await_of v (simplif l1) (simplif l2) - | Lassign (v, l) -> Lambda.assign v (simplif l) + | _ -> Lambda_traverse.shallow_map_sharing simplif lam in simplif lam diff --git a/compiler/core/lam_pass_remove_alias.ml b/compiler/core/lam_pass_remove_alias.ml index 4c4a77169e..0a9e122b74 100644 --- a/compiler/core/lam_pass_remove_alias.ml +++ b/compiler/core/lam_pass_remove_alias.ml @@ -49,7 +49,6 @@ let is_const_some (cst : Lambda.structured_constant) : bool = let simplify_alias (meta : Lam_stats.t) (lam : Lambda.t) : Lambda.t = let rec simpl (lam : Lambda.t) : Lambda.t = match lam with - | Lvar _ -> lam (* 7432: prevent optimization in JSX preserve mode *) | Lprim { @@ -58,16 +57,19 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lambda.t) : Lambda.t = loc; } when !Js_config.jsx_preserve -> - Lambda.prim ~primitive ~args:(field_arg :: Ext_list.map rest simpl) loc + let rest' = Ext_list.map_sharing rest simpl in + if rest' == rest then lam + else Lambda.prim ~primitive ~args:(field_arg :: rest') loc | Lprim {primitive = Pfield (i, info) as primitive; args = [arg]; loc} -> ( (* ATTENTION: Main use case, we should detect inline all immutable block .. *) match simpl arg with | Lvar v as l -> Lam_util.field_flatten_get - (fun _ -> Lambda.prim ~primitive ~args:[l] loc) + (fun _ -> + if l == arg then lam else Lambda.prim ~primitive ~args:[l] loc) v i info meta.ident_tbl - | l -> Lambda.prim ~primitive ~args:[l] loc) + | l -> if l == arg then lam else Lambda.prim ~primitive ~args:[l] loc) | Lprim { primitive = (Pval_from_option | Pval_from_option_not_nest) as p; @@ -76,11 +78,7 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lambda.t) : Lambda.t = match Hash_ident.find_opt meta.ident_tbl v with | Some (OptionalBlock (l, _)) -> l | _ -> if p = Pval_from_option_not_nest then lvar else x) - | Lglobal_module _ -> lam - | Lprim {primitive; args; loc} -> - Lambda.prim ~primitive ~args:(Ext_list.map args simpl) loc - | Lifthenelse - ((Lprim {primitive = Pis_not_none; args = [Lvar id]} as l1), l2, l3) + | Lifthenelse (Lprim {primitive = Pis_not_none; args = [Lvar id]}, l2, l3) -> ( match Hash_ident.find_opt meta.ident_tbl id with | Some (Constant c) when is_const_some c -> simpl l2 @@ -100,7 +98,7 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lambda.t) : Lambda.t = (Lambda.not_ Location.none (Lambda.prim ~primitive:Pis_null_undefined ~args:[l] Location.none)) (simpl l2) (simpl l3) - | Some _ | None -> Lambda.if_ l1 (simpl l2) (simpl l3)) + | Some _ | None -> Lambda_traverse.shallow_map_sharing simpl lam) (* could be the code path {[ match x with | h::hs -> @@ -112,13 +110,8 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lambda.t) : Lambda.t = match id_is_for_sure_true_in_boolean meta.ident_tbl id with | Eval_true -> simpl l2 | Eval_false -> simpl l3 - | Eval_unknown -> Lambda.if_ (simpl l1) (simpl l2) (simpl l3)) - | _ -> Lambda.if_ (simpl l1) (simpl l2) (simpl l3)) - | Lconst _ -> lam - | Llet (str, v, l1, l2) -> Lambda.let_ str v (simpl l1) (simpl l2) - | Lletrec (bindings, body) -> - let bindings = Ext_list.map_snd bindings simpl in - Lambda.letrec bindings (simpl body) + | Eval_unknown -> Lambda_traverse.shallow_map_sharing simpl lam) + | _ -> Lambda_traverse.shallow_map_sharing simpl lam) (* complicated 1. inline this function 2. ... @@ -155,21 +148,25 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lambda.t) : Lambda.t = && Lam_analysis.lfunction_can_be_inlined lfunction -> simpl (Lam_beta_reduce.propagate_beta_reduce meta params body args) | _ -> - Lambda.apply (simpl l1) (Ext_list.map args simpl) ap_info - ?ap_transformed_jsx:None) + let fn = simpl l1 in + let args' = Ext_list.map_sharing args simpl in + if fn == l1 && args' == args then lam + else Lambda.apply fn args' ap_info ?ap_transformed_jsx:None) (* Function inlining interact with other optimizations... - parameter attributes - scope issues - code bloat *) - | Lapply {ap_func = Lvar v as fn; ap_args; ap_info; ap_transformed_jsx} -> ( + | Lapply + {ap_func = Lvar v as fn; ap_args = args; ap_info; ap_transformed_jsx} + -> ( (* Check info for always inlining *) - - (* Ext_log.dwarn __LOC__ "%s/%d" v.name v.stamp; *) - let ap_args = Ext_list.map ap_args simpl in + let ap_args = Ext_list.map_sharing args simpl in let[@local] normal () = - Lambda.apply (simpl fn) ap_args ap_info ~ap_transformed_jsx + let fn' = simpl fn in + if fn' == fn && ap_args == args then lam + else Lambda.apply fn' ap_args ap_info ~ap_transformed_jsx in match Hash_ident.find_opt meta.ident_tbl v with | Some @@ -239,55 +236,22 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lambda.t) : Lambda.t = (* *\) *) (* when Ext_list.same_length params args -> *) (* simpl (Lam_beta_reduce.propogate_beta_reduce meta params body args) *) - | Lapply {ap_func = l1; ap_args = ll; ap_info; ap_transformed_jsx} -> - Lambda.apply (simpl l1) (Ext_list.map ll simpl) ap_info - ~ap_transformed_jsx - | Lfunction {params; body; attr; loc} -> - Lambda.function_ ~loc ~params ~body:(simpl body) ~attr - | Lswitch - ( l, - { - sw_failaction; - sw_consts; - sw_blocks; - sw_blocks_full; - sw_consts_full; - sw_dispatch; - } ) -> - Lambda.switch (simpl l) - { - sw_consts = Ext_list.map_snd sw_consts simpl; - sw_blocks = Ext_list.map_snd sw_blocks simpl; - sw_consts_full; - sw_blocks_full; - sw_failaction = Ext_option.map sw_failaction simpl; - sw_dispatch; - } - | Lstringswitch (l, sw, d) -> - let l = + | Lstringswitch (l, sw, d) -> ( + let known_constant = match l with | Lvar s -> ( match Hash_ident.find_opt meta.ident_tbl s with - | Some (Constant s) -> Lambda.const s - | Some _ | None -> simpl l) - | _ -> simpl l + | Some (Constant c) -> Some c + | Some _ | None -> None) + | _ -> None in - Lambda.stringswitch l (Ext_list.map_snd sw simpl) (Ext_option.map d simpl) - | Lstaticraise (i, ls) -> Lambda.staticraise i (Ext_list.map ls simpl) - | Lstaticcatch (l1, ids, l2) -> Lambda.staticcatch (simpl l1) ids (simpl l2) - | Ltrywith (l1, v, l2) -> Lambda.try_ (simpl l1) v (simpl l2) - | Lsequence (l1, l2) -> Lambda.seq (simpl l1) (simpl l2) - | Lbreak -> Lambda.break - | Lcontinue -> Lambda.continue - | Lwhile (l1, l2) -> Lambda.while_ (simpl l1) (simpl l2) - | Lfor (flag, l1, l2, dir, l3) -> - Lambda.for_ flag (simpl l1) (simpl l2) dir (simpl l3) - | Lfor_of (flag, l1, l2) -> Lambda.for_of flag (simpl l1) (simpl l2) - | Lfor_await_of (flag, l1, l2) -> - Lambda.for_await_of flag (simpl l1) (simpl l2) - | Lassign (v, l) -> - (* Lalias-bound variables are never assigned, so don't increase - v's refsimpl *) - Lambda.assign v (simpl l) + match known_constant with + | Some c -> + (* Switch on the constant the scrutinee is bound to. *) + Lambda.stringswitch (Lambda.const c) + (Ext_list.map_snd sw simpl) + (Ext_option.map d simpl) + | None -> Lambda_traverse.shallow_map_sharing simpl lam) + | _ -> Lambda_traverse.shallow_map_sharing simpl lam in simpl lam diff --git a/compiler/core/lam_util.ml b/compiler/core/lam_util.ml index 9ff39c4c1a..6e527ab507 100644 --- a/compiler/core/lam_util.ml +++ b/compiler/core/lam_util.ml @@ -55,7 +55,10 @@ let add_required_modules ( x : Ident.t list) (meta : Lam_stats.t) = Falling through keeps the original binding. Only the Alias clause changes evaluation strategy downstream, so we keep its predicate intentionally syntactic and narrow. *) -let refine_let ~kind param (arg : Lambda.t) (l : Lambda.t) : Lambda.t = +(* [original] is the binding this one was taken apart from, if any. When + nothing is refined it is handed back untouched rather than rebuilt. *) +let refine_let ?original ~kind param (arg : Lambda.t) (l : Lambda.t) : Lambda.t + = let is_block_constructor = function | Lambda.Pmakeblock _ -> true | _ -> false @@ -133,7 +136,12 @@ let refine_let ~kind param (arg : Lambda.t) (l : Lambda.t) : Lambda.t = This keeps the original semantics yet allows downstream passes to skip evaluating `x` when it turns out to be unused. *) Lambda.let_ StrictOpt param arg l - | kind, _, _ -> Lambda.let_ kind param arg l + | kind, _, _ -> ( + match original with + | Some (Lambda.Llet (kind', param', arg', l') as o) + when kind' = kind && Ident.same param' param && arg' == arg && l' == l -> + o + | _ -> Lambda.let_ kind param arg l) let alias_ident_or_global (meta : Lam_stats.t) (k : Ident.t) (v : Ident.t) (v_kind : Lam_id_kind.t) = diff --git a/compiler/core/lam_util.mli b/compiler/core/lam_util.mli index 690d6d35eb..691039a5b3 100644 --- a/compiler/core/lam_util.mli +++ b/compiler/core/lam_util.mli @@ -53,7 +53,14 @@ val alias_ident_or_global : Lam_stats.t -> Ident.t -> Ident.t -> Lam_id_kind.t -> unit val refine_let : - kind:Lambda.let_kind -> Ident.t -> Lambda.t -> Lambda.t -> Lambda.t + ?original:Lambda.t -> + kind:Lambda.let_kind -> + Ident.t -> + Lambda.t -> + Lambda.t -> + Lambda.t +(** [original] is the binding being rebuilt, when there is one. It is returned + unchanged if no refinement applies. *) val not_function : Lambda.t -> bool diff --git a/tests/ounit_tests/ounit_deep_flatten_tests.ml b/tests/ounit_tests/ounit_deep_flatten_tests.ml new file mode 100644 index 0000000000..e0f0b14106 --- /dev/null +++ b/tests/ounit_tests/ounit_deep_flatten_tests.ml @@ -0,0 +1,18 @@ +open OUnit + +(* Sharing is invisible to the generated output: a pass that rebuilds a term + into an identical one produces the same JavaScript, so no snapshot can tell. + This is the only place that notices. *) +let suites = + __FILE__ + >::: [ + ( "shares an unchanged recursive group" >:: fun _ -> + let recursive = Ident.create "recursive" in + let lam = + Lambda.letrec + [(recursive, Lambda.var recursive)] + (Lambda.var recursive) + in + assert_bool "the recursive group is physically unchanged" + (Lam_pass_deep_flatten.deep_flatten lam == lam) ); + ] diff --git a/tests/ounit_tests/ounit_exits_tests.ml b/tests/ounit_tests/ounit_exits_tests.ml new file mode 100644 index 0000000000..79099d94b3 --- /dev/null +++ b/tests/ounit_tests/ounit_exits_tests.ml @@ -0,0 +1,31 @@ +open OUnit + +let loc = Location.none + +let debugger = Lambda.prim ~primitive:Pdebugger ~args:[] loc + +let suites = + __FILE__ + >::: [ + ( "shares an unresolved raise with unchanged arguments" >:: fun _ -> + let lam = Lambda.staticraise 1 [Lambda.const (Lambda.const_int 1)] in + assert_bool "the raise is physically unchanged" + (Lam_pass_exits.simplify_exits lam == lam) ); + (* A negative exit is never inlined into its raise, and a handler that + is neither a variable nor a constant is not substituted, so this + catch survives the pass and must survive it unrebuilt. *) + ( "shares a retained catch" >:: fun _ -> + let lam = + Lambda.staticcatch + (Lambda.staticraise (-1) []) + (-1, []) + (Lambda.seq debugger Lambda.lambda_unit) + in + assert_bool "the catch is physically unchanged" + (Lam_pass_exits.simplify_exits lam == lam) ); + ( "removes a catch whose exit is unused" >:: fun _ -> + let body = Lambda.const (Lambda.const_int 1) in + let lam = Lambda.staticcatch body (1, []) debugger in + assert_bool "the unused handler is removed" + (Lam_pass_exits.simplify_exits lam == body) ); + ] diff --git a/tests/ounit_tests/ounit_lambda_traverse_tests.ml b/tests/ounit_tests/ounit_lambda_traverse_tests.ml new file mode 100644 index 0000000000..2bc3a09006 --- /dev/null +++ b/tests/ounit_tests/ounit_lambda_traverse_tests.ml @@ -0,0 +1,72 @@ +open OUnit + +let loc = Location.none +let x = Ident.create "x" +let y = Ident.create "y" +let debugger = Lambda.prim ~primitive:Pdebugger ~args:[] loc +let var = Lambda.var x + +(* One node per constructor that has children. A leaf shares trivially, so it + would pass either check below without exercising anything. *) +let nodes : (string * Lambda.t) list = + [ + ("apply", Lambda.apply var [var] {ap_loc = loc; ap_inlined = Default_inline}); + ( "function", + Lambda.function_ ~loc ~attr:Lambda.default_function_attribute ~params:[x] + ~body:debugger ); + ("let", Lambda.let_ Strict y debugger var); + ("letrec", Lambda.letrec [(y, debugger)] var); + ("prim", Lambda.prim ~primitive:Pdebugger ~args:[var] loc); + ( "switch", + Lambda.switch var + { + sw_consts_full = false; + sw_consts = [(Switch_int 0, debugger)]; + sw_blocks_full = false; + sw_blocks = []; + sw_failaction = Some debugger; + sw_dispatch = Switch_direct; + } ); + ("stringswitch", Lambda.stringswitch var [("a", debugger)] (Some debugger)); + ("staticraise", Lambda.staticraise 1 [var]); + ( "staticcatch", + Lambda.staticcatch (Lambda.staticraise 1 []) (1, []) debugger ); + ("trywith", Lambda.try_ debugger y var); + ("ifthenelse", Lambda.if_ var debugger debugger); + ("sequence", Lambda.seq debugger var); + ("while", Lambda.while_ var debugger); + ("for", Lambda.for_ y var var Upto debugger); + ("for_of", Lambda.for_of y var debugger); + ("for_await_of", Lambda.for_await_of y var debugger); + ("assign", Lambda.assign x debugger); + ] + +(* Every optimization pass routes its "nothing to do here" case through + [shallow_map_sharing], so an arm of it that stops sharing silently costs the + property in all of them. That is invisible to generated output: breaking the + [Lapply] and [Lswitch] arms leaves every fixture in the repository byte for + byte identical. Add a node above when adding a Lambda constructor. *) +let suites = + __FILE__ + >::: [ + ( "an unchanged child is not rebuilt" >:: fun _ -> + List.iter + (fun (name, node) -> + assert_bool + (name ^ " should be handed back when nothing changed") + (Lambda_traverse.shallow_map_sharing (fun lam -> lam) node + == node)) + nodes ); + ( "a changed child is rebuilt" >:: fun _ -> + (* Without this, a node whose children were never visited would pass + the check above by doing nothing at all. *) + List.iter + (fun (name, node) -> + assert_bool + (name ^ " should be rebuilt when a child changed") + (Lambda_traverse.shallow_map_sharing + (fun _ -> Lambda.const Lambda.const_unit) + node + != node)) + nodes ); + ] diff --git a/tests/ounit_tests/ounit_tests_main.ml b/tests/ounit_tests/ounit_tests_main.ml index 10c3a0cafb..453aa77815 100644 --- a/tests/ounit_tests/ounit_tests_main.ml +++ b/tests/ounit_tests/ounit_tests_main.ml @@ -20,6 +20,9 @@ let suites = Ounit_util_tests.suites; Ounit_rec_check_tests.suites; Ounit_lambda_constant_tests.suites; + Ounit_lambda_traverse_tests.suites; + Ounit_deep_flatten_tests.suites; + Ounit_exits_tests.suites; Ounit_sroa_tests.suites; Ounit_ast_mapper0_tests.suites; Ounit_object_mutability_tests.suites;