From 587ea876489ef260b8aa43f1d6c91e874a846db7 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sun, 30 Aug 2026 10:38:43 +0200 Subject: [PATCH 01/13] Move let-x-equals-y alias collapsing out of Lambda-to-Lam conversion Pattern matching introduces Alias lets as O(1) renames of a pattern ident onto the scrutinee. Convert used to substitute those while translating; do the same rewrite as a Lam pass immediately after conversion instead, so convert stays a translation. Exported aliases are kept for coercion. Later lets_dce is unchanged. JS from runtime, Belt, tests/tests, belt_tests, and commonjs_tests matched the convert-time pass (1079 files). Signed-off-by: Cristiano Calcagno --- compiler/core/lam_compile_main.ml | 3 + compiler/core/lam_convert.ml | 69 ++++++++----------- compiler/core/lam_convert.mli | 25 ++----- .../core/lam_pass_collapse_var_aliases.ml | 59 ++++++++++++++++ .../core/lam_pass_collapse_var_aliases.mli | 13 ++++ 5 files changed, 109 insertions(+), 60 deletions(-) create mode 100644 compiler/core/lam_pass_collapse_var_aliases.ml create mode 100644 compiler/core/lam_pass_collapse_var_aliases.mli diff --git a/compiler/core/lam_compile_main.ml b/compiler/core/lam_compile_main.ml index 88ea44ab543..e5b157085f8 100644 --- a/compiler/core/lam_compile_main.ml +++ b/compiler/core/lam_compile_main.ml @@ -276,6 +276,9 @@ let compile (output_prefix : string) export_idents hoisted (lam : Lambda.lambda) Lam_compile_env.reset () in let lam, may_required_modules = Lam_convert.convert export_ident_sets lam in + let lam = + Lam_pass_collapse_var_aliases.collapse ~exports:export_ident_sets lam + in let lam = d "initial" lam in let lam = Lam_pass_deep_flatten.deep_flatten lam in diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index 54fd637865c..25e2309c3b6 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -325,15 +325,14 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = let may_depend = Lam_module_ident.Hash_set.add -let convert (exports : Set_ident.t) (lam : Lambda.lambda) : +let convert (_exports : Set_ident.t) (lam : Lambda.lambda) : Lam.t * Lam_module_ident.Hash_set.t = - let alias_tbl = Hash_ident.create 64 in let exit_map = Hash_int.create 0 in let may_depends = Lam_module_ident.Hash_set.create 0 in let rec convert_aux (lam : Lambda.lambda) : Lam.t = match lam with - | Lvar x -> Lam.var (Hash_ident.find_default alias_tbl x x) + | Lvar x -> Lam.var x | Lconst x -> Lam.const (Lam_constant_convert.convert_constant x) | Lapply { @@ -414,17 +413,9 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : | Lassign (id, body) -> Lam.assign id (convert_aux body) and convert_let (kind : Lam_compat.let_kind) id (e : Lambda.lambda) body : Lam.t = - match (kind, e) with - | Alias, Lvar u -> - let new_u = Hash_ident.find_default alias_tbl u u in - Hash_ident.add alias_tbl id new_u; - if Set_ident.mem exports id then - Lam.let_ kind id (Lam.var new_u) (convert_aux body) - else convert_aux body - | _, _ -> ( - let new_e = convert_aux e in - let new_body = convert_aux body in - (* + let new_e = convert_aux e in + let new_body = convert_aux body in + (* reverse engineering cases as {[ (let (switcher/1013 =a (-1+ match/1012)) (if (isout 2 switcher/1013) (exit 1) @@ -438,31 +429,31 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : To advance this case, when [sw_failaction] is None *) - match (kind, new_e, new_body) with - | ( Alias, - Lprim {primitive = Poffsetint offset; args = [(Lvar _ as matcher)]}, - Lswitch - ( Lvar switcher3, - ({ - sw_consts_full = false; - sw_consts; - sw_blocks = []; - sw_blocks_full = true; - sw_failaction = Some ifso; - } as px) ) ) - when Ident.same switcher3 id - && (not (Lam_hit.hit_variable id ifso)) - && not (Ext_list.exists_snd sw_consts (Lam_hit.hit_variable id)) -> - Lam.switch matcher - { - px with - sw_consts = - Ext_list.map sw_consts (fun (key, act) -> - match key with - | Lambda.Switch_int i -> (Lambda.Switch_int (i - offset), act) - | Lambda.Switch_constructor _ -> assert false); - } - | _ -> Lam.let_ kind id new_e new_body) + match (kind, new_e, new_body) with + | ( Alias, + Lprim {primitive = Poffsetint offset; args = [(Lvar _ as matcher)]}, + Lswitch + ( Lvar switcher3, + ({ + sw_consts_full = false; + sw_consts; + sw_blocks = []; + sw_blocks_full = true; + sw_failaction = Some ifso; + } as px) ) ) + when Ident.same switcher3 id + && (not (Lam_hit.hit_variable id ifso)) + && not (Ext_list.exists_snd sw_consts (Lam_hit.hit_variable id)) -> + Lam.switch matcher + { + px with + sw_consts = + Ext_list.map sw_consts (fun (key, act) -> + match key with + | Lambda.Switch_int i -> (Lambda.Switch_int (i - offset), act) + | Lambda.Switch_constructor _ -> assert false); + } + | _ -> Lam.let_ kind id new_e new_body and convert_pipe (f : Lambda.lambda) (x : Lambda.lambda) outer_loc = let pipe_loc = let candidate = diff --git a/compiler/core/lam_convert.mli b/compiler/core/lam_convert.mli index 2ff227f8348..6d2ce815f19 100644 --- a/compiler/core/lam_convert.mli +++ b/compiler/core/lam_convert.mli @@ -27,24 +27,7 @@ val convert : Set_ident.t -> Lambda.lambda -> Lam.t * Lam_module_ident.Hash_set.t -(** - [convert exports lam] - it also collect [exit_map] and a collection of potential depended modules [may_depends] - In this pass we also synchronized aliases so that - {[ - let a1 = a0 in - let a2 = a1 in - let a3 = a2 in - let a4 = a3 in - ]} - converted to - {[ - let a1 = a0 in - let a2 = a0 in - let a3 = a0 in - let a4 = a0 in - ]} - we dont eliminate unused let bindings to leave it for {!Lam_pass_lets_dce} - we should remove all those let aliases, otherwise, it will be - pushed into alias table again -*) +(** [convert exports lam] translates Lambda to Lam and collects potential + depended modules. [let x = y] aliases are left for + {!Lam_pass_collapse_var_aliases}; unused lets are left for + {!Lam_pass_lets_dce}. *) diff --git a/compiler/core/lam_pass_collapse_var_aliases.ml b/compiler/core/lam_pass_collapse_var_aliases.ml new file mode 100644 index 00000000000..fe76ff17ac5 --- /dev/null +++ b/compiler/core/lam_pass_collapse_var_aliases.ml @@ -0,0 +1,59 @@ +(* Copyright (C) 2026 - Authors of ReScript + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. *) + +let rec resolve tbl id = + match Hash_ident.find_opt tbl id with + | None -> id + | Some id' -> resolve tbl id' + +let collapse ~exports (lam : Lam.t) : Lam.t = + let tbl = Hash_ident.create 64 in + let rec go (lam : Lam.t) : Lam.t = + match lam with + | Lvar x -> Lam.var (resolve tbl x) + | Lglobal_module _ | Lconst _ | Lbreak | Lcontinue -> lam + | Lapply {ap_func; ap_args; ap_info; ap_transformed_jsx} -> + Lam.apply (go ap_func) (Ext_list.map ap_args go) ap_info + ~ap_transformed_jsx + | Lfunction {arity; params; body; attr; loc} -> + Lam.function_ ~loc ~attr ~arity ~params ~body:(go body) + | Llet (Alias, id, Lvar u, body) -> + let u = resolve tbl u in + Hash_ident.add tbl id u; + if Set_ident.mem exports id then Lam.let_ Alias id (Lam.var u) (go body) + else go body + | Llet (kind, id, arg, body) -> Lam.let_ kind id (go arg) (go body) + | Lletrec (bindings, body) -> + Lam.letrec (Ext_list.map_snd bindings go) (go body) + | Lprim {primitive; args; loc} -> + Lam.prim ~primitive ~args:(Ext_list.map args go) loc + | Lswitch (arg, sw) -> + Lam.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) -> + Lam.stringswitch (go arg) + (Ext_list.map_snd cases go) + (Ext_option.map default go) + | Lstaticraise (i, args) -> Lam.staticraise i (Ext_list.map args go) + | Lstaticcatch (body, ids, handler) -> + Lam.staticcatch (go body) ids (go handler) + | Ltrywith (body, id, handler) -> Lam.try_ (go body) id (go handler) + | Lifthenelse (b, t, e) -> Lam.if_ (go b) (go t) (go e) + | Lsequence (a, b) -> Lam.seq (go a) (go b) + | Lwhile (b, body) -> Lam.while_ (go b) (go body) + | Lfor (id, lo, hi, dir, body) -> Lam.for_ id (go lo) (go hi) dir (go body) + | Lfor_of (id, iterable, body) -> Lam.for_of id (go iterable) (go body) + | Lfor_await_of (id, iterable, body) -> + Lam.for_await_of id (go iterable) (go body) + | Lassign (id, e) -> Lam.assign id (go e) + in + go lam diff --git a/compiler/core/lam_pass_collapse_var_aliases.mli b/compiler/core/lam_pass_collapse_var_aliases.mli new file mode 100644 index 00000000000..912515d2ff6 --- /dev/null +++ b/compiler/core/lam_pass_collapse_var_aliases.mli @@ -0,0 +1,13 @@ +(* Copyright (C) 2026 - Authors of ReScript + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. *) + +(** Collapse [let x = y] aliases. Pattern matching introduces these as + O(1) renames of a pattern ident onto the scrutinee; dropping them + before collect keeps [ident_tbl] from re-recording the same alias. + Exported names are kept so coercion can still see them. *) + +val collapse : exports:Set_ident.t -> Lam.t -> Lam.t From 60af999dd8904071b8baf586cbec5d875846a981 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sun, 30 Aug 2026 10:54:33 +0200 Subject: [PATCH 02/13] Remove unused Pjs_runtime_apply and JS FlatCall The Lam primitive was compiled to f.apply(null, args) but never constructed. Drop it together with the JS IR constructor and the stale Lifused/translclass comments left in convert. Signed-off-by: Cristiano Calcagno --- compiler/core/j.ml | 6 -- compiler/core/js_analyzer.ml | 7 +-- compiler/core/js_dump.ml | 13 +--- compiler/core/js_dump_lit.ml | 2 - compiler/core/js_exp_make.ml | 6 -- compiler/core/js_exp_make.mli | 2 - compiler/core/js_record_fold.ml | 4 -- compiler/core/js_record_iter.ml | 3 - compiler/core/js_record_map.ml | 4 -- compiler/core/lam_analysis.ml | 5 +- compiler/core/lam_compile_primitive.ml | 4 -- compiler/core/lam_convert.ml | 84 -------------------------- compiler/core/lam_pass_deep_flatten.ml | 2 - compiler/core/lam_primitive.ml | 7 +-- compiler/core/lam_primitive.mli | 1 - compiler/core/lam_print.ml | 1 - 16 files changed, 10 insertions(+), 141 deletions(-) diff --git a/compiler/core/j.ml b/compiler/core/j.ml index 13815ac478b..2a8a039fd4c 100644 --- a/compiler/core/j.ml +++ b/compiler/core/j.ml @@ -95,12 +95,6 @@ and expression_desc = | Seq of expression * expression | Cond of expression * expression * expression | Bin of binop * expression * expression - | FlatCall of expression * expression - (* f.apply(null,args) -- Fully applied guaranteed - TODO: once we know args's shape -- - if it's know at compile time, we can turn it into - f(args[0], args[1], ... ) - *) | Call of expression * expression list * Js_call_info.t (* Analysze over J expression is hard since, some primitive call is translated diff --git a/compiler/core/js_analyzer.ml b/compiler/core/js_analyzer.ml index 83622bc4222..fa0df8d961c 100644 --- a/compiler/core/js_analyzer.ml +++ b/compiler/core/js_analyzer.ml @@ -130,7 +130,7 @@ let rec no_side_effect_expression_desc (x : J.expression_desc) = | Cond (a, b, c) -> no_side_effect a && no_side_effect b && no_side_effect c | Call ({expression_desc = Str {txt = "Array.isArray"}}, [e], _) -> no_side_effect e - | FlatCall _ | Call _ | New _ | Raw_js_code _ (* actually true? *) -> false + | Call _ | New _ | Raw_js_code _ (* actually true? *) -> false | Await _ -> false | Spread _ -> false | Record_rest _ -> false @@ -245,9 +245,8 @@ let rec eq_expression ({expression_desc = x0} : J.expression) eq_expression_list ls0 ls1 && flag0 = flag1 && info0 = info1 | _ -> false) | Length _ | Is_null_or_undefined _ | String_append _ | Typeof _ | Js_not _ - | Js_bnot _ | In _ | Cond _ | FlatCall _ | New _ | Fun _ | Raw_js_code _ - | Array _ | Caml_block_tag _ | Object _ | Tagged_template _ | Await _ - | Record_rest _ -> + | Js_bnot _ | In _ | Cond _ | New _ | Fun _ | Raw_js_code _ | Array _ + | Caml_block_tag _ | Object _ | Tagged_template _ | Await _ | Record_rest _ -> false | Spread _ -> false diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index 0dc721a9f4f..0584e3852b2 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -164,8 +164,8 @@ let rec exp_need_paren ?(arrow = false) (e : J.expression) = | Length _ | Call _ | Caml_block_tag _ | Seq _ | Static_index _ | Cond _ | Bin _ | Is_null_or_undefined _ | String_index _ | Array_index _ | String_append _ | Var _ | Undefined _ | Null | Str _ | Array _ - | Caml_block _ | FlatCall _ | Typeof _ | Number _ | Js_not _ | Js_bnot _ - | In _ | Bool _ | New _ -> + | Caml_block _ | Typeof _ | Number _ | Js_not _ | Js_bnot _ | In _ | Bool _ + | New _ -> false | Await _ -> false | Spread _ -> false @@ -740,15 +740,6 @@ and expression_desc cxt ~(level : int) f x : cxt = else ( Curry_gen.pp_app_any f; P.paren_group f 0 (fun _ -> arguments cxt f [e; E.array el])))) - | FlatCall (e, el) -> - P.group f 0 (fun _ -> - let cxt = expression ~level:15 cxt f e in - P.string f L.dot; - P.string f L.apply; - P.paren_group f 1 (fun _ -> - P.string f L.null; - comma_sp f; - expression ~level:1 cxt f el)) | Tagged_template (call_expr, string_args, value_args) -> let cxt = expression cxt ~level f call_expr in P.string f "`"; diff --git a/compiler/core/js_dump_lit.ml b/compiler/core/js_dump_lit.ml index a3ac8452465..df5e8987fdd 100644 --- a/compiler/core/js_dump_lit.ml +++ b/compiler/core/js_dump_lit.ml @@ -134,8 +134,6 @@ let bind = "bind" let math = "Math" -let apply = "apply" - let null = "null" let undefined = "undefined" diff --git a/compiler/core/js_exp_make.ml b/compiler/core/js_exp_make.ml index c11a6c96596..a10df47a627 100644 --- a/compiler/core/js_exp_make.ml +++ b/compiler/core/js_exp_make.ml @@ -68,12 +68,6 @@ let nil : t = {expression_desc = Null; comment = None; source_loc = None} let call ?comment ~info e0 args : t = {expression_desc = Call (e0, args, info); comment; source_loc = None} -(* TODO: optimization when es is known at compile time - to be an array -*) -let flat_call ?comment e0 es : t = - {expression_desc = FlatCall (e0, es); comment; source_loc = None} - let tagged_template ?comment call_expr string_args value_args : t = { expression_desc = Tagged_template (call_expr, string_args, value_args); diff --git a/compiler/core/js_exp_make.mli b/compiler/core/js_exp_make.mli index b07de06fdc1..95e599fc53e 100644 --- a/compiler/core/js_exp_make.mli +++ b/compiler/core/js_exp_make.mli @@ -257,8 +257,6 @@ val not : t -> t val call : ?comment:string -> info:Js_call_info.t -> t -> t list -> t -val flat_call : ?comment:string -> t -> t -> t - val tagged_template : ?comment:string -> t -> t list -> t list -> t val new_ : ?comment:string -> J.expression -> J.expression list -> t diff --git a/compiler/core/js_record_fold.ml b/compiler/core/js_record_fold.ml index d0ce36b202c..21b55b9ec93 100644 --- a/compiler/core/js_record_fold.ml +++ b/compiler/core/js_record_fold.ml @@ -124,10 +124,6 @@ let expression_desc : 'a. ('a, expression_desc) fn = let st = _self.expression _self st _x1 in let st = _self.expression _self st _x2 in st - | FlatCall (_x0, _x1) -> - let st = _self.expression _self st _x0 in - let st = _self.expression _self st _x1 in - st | Call (_x0, _x1, _x2) -> let st = _self.expression _self st _x0 in let st = list _self.expression _self st _x1 in diff --git a/compiler/core/js_record_iter.ml b/compiler/core/js_record_iter.ml index 985ce0823d9..d691ff2707d 100644 --- a/compiler/core/js_record_iter.ml +++ b/compiler/core/js_record_iter.ml @@ -101,9 +101,6 @@ let expression_desc : expression_desc fn = | Bin (_x0, _x1, _x2) -> _self.expression _self _x1; _self.expression _self _x2 - | FlatCall (_x0, _x1) -> - _self.expression _self _x0; - _self.expression _self _x1 | Call (_x0, _x1, _x2) -> _self.expression _self _x0; list _self.expression _self _x1 diff --git a/compiler/core/js_record_map.ml b/compiler/core/js_record_map.ml index 3d2850bf0b2..6a6631a1778 100644 --- a/compiler/core/js_record_map.ml +++ b/compiler/core/js_record_map.ml @@ -126,10 +126,6 @@ let expression_desc : expression_desc fn = let _x1 = _self.expression _self _x1 in let _x2 = _self.expression _self _x2 in Bin (_x0, _x1, _x2) - | FlatCall (_x0, _x1) -> - let _x0 = _self.expression _self _x0 in - let _x1 = _self.expression _self _x1 in - FlatCall (_x0, _x1) | Call (_x0, _x1, _x2) -> let _x0 = _self.expression _self _x0 in let _x1 = list _self.expression _self _x1 in diff --git a/compiler/core/lam_analysis.ml b/compiler/core/lam_analysis.ml index b1f10dc12ab..5d506e9e878 100644 --- a/compiler/core/lam_analysis.ml +++ b/compiler/core/lam_analysis.ml @@ -92,9 +92,8 @@ let rec no_side_effects (lam : Lam.t) : bool = true (* A tagged template invokes its tag at runtime, so it always has side effects. *) - | Ptagged_template | Pjs_apply | Pjs_runtime_apply | Pjs_call _ | Pinit_mod - | Pupdate_mod | Pjs_object_get _ | Pjs_object_set _ | Pdebugger - | Pjs_fn_method + | Ptagged_template | Pjs_apply | Pjs_call _ | Pinit_mod | Pupdate_mod + | Pjs_object_get _ | Pjs_object_set _ | Pdebugger | Pjs_fn_method (* Await promise *) | Pawait (* TODO *) diff --git a/compiler/core/lam_compile_primitive.ml b/compiler/core/lam_compile_primitive.ml index 45bf8fad93a..8124782c446 100644 --- a/compiler/core/lam_compile_primitive.ml +++ b/compiler/core/lam_compile_primitive.ml @@ -83,10 +83,6 @@ let translate output_prefix loc (cxt : Lam_compile_context.t) trim can not be done before syntax checking otherwise location is incorrect *) - | Pjs_runtime_apply -> ( - match args with - | [f; args] -> E.flat_call f args - | _ -> assert false) | Pjs_apply -> ( match args with | fn :: rest -> E.call ~info:call_info fn rest diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index 25e2309c3b6..22d7fa3c94b 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -531,87 +531,3 @@ let convert (_exports : Set_ident.t) (lam : Lambda.lambda) : } in (convert_aux lam, may_depends) - -(** FIXME: more precise analysis of [id], if it is not - used, we can remove it - only two places emit [Lifused], - {[ - lsequence (Lifused(id, set_inst_var obj id expr)) rem - Lifused (env2, Lprim(Parrayset Paddrarray, [Lvar self; Lvar env2; Lvar env1'])) - ]} - - Note the variable, [id], or [env2] is already defined, it can be removed if it is not - used. This optimization seems useful, but doesnt really matter since it only hit translclass - - more details, see [translclass] and [if_used_test] - seems to be an optimization trick for [translclass] - - | Lifused(v, l) -> - if count_var v > 0 then simplif l else lambda_unit -*) - -(* - | Lfunction(kind,params,Lprim(prim,inner_args,inner_loc)) - when List.for_all2_no_exn (fun x y -> - match y with - | Lambda.Lvar y when Ident.same x y -> true - | _ -> false - ) params inner_args - -> - let rec aux outer_args params = - match outer_args, params with - | x::xs , _::ys -> - x :: aux xs ys - | [], [] -> [] - | x::xs, [] -> - | [], y::ys - if Ext_list.same_length inner_args args then - aux (Lprim(prim,args,inner_loc)) - else - - {[ - (fun x y -> f x y) (computation;e) --> - (fun y -> f (computation;e) y) - ]} - is wrong - - or - {[ - (fun x y -> f x y ) ([|1;2;3|]) --> - (fun y -> f [|1;2;3|] y) - ]} - is also wrong. - - It seems, we need handle [@variadic] earlier - - or - {[ - (fun x y -> f x y) ([|1;2;3|]) --> - let x0, x1, x2 =1,2,3 in - (fun y -> f [|x0;x1;x2|] y) - ]} - But this still need us to know [@variadic] in advance - - - we should not remove it immediately, since we have to be careful - where it is used, it can be [exported], [Lvar] or [Lassign] etc - The other common mistake is that - {[ - let x = y (* elimiated x/y*) - let u = x (* eliminated u/x *) - ]} - - however, [x] is already eliminated - To improve the algorithm - {[ - let x = y (* x/y *) - let u = x (* u/y *) - ]} - This looks more correct, but lets be conservative here - - global module inclusion {[ include List ]} - will cause code like {[ let include =a Lglobal_module (list)]} - - when [u] is global, it can not be bound again, - it should always be the leaf -*) diff --git a/compiler/core/lam_pass_deep_flatten.ml b/compiler/core/lam_pass_deep_flatten.ml index efe7625838e..bd630b7a956 100644 --- a/compiler/core/lam_pass_deep_flatten.ml +++ b/compiler/core/lam_pass_deep_flatten.ml @@ -110,8 +110,6 @@ let lambda_of_groups ~(rev_bindings : Lam_group.t list) (result : Lam.t) : Lam.t (* TODO: refine effectful [ket_kind] to be pure or not - Be careful of how [Lifused(v,l)] work - since its semantics depend on whether v is used or not return value are in reverse order, but handled by [lambda_of_groups] *) (* The shape [let x = in ... in apply f args]: the residue diff --git a/compiler/core/lam_primitive.ml b/compiler/core/lam_primitive.ml index 4eacac5654a..1dff8c939c2 100644 --- a/compiler/core/lam_primitive.ml +++ b/compiler/core/lam_primitive.ml @@ -143,7 +143,6 @@ type t = | Pisout of int | Pjscomp of Lam_compat.comparison | Pjs_apply (*[f;arg0;arg1; arg2; ... argN]*) - | Pjs_runtime_apply (* [f; [...]] *) | Pdebugger | Pjs_object_get of string | Pjs_object_set of string @@ -216,9 +215,9 @@ let eq_primitive_approx (lhs : t) (rhs : t) = (* promise *) | Pawait (* etc *) - | Pjs_apply | Pjs_runtime_apply | Pval_from_option | Pval_from_option_not_nest - | Pnull_to_opt | Pnull_undefined_to_opt | Pis_null | Pis_not_none | Psome - | Psome_not_nest | Pis_undefined | Pis_null_undefined | Ptypeof | Pfn_arity + | Pjs_apply | Pval_from_option | Pval_from_option_not_nest | Pnull_to_opt + | Pnull_undefined_to_opt | Pis_null | Pis_not_none | Psome | Psome_not_nest + | Pis_undefined | Pis_null_undefined | Ptypeof | Pfn_arity | Pis_poly_var_block | Pdebugger | Pinit_mod | Pupdate_mod | Pduprecord | Pmakearray | Parraylength | Parrayrefu | Parraysetu | Parrayrefs | Parraysets | Pjs_fn_method | Phash | Phash_mixstring | Phash_mixint diff --git a/compiler/core/lam_primitive.mli b/compiler/core/lam_primitive.mli index 9d537cf4b1e..cfcd19e5772 100644 --- a/compiler/core/lam_primitive.mli +++ b/compiler/core/lam_primitive.mli @@ -137,7 +137,6 @@ type t = | Pisout of int | Pjscomp of Lam_compat.comparison | Pjs_apply (*[f;arg0;arg1; arg2; ... argN]*) - | Pjs_runtime_apply (* [f; [...]] *) | Pdebugger | Pjs_object_get of string | Pjs_object_set of string diff --git a/compiler/core/lam_print.ml b/compiler/core/lam_print.ml index b459bedd8a0..c863ad9fdca 100644 --- a/compiler/core/lam_print.ml +++ b/compiler/core/lam_print.ml @@ -53,7 +53,6 @@ let primitive ppf (prim : Lam_primitive.t) = | Pinit_mod -> fprintf ppf "init_mod!" | Pupdate_mod -> fprintf ppf "update_mod!" | Pjs_apply -> fprintf ppf "#apply" - | Pjs_runtime_apply -> fprintf ppf "#runtime_apply" (* Debug-only dump, exercised solely under -drawlambda/-dlambda. *) | Ptagged_template -> fprintf ppf "#tagged_template" [@coverage off] | Pjs_object_get name -> fprintf ppf "js_object_get[%s]" name From c3648fea86b7164aaa97c45b9ceb620c5f187fd6 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sun, 30 Aug 2026 11:07:38 +0200 Subject: [PATCH 03/13] Remove OCaml pipe primitives and Ploc from Lambda %revapply/%apply were leftover |>/@@ encodings; ReScript -> is rewritten before typing. __LOC__ and friends still compile, but as constants in translcore rather than a Lambda primitive. Signed-off-by: Cristiano Calcagno --- CHANGELOG.md | 1 + compiler/core/lam_convert.ml | 51 --------- compiler/core/lam_print.ml | 8 -- compiler/ml/lambda.ml | 36 ------- compiler/ml/lambda.mli | 6 -- compiler/ml/printlambda.ml | 10 -- compiler/ml/translcore.ml | 200 +++++++++++++++++++++-------------- tests/tests/src/test_per.res | 5 - 8 files changed, 121 insertions(+), 196 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index a01ee8ec9b8..8f5732539a0 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -70,6 +70,7 @@ - Represent optional parameters with defaults structurally, removing downstream name-based detection and producing more consistent JavaScript parameter names. https://github.com/rescript-lang/rescript/pull/8580 - Sync the platform npm package's compiler binaries (`packages/@rescript//bin`) via dune promotion on every `dune build`, instead of Makefile/CI copy steps that only ran when make did: a plain `dune build` can no longer leave `cli/*.js` and the test harnesses running a stale compiler. https://github.com/rescript-lang/rescript/pull/8560 - Remove unused compiler IR definitions, modules, helpers, error variants, and Typedtree fields. https://github.com/rescript-lang/rescript/pull/8551 https://github.com/rescript-lang/rescript/pull/8555 +- Remove the unused OCaml pipe primitives `%revapply`/`%apply` and the `Ploc` Lambda constructor. `__LOC__` and friends still compile to location constants in `translcore`. - Make locally abstract value constraints (`let f: type a. t = value`) structural in the parsetree, remove the obsolete `Pexp_newtype` and `Texp_newtype` wrapper metadata, and keep the old encoding confined to the frozen external-PPX bridge. The CMT magic number is bumped to `Caml1999T024`. https://github.com/rescript-lang/rescript/pull/8575 - Eliminate the `Pjs_fn_make`/`Pjs_fn_make_unit` arity-adjustment primitives and the `unsafe_adjust_to_arity` machinery: with structural arity, functions are constructed at their final arity, so the enforcement layer (and the active-pattern currying split it compensated for) is deleted. Generated code improves: no adapter closures for patterns on mutable fields, better constant propagation and name preservation, and recursive modules whose members are plain functions compile statically without the runtime bootstrap. https://github.com/rescript-lang/rescript/pull/8570 - Cleanups enabled by structural arity: remove the unreachable `Too_many_arguments` error and the `?in_function` threading through the type checker that existed only to decorate it; remove the dead `function$`-vs-arrow unification bridge, `Ctype.arity`, and the unused parsetree arity helpers; deduplicate the analysis arrow-flattening helpers. https://github.com/rescript-lang/rescript/pull/8569 diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index 22d7fa3c94b..653c5f3a50c 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -109,11 +109,6 @@ let exception_id_destructed (l : Lam.t) (fv : Ident.t) : bool = let abs_int x = if x < 0 then -x else x let no_over_flow x = abs_int x < 0x1fff_ffff -let lam_is_var (x : Lam.t) (y : Ident.t) = - match x with - | Lvar y2 -> Ident.same y2 y - | _ -> false - (** Make sure no int range overflow happens also we only check [int] *) @@ -154,9 +149,6 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = | Pidentity -> Ext_list.singleton_exn args | Pnull -> Lam.const Const_js_null | Pundefined -> Lam.const (Const_js_undefined {is_unit = false}) - | Prevapply -> assert false - | Pdirapply -> assert false - | Ploc _ -> assert false (* already compiled away here*) | Pcreate_extension s -> prim ~primitive:(Pcreate_extension s) ~args loc | Pextension_slot_eq -> ( match args with @@ -357,11 +349,6 @@ let convert (_exports : Set_ident.t) (lam : Lambda.lambda) : let lam = Lam.letrec bindings body in Lam_scc.scc bindings lam body (* inlining will affect how mututal recursive behave *) - | Lprim (Prevapply, [x; f], outer_loc) | Lprim (Pdirapply, [f; x], outer_loc) - -> - convert_pipe f x outer_loc - | Lprim (Prevapply, _, _) -> assert false - | Lprim (Pdirapply, _, _) -> assert false | Lprim (Pgetglobal id, args, _) -> let args = Ext_list.map args convert_aux in if Ident.is_predef_exn id then @@ -454,44 +441,6 @@ let convert (_exports : Set_ident.t) (lam : Lambda.lambda) : | Lambda.Switch_constructor _ -> assert false); } | _ -> Lam.let_ kind id new_e new_body - and convert_pipe (f : Lambda.lambda) (x : Lambda.lambda) outer_loc = - let pipe_loc = - let candidate = - match f with - | Lapply {ap_loc} -> Some ap_loc - | Lfunction {loc} -> Some loc - | Lprim (_, _, loc) | Lswitch (_, _, loc) | Lstringswitch (_, _, _, loc) - -> - Some loc - | _ -> None - in - match candidate with - | Some loc when (not loc.loc_ghost) && loc.loc_start.pos_cnum >= 0 -> loc - | _ -> outer_loc - in - let x = convert_aux x in - let f = convert_aux f in - match f with - | Lfunction - {params = [param]; body = Lprim {primitive; args = [Lvar inner_arg]}} - when Ident.same param inner_arg -> - Lam.prim ~primitive ~args:[x] pipe_loc - | Lapply - { - ap_func = - Lfunction {params; body = Lprim {primitive; args = inner_args}}; - ap_args = args; - } - when Ext_list.for_all2_no_exn inner_args params lam_is_var - && Ext_list.length_larger_than_n inner_args args 1 -> - Lam.prim ~primitive ~args:(Ext_list.append_one args x) pipe_loc - | Lapply {ap_func; ap_args; ap_info; ap_transformed_jsx} -> - Lam.apply ~ap_transformed_jsx ap_func - (Ext_list.append_one ap_args x) - {ap_loc = pipe_loc; ap_inlined = ap_info.ap_inlined; ap_status = App_na} - | _ -> - Lam.apply f [x] - {ap_loc = pipe_loc; ap_inlined = Default_inline; ap_status = App_na} and convert_switch (e : Lambda.lambda) (s : Lambda.lambda_switch) = let e = convert_aux e in match s with diff --git a/compiler/core/lam_print.ml b/compiler/core/lam_print.ml index c863ad9fdca..7d9b940026d 100644 --- a/compiler/core/lam_print.ml +++ b/compiler/core/lam_print.ml @@ -37,14 +37,6 @@ let rec struct_const ppf (cst : Lam_constant.t) = (Lambda.tag_label_of_tag_info i) struct_const sc1 sconsts scl -(* let string_of_loc_kind (loc : Lambda.loc_kind) = - match loc with - | Loc_FILE -> "loc_FILE" - | Loc_LINE -> "loc_LINE" - | Loc_MODULE -> "loc_MODULE" - | Loc_POS -> "loc_POS" - | Loc_LOC -> "loc_LOC" *) - let primitive ppf (prim : Lam_primitive.t) = match prim with (* | Pcreate_exception s -> fprintf ppf "[exn-create]%S" s *) diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index e53cdceacad..f574d14e9b8 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -13,8 +13,6 @@ (* *) (**************************************************************************) -type loc_kind = Loc_FILE | Loc_LINE | Loc_MODULE | Loc_LOC | Loc_POS - type hoisted_function = {binding: Ident.t; path: string list; loc: Location.t} type tag_info = @@ -180,9 +178,6 @@ type primitive = | Pnull | Pundefined | Pfn_arity - | Prevapply - | Pdirapply - | Ploc of loc_kind (* Globals *) | Pgetglobal of Ident.t (* Operations on heap blocks *) | Pmakeblock of tag_info @@ -739,34 +734,3 @@ let bind str var exp body = let raise_kind = function | Raise_regular -> "raise" | Raise_reraise -> "reraise" - -let lam_of_loc kind loc = - let loc_start = loc.Location.loc_start in - let file, lnum, cnum = Location.get_pos_info loc_start in - let file = Filename.basename file in - let enum = - loc.Location.loc_end.Lexing.pos_cnum - loc_start.Lexing.pos_cnum + cnum - in - match kind with - | Loc_POS -> - Lconst - (Const_block - ( Blk_tuple, - [ - Const_immstring file; - Const_base (Const_int lnum); - Const_base (Const_int cnum); - Const_base (Const_int enum); - ] )) - | Loc_FILE -> Lconst (Const_immstring file) - | Loc_MODULE -> - let filename = Filename.basename file in - let name = Env.get_unit_name () in - let module_name = if name = "" then "//" ^ filename ^ "//" else name in - Lconst (Const_immstring module_name) - | Loc_LOC -> - let loc = - Printf.sprintf "File %S, line %d, characters %d-%d" file lnum cnum enum - in - Lconst (Const_immstring loc) - | Loc_LINE -> Lconst (Const_base (Const_int lnum)) diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index 8e0134747c6..08d2191bb76 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -17,8 +17,6 @@ open Asttypes -type loc_kind = Loc_FILE | Loc_LINE | Loc_MODULE | Loc_LOC | Loc_POS - type hoisted_function = {binding: Ident.t; path: string list; loc: Location.t} type tag_info = @@ -146,9 +144,6 @@ type primitive = | Pnull | Pundefined | Pfn_arity - | Prevapply - | Pdirapply - | Ploc of loc_kind (* Globals *) | Pgetglobal of Ident.t (* Operations on heap blocks *) | Pmakeblock of tag_info @@ -447,4 +442,3 @@ val is_guarded : lambda -> bool val patch_guarded : lambda -> lambda -> lambda val raise_kind : raise_kind -> string -val lam_of_loc : loc_kind -> Location.t -> lambda diff --git a/compiler/ml/printlambda.ml b/compiler/ml/printlambda.ml index 112e1ebf365..e86fe12c8a0 100644 --- a/compiler/ml/printlambda.ml +++ b/compiler/ml/printlambda.ml @@ -54,13 +54,6 @@ let value_kind = function | Pfloatval -> "float" | Pboxedintval bi -> boxed_integer_name bi *) -let string_of_loc_kind = function - | Loc_FILE -> "loc_FILE" - | Loc_LINE -> "loc_LINE" - | Loc_MODULE -> "loc_MODULE" - | Loc_POS -> "loc_POS" - | Loc_LOC -> "loc_LOC" - (* let block_shape ppf shape = match shape with | None | Some [] -> () | Some l when List.for_all ((=) Pgenval) l -> () @@ -111,9 +104,6 @@ let primitive ppf = function | Pnull -> fprintf ppf "null" | Pundefined -> fprintf ppf "undefined" | Pfn_arity -> fprintf ppf "fn.length" - | Prevapply -> fprintf ppf "revapply" - | Pdirapply -> fprintf ppf "dirapply" - | Ploc kind -> fprintf ppf "%s" (string_of_loc_kind kind) | Pgetglobal id -> fprintf ppf "global %a" Ident.print id | Pmakeblock taginfo -> fprintf ppf "makeblock %a" print_taginfo taginfo | Pfield (n, fld) -> fprintf ppf "field:%s/%i" (str_of_field_info fld) n diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index b0dc3065a09..61af102417c 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -243,13 +243,6 @@ let primitives_table = ("%identity", Pidentity); ("%component_identity", Pidentity); ("%ignore", Pignore); - ("%revapply", Prevapply); - ("%apply", Pdirapply); - ("%loc_LOC", Ploc Loc_LOC); - ("%loc_FILE", Ploc Loc_FILE); - ("%loc_LINE", Ploc Loc_LINE); - ("%loc_POS", Ploc Loc_POS); - ("%loc_MODULE", Ploc Loc_MODULE); (* BEGIN Triples for ref data type *) ("%makeref", Pmakeblock Lambda.ref_tag_info); ("%refset", Psetfield (0, Lambda.ref_field_set_info)); @@ -726,58 +719,101 @@ let transl_external_application loc env (p : Primitive.description) "@{Error:@} internal error, using unrecognized primitive %s" p.prim_name +(* Compile-time source location (`__LOC__` / `%loc_*`). Lowered here so + Lambda never carries a location primitive. *) +type loc_kind = Loc_FILE | Loc_LINE | Loc_MODULE | Loc_LOC | Loc_POS + +let loc_kind_of_prim_name = function + | "%loc_LOC" -> Some Loc_LOC + | "%loc_FILE" -> Some Loc_FILE + | "%loc_LINE" -> Some Loc_LINE + | "%loc_POS" -> Some Loc_POS + | "%loc_MODULE" -> Some Loc_MODULE + | _ -> None + +let lam_of_loc kind loc = + let loc_start = loc.Location.loc_start in + let file, lnum, cnum = Location.get_pos_info loc_start in + let file = Filename.basename file in + let enum = + loc.Location.loc_end.Lexing.pos_cnum - loc_start.Lexing.pos_cnum + cnum + in + match kind with + | Loc_POS -> + Lconst + (Const_block + ( Blk_tuple, + [ + Const_immstring file; + Const_base (Const_int lnum); + Const_base (Const_int cnum); + Const_base (Const_int enum); + ] )) + | Loc_FILE -> Lconst (Const_immstring file) + | Loc_MODULE -> + let filename = Filename.basename file in + let name = Env.get_unit_name () in + let module_name = if name = "" then "//" ^ filename ^ "//" else name in + Lconst (Const_immstring module_name) + | Loc_LOC -> + let loc = + Printf.sprintf "File %S, line %d, characters %d-%d" file lnum cnum enum + in + Lconst (Const_immstring loc) + | Loc_LINE -> Lconst (Const_base (Const_int lnum)) + (* Eta-expand a primitive *) let transl_primitive loc p env ty ~val_type = (* Printf.eprintf "----transl_primitive %s----\n" p.prim_name; *) - let prim = - try Some (specialize_primitive p env ty) with Not_found -> None - in - match prim with - | None when p.prim_name = "%import" || p.prim_name = "#import" -> - Location.raise_errorf ~loc - "Dynamic import must be applied directly to a module or a value from \ - another module; it cannot be used as a first-class value." - | None -> - (* an external: expand its FFI spec, eta-expanded to its arity *) - if p.prim_from_constructor || p.prim_arity = 0 then - transl_external_application loc env p ~val_type [] ~transformed_jsx:false - else - let params = - if p.prim_arity = 1 then [Ident.create "prim"] - else - List.init p.prim_arity (fun i -> - Ident.create ("prim" ^ string_of_int i)) - in + match loc_kind_of_prim_name p.prim_name with + | Some kind -> ( + let lam = lam_of_loc kind loc in + match p.prim_arity with + | 0 -> lam + | 1 -> + let param = Ident.create "prim" in Lfunction { - params; + params = [param]; attr = default_function_attribute; loc; - body = - transl_external_application loc env p ~val_type - (List.map (fun id -> Lvar id) params) - ~transformed_jsx:false; + body = Lprim (Pmakeblock Blk_tuple, [lam; Lvar param], loc); } - | Some prim -> ( - warn_polymorphic_comparison loc prim []; + | _ -> assert false) + | None -> ( + let prim = + try Some (specialize_primitive p env ty) with Not_found -> None + in match prim with - | Ploc kind -> ( - let lam = lam_of_loc kind loc in - match p.prim_arity with - | 0 -> lam - | 1 -> - (* TODO: we should issue a warning ? *) - let param = Ident.create "prim" in + | None when p.prim_name = "%import" || p.prim_name = "#import" -> + Location.raise_errorf ~loc + "Dynamic import must be applied directly to a module or a value from \ + another module; it cannot be used as a first-class value." + | None -> + (* an external: expand its FFI spec, eta-expanded to its arity *) + if p.prim_from_constructor || p.prim_arity = 0 then + transl_external_application loc env p ~val_type [] + ~transformed_jsx:false + else + let params = + if p.prim_arity = 1 then [Ident.create "prim"] + else + List.init p.prim_arity (fun i -> + Ident.create ("prim" ^ string_of_int i)) + in Lfunction { - params = [param]; + params; attr = default_function_attribute; loc; - body = Lprim (Pmakeblock Blk_tuple, [lam; Lvar param], loc); + body = + transl_external_application loc env p ~val_type + (List.map (fun id -> Lvar id) params) + ~transformed_jsx:false; } - | _ -> assert false) - | _ -> + | Some prim -> + warn_polymorphic_comparison loc prim []; let rec make_params n total = if n <= 0 then [] else @@ -1031,44 +1067,48 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = wrap (transl_dynamic_import e.exp_loc arg) | _ -> ( let argl = transl_list args in - match - transl_primitive_application e.exp_loc p e.exp_env prim_type args - with + match loc_kind_of_prim_name p.prim_name with + | Some kind -> ( + match args with + | [] -> wrap (lam_of_loc kind e.exp_loc) + | [arg1] -> + let lam = lam_of_loc kind arg1.exp_loc in + wrap (Lprim (Pmakeblock Blk_tuple, lam :: argl, e.exp_loc)) + | _ -> assert false) | None -> ( - (* an external: expand its FFI spec here; %raw parses and classifies + match + transl_primitive_application e.exp_loc p e.exp_env prim_type args + with + | None -> ( + (* an external: expand its FFI spec here; %raw parses and classifies its snippet *) - match (p.prim_name, argl) with - | "#raw_expr", [Lconst (Const_base (Const_string (code, _)))] -> - let kind = Classify_function.classify code in - wrap - (Lprim (Praw_js_code {code; code_info = Exp kind}, [], e.exp_loc)) - | "#raw_stmt", [Lconst (Const_base (Const_string (code, _)))] -> - let kind = Classify_function.classify_stmt code in - wrap - (Lprim (Praw_js_code {code; code_info = Stmt kind}, [], e.exp_loc)) - | ("#raw_expr" | "#raw_stmt"), _ -> assert false - | _ -> - wrap - (transl_external_application e.exp_loc e.exp_env p - ~val_type:prim_vd.val_type argl ~transformed_jsx)) - | Some prim -> ( - warn_polymorphic_comparison e.exp_loc prim argl; - match (prim, args) with - | Praise k, [_] -> - let targ = List.hd argl in - let k = - match (k, targ) with - | Raise_regular, Lvar id when Hashtbl.mem try_ids id -> - Raise_reraise - | _ -> k - in - wrap (Lprim (Praise k, [targ], e.exp_loc)) - | Ploc kind, [] -> lam_of_loc kind e.exp_loc - | Ploc kind, [arg1] -> - let lam = lam_of_loc kind arg1.exp_loc in - Lprim (Pmakeblock Blk_tuple, lam :: argl, e.exp_loc) - | Ploc _, _ -> assert false - | _, _ -> wrap (Lprim (prim, argl, e.exp_loc))))) + match (p.prim_name, argl) with + | "#raw_expr", [Lconst (Const_base (Const_string (code, _)))] -> + let kind = Classify_function.classify code in + wrap + (Lprim (Praw_js_code {code; code_info = Exp kind}, [], e.exp_loc)) + | "#raw_stmt", [Lconst (Const_base (Const_string (code, _)))] -> + let kind = Classify_function.classify_stmt code in + wrap + (Lprim (Praw_js_code {code; code_info = Stmt kind}, [], e.exp_loc)) + | ("#raw_expr" | "#raw_stmt"), _ -> assert false + | _ -> + wrap + (transl_external_application e.exp_loc e.exp_env p + ~val_type:prim_vd.val_type argl ~transformed_jsx)) + | Some prim -> ( + warn_polymorphic_comparison e.exp_loc prim argl; + match (prim, args) with + | Praise k, [_] -> + let targ = List.hd argl in + let k = + match (k, targ) with + | Raise_regular, Lvar id when Hashtbl.mem try_ids id -> + Raise_reraise + | _ -> k + in + wrap (Lprim (Praise k, [targ], e.exp_loc)) + | _, _ -> wrap (Lprim (prim, argl, e.exp_loc)))))) | Texp_apply {funct; args = oargs; partial; transformed_jsx} -> let inlined, funct = Translattribute.get_and_remove_inlined_attribute funct diff --git a/tests/tests/src/test_per.res b/tests/tests/src/test_per.res index d79ef145758..da968bff30a 100644 --- a/tests/tests/src/test_per.res +++ b/tests/tests/src/test_per.res @@ -7,11 +7,6 @@ let invalid_arg = s => throw(Invalid_argument(s)) exception Exit -/* Composition operators */ - -external \"|>": ('a, 'a => 'b) => 'b = "%revapply" -external \"@@": ('a => 'b, 'a) => 'b = "%apply" - /* Debugging */ external __LOC__: string = "%loc_LOC" From 0733df6634c0f2ed7d75d3b2db25d3f066c685a5 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sun, 30 Aug 2026 11:39:32 +0200 Subject: [PATCH 04/13] Move exception packing out of convert and drop OCaml leftovers Pack JS catch values in translcore so convert only translates Ltrywith. Drop raise_kind/reraise tracking (JS throw is one operation) and emit RE_EXN_ID string equality from matching instead of Pextension_slot_eq. Signed-off-by: Cristiano Calcagno --- CHANGELOG.md | 1 + compiler/core/lam_convert.ml | 101 +---------------------------------- compiler/ml/lambda.ml | 9 +--- compiler/ml/lambda.mli | 7 +-- compiler/ml/matching.ml | 17 ++++-- compiler/ml/printlambda.ml | 3 +- compiler/ml/translcore.ml | 95 ++++++++++++++++++++------------ 7 files changed, 80 insertions(+), 153 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 8f5732539a0..5785b3d7e94 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -71,6 +71,7 @@ - Sync the platform npm package's compiler binaries (`packages/@rescript//bin`) via dune promotion on every `dune build`, instead of Makefile/CI copy steps that only ran when make did: a plain `dune build` can no longer leave `cli/*.js` and the test harnesses running a stale compiler. https://github.com/rescript-lang/rescript/pull/8560 - Remove unused compiler IR definitions, modules, helpers, error variants, and Typedtree fields. https://github.com/rescript-lang/rescript/pull/8551 https://github.com/rescript-lang/rescript/pull/8555 - Remove the unused OCaml pipe primitives `%revapply`/`%apply` and the `Ploc` Lambda constructor. `__LOC__` and friends still compile to location constants in `translcore`. +- Lower exception packing (`Pwrap_exn`) in `translcore` instead of convert, drop unused `raise_kind` / reraise tracking, and emit `RE_EXN_ID` string equality from matching instead of `Pextension_slot_eq`. - Make locally abstract value constraints (`let f: type a. t = value`) structural in the parsetree, remove the obsolete `Pexp_newtype` and `Texp_newtype` wrapper metadata, and keep the old encoding confined to the frozen external-PPX bridge. The CMT magic number is bumped to `Caml1999T024`. https://github.com/rescript-lang/rescript/pull/8575 - Eliminate the `Pjs_fn_make`/`Pjs_fn_make_unit` arity-adjustment primitives and the `unsafe_adjust_to_arity` machinery: with structural arity, functions are constructed at their final arity, so the enforcement layer (and the active-pattern currying split it compensated for) is deleted. Generated code improves: no adapter closures for patterns on mutable fields, better constant propagation and name preservation, and recursive modules whose members are plain functions compile statically without the runtime bootstrap. https://github.com/rescript-lang/rescript/pull/8570 - Cleanups enabled by structural arity: remove the unreachable `Too_many_arguments` error and the `?in_function` threading through the type checker that existed only to decorate it; remove the dead `function$`-vs-arrow unification bridge, `Ctype.arity`, and the unused parsetree arity helpers; deduplicate the analysis arrow-flattening helpers. https://github.com/rescript-lang/rescript/pull/8569 diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index 653c5f3a50c..35ef382d2f6 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -22,90 +22,8 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -let caml_id_field_info : Lambda.field_dbg_info = - Fld_record {name = Literals.exception_id} - -let lam_caml_id : Lam_primitive.t = Pfield (0, caml_id_field_info) let prim = Lam.prim -let lam_extension_id loc (head : Lam.t) = - prim ~primitive:lam_caml_id ~args:[head] loc - -(** A conservative approach to avoid packing exceptions - for lambda expression like {[ - try { ... }catch(id){body} - ]} - we approximate that if [id] is destructed or not. - If it is destructed, we need pack it in case it is JS exception. - The packing is called Primitive_exceptions.internalToException, which is a nop for OCaml exception, - but will wrap as (Error e) when it is an JS exception. - - {[ - try .. with - | A (x,y) -> - | Exn.Error .. - ]} - - Without such wrapping, the code above would raise - - Note it is not guaranteed that exception raised(or re-raised) is a structured - ocaml exception but it is guaranteed that if such exception is processed it would - still be an ocaml exception. - for example {[ - match x with - | exception e -> raise e - ]} - it will re-raise an exception as it is (we are not packing it anywhere) - - It is hard to judge an exception is destructed or escaped, any potential - alias(or if it is passed as an argument) would cause it to be leaked -*) -let exception_id_destructed (l : Lam.t) (fv : Ident.t) : bool = - let rec hit_opt (x : _ option) = - match x with - | None -> false - | Some a -> hit a - and hit_list_snd : 'a. ('a * _) list -> bool = - fun x -> Ext_list.exists_snd x hit - and hit_list xs = Ext_list.exists xs hit - and hit (l : Lam.t) = - match l with - (* | Lprim {primitive = Pintcomp _ ; - args = ([x;y ]) } -> - begin match x,y with - | Lvar _, Lvar _ -> false - | Lvar _, _ -> hit y - | _, Lvar _ -> hit x - | _, _ -> hit x || hit y - end *) - (* FIXME: this can be uncovered after we do the unboxing *) - | Lprim {primitive = Praise; args = [Lvar _]} -> false - | Lprim {primitive = _; args; _} -> hit_list args - | Lvar id -> Ident.same id fv - | Lassign (id, e) -> Ident.same id fv || hit e - | Lstaticcatch (e1, (_, _vars), e2) -> hit e1 || hit e2 - | Ltrywith (e1, _exn, e2) -> hit e1 || hit e2 - | Lfunction {body; params = _} -> hit body - | Llet (_str, _id, arg, body) -> hit arg || hit body - | Lletrec (decl, body) -> hit body || hit_list_snd decl - | Lfor (_v, e1, e2, _dir, e3) -> hit e1 || hit e2 || hit e3 - | Lfor_of (_v, e1, e2) | Lfor_await_of (_v, e1, e2) -> hit e1 || hit e2 - | Lconst _ -> false - | Lapply {ap_func; ap_args; _} -> hit ap_func || hit_list ap_args - | Lglobal_module _ (* global persistent module, play safe *) -> false - | Lswitch (arg, sw) -> - hit arg || hit_list_snd sw.sw_consts || hit_list_snd sw.sw_blocks - || hit_opt sw.sw_failaction - | Lstringswitch (arg, cases, default) -> - hit arg || hit_list_snd cases || hit_opt default - | Lstaticraise (_, args) -> hit_list args - | Lifthenelse (e1, e2, e3) -> hit e1 || hit e2 || hit e3 - | Lsequence (e1, e2) -> hit e1 || hit e2 - | Lbreak | Lcontinue -> false - | Lwhile (e1, e2) -> hit e1 || hit e2 - in - hit l - let abs_int x = if x < 0 then -x else x let no_over_flow x = abs_int x < 0x1fff_ffff @@ -150,13 +68,6 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = | Pnull -> Lam.const Const_js_null | Pundefined -> Lam.const (Const_js_undefined {is_unit = false}) | Pcreate_extension s -> prim ~primitive:(Pcreate_extension s) ~args loc - | Pextension_slot_eq -> ( - match args with - | [lhs; rhs] -> - prim ~primitive:(Pstringcomp Ceq) - ~args:[lam_extension_id loc lhs; rhs] - loc - | _ -> assert false) | Pwrap_exn -> prim ~primitive:Pwrap_exn ~args loc | Pignore -> (* Pignore means return unit, it is not an nop *) @@ -199,7 +110,7 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = | Pduprecord -> prim ~primitive:Pduprecord ~args loc | Ptagged_template -> prim ~primitive:Ptagged_template ~args loc | Precord_rest excluded -> prim ~primitive:(Precord_rest excluded) ~args loc - | Praise _ -> prim ~primitive:Praise ~args loc + | Praise -> prim ~primitive:Praise ~args loc | Pobjcomp x -> prim ~primitive:(Pobjcomp x) ~args loc | Pobjorder -> prim ~primitive:Pobjorder ~args loc | Pobjmin -> prim ~primitive:Pobjmin ~args loc @@ -376,15 +287,7 @@ let convert (_exports : Set_ident.t) (lam : Lambda.lambda) : | Lstaticcatch (b, (i, ids), handler) -> Lam.staticcatch (convert_aux b) (i, ids) (convert_aux handler) | Ltrywith (b, id, handler) -> - let body = convert_aux b in - let handler = convert_aux handler in - if exception_id_destructed handler id then - let new_id = Ident.create ("raw_" ^ id.name) in - Lam.try_ body new_id - (Lam.let_ StrictOpt id - (prim ~primitive:Pwrap_exn ~args:[Lam.var new_id] Location.none) - handler) - else Lam.try_ body id handler + Lam.try_ (convert_aux b) id (convert_aux handler) | Lifthenelse (b, then_, else_) -> Lam.if_ (convert_aux b) (convert_aux then_) (convert_aux else_) | Lsequence (a, b) -> Lam.seq (convert_aux a) (convert_aux b) diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index f574d14e9b8..ebced0ec7b8 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -196,7 +196,7 @@ type primitive = | Pjs_object_get of string | Pjs_object_set of string (* Exceptions *) - | Praise of raise_kind + | Praise (* object operations *) | Pobjcomp of comparison | Pobjorder @@ -305,7 +305,6 @@ type primitive = | Pisnullable (* exn *) | Pcreate_extension of string - | Pextension_slot_eq | Pwrap_exn (* js *) | Pcurry_apply of int @@ -325,8 +324,6 @@ and comparison = Ceq | Cneq | Clt | Cgt | Cle | Cge and value_kind = Pgenval -and raise_kind = Raise_regular | Raise_reraise - type pointer_info = | Pt_constructor of Variant_runtime.tag | Pt_variant of {name: string} @@ -730,7 +727,3 @@ let bind str var exp body = match exp with | Lvar var' when Ident.same var var' -> body | _ -> Llet (str, Pgenval, var, exp, body) - -let raise_kind = function - | Raise_regular -> "raise" - | Raise_reraise -> "reraise" diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index 08d2191bb76..2d6826d84f2 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -162,7 +162,7 @@ type primitive = | Pjs_object_get of string | Pjs_object_set of string (* Exceptions *) - | Praise of raise_kind + | Praise (* object primitives *) | Pobjcomp of comparison | Pobjorder @@ -271,7 +271,6 @@ type primitive = | Pisnullable (* exn *) | Pcreate_extension of string - | Pextension_slot_eq | Pwrap_exn (* js *) | Pcurry_apply of int @@ -290,8 +289,6 @@ and comparison = Ceq | Cneq | Clt | Cgt | Cle | Cge and value_kind = Pgenval -and raise_kind = Raise_regular | Raise_reraise - type structured_constant = | Const_base of constant | Const_pointer of pointer_info @@ -440,5 +437,3 @@ val staticfail : lambda (* Anticipated static failure *) (* Check anticipated failure, substitute its final value *) val is_guarded : lambda -> bool val patch_guarded : lambda -> lambda -> lambda - -val raise_kind : raise_kind -> string diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index d46b3fc3162..cf5bb4e79b7 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -2161,7 +2161,18 @@ let combine_constructor loc arg ex_pat cstr partial ctx def (fun (path, act) rem -> let ext = transl_extension_path ex_pat.pat_env path in Lifthenelse - (Lprim (Pextension_slot_eq, [Lvar tag; ext], loc), act, rem)) + ( Lprim + ( Pstringcomp Ceq, + [ + Lprim + ( Pfield (0, Fld_record {name = Literals.exception_id}), + [Lvar tag], + loc ); + ext; + ], + loc ), + act, + rem )) extension_cases default in Llet (Alias, Pgenval, tag, arg, tests) @@ -2687,7 +2698,7 @@ let partial_function loc () = let fname, line, char = Location.get_pos_info loc.Location.loc_start in let fname = Filename.basename fname in Lprim - ( Praise Raise_regular, + ( Praise, [ Lprim ( Pmakeblock Blk_extension, @@ -2712,7 +2723,7 @@ let for_function loc repr param pat_act_list partial = (* In the following two cases, exhaustiveness info is not available! *) let for_trywith param pat_act_list = compile_matching None - (fun () -> Lprim (Praise Raise_reraise, [param], Location.none)) + (fun () -> Lprim (Praise, [param], Location.none)) param pat_act_list Partial let simple_for_let loc param pat body = diff --git a/compiler/ml/printlambda.ml b/compiler/ml/printlambda.ml index e86fe12c8a0..52167d90e16 100644 --- a/compiler/ml/printlambda.ml +++ b/compiler/ml/printlambda.ml @@ -115,7 +115,7 @@ let primitive ppf = function | Pjs_object_create _ -> fprintf ppf "js_obj_create" | Pjs_object_get name -> fprintf ppf "js_object_get[%s]" name | Pjs_object_set name -> fprintf ppf "js_object_set[%s]" name - | Praise k -> fprintf ppf "%s" (Lambda.raise_kind k) + | Praise -> fprintf ppf "raise" | Pobjcomp Ceq -> fprintf ppf "==" | Pobjcomp Cneq -> fprintf ppf "!=" | Pobjcomp Clt -> fprintf ppf "<" @@ -230,7 +230,6 @@ let primitive ppf = function | Pisout -> fprintf ppf "isout" | Pisnullable -> fprintf ppf "isnullable" | Pcreate_extension s -> fprintf ppf "extension[%s]" s - | Pextension_slot_eq -> fprintf ppf "#extension_slot_eq" | Pwrap_exn -> fprintf ppf "wrap_exn" | Pawait -> fprintf ppf "await" | Pimport (Import_module {module_; path}) -> diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 61af102417c..9b2c06f4b18 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -257,7 +257,7 @@ let primitives_table = ("%obj_size", Pobjsize); ("%obj_get_field", Parrayrefu); ("%obj_set_field", Parraysetu); - ("%raise", Praise Raise_regular); + ("%raise", Praise); (* bool primitives *) ("%sequand", Psequand); ("%sequor", Psequor); @@ -909,7 +909,7 @@ let assert_failed exp = in let fname = Filename.basename fname in Lprim - ( Praise Raise_regular, + ( Praise, [ Lprim ( Pmakeblock Blk_extension, @@ -939,7 +939,55 @@ let rec cut n l = (* Translation of expressions *) -let try_ids = Hashtbl.create 8 +(* JS catch can receive a ReScript exception or a raw throw. If the handler + inspects [fv], bind [fv] to [Pwrap_exn raw] so matching sees a ReScript + value. Pure [throw v] is not an inspect: rethrow the raw JS value. *) +let exception_id_destructed (l : lambda) (fv : Ident.t) : bool = + let rec hit_opt = function + | None -> false + | Some a -> hit a + and hit_list_snd : 'a. ('a * _) list -> bool = + fun x -> Ext_list.exists_snd x hit + and hit_list xs = Ext_list.exists xs hit + and hit (l : lambda) = + match l with + | Lprim (Praise, [Lvar _], _) -> false + | Lprim (_, args, _) -> hit_list args + | Lvar id -> Ident.same id fv + | Lassign (id, e) -> Ident.same id fv || hit e + | Lstaticcatch (e1, _, e2) -> hit e1 || hit e2 + | Ltrywith (e1, _, e2) -> hit e1 || hit e2 + | Lfunction {body} -> hit body + | Llet (_, _, _, arg, body) -> hit arg || hit body + | Lletrec (decl, body) -> hit body || hit_list_snd decl + | Lfor (_, e1, e2, _, e3) -> hit e1 || hit e2 || hit e3 + | Lfor_of (_, e1, e2) | Lfor_await_of (_, e1, e2) -> hit e1 || hit e2 + | Lconst _ -> false + | Lapply {ap_func; ap_args} -> hit ap_func || hit_list ap_args + | Lswitch (arg, sw, _) -> + hit arg || hit_list_snd sw.sw_consts || hit_list_snd sw.sw_blocks + || hit_opt sw.sw_failaction + | Lstringswitch (arg, cases, default, _) -> + hit arg || hit_list_snd cases || hit_opt default + | Lstaticraise (_, args) -> hit_list args + | Lifthenelse (e1, e2, e3) -> hit e1 || hit e2 || hit e3 + | Lsequence (e1, e2) -> hit e1 || hit e2 + | Lbreak | Lcontinue -> false + | Lwhile (e1, e2) -> hit e1 || hit e2 + in + hit l + +let pack_trywith_exn id handler = + if exception_id_destructed handler id then + let raw_id = Ident.create ("raw_" ^ id.name) in + ( raw_id, + Llet + ( StrictOpt, + Pgenval, + id, + Lprim (Pwrap_exn, [Lvar raw_id], Location.none), + handler ) ) + else (id, handler) let extract_directive_for_fn exp = exp.exp_attributes @@ -1096,19 +1144,9 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = wrap (transl_external_application e.exp_loc e.exp_env p ~val_type:prim_vd.val_type argl ~transformed_jsx)) - | Some prim -> ( + | Some prim -> warn_polymorphic_comparison e.exp_loc prim argl; - match (prim, args) with - | Praise k, [_] -> - let targ = List.hd argl in - let k = - match (k, targ) with - | Raise_regular, Lvar id when Hashtbl.mem try_ids id -> - Raise_reraise - | _ -> k - in - wrap (Lprim (Praise k, [targ], e.exp_loc)) - | _, _ -> wrap (Lprim (prim, argl, e.exp_loc)))))) + wrap (Lprim (prim, argl, e.exp_loc))))) | Texp_apply {funct; args = oargs; partial; transformed_jsx} -> let inlined, funct = Translattribute.get_and_remove_inlined_attribute funct @@ -1131,10 +1169,9 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = transl_match e arg pat_expr_list exn_pat_expr_list partial | Texp_try (body, pat_expr_list) -> let id = Typecore.name_pattern "exn" pat_expr_list in - Ltrywith - ( transl_exp body, - id, - Matching.for_trywith (Lvar id) (transl_cases_try pat_expr_list) ) + let handler = Matching.for_trywith (Lvar id) (transl_cases pat_expr_list) in + let id, handler = pack_trywith_exn id handler in + Ltrywith (transl_exp body, id, handler) | Texp_tuple el -> ( let ll = transl_list el in try Lconst (Const_block (Blk_tuple, List.map extract_constant ll)) @@ -1305,17 +1342,6 @@ and transl_case {c_lhs; c_guard; c_rhs} = (c_lhs, transl_guard c_guard c_rhs) and transl_cases cases = List.map transl_case cases -and transl_case_try {c_lhs; c_guard; c_rhs} = - match c_lhs.pat_desc with - | Tpat_var (id, _) | Tpat_alias (_, id, _) -> - Hashtbl.replace try_ids id (); - Misc.try_finally - (fun () -> (c_lhs, transl_guard c_guard c_rhs)) - (fun () -> Hashtbl.remove try_ids id) - | _ -> (c_lhs, transl_guard c_guard c_rhs) - -and transl_cases_try cases = List.map transl_case_try cases - and transl_apply ?(inlined = Default_inline) ?(uncurried_partial_application = None) ?(transformed_jsx = false) lam sargs loc = @@ -1611,14 +1637,13 @@ and transl_record loc env fields repres opt_init_expr = and transl_match e arg pat_expr_list exn_pat_expr_list partial = let id = Typecore.name_pattern "exn" exn_pat_expr_list and cases = transl_cases pat_expr_list - and exn_cases = transl_cases_try exn_pat_expr_list in + and exn_cases = transl_cases exn_pat_expr_list in let static_catch body val_ids handler = let static_exception_id = next_negative_raise_count () in + let exn_handler = Matching.for_trywith (Lvar id) exn_cases in + let id, exn_handler = pack_trywith_exn id exn_handler in Lstaticcatch - ( Ltrywith - ( Lstaticraise (static_exception_id, body), - id, - Matching.for_trywith (Lvar id) exn_cases ), + ( Ltrywith (Lstaticraise (static_exception_id, body), id, exn_handler), (static_exception_id, val_ids), handler ) in From 0cd79443febc28b21235f6875fd70e540f583aea Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sun, 30 Aug 2026 12:49:58 +0200 Subject: [PATCH 05/13] Remove Pwrap_exn and call internalToException as a normal function Exception packing, Promise.catch, and JsExn.anyToExnInternal now apply Primitive_exceptions.internalToException instead of a dedicated primitive. Signed-off-by: Cristiano Calcagno --- CHANGELOG.md | 3 +- compiler/core/lam_analysis.ml | 4 +-- compiler/core/lam_compile_primitive.ml | 2 -- compiler/core/lam_convert.ml | 1 - compiler/core/lam_primitive.ml | 4 +-- compiler/core/lam_primitive.mli | 2 -- compiler/core/lam_print.ml | 1 - compiler/ml/lambda.ml | 1 - compiler/ml/lambda.mli | 1 - compiler/ml/printlambda.ml | 1 - compiler/ml/translcore.ml | 32 ++++++++++++++----- packages/@rescript/runtime/Stdlib_Exn.res | 3 +- packages/@rescript/runtime/Stdlib_Exn.resi | 2 +- packages/@rescript/runtime/Stdlib_JsExn.res | 3 +- packages/@rescript/runtime/Stdlib_JsExn.resi | 2 +- packages/@rescript/runtime/Stdlib_Promise.res | 4 +-- .../@rescript/runtime/lib/es6/Stdlib_Exn.mjs | 4 +++ .../runtime/lib/es6/Stdlib_JsExn.mjs | 4 +++ .../@rescript/runtime/lib/js/Stdlib_Exn.cjs | 4 +++ .../@rescript/runtime/lib/js/Stdlib_JsExn.cjs | 4 +++ .../tests/src/stdlib/Stdlib_IteratorTests.mjs | 6 ++-- 21 files changed, 56 insertions(+), 32 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 5785b3d7e94..bffac014841 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -71,7 +71,8 @@ - Sync the platform npm package's compiler binaries (`packages/@rescript//bin`) via dune promotion on every `dune build`, instead of Makefile/CI copy steps that only ran when make did: a plain `dune build` can no longer leave `cli/*.js` and the test harnesses running a stale compiler. https://github.com/rescript-lang/rescript/pull/8560 - Remove unused compiler IR definitions, modules, helpers, error variants, and Typedtree fields. https://github.com/rescript-lang/rescript/pull/8551 https://github.com/rescript-lang/rescript/pull/8555 - Remove the unused OCaml pipe primitives `%revapply`/`%apply` and the `Ploc` Lambda constructor. `__LOC__` and friends still compile to location constants in `translcore`. -- Lower exception packing (`Pwrap_exn`) in `translcore` instead of convert, drop unused `raise_kind` / reraise tracking, and emit `RE_EXN_ID` string equality from matching instead of `Pextension_slot_eq`. +- Lower exception packing in `translcore` instead of convert, drop unused `raise_kind` / reraise tracking, and emit `RE_EXN_ID` string equality from matching instead of `Pextension_slot_eq`. +- Remove the `Pwrap_exn` / `%wrap_exn` primitive. Exception packing, `Promise.catch`, and `JsExn.anyToExnInternal` call `Primitive_exceptions.internalToException` as a normal module function. - Make locally abstract value constraints (`let f: type a. t = value`) structural in the parsetree, remove the obsolete `Pexp_newtype` and `Texp_newtype` wrapper metadata, and keep the old encoding confined to the frozen external-PPX bridge. The CMT magic number is bumped to `Caml1999T024`. https://github.com/rescript-lang/rescript/pull/8575 - Eliminate the `Pjs_fn_make`/`Pjs_fn_make_unit` arity-adjustment primitives and the `unsafe_adjust_to_arity` machinery: with structural arity, functions are constructed at their final arity, so the enforcement layer (and the active-pattern currying split it compensated for) is deleted. Generated code improves: no adapter closures for patterns on mutable fields, better constant propagation and name preservation, and recursive modules whose members are plain functions compile statically without the runtime bootstrap. https://github.com/rescript-lang/rescript/pull/8570 - Cleanups enabled by structural arity: remove the unreachable `Too_many_arguments` error and the `?in_function` threading through the type checker that existed only to decorate it; remove the dead `function$`-vs-arrow unification bridge, `Ctype.arity`, and the unused parsetree arity helpers; deduplicate the analysis arrow-flattening helpers. https://github.com/rescript-lang/rescript/pull/8569 diff --git a/compiler/core/lam_analysis.ml b/compiler/core/lam_analysis.ml index 5d506e9e878..6e8308dd92b 100644 --- a/compiler/core/lam_analysis.ml +++ b/compiler/core/lam_analysis.ml @@ -84,8 +84,8 @@ let rec no_side_effects (lam : Lam.t) : bool = | Pisout _ (* Operations on big arrays: (unsafe, #dimensions, kind, layout) *) (* Compile time constants *) - | Poffsetint _ | Pstringadd | Pfn_arity | Pwrap_exn | Phash - | Phash_mixstring | Phash_mixint | Phash_finalmix + | Poffsetint _ | Pstringadd | Pfn_arity | Phash | Phash_mixstring + | Phash_mixint | Phash_finalmix | Praw_js_code {code_info = Exp (Js_function _ | Js_literal _) | Stmt Js_stmt_comment} -> diff --git a/compiler/core/lam_compile_primitive.ml b/compiler/core/lam_compile_primitive.ml index 8124782c446..789ed9e5ed9 100644 --- a/compiler/core/lam_compile_primitive.ml +++ b/compiler/core/lam_compile_primitive.ml @@ -76,8 +76,6 @@ let translate output_prefix loc (cxt : Lam_compile_context.t) match prim with | Pis_not_none -> Js_of_lam_option.is_not_none (Ext_list.singleton_exn args) | Pcreate_extension s -> E.make_exception s - | Pwrap_exn -> - E.runtime_call Primitive_modules.exceptions "internalToException" args | Praw_js_code {code; code_info} -> E.raw_js_code code_info code (* FIXME: save one allocation trim can not be done before syntax checking diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index 35ef382d2f6..1f646feab1e 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -68,7 +68,6 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = | Pnull -> Lam.const Const_js_null | Pundefined -> Lam.const (Const_js_undefined {is_unit = false}) | Pcreate_extension s -> prim ~primitive:(Pcreate_extension s) ~args loc - | Pwrap_exn -> prim ~primitive:Pwrap_exn ~args loc | Pignore -> (* Pignore means return unit, it is not an nop *) seq (Ext_list.singleton_exn args) unit diff --git a/compiler/core/lam_primitive.ml b/compiler/core/lam_primitive.ml index 1dff8c939c2..fac944c81ff 100644 --- a/compiler/core/lam_primitive.ml +++ b/compiler/core/lam_primitive.ml @@ -162,8 +162,6 @@ type t = | Pimport of Lambda.import_source | Ptypeof | Pfn_arity - | Pwrap_exn - (* convert either JS exception or OCaml exception into OCaml format *) | Pcreate_extension of string | Pis_not_none (* no info about its type *) | Pval_from_option @@ -189,7 +187,7 @@ let eq_tag_info (x : Lam_tag_info.t) y = x = y let eq_primitive_approx (lhs : t) (rhs : t) = match lhs with - | Pwrap_exn | Praise + | Praise (* generic comparison *) | Pobjorder | Pobjmin | Pobjmax | Pobjtag | Pobjsize (* bool primitives *) diff --git a/compiler/core/lam_primitive.mli b/compiler/core/lam_primitive.mli index cfcd19e5772..32b791b63ff 100644 --- a/compiler/core/lam_primitive.mli +++ b/compiler/core/lam_primitive.mli @@ -152,8 +152,6 @@ type t = | Pimport of Lambda.import_source | Ptypeof | Pfn_arity - | Pwrap_exn - (* convert either JS exception or OCaml exception into OCaml format *) | Pcreate_extension of string | Pis_not_none | Pval_from_option diff --git a/compiler/core/lam_print.ml b/compiler/core/lam_print.ml index 7d9b940026d..d38bf1bc5ac 100644 --- a/compiler/core/lam_print.ml +++ b/compiler/core/lam_print.ml @@ -41,7 +41,6 @@ let primitive ppf (prim : Lam_primitive.t) = match prim with (* | Pcreate_exception s -> fprintf ppf "[exn-create]%S" s *) | Pcreate_extension s -> fprintf ppf "[ext-create]%S" s - | Pwrap_exn -> fprintf ppf "#exn" | Pinit_mod -> fprintf ppf "init_mod!" | Pupdate_mod -> fprintf ppf "update_mod!" | Pjs_apply -> fprintf ppf "#apply" diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index ebced0ec7b8..f0d29ce23f3 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -305,7 +305,6 @@ type primitive = | Pisnullable (* exn *) | Pcreate_extension of string - | Pwrap_exn (* js *) | Pcurry_apply of int | Pjscomp of comparison diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index 2d6826d84f2..95939fe8265 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -271,7 +271,6 @@ type primitive = | Pisnullable (* exn *) | Pcreate_extension of string - | Pwrap_exn (* js *) | Pcurry_apply of int | Pjscomp of comparison diff --git a/compiler/ml/printlambda.ml b/compiler/ml/printlambda.ml index 52167d90e16..86da9848dc0 100644 --- a/compiler/ml/printlambda.ml +++ b/compiler/ml/printlambda.ml @@ -230,7 +230,6 @@ let primitive ppf = function | Pisout -> fprintf ppf "isout" | Pisnullable -> fprintf ppf "isnullable" | Pcreate_extension s -> fprintf ppf "extension[%s]" s - | Pwrap_exn -> fprintf ppf "wrap_exn" | Pawait -> fprintf ppf "await" | Pimport (Import_module {module_; path}) -> fprintf ppf "import[%s]" (String.concat "." (Ident.name module_ :: path)) diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 9b2c06f4b18..a88dae9e25f 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -372,7 +372,6 @@ let primitives_table = ("%null_to_opt", Pnull_to_opt); ("%nullable_to_opt", Pnullable_to_opt); ("%function_arity", Pfn_arity); - ("%wrap_exn", Pwrap_exn); ("%curry_apply1", Pcurry_apply 1); ("%curry_apply2", Pcurry_apply 2); ("%curry_apply3", Pcurry_apply 3); @@ -940,8 +939,28 @@ let rec cut n l = (* Translation of expressions *) (* JS catch can receive a ReScript exception or a raw throw. If the handler - inspects [fv], bind [fv] to [Pwrap_exn raw] so matching sees a ReScript - value. Pure [throw v] is not an inspect: rethrow the raw JS value. *) + inspects [fv], bind [fv] to [Primitive_exceptions.internalToException raw] + so matching sees a ReScript value. Pure [throw v] is not an inspect: + rethrow the raw JS value. *) +let wrap_exn loc arg = + Lapply + { + ap_func = + Lprim + ( Pfield (0, Fld_module {name = "internalToException"}), + [ + Lprim + ( Pgetglobal + (Ident.create_persistent Primitive_modules.exceptions), + [], + loc ); + ], + loc ); + ap_args = [arg]; + ap_loc = loc; + ap_inlined = Default_inline; + ap_transformed_jsx = false; + } let exception_id_destructed (l : lambda) (fv : Ident.t) : bool = let rec hit_opt = function | None -> false @@ -982,11 +1001,8 @@ let pack_trywith_exn id handler = let raw_id = Ident.create ("raw_" ^ id.name) in ( raw_id, Llet - ( StrictOpt, - Pgenval, - id, - Lprim (Pwrap_exn, [Lvar raw_id], Location.none), - handler ) ) + (StrictOpt, Pgenval, id, wrap_exn Location.none (Lvar raw_id), handler) + ) else (id, handler) let extract_directive_for_fn exp = diff --git a/packages/@rescript/runtime/Stdlib_Exn.res b/packages/@rescript/runtime/Stdlib_Exn.res index 648cb9e072f..65629c01a08 100644 --- a/packages/@rescript/runtime/Stdlib_Exn.res +++ b/packages/@rescript/runtime/Stdlib_Exn.res @@ -23,7 +23,8 @@ let asJsExn: exn => option = exn => type error @new external makeError: string => error = "Error" -external anyToExnInternal: 'a => exn = "%wrap_exn" +let anyToExnInternal = (x: 'a): exn => + Primitive_exceptions.internalToException((Obj.magic(x): unknown)) let raiseError = str => throw((Obj.magic((makeError(str): error)): exn)) diff --git a/packages/@rescript/runtime/Stdlib_Exn.resi b/packages/@rescript/runtime/Stdlib_Exn.resi index e82347c6911..ea5443b3d55 100644 --- a/packages/@rescript/runtime/Stdlib_Exn.resi +++ b/packages/@rescript/runtime/Stdlib_Exn.resi @@ -70,7 +70,7 @@ a value passed to a Promise.catch callback) reason: "Use `JsExn.anyToExnInternal` instead", migrate: JsExn.anyToExnInternal(), }) -external anyToExnInternal: 'a => exn = "%wrap_exn" +let anyToExnInternal: 'a => exn /** Raise Js exception Error object with stacktrace */ @deprecated({ diff --git a/packages/@rescript/runtime/Stdlib_JsExn.res b/packages/@rescript/runtime/Stdlib_JsExn.res index 45e29af43af..88866e79f4e 100644 --- a/packages/@rescript/runtime/Stdlib_JsExn.res +++ b/packages/@rescript/runtime/Stdlib_JsExn.res @@ -6,7 +6,8 @@ let fromException: exn => option = exn => | _ => None } -external anyToExnInternal: 'a => exn = "%wrap_exn" +let anyToExnInternal = (x: 'a): exn => + Primitive_exceptions.internalToException((Obj.magic(x): unknown)) let getOrUndefined: string => t => option< string, diff --git a/packages/@rescript/runtime/Stdlib_JsExn.resi b/packages/@rescript/runtime/Stdlib_JsExn.resi index b76b973bb67..0efaed31f8d 100644 --- a/packages/@rescript/runtime/Stdlib_JsExn.resi +++ b/packages/@rescript/runtime/Stdlib_JsExn.resi @@ -23,7 +23,7 @@ a value passed to a Promise.catch callback) **IMPORTANT**: This is an internal API and may be changed / removed any time in the future. */ -external anyToExnInternal: 'a => exn = "%wrap_exn" +let anyToExnInternal: 'a => exn /** `stack(jsExn)` retrieves the `stack` property of the exception, if it exists. The stack is a list of what functions were called, and what files they are defined in, prior to the error happening. diff --git a/packages/@rescript/runtime/Stdlib_Promise.res b/packages/@rescript/runtime/Stdlib_Promise.res index 05f41fa8341..a5b5e4b0293 100644 --- a/packages/@rescript/runtime/Stdlib_Promise.res +++ b/packages/@rescript/runtime/Stdlib_Promise.res @@ -95,11 +95,11 @@ external allSettled6: ( )> = "allSettled" @send -external _catch: (t<'a>, exn => t<'a>) => t<'a> = "catch" +external _catch: (t<'a>, unknown => t<'a>) => t<'a> = "catch" let catch = (promise: promise<'a>, callback: exn => promise<'a>): promise<'a> => { _catch(promise, err => { - callback(Stdlib_Exn.anyToExnInternal(err)) + callback(Primitive_exceptions.internalToException(err)) }) } diff --git a/packages/@rescript/runtime/lib/es6/Stdlib_Exn.mjs b/packages/@rescript/runtime/lib/es6/Stdlib_Exn.mjs index 57d5bf89290..f4836a1476c 100644 --- a/packages/@rescript/runtime/lib/es6/Stdlib_Exn.mjs +++ b/packages/@rescript/runtime/lib/es6/Stdlib_Exn.mjs @@ -1,6 +1,7 @@ import * as Primitive_option from "./Primitive_option.mjs"; +import * as Primitive_exceptions from "./Primitive_exceptions.mjs"; let $$Error = "JsExn"; @@ -10,6 +11,8 @@ function asJsExn(exn) { } } +let anyToExnInternal = Primitive_exceptions.internalToException; + function raiseError(str) { throw new Error(str); } @@ -41,6 +44,7 @@ function raiseUriError(str) { export { $$Error, asJsExn, + anyToExnInternal, raiseError, raiseEvalError, raiseRangeError, diff --git a/packages/@rescript/runtime/lib/es6/Stdlib_JsExn.mjs b/packages/@rescript/runtime/lib/es6/Stdlib_JsExn.mjs index 749e717b1ec..9ab809e069d 100644 --- a/packages/@rescript/runtime/lib/es6/Stdlib_JsExn.mjs +++ b/packages/@rescript/runtime/lib/es6/Stdlib_JsExn.mjs @@ -1,6 +1,7 @@ import * as Primitive_option from "./Primitive_option.mjs"; +import * as Primitive_exceptions from "./Primitive_exceptions.mjs"; function fromException(exn) { if (exn.RE_EXN_ID === "JsExn") { @@ -8,6 +9,8 @@ function fromException(exn) { } } +let anyToExnInternal = Primitive_exceptions.internalToException; + let getOrUndefined = (fieldName => t => (t && typeof t[fieldName] === "string" ? t[fieldName] : undefined)); let stack = getOrUndefined("stack"); @@ -20,6 +23,7 @@ let fileName = getOrUndefined("fileName"); export { fromException, + anyToExnInternal, stack, message, name, diff --git a/packages/@rescript/runtime/lib/js/Stdlib_Exn.cjs b/packages/@rescript/runtime/lib/js/Stdlib_Exn.cjs index 6337268359f..2bf7a7a90f1 100644 --- a/packages/@rescript/runtime/lib/js/Stdlib_Exn.cjs +++ b/packages/@rescript/runtime/lib/js/Stdlib_Exn.cjs @@ -1,6 +1,7 @@ 'use strict'; let Primitive_option = require("./Primitive_option.cjs"); +let Primitive_exceptions = require("./Primitive_exceptions.cjs"); let $$Error = "JsExn"; @@ -10,6 +11,8 @@ function asJsExn(exn) { } } +let anyToExnInternal = Primitive_exceptions.internalToException; + function raiseError(str) { throw new Error(str); } @@ -40,6 +43,7 @@ function raiseUriError(str) { exports.$$Error = $$Error; exports.asJsExn = asJsExn; +exports.anyToExnInternal = anyToExnInternal; exports.raiseError = raiseError; exports.raiseEvalError = raiseEvalError; exports.raiseRangeError = raiseRangeError; diff --git a/packages/@rescript/runtime/lib/js/Stdlib_JsExn.cjs b/packages/@rescript/runtime/lib/js/Stdlib_JsExn.cjs index 06ca1c33cc1..178a12d0b6c 100644 --- a/packages/@rescript/runtime/lib/js/Stdlib_JsExn.cjs +++ b/packages/@rescript/runtime/lib/js/Stdlib_JsExn.cjs @@ -1,6 +1,7 @@ 'use strict'; let Primitive_option = require("./Primitive_option.cjs"); +let Primitive_exceptions = require("./Primitive_exceptions.cjs"); function fromException(exn) { if (exn.RE_EXN_ID === "JsExn") { @@ -8,6 +9,8 @@ function fromException(exn) { } } +let anyToExnInternal = Primitive_exceptions.internalToException; + let getOrUndefined = (fieldName => t => (t && typeof t[fieldName] === "string" ? t[fieldName] : undefined)); let stack = getOrUndefined("stack"); @@ -19,6 +22,7 @@ let name = getOrUndefined("name"); let fileName = getOrUndefined("fileName"); exports.fromException = fromException; +exports.anyToExnInternal = anyToExnInternal; exports.stack = stack; exports.message = message; exports.name = name; diff --git a/tests/tests/src/stdlib/Stdlib_IteratorTests.mjs b/tests/tests/src/stdlib/Stdlib_IteratorTests.mjs index d32ecb0bc0c..eaa54314309 100644 --- a/tests/tests/src/stdlib/Stdlib_IteratorTests.mjs +++ b/tests/tests/src/stdlib/Stdlib_IteratorTests.mjs @@ -1,11 +1,11 @@ // Generated by ReScript, PLEASE EDIT WITH CARE import * as Test from "./Test.mjs"; +import * as Stdlib_JsExn from "@rescript/runtime/lib/es6/Stdlib_JsExn.mjs"; import * as Primitive_array from "@rescript/runtime/lib/es6/Primitive_array.mjs"; import * as Stdlib_Iterator from "@rescript/runtime/lib/es6/Stdlib_Iterator.mjs"; import * as Primitive_object from "@rescript/runtime/lib/es6/Primitive_object.mjs"; import * as Stdlib_Generator from "@rescript/runtime/lib/es6/Stdlib_Generator.mjs"; -import * as Primitive_exceptions from "@rescript/runtime/lib/es6/Primitive_exceptions.mjs"; import * as Stdlib_AsyncIterator from "@rescript/runtime/lib/es6/Stdlib_AsyncIterator.mjs"; import * as Stdlib_AsyncGenerator from "@rescript/runtime/lib/es6/Stdlib_AsyncGenerator.mjs"; import * as Stdlib_IteratorObject from "@rescript/runtime/lib/es6/Stdlib_IteratorObject.mjs"; @@ -468,7 +468,7 @@ let generatorThrowError = ((function* () { let match$13 = Stdlib_Generator.next(generatorThrowError); -let match$14 = Stdlib_Generator.throwError(generatorThrowError, Primitive_exceptions.internalToException(new Error("boom"))); +let match$14 = Stdlib_Generator.throwError(generatorThrowError, Stdlib_JsExn.anyToExnInternal(new Error("boom"))); if (match$14.done !== false) { generatorThrowErrorResult.contents = "throwError"; @@ -795,7 +795,7 @@ let asyncGeneratorThrowError = ((async function* () { let match$20 = await Stdlib_AsyncGenerator.next(asyncGeneratorThrowError); -let match$21 = await Stdlib_AsyncGenerator.throwError(asyncGeneratorThrowError, Primitive_exceptions.internalToException(new Error("boom"))); +let match$21 = await Stdlib_AsyncGenerator.throwError(asyncGeneratorThrowError, Stdlib_JsExn.anyToExnInternal(new Error("boom"))); if (match$21.done !== false) { asyncGeneratorThrowErrorResult.contents = "throwError"; From bb67cf1ceaff9763f7327502e4e5de939858d263 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sun, 30 Aug 2026 13:41:03 +0200 Subject: [PATCH 06/13] Split let rec groups at Lambda production and drop Lam_scc Emit nested let/letrec from transl_let and eval_rec_bindings via Lambda_scc.bind_rec. Convert Lletrec is identity. JS compile only sorts functions before values for dummy/updateDummy init. Signed-off-by: Cristiano Calcagno --- CHANGELOG.md | 1 + compiler/core/lam_compile.ml | 32 ++-- compiler/core/lam_convert.ml | 6 +- compiler/core/lam_scc.ml | 159 ------------------ compiler/ml/lambda_scc.ml | 113 +++++++++++++ .../{core/lam_scc.mli => ml/lambda_scc.mli} | 12 +- compiler/ml/transl_recmodule.ml | 4 +- compiler/ml/translcore.ml | 2 +- .../belt/lib/es6/src/Belt_internalBuckets.mjs | 26 +-- .../belt/lib/js/src/Belt_internalBuckets.cjs | 26 +-- tests/tests/src/hoisted_function_attr.mjs | 2 +- tests/tests/src/recursive_module.mjs | 2 +- 12 files changed, 174 insertions(+), 211 deletions(-) delete mode 100644 compiler/core/lam_scc.ml create mode 100644 compiler/ml/lambda_scc.ml rename compiler/{core/lam_scc.mli => ml/lambda_scc.mli} (86%) diff --git a/CHANGELOG.md b/CHANGELOG.md index bffac014841..856ca1c97d1 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -73,6 +73,7 @@ - Remove the unused OCaml pipe primitives `%revapply`/`%apply` and the `Ploc` Lambda constructor. `__LOC__` and friends still compile to location constants in `translcore`. - Lower exception packing in `translcore` instead of convert, drop unused `raise_kind` / reraise tracking, and emit `RE_EXN_ID` string equality from matching instead of `Pextension_slot_eq`. - Remove the `Pwrap_exn` / `%wrap_exn` primitive. Exception packing, `Promise.catch`, and `JsExn.anyToExnInternal` call `Primitive_exceptions.internalToException` as a normal module function. +- Split `let rec` groups into actual recursive clusters when Lambda is produced (`Lambda_scc.bind_rec`). Convert `Lletrec` is identity; `Lam_scc` is removed. JS compile only sorts functions before values for dummy/`updateDummy` init. - Make locally abstract value constraints (`let f: type a. t = value`) structural in the parsetree, remove the obsolete `Pexp_newtype` and `Texp_newtype` wrapper metadata, and keep the old encoding confined to the frozen external-PPX bridge. The CMT magic number is bumped to `Caml1999T024`. https://github.com/rescript-lang/rescript/pull/8575 - Eliminate the `Pjs_fn_make`/`Pjs_fn_make_unit` arity-adjustment primitives and the `unsafe_adjust_to_arity` machinery: with structural arity, functions are constructed at their final arity, so the enforcement layer (and the active-pattern currying split it compensated for) is deleted. Generated code improves: no adapter closures for patterns on mutable fields, better constant propagation and name preservation, and recursive modules whose members are plain functions compile statically without the runtime bootstrap. https://github.com/rescript-lang/rescript/pull/8570 - Cleanups enabled by structural arity: remove the unreachable `Too_many_arguments` error and the `?in_function` threading through the type checker that existed only to decorate it; remove the dead `function$`-vs-arrow unification bridge, `Ctype.arity`, and the unused parsetree arity helpers; deduplicate the analysis arrow-flattening helpers. https://github.com/rescript-lang/rescript/pull/8569 diff --git a/compiler/core/lam_compile.ml b/compiler/core/lam_compile.ml index 41a238f07f8..907b056a8b9 100644 --- a/compiler/core/lam_compile.ml +++ b/compiler/core/lam_compile.ml @@ -265,6 +265,25 @@ type initialization = J.block non-toplevel, it will explode code very quickly *) +(* Semantic SCC already ran in [Lambda_scc.bind_rec]. JS still wants + functions before values so dummy / updateDummy init is well-ordered. *) +let functions_before_values (group : (Ident.t * Lam.t) list) = + if + Ext_list.for_all group (fun (_, x) -> + match x with + | Lfunction _ -> true + | _ -> false) + then group + else + List.sort + (fun (_, lama) (_, lamb) -> + match ((lama : Lam.t), (lamb : Lam.t)) with + | Lfunction _, Lfunction _ -> 0 + | Lfunction _, _ -> -1 + | _, Lfunction _ -> 1 + | _, _ -> 0) + group + let compile output_prefix = (* When compiling a read from another module, a nested source path like Other.A.B.make reaches this point as nested module-field reads: @@ -553,8 +572,8 @@ let compile output_prefix = ]} *) (compile_lambda {cxt with continuation = Declare (Alias, id)} arg, []) - and compile_recursive_lets_aux cxt (id_args : Lam_scc.bindings) : Js_output.t - = + and compile_recursive_lets_aux cxt (id_args : (Ident.t * Lam.t) list) : + Js_output.t = (* #1716 *) let output_code, ids = Ext_list.fold_right id_args (Js_output.dummy, []) @@ -570,14 +589,7 @@ let compile output_prefix = and compile_recursive_lets cxt id_args : Js_output.t = match id_args with | [] -> Js_output.dummy - | _ -> ( - let id_args_group = Lam_scc.scc_bindings id_args in - match id_args_group with - | [] -> assert false - | first :: rest -> - let acc = compile_recursive_lets_aux cxt first in - Ext_list.fold_left rest acc (fun acc x -> - Js_output.append_output acc (compile_recursive_lets_aux cxt x))) + | _ -> compile_recursive_lets_aux cxt (functions_before_values id_args) and compile_general_cases : 'a. make_exp:('a -> J.expression) -> diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index 1f646feab1e..7a36d152913 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -254,11 +254,7 @@ let convert (_exports : Set_ident.t) (lam : Lambda.lambda) : ~body:(convert_aux body) | Llet (kind, Pgenval, id, e, body) (*FIXME*) -> convert_let kind id e body | Lletrec (bindings, body) -> - let bindings = Ext_list.map_snd bindings convert_aux in - let body = convert_aux body in - let lam = Lam.letrec bindings body in - Lam_scc.scc bindings lam body - (* inlining will affect how mututal recursive behave *) + Lam.letrec (Ext_list.map_snd bindings convert_aux) (convert_aux body) | Lprim (Pgetglobal id, args, _) -> let args = Ext_list.map args convert_aux in if Ident.is_predef_exn id then diff --git a/compiler/core/lam_scc.ml b/compiler/core/lam_scc.ml deleted file mode 100644 index 6f1e1b7583c..00000000000 --- a/compiler/core/lam_scc.ml +++ /dev/null @@ -1,159 +0,0 @@ -(* Copyright (C) 2018 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** - [hit_mask mask lambda] iters through the lambda - set the bit of corresponding [id] if [id] is hit. - As an optimization step if [mask_and_check_all_hit], - there is no need to iter such lambda any more -*) -let hit_mask (mask : Hash_set_ident_mask.t) (l : Lam.t) : bool = - let rec hit_opt (x : Lam.t option) = - match x with - | None -> false - | Some a -> hit a - and hit_var (id : Ident.t) = - Hash_set_ident_mask.mask_and_check_all_hit mask id - and hit_list_snd : 'a. ('a * Lam.t) list -> bool = - fun x -> Ext_list.exists_snd x hit - and hit_list xs = Ext_list.exists xs hit - and hit (l : Lam.t) = - match l with - | Lvar id -> hit_var id - | Lassign (id, e) -> hit_var id || hit e - | Lstaticcatch (e1, (_, _), e2) -> hit e1 || hit e2 - | Ltrywith (e1, _exn, e2) -> hit e1 || hit e2 - | Lfunction {body; params = _} -> hit body - | Llet (_str, _id, arg, body) -> hit arg || hit body - | Lletrec (decl, body) -> hit body || hit_list_snd decl - | Lfor (_v, e1, e2, _dir, e3) -> hit e1 || hit e2 || hit e3 - | Lfor_of (_v, e1, e2) | Lfor_await_of (_v, e1, e2) -> hit e1 || hit e2 - | Lconst _ -> false - | Lapply {ap_func; ap_args; _} -> hit ap_func || hit_list ap_args - | Lglobal_module _ (* playsafe *) -> false - | Lprim {args; _} -> hit_list args - | Lswitch (arg, sw) -> - hit arg || hit_list_snd sw.sw_consts || hit_list_snd sw.sw_blocks - || hit_opt sw.sw_failaction - | Lstringswitch (arg, cases, default) -> - hit arg || hit_list_snd cases || hit_opt default - | Lstaticraise (_, args) -> hit_list args - | Lifthenelse (e1, e2, e3) -> hit e1 || hit e2 || hit e3 - | Lsequence (e1, e2) -> hit e1 || hit e2 - | Lbreak | Lcontinue -> false - | Lwhile (e1, e2) -> hit e1 || hit e2 - in - hit l - -type bindings = (Ident.t * Lam.t) list - -let preprocess_deps (groups : bindings) : _ * Ident.t array * Vec_int.t array = - let len = List.length groups in - let domain : _ Ordered_hash_map_local_ident.t = - Ordered_hash_map_local_ident.create len - in - let mask = Hash_set_ident_mask.create len in - Ext_list.iter groups (fun (x, lam) -> - Ordered_hash_map_local_ident.add domain x lam; - Hash_set_ident_mask.add_unmask mask x); - let int_mapping = Ordered_hash_map_local_ident.to_sorted_array domain in - let node_vec = Array.make (Array.length int_mapping) (Vec_int.empty ()) in - Ordered_hash_map_local_ident.iter domain (fun _id lam key_index -> - let base_key = node_vec.(key_index) in - ignore (hit_mask mask lam); - Hash_set_ident_mask.iter_and_unmask mask (fun ident hit -> - if hit then - let key = Ordered_hash_map_local_ident.rank domain ident in - Vec_int.push base_key key)); - (domain, int_mapping, node_vec) - -let is_function_bind (_, (x : Lam.t)) = - match x with - | Lfunction _ -> true - | _ -> false - -let sort_single_binding_group (group : bindings) = - if Ext_list.for_all group is_function_bind then group - else - List.sort - (fun (_, lama) (_, lamb) -> - match ((lama : Lam.t), (lamb : Lam.t)) with - | Lfunction _, Lfunction _ -> 0 - | Lfunction _, _ -> -1 - | _, Lfunction _ -> 1 - | _, _ -> 0) - group - -(** TODO: even for a singleton recursive function, tell whehter it is recursive or not ? *) -let scc_bindings (groups : bindings) : bindings list = - match groups with - | [_] -> [sort_single_binding_group groups] - | _ -> - let domain, int_mapping, node_vec = preprocess_deps groups in - let clusters : Int_vec_vec.t = Ext_scc.graph node_vec in - if Int_vec_vec.length clusters <= 1 then [sort_single_binding_group groups] - else - Int_vec_vec.fold_right - (fun (v : Vec_int.t) acc -> - let bindings = - Vec_int.map_into_list - (fun i -> - let id = int_mapping.(i) in - let lam = Ordered_hash_map_local_ident.find_value domain id in - (id, lam)) - v - in - sort_single_binding_group bindings :: acc) - clusters [] - -(* single binding, it does not make sense to do scc, - we can eliminate {[ let rec f x = x + x ]}, but it happens rarely in real world -*) -let scc (groups : bindings) (lam : Lam.t) (body : Lam.t) = - match groups with - | [(id, bind)] -> - if Lam_hit.hit_variable id bind then lam else Lam.let_ Strict id bind body - | _ -> - let domain, int_mapping, node_vec = preprocess_deps groups in - let clusters = Ext_scc.graph node_vec in - if Int_vec_vec.length clusters <= 1 then lam - else - Int_vec_vec.fold_right - (fun (v : Vec_int.t) acc -> - let bindings = - Vec_int.map_into_list - (fun i -> - let id = int_mapping.(i) in - let lam = Ordered_hash_map_local_ident.find_value domain id in - (id, lam)) - v - in - match bindings with - | [(id, lam)] -> - let base_key = Ordered_hash_map_local_ident.rank domain id in - if Int_vec_util.mem base_key node_vec.(base_key) then - Lam.letrec bindings acc - else Lam.let_ Strict id lam acc - | _ -> Lam.letrec bindings acc) - clusters body diff --git a/compiler/ml/lambda_scc.ml b/compiler/ml/lambda_scc.ml new file mode 100644 index 00000000000..e216d5b092b --- /dev/null +++ b/compiler/ml/lambda_scc.ml @@ -0,0 +1,113 @@ +(* Copyright (C) 2018 - Hongbo Zhang, Authors of ReScript + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +open Lambda + +type bindings = (Ident.t * lambda) list + +(* [p] may have side effects (masking). Returning true stops the walk. *) +let exists_var (p : Ident.t -> bool) (l : lambda) : bool = + let rec hit_opt = function + | None -> false + | Some a -> hit a + and hit_list_snd : 'a. ('a * lambda) list -> bool = + fun x -> Ext_list.exists_snd x hit + and hit_list xs = Ext_list.exists xs hit + and hit (l : lambda) = + match l with + | Lvar id -> p id + | Lassign (id, e) -> p id || hit e + | Lstaticcatch (e1, _, e2) + | Ltrywith (e1, _, e2) + | Lsequence (e1, e2) + | Lwhile (e1, e2) + | Lfor_of (_, e1, e2) + | Lfor_await_of (_, e1, e2) -> + hit e1 || hit e2 + | Lfunction {body} -> hit body + | Llet (_, _, _, arg, body) -> hit arg || hit body + | Lletrec (decl, body) -> hit body || hit_list_snd decl + | Lfor (_, e1, e2, _, e3) | Lifthenelse (e1, e2, e3) -> + hit e1 || hit e2 || hit e3 + | Lconst _ | Lbreak | Lcontinue -> false + | Lapply {ap_func; ap_args} -> hit ap_func || hit_list ap_args + | Lprim (_, args, _) | Lstaticraise (_, args) -> hit_list args + | Lswitch (arg, sw, _) -> + hit arg || hit_list_snd sw.sw_consts || hit_list_snd sw.sw_blocks + || hit_opt sw.sw_failaction + | Lstringswitch (arg, cases, default, _) -> + hit arg || hit_list_snd cases || hit_opt default + in + hit l + +let preprocess_deps (groups : bindings) : _ * Ident.t array * Vec_int.t array = + let len = List.length groups in + let domain : _ Ordered_hash_map_local_ident.t = + Ordered_hash_map_local_ident.create len + in + let mask = Hash_set_ident_mask.create len in + Ext_list.iter groups (fun (x, lam) -> + Ordered_hash_map_local_ident.add domain x lam; + Hash_set_ident_mask.add_unmask mask x); + let int_mapping = Ordered_hash_map_local_ident.to_sorted_array domain in + let node_vec = + Array.init (Array.length int_mapping) (fun _ -> Vec_int.empty ()) + in + Ordered_hash_map_local_ident.iter domain (fun _id lam key_index -> + let base_key = node_vec.(key_index) in + ignore (exists_var (Hash_set_ident_mask.mask_and_check_all_hit mask) lam); + Hash_set_ident_mask.iter_and_unmask mask (fun ident hit -> + if hit then + let key = Ordered_hash_map_local_ident.rank domain ident in + Vec_int.push base_key key)); + (domain, int_mapping, node_vec) + +let bind_rec (groups : bindings) (body : lambda) : lambda = + match groups with + | [(id, bind)] -> + if exists_var (Ident.same id) bind then Lletrec (groups, body) + else Llet (Strict, Pgenval, id, bind, body) + | _ -> + let domain, int_mapping, node_vec = preprocess_deps groups in + let clusters = Ext_scc.graph node_vec in + if Int_vec_vec.length clusters <= 1 then Lletrec (groups, body) + else + Int_vec_vec.fold_right + (fun (v : Vec_int.t) acc -> + let bindings = + Vec_int.map_into_list + (fun i -> + let id = int_mapping.(i) in + let lam = Ordered_hash_map_local_ident.find_value domain id in + (id, lam)) + v + in + match bindings with + | [(id, lam)] -> + let base_key = Ordered_hash_map_local_ident.rank domain id in + if Int_vec_util.mem base_key node_vec.(base_key) then + Lletrec (bindings, acc) + else Llet (Strict, Pgenval, id, lam, acc) + | _ -> Lletrec (bindings, acc)) + clusters body diff --git a/compiler/core/lam_scc.mli b/compiler/ml/lambda_scc.mli similarity index 86% rename from compiler/core/lam_scc.mli rename to compiler/ml/lambda_scc.mli index 46cf4811806..b38dc9b6ae0 100644 --- a/compiler/core/lam_scc.mli +++ b/compiler/ml/lambda_scc.mli @@ -1,5 +1,5 @@ (* Copyright (C) 2018 - Hongbo Zhang, Authors of ReScript - * + * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or @@ -17,13 +17,11 @@ * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. - * + * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type bindings = (Ident.t * Lam.t) list - -val scc_bindings : bindings -> bindings list - -val scc : bindings -> Lam.t -> Lam.t -> Lam.t +val bind_rec : (Ident.t * Lambda.lambda) list -> Lambda.lambda -> Lambda.lambda +(** Split a syntactic [let rec] group into the actual recursive clusters + and demote bindings that are not recursive. *) diff --git a/compiler/ml/transl_recmodule.ml b/compiler/ml/transl_recmodule.ml index 15e98ce015a..6a0aa657da8 100644 --- a/compiler/ml/transl_recmodule.ml +++ b/compiler/ml/transl_recmodule.ml @@ -230,7 +230,9 @@ let is_strict_or_all_functions (xs : binding list) = *) let eval_rec_bindings (bindings : binding list) (cont : t) : t = if is_strict_or_all_functions bindings then - Lambda.Lletrec (Ext_list.map bindings (fun (id, _, rhs) -> (id, rhs)), cont) + Lambda_scc.bind_rec + (Ext_list.map bindings (fun (id, _, rhs) -> (id, rhs))) + cont else eval_rec_bindings_aux bindings cont let compile_recmodule compile_rhs bindings cont = diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index a88dae9e25f..59c5c323e86 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -1501,7 +1501,7 @@ and transl_let ~js_hoist rec_flag pat_expr_list body = mark_js_hoisted_pattern ~js_hoist vb_attributes pat lam; (id, lam) in - Lletrec (Ext_list.map pat_expr_list transl_case, body) + Lambda_scc.bind_rec (Ext_list.map pat_expr_list transl_case) body and transl_record loc env fields repres opt_init_expr = match (opt_init_expr, repres, fields) with diff --git a/packages/@rescript/belt/lib/es6/src/Belt_internalBuckets.mjs b/packages/@rescript/belt/lib/es6/src/Belt_internalBuckets.mjs index b050532526d..9ed766f6fba 100644 --- a/packages/@rescript/belt/lib/es6/src/Belt_internalBuckets.mjs +++ b/packages/@rescript/belt/lib/es6/src/Belt_internalBuckets.mjs @@ -4,19 +4,6 @@ import * as Belt_Array from "./Belt_Array.mjs"; import * as Primitive_int from "@rescript/runtime/lib/es6/Primitive_int.mjs"; import * as Primitive_option from "@rescript/runtime/lib/es6/Primitive_option.mjs"; -function copyBucket(c) { - if (c === undefined) { - return c; - } - let head = { - key: c.key, - value: c.value, - next: undefined - }; - copyAuxCont(c.next, head); - return head; -} - function copyAuxCont(_c, _prec) { while (true) { let prec = _prec; @@ -36,6 +23,19 @@ function copyAuxCont(_c, _prec) { }; } +function copyBucket(c) { + if (c === undefined) { + return c; + } + let head = { + key: c.key, + value: c.value, + next: undefined + }; + copyAuxCont(c.next, head); + return head; +} + function copyBuckets(buckets) { let len = buckets.length; let newBuckets = new Array(len); diff --git a/packages/@rescript/belt/lib/js/src/Belt_internalBuckets.cjs b/packages/@rescript/belt/lib/js/src/Belt_internalBuckets.cjs index 8f08e017521..55e211a3725 100644 --- a/packages/@rescript/belt/lib/js/src/Belt_internalBuckets.cjs +++ b/packages/@rescript/belt/lib/js/src/Belt_internalBuckets.cjs @@ -4,19 +4,6 @@ let Belt_Array = require("./Belt_Array.cjs"); let Primitive_int = require("@rescript/runtime/lib/js/Primitive_int.cjs"); let Primitive_option = require("@rescript/runtime/lib/js/Primitive_option.cjs"); -function copyBucket(c) { - if (c === undefined) { - return c; - } - let head = { - key: c.key, - value: c.value, - next: undefined - }; - copyAuxCont(c.next, head); - return head; -} - function copyAuxCont(_c, _prec) { while (true) { let prec = _prec; @@ -36,6 +23,19 @@ function copyAuxCont(_c, _prec) { }; } +function copyBucket(c) { + if (c === undefined) { + return c; + } + let head = { + key: c.key, + value: c.value, + next: undefined + }; + copyAuxCont(c.next, head); + return head; +} + function copyBuckets(buckets) { let len = buckets.length; let newBuckets = new Array(len); diff --git a/tests/tests/src/hoisted_function_attr.mjs b/tests/tests/src/hoisted_function_attr.mjs index 3d466232380..9e68ea7f5ed 100644 --- a/tests/tests/src/hoisted_function_attr.mjs +++ b/tests/tests/src/hoisted_function_attr.mjs @@ -109,7 +109,7 @@ let RecursiveB = { }; function make$4() { - return RecursiveB.value(); + return "recursive"; } let RecursiveA = { diff --git a/tests/tests/src/recursive_module.mjs b/tests/tests/src/recursive_module.mjs index e651eb16041..12f04b3970b 100644 --- a/tests/tests/src/recursive_module.mjs +++ b/tests/tests/src/recursive_module.mjs @@ -36,7 +36,7 @@ let Intb = { a: a }; -let a$1 = Stdlib_Lazy.make(() => Stdlib_Lazy.get(Intb.a) + 1 | 0); +let a$1 = Stdlib_Lazy.make(() => Stdlib_Lazy.get(a) + 1 | 0); let Inta = { a: a$1 From e53cffe2500bde17684c4aaaaa96ce9fe731e097 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sun, 30 Aug 2026 14:09:59 +0200 Subject: [PATCH 07/13] Make convert Llet and Lswitch translations Remove the dense int-switch-to-add peephole and the switcher-offset let rewrite. Rewrite the one test that relied on the former to an or-pattern plus add. Signed-off-by: Cristiano Calcagno --- CHANGELOG.md | 2 + compiler/core/lam_convert.ml | 119 +++--------------------------- compiler/core/lam_convert.mli | 3 - tests/tests/src/gpr_2413_test.mjs | 6 +- tests/tests/src/gpr_2413_test.res | 5 +- 5 files changed, 17 insertions(+), 118 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 856ca1c97d1..903db894017 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -74,6 +74,8 @@ - Lower exception packing in `translcore` instead of convert, drop unused `raise_kind` / reraise tracking, and emit `RE_EXN_ID` string equality from matching instead of `Pextension_slot_eq`. - Remove the `Pwrap_exn` / `%wrap_exn` primitive. Exception packing, `Promise.catch`, and `JsExn.anyToExnInternal` call `Primitive_exceptions.internalToException` as a normal module function. - Split `let rec` groups into actual recursive clusters when Lambda is produced (`Lambda_scc.bind_rec`). Convert `Lletrec` is identity; `Lam_scc` is removed. JS compile only sorts functions before values for dummy/`updateDummy` init. +- Remove the dense int-switch-to-add peephole (`happens_to_be_diff`) from Lambda-to-Lam conversion. Convert `Lswitch` is identity. +- Remove the switcher-offset peephole from Lambda-to-Lam conversion. Convert `Llet` is identity. - Make locally abstract value constraints (`let f: type a. t = value`) structural in the parsetree, remove the obsolete `Pexp_newtype` and `Texp_newtype` wrapper metadata, and keep the old encoding confined to the frozen external-PPX bridge. The CMT magic number is bumped to `Caml1999T024`. https://github.com/rescript-lang/rescript/pull/8575 - Eliminate the `Pjs_fn_make`/`Pjs_fn_make_unit` arity-adjustment primitives and the `unsafe_adjust_to_arity` machinery: with structural arity, functions are constructed at their final arity, so the enforcement layer (and the active-pattern currying split it compensated for) is deleted. Generated code improves: no adapter closures for patterns on mutable fields, better constant propagation and name preservation, and recursive modules whose members are plain functions compile statically without the runtime bootstrap. https://github.com/rescript-lang/rescript/pull/8570 - Cleanups enabled by structural arity: remove the unreachable `Too_many_arguments` error and the `?in_function` threading through the type checker that existed only to decorate it; remove the dead `function$`-vs-arrow unification bridge, `Ctype.arity`, and the unused parsetree arity helpers; deduplicate the analysis arrow-flattening helpers. https://github.com/rescript-lang/rescript/pull/8569 diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index 7a36d152913..28dbe2ee8c0 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -24,34 +24,6 @@ let prim = Lam.prim -let abs_int x = if x < 0 then -x else x -let no_over_flow x = abs_int x < 0x1fff_ffff - -(** Make sure no int range overflow happens - also we only check [int] -*) -let happens_to_be_diff (sw_consts : (Lambda.switch_key * Lambda.lambda) list) : - int option = - match sw_consts with - | (Switch_int a, Lconst (Const_base (Const_int a0))) - :: (Switch_int b, Lconst (Const_base (Const_int b0))) - :: rest - when no_over_flow a && no_over_flow a0 && no_over_flow b && no_over_flow b0 - -> - let diff = a0 - a in - if b0 - b = diff then - if - Ext_list.for_all rest (fun (key, lam) -> - match (key, lam) with - | Switch_int x, Lconst (Const_base (Const_int x0)) - when no_over_flow x0 && no_over_flow x -> - x0 - x = diff - | _ -> false) - then Some diff - else None - else None - | _ -> None - (* type required_modules = Lam_module_ident.Hash_set.t *) (** drop Lseq (List! ) etc @@ -252,7 +224,8 @@ let convert (_exports : Set_ident.t) (lam : Lambda.lambda) : | Lfunction {params; body; attr; loc} -> Lam.function_ ~loc ~attr ~arity:(List.length params) ~params ~body:(convert_aux body) - | Llet (kind, Pgenval, id, e, body) (*FIXME*) -> convert_let kind id e body + | Llet (kind, Pgenval, id, e, body) -> + Lam.let_ kind id (convert_aux e) (convert_aux body) | Lletrec (bindings, body) -> Lam.letrec (Ext_list.map_snd bindings convert_aux) (convert_aux body) | Lprim (Pgetglobal id, args, _) -> @@ -296,85 +269,15 @@ let convert (_exports : Set_ident.t) (lam : Lambda.lambda) : | Lfor_await_of (id, iterable, body) -> Lam.for_await_of id (convert_aux iterable) (convert_aux body) | Lassign (id, body) -> Lam.assign id (convert_aux body) - and convert_let (kind : Lam_compat.let_kind) id (e : Lambda.lambda) body : - Lam.t = - let new_e = convert_aux e in - let new_body = convert_aux body in - (* - reverse engineering cases as {[ - (let (switcher/1013 =a (-1+ match/1012)) - (if (isout 2 switcher/1013) (exit 1) - (switch* switcher/1013 - case int 0: 'a' - case int 1: 'b' - case int 2: 'c'))) - ]} - To elemininate the id [switcher], we need ensure it appears only - in two places. - - To advance this case, when [sw_failaction] is None - *) - match (kind, new_e, new_body) with - | ( Alias, - Lprim {primitive = Poffsetint offset; args = [(Lvar _ as matcher)]}, - Lswitch - ( Lvar switcher3, - ({ - sw_consts_full = false; - sw_consts; - sw_blocks = []; - sw_blocks_full = true; - sw_failaction = Some ifso; - } as px) ) ) - when Ident.same switcher3 id - && (not (Lam_hit.hit_variable id ifso)) - && not (Ext_list.exists_snd sw_consts (Lam_hit.hit_variable id)) -> - Lam.switch matcher - { - px with - sw_consts = - Ext_list.map sw_consts (fun (key, act) -> - match key with - | Lambda.Switch_int i -> (Lambda.Switch_int (i - offset), act) - | Lambda.Switch_constructor _ -> assert false); - } - | _ -> Lam.let_ kind id new_e new_body and convert_switch (e : Lambda.lambda) (s : Lambda.lambda_switch) = - let e = convert_aux e in - match s with - | { - sw_failaction = None; - sw_blocks = []; - sw_blocks_full = true; - sw_consts; - sw_consts_full; - sw_dispatch; - } -> ( - match happens_to_be_diff sw_consts with - | Some 0 -> e - | Some i -> - prim ~primitive:Paddint - ~args:[e; Lam.const (Const_int {i = Int32.of_int i; comment = None})] - Location.none - | _ -> - Lam.switch e - { - sw_failaction = None; - sw_blocks = []; - sw_blocks_full = true; - sw_consts = Ext_list.map_snd sw_consts convert_aux; - sw_consts_full; - sw_dispatch; - }) - | _ -> - Lam.switch e - { - sw_consts_full = s.sw_consts_full; - sw_consts = Ext_list.map_snd s.sw_consts convert_aux; - sw_blocks_full = s.sw_blocks_full; - sw_blocks = Ext_list.map_snd s.sw_blocks convert_aux; - sw_failaction = Ext_option.map s.sw_failaction convert_aux; - sw_dispatch = s.sw_dispatch; - } + Lam.switch (convert_aux e) + { + sw_consts_full = s.sw_consts_full; + sw_consts = Ext_list.map_snd s.sw_consts convert_aux; + sw_blocks_full = s.sw_blocks_full; + sw_blocks = Ext_list.map_snd s.sw_blocks convert_aux; + sw_failaction = Ext_option.map s.sw_failaction convert_aux; + sw_dispatch = s.sw_dispatch; + } in (convert_aux lam, may_depends) diff --git a/compiler/core/lam_convert.mli b/compiler/core/lam_convert.mli index 6d2ce815f19..7f7826c3592 100644 --- a/compiler/core/lam_convert.mli +++ b/compiler/core/lam_convert.mli @@ -22,9 +22,6 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -(* val happens_to_be_diff: - (int * Lambda.lambda) list -> int option *) - val convert : Set_ident.t -> Lambda.lambda -> Lam.t * Lam_module_ident.Hash_set.t (** [convert exports lam] translates Lambda to Lam and collects potential diff --git a/tests/tests/src/gpr_2413_test.mjs b/tests/tests/src/gpr_2413_test.mjs index 42a0ec1a930..18d53956cfc 100644 --- a/tests/tests/src/gpr_2413_test.mjs +++ b/tests/tests/src/gpr_2413_test.mjs @@ -21,11 +21,11 @@ function f(x) { function ff(c) { c.contents = c.contents + 1 | 0; - let match = (1 + c.contents | 0) + 1 | 0; - if (match > 3 || match < 0) { + let n = (1 + c.contents | 0) + 1 | 0; + if (n > 3 || n < 0) { return 0; } else { - return match + 1 | 0; + return n + 1 | 0; } } diff --git a/tests/tests/src/gpr_2413_test.res b/tests/tests/src/gpr_2413_test.res index 9e76dcc5d29..e8df3176680 100644 --- a/tests/tests/src/gpr_2413_test.res +++ b/tests/tests/src/gpr_2413_test.res @@ -23,9 +23,6 @@ let ff = c => Int.Ref.increment(c) a + c.contents + b } { - | 0 => 1 - | 1 => 2 - | 2 => 3 - | 3 => 4 + | (0 | 1 | 2 | 3) as n => n + 1 | _ => 0 } From c6ca45bc8937078ca575b5464f0c3d8ac439d876 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sun, 30 Aug 2026 14:44:23 +0200 Subject: [PATCH 08/13] Make convert Lstaticcatch and Lstaticraise translations Drop exit_map and the catch-of-raise peephole. Matching still emits catch body with (i) (exit j); Lam_pass_exits inlines the size-1 handler. Signed-off-by: Cristiano Calcagno --- CHANGELOG.md | 1 + compiler/core/lam_convert.ml | 7 ------- 2 files changed, 1 insertion(+), 7 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 903db894017..0ebc7c455ab 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -76,6 +76,7 @@ - Split `let rec` groups into actual recursive clusters when Lambda is produced (`Lambda_scc.bind_rec`). Convert `Lletrec` is identity; `Lam_scc` is removed. JS compile only sorts functions before values for dummy/`updateDummy` init. - Remove the dense int-switch-to-add peephole (`happens_to_be_diff`) from Lambda-to-Lam conversion. Convert `Lswitch` is identity. - Remove the switcher-offset peephole from Lambda-to-Lam conversion. Convert `Llet` is identity. +- Convert `Lstaticcatch` / `Lstaticraise` are identity. Drop exit aliasing (`exit_map`); `Lam_pass_exits` already inlines a catch whose handler is a tiny `Lstaticraise`. - Make locally abstract value constraints (`let f: type a. t = value`) structural in the parsetree, remove the obsolete `Pexp_newtype` and `Texp_newtype` wrapper metadata, and keep the old encoding confined to the frozen external-PPX bridge. The CMT magic number is bumped to `Caml1999T024`. https://github.com/rescript-lang/rescript/pull/8575 - Eliminate the `Pjs_fn_make`/`Pjs_fn_make_unit` arity-adjustment primitives and the `unsafe_adjust_to_arity` machinery: with structural arity, functions are constructed at their final arity, so the enforcement layer (and the active-pattern currying split it compensated for) is deleted. Generated code improves: no adapter closures for patterns on mutable fields, better constant propagation and name preservation, and recursive modules whose members are plain functions compile statically without the runtime bootstrap. https://github.com/rescript-lang/rescript/pull/8570 - Cleanups enabled by structural arity: remove the unreachable `Too_many_arguments` error and the `?in_function` threading through the type checker that existed only to decorate it; remove the dead `function$`-vs-arrow unification bridge, `Ctype.arity`, and the unused parsetree arity helpers; deduplicate the analysis arrow-flattening helpers. https://github.com/rescript-lang/rescript/pull/8569 diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index 28dbe2ee8c0..5f07ad7dabd 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -201,7 +201,6 @@ let may_depend = Lam_module_ident.Hash_set.add let convert (_exports : Set_ident.t) (lam : Lambda.lambda) : Lam.t * Lam_module_ident.Hash_set.t = - let exit_map = Hash_int.create 0 in let may_depends = Lam_module_ident.Hash_set.create 0 in let rec convert_aux (lam : Lambda.lambda) : Lam.t = @@ -244,14 +243,8 @@ let convert (_exports : Set_ident.t) (lam : Lambda.lambda) : Lam.stringswitch (convert_aux e) (Ext_list.map_snd cases convert_aux) (Ext_option.map default convert_aux) - | Lstaticraise (id, []) -> - Lam.staticraise (Hash_int.find_default exit_map id id) [] | Lstaticraise (id, args) -> Lam.staticraise id (Ext_list.map args convert_aux) - | Lstaticcatch (b, (i, []), Lstaticraise (j, [])) -> - (* peep-hole [i] aliased to [j] *) - Hash_int.add exit_map i (Hash_int.find_default exit_map j j); - convert_aux b | Lstaticcatch (b, (i, ids), handler) -> Lam.staticcatch (convert_aux b) (i, ids) (convert_aux handler) | Ltrywith (b, id, handler) -> From edce1f0286e979eff546261275b48ad3f6ae3281 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sun, 30 Aug 2026 15:25:43 +0200 Subject: [PATCH 09/13] Drop unused exports argument from Lambda-to-Lam conversion Signed-off-by: Cristiano Calcagno --- CHANGELOG.md | 1 + compiler/core/lam_compile_main.ml | 2 +- compiler/core/lam_convert.ml | 9 ++------- compiler/core/lam_convert.mli | 5 ++--- compiler/jsoo/jsoo_playground_main.ml | 3 +-- 5 files changed, 7 insertions(+), 13 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 0ebc7c455ab..e9c78717bf2 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -77,6 +77,7 @@ - Remove the dense int-switch-to-add peephole (`happens_to_be_diff`) from Lambda-to-Lam conversion. Convert `Lswitch` is identity. - Remove the switcher-offset peephole from Lambda-to-Lam conversion. Convert `Llet` is identity. - Convert `Lstaticcatch` / `Lstaticraise` are identity. Drop exit aliasing (`exit_map`); `Lam_pass_exits` already inlines a catch whose handler is a tiny `Lstaticraise`. +- Drop the unused `exports` argument from Lambda-to-Lam conversion. - Make locally abstract value constraints (`let f: type a. t = value`) structural in the parsetree, remove the obsolete `Pexp_newtype` and `Texp_newtype` wrapper metadata, and keep the old encoding confined to the frozen external-PPX bridge. The CMT magic number is bumped to `Caml1999T024`. https://github.com/rescript-lang/rescript/pull/8575 - Eliminate the `Pjs_fn_make`/`Pjs_fn_make_unit` arity-adjustment primitives and the `unsafe_adjust_to_arity` machinery: with structural arity, functions are constructed at their final arity, so the enforcement layer (and the active-pattern currying split it compensated for) is deleted. Generated code improves: no adapter closures for patterns on mutable fields, better constant propagation and name preservation, and recursive modules whose members are plain functions compile statically without the runtime bootstrap. https://github.com/rescript-lang/rescript/pull/8570 - Cleanups enabled by structural arity: remove the unreachable `Too_many_arguments` error and the `?in_function` threading through the type checker that existed only to decorate it; remove the dead `function$`-vs-arrow unification bridge, `Ctype.arity`, and the unused parsetree arity helpers; deduplicate the analysis arrow-flattening helpers. https://github.com/rescript-lang/rescript/pull/8569 diff --git a/compiler/core/lam_compile_main.ml b/compiler/core/lam_compile_main.ml index e5b157085f8..e68358bcccd 100644 --- a/compiler/core/lam_compile_main.ml +++ b/compiler/core/lam_compile_main.ml @@ -275,7 +275,7 @@ let compile (output_prefix : string) export_idents hoisted (lam : Lambda.lambda) Ext_log.dwarn ~__POS__ "export idents: %s/%d" id.name id.stamp); Lam_compile_env.reset () in - let lam, may_required_modules = Lam_convert.convert export_ident_sets lam in + let lam, may_required_modules = Lam_convert.convert lam in let lam = Lam_pass_collapse_var_aliases.collapse ~exports:export_ident_sets lam in diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index 5f07ad7dabd..27e740197ea 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -30,10 +30,6 @@ let prim = Lam.prim see #3852, we drop all these required global modules but added it back based on our own module analysis *) -let seq = Lam.seq - -let unit = Lam.unit - let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = match p with | Pidentity -> Ext_list.singleton_exn args @@ -42,7 +38,7 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = | Pcreate_extension s -> prim ~primitive:(Pcreate_extension s) ~args loc | Pignore -> (* Pignore means return unit, it is not an nop *) - seq (Ext_list.singleton_exn args) unit + Lam.seq (Ext_list.singleton_exn args) Lam.unit | Pgetglobal _ -> assert false | Pmakeblock info -> ( let mutable_flag = Lambda.mutable_flag_of_tag_info info in @@ -199,8 +195,7 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = let may_depend = Lam_module_ident.Hash_set.add -let convert (_exports : Set_ident.t) (lam : Lambda.lambda) : - Lam.t * Lam_module_ident.Hash_set.t = +let convert (lam : Lambda.lambda) : Lam.t * Lam_module_ident.Hash_set.t = let may_depends = Lam_module_ident.Hash_set.create 0 in let rec convert_aux (lam : Lambda.lambda) : Lam.t = diff --git a/compiler/core/lam_convert.mli b/compiler/core/lam_convert.mli index 7f7826c3592..dd3a3c74e6b 100644 --- a/compiler/core/lam_convert.mli +++ b/compiler/core/lam_convert.mli @@ -22,9 +22,8 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val convert : - Set_ident.t -> Lambda.lambda -> Lam.t * Lam_module_ident.Hash_set.t -(** [convert exports lam] translates Lambda to Lam and collects potential +val convert : Lambda.lambda -> Lam.t * Lam_module_ident.Hash_set.t +(** [convert lam] translates Lambda to Lam and collects potential depended modules. [let x = y] aliases are left for {!Lam_pass_collapse_var_aliases}; unused lets are left for {!Lam_pass_lets_dce}. *) diff --git a/compiler/jsoo/jsoo_playground_main.ml b/compiler/jsoo/jsoo_playground_main.ml index 9abef11ca6f..2e4536b6958 100644 --- a/compiler/jsoo/jsoo_playground_main.ml +++ b/compiler/jsoo/jsoo_playground_main.ml @@ -542,13 +542,12 @@ module Compile = struct |] in if include_debug_outputs then - let export_ident_sets = Set_ident.of_list exports in let parsetree = Printer.to_string Printast.implementation ast in let typedtree = Printer.to_string Printtyped.implementation_with_coercion typed_tree in let lambda_output = Printer.to_string Printlambda.lambda lambda in - let lam, _ = Lam_convert.convert export_ident_sets lambda in + let lam, _ = Lam_convert.convert lambda in let lam = Lam_print.lambda_to_string lam in let debug_attrs = Js.Unsafe. From f78598ee9b22edf3570b7409bf0fb56e6eb25bba Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sun, 30 Aug 2026 16:44:14 +0200 Subject: [PATCH 10/13] Represent identity and ignore as Peliminated on Lambda and Lam Lambda.mk_prim expands Peliminated so those payloads never appear as Lprim nodes. Convert maps the constructor 1-1. Lam matches assert false because the node cannot occur. Signed-off-by: Cristiano Calcagno --- CHANGELOG.md | 1 + compiler/core/lam_analysis.ml | 1 + compiler/core/lam_compile_primitive.ml | 1 + compiler/core/lam_convert.ml | 5 +---- compiler/core/lam_primitive.ml | 2 ++ compiler/core/lam_primitive.mli | 1 + compiler/core/lam_print.ml | 1 + compiler/ml/lambda.ml | 25 +++++++++++++++++++++---- compiler/ml/lambda.mli | 9 +++++++-- compiler/ml/matching.ml | 5 ++--- compiler/ml/printlambda.ml | 6 ++++-- compiler/ml/translcore.ml | 12 ++++++------ compiler/ml/unified_ops.ml | 6 +++--- 13 files changed, 51 insertions(+), 24 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index e9c78717bf2..f6de8b985c6 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -78,6 +78,7 @@ - Remove the switcher-offset peephole from Lambda-to-Lam conversion. Convert `Llet` is identity. - Convert `Lstaticcatch` / `Lstaticraise` are identity. Drop exit aliasing (`exit_map`); `Lam_pass_exits` already inlines a catch whose handler is a tiny `Lstaticraise`. - Drop the unused `exports` argument from Lambda-to-Lam conversion. +- Represent `%identity` / `%ignore` / unary `+` as `Peliminated` on both Lambda and Lam. `Lambda.mk_prim` expands them so they never appear as `Lprim` nodes; Lam matches `assert false`. - Make locally abstract value constraints (`let f: type a. t = value`) structural in the parsetree, remove the obsolete `Pexp_newtype` and `Texp_newtype` wrapper metadata, and keep the old encoding confined to the frozen external-PPX bridge. The CMT magic number is bumped to `Caml1999T024`. https://github.com/rescript-lang/rescript/pull/8575 - Eliminate the `Pjs_fn_make`/`Pjs_fn_make_unit` arity-adjustment primitives and the `unsafe_adjust_to_arity` machinery: with structural arity, functions are constructed at their final arity, so the enforcement layer (and the active-pattern currying split it compensated for) is deleted. Generated code improves: no adapter closures for patterns on mutable fields, better constant propagation and name preservation, and recursive modules whose members are plain functions compile statically without the runtime bootstrap. https://github.com/rescript-lang/rescript/pull/8570 - Cleanups enabled by structural arity: remove the unreachable `Too_many_arguments` error and the `?in_function` threading through the type checker that existed only to decorate it; remove the dead `function$`-vs-arrow unification bridge, `Ctype.arity`, and the unused parsetree arity helpers; deduplicate the analysis arrow-flattening helpers. https://github.com/rescript-lang/rescript/pull/8569 diff --git a/compiler/core/lam_analysis.ml b/compiler/core/lam_analysis.ml index 6e8308dd92b..f967465fa7f 100644 --- a/compiler/core/lam_analysis.ml +++ b/compiler/core/lam_analysis.ml @@ -44,6 +44,7 @@ let rec no_side_effects (lam : Lam.t) : bool = match args with | [_; Lconst cst] -> not_zero_constant cst | _ -> false) + | Peliminated _ -> assert false | Pcreate_extension _ | Ptypeof | Pis_null | Pis_not_none | Psome | Psome_not_nest | Pis_undefined | Pis_null_undefined | Pnull_to_opt | Pnull_undefined_to_opt | Pjs_object_create _ | Pimport _ diff --git a/compiler/core/lam_compile_primitive.ml b/compiler/core/lam_compile_primitive.ml index 789ed9e5ed9..eb1540a5773 100644 --- a/compiler/core/lam_compile_primitive.ml +++ b/compiler/core/lam_compile_primitive.ml @@ -74,6 +74,7 @@ let wrap_then import value = wrap_then_path import [value] let translate output_prefix loc (cxt : Lam_compile_context.t) (prim : Lam_primitive.t) (args : J.expression list) : J.expression = match prim with + | Peliminated _ -> assert false | Pis_not_none -> Js_of_lam_option.is_not_none (Ext_list.singleton_exn args) | Pcreate_extension s -> E.make_exception s | Praw_js_code {code; code_info} -> E.raw_js_code code_info code diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index 27e740197ea..7d6f06ba84f 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -32,13 +32,10 @@ let prim = Lam.prim *) let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = match p with - | Pidentity -> Ext_list.singleton_exn args + | Peliminated e -> prim ~primitive:(Peliminated e) ~args loc | Pnull -> Lam.const Const_js_null | Pundefined -> Lam.const (Const_js_undefined {is_unit = false}) | Pcreate_extension s -> prim ~primitive:(Pcreate_extension s) ~args loc - | Pignore -> - (* Pignore means return unit, it is not an nop *) - Lam.seq (Ext_list.singleton_exn args) Lam.unit | Pgetglobal _ -> assert false | Pmakeblock info -> ( let mutable_flag = Lambda.mutable_flag_of_tag_info info in diff --git a/compiler/core/lam_primitive.ml b/compiler/core/lam_primitive.ml index fac944c81ff..4d5f64c7029 100644 --- a/compiler/core/lam_primitive.ml +++ b/compiler/core/lam_primitive.ml @@ -27,6 +27,7 @@ type ident = Ident.t type t = + | Peliminated of Lambda.eliminated (* Operations on heap blocks *) | Pmakeblock of Lam_tag_info.t * Asttypes.mutable_flag | Pfield of int * Lam_compat.field_dbg_info @@ -187,6 +188,7 @@ let eq_tag_info (x : Lam_tag_info.t) y = x = y let eq_primitive_approx (lhs : t) (rhs : t) = match lhs with + | Peliminated _ -> assert false | Praise (* generic comparison *) | Pobjorder | Pobjmin | Pobjmax | Pobjtag | Pobjsize diff --git a/compiler/core/lam_primitive.mli b/compiler/core/lam_primitive.mli index 32b791b63ff..5b1114a978b 100644 --- a/compiler/core/lam_primitive.mli +++ b/compiler/core/lam_primitive.mli @@ -25,6 +25,7 @@ type ident = Ident.t type t = + | Peliminated of Lambda.eliminated | Pmakeblock of Lam_tag_info.t * Asttypes.mutable_flag | Pfield of int * Lambda.field_dbg_info | Psetfield of int * Lambda.set_field_dbg_info diff --git a/compiler/core/lam_print.ml b/compiler/core/lam_print.ml index d38bf1bc5ac..22cc448c781 100644 --- a/compiler/core/lam_print.ml +++ b/compiler/core/lam_print.ml @@ -39,6 +39,7 @@ let rec struct_const ppf (cst : Lam_constant.t) = let primitive ppf (prim : Lam_primitive.t) = match prim with + | Peliminated _ -> assert false (* | Pcreate_exception s -> fprintf ppf "[exn-create]%S" s *) | Pcreate_extension s -> fprintf ppf "[ext-create]%S" s | Pinit_mod -> fprintf ppf "init_mod!" diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index f0d29ce23f3..fdd36d6fbfb 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -170,9 +170,12 @@ type import_source = name; [] means the external is the module itself *) } +(* Table keys for `%identity` / `%ignore` / unary `+`. [mk_prim] expands + these; they must not appear as [Lprim] nodes. *) +type eliminated = Identity | Ignore + type primitive = - | Pidentity - | Pignore + | Peliminated of eliminated | Pdebugger | Ptypeof | Pnull @@ -424,6 +427,20 @@ let lambda_module_alias = Lconst (Const_pointer Pt_module_alias) let lambda_unit = Lconst const_unit +let mk_prim p args loc = + match p with + | Peliminated kind -> ( + match kind with + | Identity -> ( + match args with + | [arg] -> arg + | _ -> assert false) + | Ignore -> ( + match args with + | [arg] -> Lsequence (arg, lambda_unit) + | _ -> assert false)) + | _ -> Lprim (p, args, loc) + let default_function_attribute = { inline = Default_inline; @@ -477,7 +494,7 @@ let make_key e = let ex = tr_rec env ex in let y = make_key x in Llet (str, k, y, ex, tr_rec (Ident.add x (Lvar y) env) e) - | Lprim (p, es, _) -> Lprim (p, tr_recs env es, Location.none) + | Lprim (p, es, _) -> mk_prim p (tr_recs env es) Location.none | Lswitch (e, sw, loc) -> Lswitch (tr_rec env e, tr_sw env sw, loc) | Lstringswitch (e, sw, d, _) -> Lstringswitch @@ -685,7 +702,7 @@ let subst_lambda s lam = Lfunction {params; body = subst body; attr; loc} | Llet (str, k, id, arg, body) -> Llet (str, k, id, subst arg, subst body) | Lletrec (decl, body) -> Lletrec (List.map subst_decl decl, subst body) - | Lprim (p, args, loc) -> Lprim (p, List.map subst args, loc) + | Lprim (p, args, loc) -> mk_prim p (List.map subst args) loc | Lswitch (arg, sw, loc) -> Lswitch ( subst arg, diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index 95939fe8265..013b8df3eff 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -136,9 +136,10 @@ type import_source = name; [] means the external is the module itself *) } +type eliminated = Identity | Ignore + type primitive = - | Pidentity - | Pignore + | Peliminated of eliminated | Pdebugger | Ptypeof | Pnull @@ -401,6 +402,10 @@ val make_key : lambda -> lambda option val const_unit : structured_constant val lambda_assert_false : lambda val lambda_unit : lambda + +val mk_prim : primitive -> lambda list -> Location.t -> lambda +(** Expands [Peliminated] so it never appears as [Lprim]. *) + val lambda_module_alias : lambda val name_lambda : let_kind -> lambda -> (Ident.t -> lambda) -> lambda diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index cf5bb4e79b7..1dbab92abd6 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -1615,8 +1615,7 @@ let make_test_sequence loc fail tst lt_tst arg const_lambda_list = let hs, const_lambda_list, fail = share_actions_tree const_lambda_list fail in let rec make_test_sequence const_lambda_list = - if List.length const_lambda_list >= 4 && lt_tst <> Pignore then - split_sequence const_lambda_list + if List.length const_lambda_list >= 4 then split_sequence const_lambda_list else match fail with | None -> do_tests_nofail loc tst arg const_lambda_list @@ -1644,7 +1643,7 @@ module S_arg = struct type act = Lambda.lambda - let make_prim p args = Lprim (p, args, Location.none) + let make_prim p args = mk_prim p args Location.none let make_offset arg n = match n with | 0 -> arg diff --git a/compiler/ml/printlambda.ml b/compiler/ml/printlambda.ml index 86da9848dc0..36e2e4a8802 100644 --- a/compiler/ml/printlambda.ml +++ b/compiler/ml/printlambda.ml @@ -97,8 +97,10 @@ let print_taginfo ppf = function fprintf ppf "[%s]" (String.concat ";" (List.map fst (Array.to_list ss))) let primitive ppf = function - | Pidentity -> fprintf ppf "id" - | Pignore -> fprintf ppf "ignore" + | Peliminated kind -> ( + match kind with + | Identity -> fprintf ppf "id" + | Ignore -> fprintf ppf "ignore") | Pdebugger -> fprintf ppf "debugger" | Ptypeof -> fprintf ppf "typeof" | Pnull -> fprintf ppf "null" diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 59c5c323e86..11fcdd73ad9 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -240,9 +240,9 @@ let comparisons_table = let primitives_table = create_hashtable [| - ("%identity", Pidentity); - ("%component_identity", Pidentity); - ("%ignore", Pignore); + ("%identity", Peliminated Identity); + ("%component_identity", Peliminated Identity); + ("%ignore", Peliminated Ignore); (* BEGIN Triples for ref data type *) ("%makeref", Pmakeblock Lambda.ref_tag_info); ("%refset", Psetfield (0, Lambda.ref_field_set_info)); @@ -820,7 +820,7 @@ let transl_primitive loc p env ty ~val_type = :: make_params (n - 1) total in let prim_arity = p.prim_arity in - if p.prim_from_constructor || prim_arity = 0 then Lprim (prim, [], loc) + if p.prim_from_constructor || prim_arity = 0 then mk_prim prim [] loc else let params = if prim_arity = 1 then [Ident.create "prim"] @@ -831,7 +831,7 @@ let transl_primitive loc p env ty ~val_type = params; attr = default_function_attribute; loc; - body = Lprim (prim, List.map (fun id -> Lvar id) params, loc); + body = mk_prim prim (List.map (fun id -> Lvar id) params) loc; }) (* [None] means the primitive is an external whose application must be @@ -1162,7 +1162,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = ~val_type:prim_vd.val_type argl ~transformed_jsx)) | Some prim -> warn_polymorphic_comparison e.exp_loc prim argl; - wrap (Lprim (prim, argl, e.exp_loc))))) + wrap (mk_prim prim argl e.exp_loc)))) | Texp_apply {funct; args = oargs; partial; transformed_jsx} -> let inlined, funct = Translattribute.get_and_remove_inlined_attribute funct diff --git a/compiler/ml/unified_ops.ml b/compiler/ml/unified_ops.ml index 50d0ed94b4b..4debc8b1e40 100644 --- a/compiler/ml/unified_ops.ml +++ b/compiler/ml/unified_ops.ml @@ -63,10 +63,10 @@ let entries = form = Unary; specialization = { - int = Pidentity; + int = Peliminated Identity; bool = None; - float = Some Pidentity; - bigint = Some Pidentity; + float = Some (Peliminated Identity); + bigint = Some (Peliminated Identity); string = None; }; }; From b02837e671522667e02b0b9f331a724e9f6aeb17 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 31 Aug 2026 13:15:23 +0200 Subject: [PATCH 11/13] Simplify constant representations across compiler IRs Replace Lambda Const_base and Const_immstring with direct int, char, string, float, and bigint constructors, and use int32-backed Const_int consistently in Lambda and Lam. Represent Lam assert-false separately from ordinary integer zero. Remove the unreachable typedtree Const_int32 and Const_int64 variants and bump the CMT magic number for the serialized type change. Treat ReScript strings as immutable when normalizing match actions, with snapshots covering early string-action sharing and the separate untagged-discriminator merge boundary. Signed-off-by: Cristiano Calcagno --- CHANGELOG.md | 4 ++ analysis/src/hint.ml | 2 - analysis/src/hover.ml | 2 - compiler/core/lam.ml | 32 +++++++-------- compiler/core/lam_analysis.ml | 10 +++-- compiler/core/lam_compile.ml | 5 +-- compiler/core/lam_compile_const.ml | 4 +- compiler/core/lam_constant_convert.ml | 21 ++++------ compiler/core/lam_convert.ml | 2 +- compiler/core/lam_eta_conversion.ml | 7 ++-- compiler/core/lam_pass_lets_dce.ml | 9 ++-- compiler/core/lam_pass_remove_alias.ml | 2 +- compiler/core/lam_print.ml | 3 +- compiler/ext/config.ml | 2 +- compiler/frontend/lam_constant.ml | 19 ++++----- compiler/frontend/lam_constant.mli | 7 +--- compiler/ml/asttypes.ml | 2 - compiler/ml/lambda.ml | 20 ++++++--- compiler/ml/lambda.mli | 9 +++- compiler/ml/matching.ml | 28 +++++-------- compiler/ml/parmatch.ml | 28 ++----------- compiler/ml/printlambda.ml | 15 +++---- compiler/ml/printtyped.ml | 2 - compiler/ml/transl_recmodule.ml | 8 +--- compiler/ml/translcore.ml | 45 ++++++++------------ compiler/ml/typecore.ml | 2 - compiler/ml/untypeast.ml | 2 - tests/tests/src/UntaggedVariants.mjs | 57 ++++++++++++++++++++++---- tests/tests/src/UntaggedVariants.res | 40 +++++++++++++++++- 29 files changed, 206 insertions(+), 183 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index f6de8b985c6..f3d3e840056 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -79,6 +79,10 @@ - Convert `Lstaticcatch` / `Lstaticraise` are identity. Drop exit aliasing (`exit_map`); `Lam_pass_exits` already inlines a catch whose handler is a tiny `Lstaticraise`. - Drop the unused `exports` argument from Lambda-to-Lam conversion. - Represent `%identity` / `%ignore` / unary `+` as `Peliminated` on both Lambda and Lam. `Lambda.mk_prim` expands them so they never appear as `Lprim` nodes; Lam matches `assert false`. +- Use a single `int32` integer constant on Lambda and Lam (`Const_int of int32`). Assert-false is a dedicated constant (`Const_assertfalse`), not a tagged `0`. +- Drop dead typedtree constants `Const_int32` and `Const_int64`. Integer literals are `Const_int` (native `int`) or `Const_bigint`. +- Put char, string, float, and bigint constants on Lambda and drop `Const_base`. +- Drop Lambda `Const_immstring`; location primitives use `Const_string`, and matching can share equivalent string-valued actions. - Make locally abstract value constraints (`let f: type a. t = value`) structural in the parsetree, remove the obsolete `Pexp_newtype` and `Texp_newtype` wrapper metadata, and keep the old encoding confined to the frozen external-PPX bridge. The CMT magic number is bumped to `Caml1999T024`. https://github.com/rescript-lang/rescript/pull/8575 - Eliminate the `Pjs_fn_make`/`Pjs_fn_make_unit` arity-adjustment primitives and the `unsafe_adjust_to_arity` machinery: with structural arity, functions are constructed at their final arity, so the enforcement layer (and the active-pattern currying split it compensated for) is deleted. Generated code improves: no adapter closures for patterns on mutable fields, better constant propagation and name preservation, and recursive modules whose members are plain functions compile statically without the runtime bootstrap. https://github.com/rescript-lang/rescript/pull/8570 - Cleanups enabled by structural arity: remove the unreachable `Too_many_arguments` error and the `?in_function` threading through the type checker that existed only to decorate it; remove the dead `function$`-vs-arrow unification bridge, `Ctype.arity`, and the unused parsetree arity helpers; deduplicate the analysis arrow-flattening helpers. https://github.com/rescript-lang/rescript/pull/8569 diff --git a/analysis/src/hint.ml b/analysis/src/hint.ml index 0f0d2b0e481..a8c2968c677 100644 --- a/analysis/src/hint.ml +++ b/analysis/src/hint.ml @@ -13,8 +13,6 @@ let loc_item_to_type_hint ~state ~full:{file; package} loc_item = | Const_char _ -> "char" | Const_string _ -> "string" | Const_float _ -> "float" - | Const_int32 _ -> "int32" - | Const_int64 _ -> "int64" | Const_bigint _ -> "bigint") | Typed (_, t, loc_kind) -> let from_type typ = diff --git a/analysis/src/hover.ml b/analysis/src/hover.ml index c4f5a629e8d..3907d98f037 100644 --- a/analysis/src/hover.ml +++ b/analysis/src/hover.ml @@ -299,8 +299,6 @@ let new_hover ~state ~full:{file; package} ~supports_markdown_links loc_item = | Const_char _ -> "char" | Const_string _ -> "string" | Const_float _ -> "float" - | Const_int32 _ -> "int32" - | Const_int64 _ -> "int64" | Const_bigint _ -> "bigint")) | Typed (_, t, loc_kind) -> ( let from_type ?docstring ?constructor typ = diff --git a/compiler/core/lam.ml b/compiler/core/lam.ml index de5dd2c89d9..67c346d85c6 100644 --- a/compiler/core/lam.ml +++ b/compiler/core/lam.ml @@ -285,7 +285,7 @@ let switch lam (lam_switch : lambda_switch) : t = | Switch_int _ | Switch_constructor _ -> None) in action_or_switch action - | Lconst (Const_int {i; comment}) -> + | Lconst (Const_int i) -> (* Because of inlining and dead code, we might be looking at a value of unexpected type e.g. an integer, so the const case might not be found *) let i = Int32.to_int i in @@ -295,7 +295,7 @@ let switch lam (lam_switch : lambda_switch) : t = | Lambda.Switch_int ordinal when ordinal = i -> Some action | Switch_constructor (Constant {tag_type = Some (Variant_runtime.Int value)}) - when comment = None && value = i -> + when value = i -> Some action | Switch_int _ | Switch_constructor _ -> None) in @@ -360,10 +360,7 @@ let staticcatch a b c : t = Lstaticcatch (a, b, c) let staticraise a b : t = Lstaticraise (a, b) module Lift = struct - let int i : t = Lconst (Const_int {i; comment = None}) - - (* let int32 i : t = - Lconst ((Const_int32 i)) *) + let int i : t = Lconst (Const_int i) let bool b = if b then true_ else false_ @@ -377,7 +374,7 @@ let prim ~primitive:(prim : Lam_primitive.t) ~args loc : t = match args with | [Lconst a] -> ( match (prim, a) with - | Pnegint, Const_int {i} -> Lift.int (Int32.neg i) + | Pnegint, Const_int i -> Lift.int (Int32.neg i) (* | Pfloatofint, ( (Const_int a)) *) (* -> Lift.float (float_of_int a) *) | Pintoffloat, Const_float a -> @@ -394,7 +391,7 @@ let prim ~primitive:(prim : Lam_primitive.t) ~args loc : t = | [Lconst a; Lconst b] -> ( match (prim, a, b) with | Pintcomp cmp, Const_int a, Const_int b -> - Lift.bool (Lam_compat.cmp_int32 cmp a.i b.i) + Lift.bool (Lam_compat.cmp_int32 cmp a b) | Pfloatcomp cmp, Const_float a, Const_float b -> (* FIXME: could raise? *) Lift.bool @@ -417,8 +414,8 @@ let prim ~primitive:(prim : Lam_primitive.t) ~args loc : t = | _ -> assert false) | ( ( Paddint | Psubint | Pmulint | Pdivint | Pmodint | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint ), - Const_int {i = aa}, - Const_int {i = bb} ) -> ( + Const_int aa, + Const_int bb ) -> ( (* WE SHOULD keep it as [int], to preserve types *) let int_ = Lift.int in match prim with @@ -446,7 +443,7 @@ let prim ~primitive:(prim : Lam_primitive.t) ~args loc : t = Lift.string (a ^ b) | ( (Pstringrefs | Pstringrefu), Const_string {s = a; delim = None}, - Const_int {i = b} ) -> ( + Const_int b ) -> ( try Lift.char (Char.code (String.get a (Int32.to_int b))) with _ -> default ()) | _ -> default ()) @@ -518,7 +515,8 @@ let rec complete_range (sw_consts : (Lambda.switch_key * _) list) ~(start : int) let rec eval_const_as_bool (v : Lam_constant.t) : bool option = match v with - | Const_int {i = x} -> Some (x <> 0l) + | Const_int x -> Some (x <> 0l) + | Const_assertfalse -> Some false | Const_char x -> Some (x <> 0) | Const_js_false | Const_js_null | Const_module_alias | Const_js_undefined _ -> @@ -545,9 +543,9 @@ let if_ (a : t) (b : t) (c : t) : t = | None -> Lifthenelse (a, b, c)) | _ -> ( match (b, c) with - | _, Lconst (Const_int {comment = Pt_assertfalse}) -> + | _, Lconst Const_assertfalse -> seq a b (* TODO: we could customize more cases *) - | Lconst (Const_int {comment = Pt_assertfalse}), _ -> seq a c + | Lconst Const_assertfalse, _ -> seq a c | Lconst Const_js_true, Lconst Const_js_false -> if has_boolean_type a != None then a else Lifthenelse (a, b, c) | Lconst Const_js_false, Lconst Const_js_true -> ( @@ -561,10 +559,8 @@ let if_ (a : t) (b : t) (c : t) : t = | _ -> ( match a with | Lprim - { - primitive = Pisout off; - args = [Lconst (Const_int {i = range}); Lvar xx]; - } -> ( + {primitive = Pisout off; args = [Lconst (Const_int range); Lvar xx]} + -> ( let range = Int32.to_int range in match c with | Lswitch diff --git a/compiler/core/lam_analysis.ml b/compiler/core/lam_analysis.ml index f967465fa7f..5fd3f44efec 100644 --- a/compiler/core/lam_analysis.ml +++ b/compiler/core/lam_analysis.ml @@ -25,7 +25,8 @@ (**used in effect analysis, it is sound but not-complete *) let not_zero_constant (x : Lam_constant.t) = match x with - | Const_int {i} -> i <> 0l + | Const_int i -> i <> 0l + | Const_assertfalse -> false | Const_bigint (_, i) -> i <> "0" | _ -> false @@ -190,9 +191,10 @@ let rec size (lam : Lam.t) = and size_constant x = match x with - | Const_int _ | Const_constructor _ | Const_char _ | Const_float _ - | Const_bigint _ | Const_pointer _ | Const_js_null | Const_js_undefined _ - | Const_module_alias | Const_js_true | Const_js_false -> + | Const_int _ | Const_assertfalse | Const_constructor _ | Const_char _ + | Const_float _ | Const_bigint _ | Const_pointer _ | Const_js_null + | Const_js_undefined _ | Const_module_alias | Const_js_true | Const_js_false + -> 1 | Const_string _ -> 1 | Const_some s -> size_constant s diff --git a/compiler/core/lam_compile.ml b/compiler/core/lam_compile.ml index 907b056a8b9..ffbdc779051 100644 --- a/compiler/core/lam_compile.ml +++ b/compiler/core/lam_compile.ml @@ -1989,10 +1989,7 @@ let compile output_prefix = match (direction, finish) with | ( Upto, ( Lprim - { - primitive = Psubint; - args = [new_finish; Lconst (Const_int {i = 1l})]; - } + {primitive = Psubint; args = [new_finish; Lconst (Const_int 1l)]} | Lprim {primitive = Poffsetint -1; args = [new_finish]} ) ) -> compile_for id start new_finish Up body lambda_cxt | _ -> diff --git a/compiler/core/lam_compile_const.ml b/compiler/core/lam_compile_const.ml index e30c0423b2b..46e0919c706 100644 --- a/compiler/core/lam_compile_const.ml +++ b/compiler/core/lam_compile_const.ml @@ -55,8 +55,8 @@ and translate (x : Lam_constant.t) : J.expression = except for the list constructor [] which is the number 0 *) if name = "[]" then E.int 0l ~comment:"[]" else E.str name | Const_constructor {tag_type = Some t} -> E.tag_type t - | Const_int {i; comment} -> - E.int i ?comment:(Lam_constant.string_of_pointer_info comment) + | Const_int i -> E.int i + | Const_assertfalse -> E.int 0l ~comment:"assert_false" | Const_char i -> Js_of_lam_string.const_char i | Const_bigint (sign, i) -> E.bigint sign i | Const_float f -> E.float f (* TODO: preserve float *) diff --git a/compiler/core/lam_constant_convert.ml b/compiler/core/lam_constant_convert.ml index 7d5b58ad47f..38469765de6 100644 --- a/compiler/core/lam_constant_convert.ml +++ b/compiler/core/lam_constant_convert.ml @@ -24,15 +24,13 @@ let rec convert_constant (const : Lambda.structured_constant) : Lam_constant.t = match const with - | Const_base (Const_int i) -> Const_int {i = Int32.of_int i; comment = None} - | Const_base (Const_char i) -> Const_char i - | Const_base (Const_string (s, opt)) -> + | Const_int i -> Const_int i + | Const_char i -> Const_char i + | Const_string (s, opt) -> let delim = Ast_utf8_string_interp.parse_processed_delim opt in Const_string {s; delim} - | Const_base (Const_float i) -> Const_float i - | Const_base (Const_int32 i) -> Const_int {i; comment = None} - | Const_base (Const_int64 _) -> assert false - | Const_base (Const_bigint (sign, i)) -> Const_bigint (sign, i) + | Const_float i -> Const_float i + | Const_bigint (sign, i) -> Const_bigint (sign, i) | Const_pointer (Pt_constructor {name = "()"}) -> Const_js_undefined {is_unit = true} | Const_false -> Const_js_false @@ -41,17 +39,16 @@ let rec convert_constant (const : Lambda.structured_constant) : Lam_constant.t = match p with | Pt_module_alias -> Const_module_alias | Pt_shape_none -> Lam_constant.lam_none - | Pt_assertfalse -> Const_int {i = 0l; comment = Pt_assertfalse} + | Pt_assertfalse -> Const_assertfalse | Pt_constructor {tag_type = Some (Variant_runtime.Int v)} -> (* A constructor represented as a number is a genuine number at runtime; folding relies on it being an ordinary int constant *) - Const_int {i = Int32.of_int v; comment = None} + Const_int (Int32.of_int v) | Pt_constructor runtime -> Const_constructor runtime | Pt_variant {name} -> if Ext_string.is_valid_hash_number name then - Const_int {i = Ext_string.hash_number_as_i32_exn name; comment = None} + Const_int (Ext_string.hash_number_as_i32_exn name) else Const_pointer name) - | Const_immstring s -> Const_string {s; delim = None} | Const_block (t, xs) -> ( match t with | Blk_some_not_nested -> @@ -66,7 +63,7 @@ let rec convert_constant (const : Lambda.structured_constant) : Lam_constant.t = | [_; value] -> let tag_val : Lam_constant.t = if Ext_string.is_valid_hash_number s then - Const_int {i = Ext_string.hash_number_as_i32_exn s; comment = None} + Const_int (Ext_string.hash_number_as_i32_exn s) else Const_string {s; delim = None} in Const_block (t, [tag_val; convert_constant value]) diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index 7d6f06ba84f..fe3c1dd052c 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -50,7 +50,7 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = | [_; value] -> let tag_val : Lam_constant.t = if Ext_string.is_valid_hash_number s then - Const_int {i = Ext_string.hash_number_as_i32_exn s; comment = None} + Const_int (Ext_string.hash_number_as_i32_exn s) else Const_string {s; delim = None} in prim diff --git a/compiler/core/lam_eta_conversion.ml b/compiler/core/lam_eta_conversion.ml index 4e2e61c18a4..bd0f7decd14 100644 --- a/compiler/core/lam_eta_conversion.ml +++ b/compiler/core/lam_eta_conversion.ml @@ -42,9 +42,10 @@ let transform_under_supply n ap_info fn args = match lam with | Lvar _ | Lconst - ( Const_int _ | Const_constructor _ | Const_char _ | Const_string _ - | Const_float _ | Const_bigint _ | Const_pointer _ | Const_js_true - | Const_js_false | Const_js_undefined _ ) + ( Const_int _ | Const_assertfalse | Const_constructor _ + | Const_char _ | Const_string _ | Const_float _ | Const_bigint _ + | Const_pointer _ | Const_js_true | Const_js_false + | Const_js_undefined _ ) | Lprim {primitive = Pfield (_, Fld_module _); _} | Lfunction _ -> (lam :: acc, bind) diff --git a/compiler/core/lam_pass_lets_dce.ml b/compiler/core/lam_pass_lets_dce.ml index f0e5f2f5ba0..80956f4b9e6 100644 --- a/compiler/core/lam_pass_lets_dce.ml +++ b/compiler/core/lam_pass_lets_dce.ml @@ -51,13 +51,12 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = | {times = 1; captured = true}, (Lconst _ | Lvar _) | ( _, ( Lconst - ( Const_int _ | Const_constructor _ | Const_char _ | Const_float _ - | Const_bigint _ | Const_pointer _ | Const_js_true - | Const_js_false | Const_js_undefined _ ) + ( Const_int _ | Const_assertfalse | Const_constructor _ + | Const_char _ | Const_float _ | Const_bigint _ | Const_pointer _ + | Const_js_true | Const_js_false | Const_js_undefined _ ) (* could be poly-variant [`A] -> [65a]*) | Lprim {primitive = Pfield _; args = [Lglobal_module _]} ) ) - (* Const_int64 is no longer primitive - Note for some constant which is not + (* Note for some constant which is not inlined, we can still record it and do constant folding independently *) diff --git a/compiler/core/lam_pass_remove_alias.ml b/compiler/core/lam_pass_remove_alias.ml index eb0994beb88..cdd31e5940e 100644 --- a/compiler/core/lam_pass_remove_alias.ml +++ b/compiler/core/lam_pass_remove_alias.ml @@ -31,7 +31,7 @@ let id_is_for_sure_true_in_boolean (tbl : Lam_stats.ident_tbl) id = (Lconst (Const_js_false | Const_js_null | Const_js_undefined _))) -> Eval_false | Some (Constant Const_js_true) -> Eval_true - | Some (Constant (Const_int {i})) -> if i = 0l then Eval_false else Eval_true + | Some (Constant (Const_int i)) -> if i = 0l then Eval_false else Eval_true | Some (Constant (Const_js_false | Const_js_null | Const_js_undefined _)) -> Eval_false | Some diff --git a/compiler/core/lam_print.ml b/compiler/core/lam_print.ml index 22cc448c781..c9d837bfd98 100644 --- a/compiler/core/lam_print.ml +++ b/compiler/core/lam_print.ml @@ -20,7 +20,8 @@ let rec struct_const ppf (cst : Lam_constant.t) = | Const_js_null -> fprintf ppf "#null" | Const_module_alias -> fprintf ppf "#alias" | Const_js_undefined _ -> fprintf ppf "#undefined" - | Const_int {i} -> fprintf ppf "%ld" i + | Const_int i -> fprintf ppf "%ld" i + | Const_assertfalse -> fprintf ppf "assertfalse" | Const_char i -> fprintf ppf "%s" (Ext_util.string_of_int_as_char i) | Const_string {s} -> fprintf ppf "%S" s | Const_float f -> fprintf ppf "%s" f diff --git a/compiler/ext/config.ml b/compiler/ext/config.ml index a7eeaffaaf0..4c3b18781ca 100644 --- a/compiler/ext/config.ml +++ b/compiler/ext/config.ml @@ -13,6 +13,6 @@ and ast0_impl_magic_number = "Caml1999M022" and ast0_intf_magic_number = "Caml1999N022" -and cmt_magic_number = "Caml1999T030" +and cmt_magic_number = "Caml1999T031" let load_path = ref ([] : string list) diff --git a/compiler/frontend/lam_constant.ml b/compiler/frontend/lam_constant.ml index 31e3a542cb6..851a565f7ae 100644 --- a/compiler/frontend/lam_constant.ml +++ b/compiler/frontend/lam_constant.ml @@ -22,20 +22,13 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type pointer_info = None | Pt_assertfalse | Some of string - -let string_of_pointer_info (x : pointer_info) : string option = - match x with - | Some name -> Some name - | Pt_assertfalse -> Some "assert_false" - | None -> None - type t = | Const_js_null | Const_js_undefined of {is_unit: bool} | Const_js_true | Const_js_false - | Const_int of {i: int32; comment: pointer_info} + | Const_int of int32 + | Const_assertfalse | Const_constructor of Variant_runtime.tag (* Constant constructor of a nominal variant, emitted from its canonical runtime descriptor rather than an ordinal *) @@ -60,8 +53,9 @@ let rec eq_approx (x : t) (y : t) = | Const_js_false -> y = Const_js_false | Const_int ix -> ( match y with - | Const_int iy -> ix.i = iy.i + | Const_int iy -> ix = iy | _ -> false) + | Const_assertfalse -> y = Const_assertfalse | Const_constructor ix -> ( match y with | Const_constructor iy -> ix = iy @@ -103,6 +97,7 @@ let rec is_allocating (c : t) : bool = | Const_some t -> is_allocating t | Const_block _ -> true | Const_js_null | Const_js_undefined _ | Const_js_true | Const_js_false - | Const_int _ | Const_constructor _ | Const_char _ | Const_string _ - | Const_float _ | Const_bigint _ | Const_pointer _ | Const_module_alias -> + | Const_int _ | Const_assertfalse | Const_constructor _ | Const_char _ + | Const_string _ | Const_float _ | Const_bigint _ | Const_pointer _ + | Const_module_alias -> false diff --git a/compiler/frontend/lam_constant.mli b/compiler/frontend/lam_constant.mli index ab375f87698..93096c98971 100644 --- a/compiler/frontend/lam_constant.mli +++ b/compiler/frontend/lam_constant.mli @@ -22,16 +22,13 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type pointer_info = None | Pt_assertfalse | Some of string - -val string_of_pointer_info : pointer_info -> string option - type t = | Const_js_null | Const_js_undefined of {is_unit: bool} | Const_js_true | Const_js_false - | Const_int of {i: int32; comment: pointer_info} + | Const_int of int32 + | Const_assertfalse | Const_constructor of Variant_runtime.tag (* Constant constructor of a nominal variant, emitted from its canonical runtime descriptor rather than an ordinal *) diff --git a/compiler/ml/asttypes.ml b/compiler/ml/asttypes.ml index a52db0da016..85a2c3ad5a7 100644 --- a/compiler/ml/asttypes.ml +++ b/compiler/ml/asttypes.ml @@ -20,8 +20,6 @@ type constant = | Const_char of int | Const_string of string * string option | Const_float of string - | Const_int32 of int32 - | Const_int64 of int64 | Const_bigint of bool * string type rec_flag = Nonrecursive | Recursive diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index fdd36d6fbfb..3a3e2f5d24f 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -334,10 +334,13 @@ type pointer_info = | Pt_assertfalse type structured_constant = - | Const_base of Asttypes.constant + | Const_int of int32 + | Const_char of int + | Const_string of string * string option + | Const_float of string + | Const_bigint of bool * string | Const_pointer of pointer_info | Const_block of tag_info * structured_constant list - | Const_immstring of string | Const_false | Const_true type inline_attribute = @@ -418,6 +421,16 @@ and lambda_switch = lambda switch not necessary "()", it can be used as a place holder for module alias etc. *) +let const_int (i : int) = Const_int (Int32.of_int i) + +let const_of_typed (c : Asttypes.constant) : structured_constant = + match c with + | Asttypes.Const_int i -> Const_int (Int32.of_int i) + | Asttypes.Const_char i -> Const_char i + | Asttypes.Const_string (s, d) -> Const_string (s, d) + | Asttypes.Const_float f -> Const_float f + | Asttypes.Const_bigint (sign, i) -> Const_bigint (sign, i) + let const_unit = Const_pointer (Pt_constructor {Variant_runtime.name = "()"; tag_type = None}) @@ -471,9 +484,6 @@ let make_key e = (* Too big ! *) match e with | Lvar id -> ( try Ident.find_same id env with Not_found -> e) - | Lconst (Const_base (Const_string _)) -> - (* Mutable constants are not shared *) - raise_notrace Not_simple | Lconst _ -> e | Lapply ap -> Lapply diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index 013b8df3eff..75f4fe003ae 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -290,10 +290,13 @@ and comparison = Ceq | Cneq | Clt | Cgt | Cle | Cge and value_kind = Pgenval type structured_constant = - | Const_base of constant + | Const_int of int32 + | Const_char of int + | Const_string of string * string option + | Const_float of string + | Const_bigint of bool * string | Const_pointer of pointer_info | Const_block of tag_info * structured_constant list - | Const_immstring of string | Const_false | Const_true @@ -399,6 +402,8 @@ and lambda_switch = lambda switch (* Sharing key *) val make_key : lambda -> lambda option +val const_int : int -> structured_constant +val const_of_typed : constant -> structured_constant val const_unit : structured_constant val lambda_assert_false : lambda val lambda_unit : lambda diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index 1dbab92abd6..6098e20201c 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -1516,9 +1516,7 @@ let make_array_matching p def ctx = function let rec make_args pos = if pos >= len then argl else - ( Lprim - (Parrayrefu, [arg; Lconst (Const_base (Const_int pos))], p.pat_loc), - StrictOpt ) + (Lprim (Parrayrefu, [arg; Lconst (const_int pos)], p.pat_loc), StrictOpt) :: make_args (pos + 1) in let def = make_default (matcher_array len) def and ctx = filter_ctx p ctx in @@ -1597,7 +1595,7 @@ let rec do_tests_fail loc fail tst arg = function | [] -> fail | (c, act) :: rem -> Lifthenelse - ( Lprim (tst, [arg; Lconst (Const_base c)], loc), + ( Lprim (tst, [arg; Lconst (const_of_typed c)], loc), do_tests_fail loc fail tst arg rem, act ) @@ -1606,7 +1604,7 @@ let rec do_tests_nofail loc tst arg = function | [(_, act)] -> act | (c, act) :: rem -> Lifthenelse - ( Lprim (tst, [arg; Lconst (Const_base c)], loc), + ( Lprim (tst, [arg; Lconst (const_of_typed c)], loc), do_tests_nofail loc tst arg rem, act ) @@ -1625,7 +1623,7 @@ let make_test_sequence loc fail tst lt_tst arg const_lambda_list = cut (List.length const_lambda_list / 2) const_lambda_list in Lifthenelse - ( Lprim (lt_tst, [arg; Lconst (Const_base (fst (List.hd list2)))], loc), + ( Lprim (lt_tst, [arg; Lconst (const_of_typed (fst (List.hd list2)))], loc), make_test_sequence list1, make_test_sequence list2 ) in @@ -1658,7 +1656,7 @@ module S_arg = struct (newvar, Lvar newvar) in bind Alias newvar arg (body newarg) - let make_const i = Lconst (Const_base (Const_int i)) + let make_const i = Lconst (const_int i) let make_isout h arg = Lprim (Pisout, [h; arg], Location.none) let make_isin h arg = Lprim (Pnot, [make_isout h arg], Location.none) let make_if cond ifso ifnot = Lifthenelse (cond, ifso, ifnot) @@ -1954,12 +1952,12 @@ let combine_constant loc arg cst partial ctx def (const_lambda_list, total, _pats) = let fail, local_jumps = mk_failaction_neg partial ctx def in let lambda1 = - match cst with + match (cst : Asttypes.constant) with | Const_int _ -> let int_lambda_list = List.map (function - | Const_int n, l -> (n, l) + | Asttypes.Const_int n, l -> (n, l) | _ -> assert false) const_lambda_list in @@ -1968,7 +1966,7 @@ let combine_constant loc arg cst partial ctx def let int_lambda_list = List.map (function - | Const_char c, l -> (c, l) + | Asttypes.Const_char c, l -> (c, l) | _ -> assert false) const_lambda_list in @@ -1983,7 +1981,7 @@ let combine_constant loc arg cst partial ctx def List.map (fun (c, act) -> match c with - | Const_string (s, _) -> (s, act) + | Asttypes.Const_string (s, _) -> (s, act) | _ -> assert false) const_lambda_list in @@ -1992,8 +1990,6 @@ let combine_constant loc arg cst partial ctx def | Const_float _ -> make_test_sequence loc fail (Pfloatcomp Cneq) (Pfloatcomp Clt) arg const_lambda_list - | Const_int32 _ -> assert false - | Const_int64 _ -> assert false | Const_bigint _ -> make_test_sequence loc fail (Pbigintcomp Cneq) (Pbigintcomp Clt) arg const_lambda_list @@ -2076,7 +2072,7 @@ let lower_constructor_matching_plan ~loc ~arg = function match test with | Is_present_option -> Lprim (Pis_not_none, [arg], loc) | Is_nonempty_list -> - Lprim (Pjscomp Cneq, [arg; Lconst (Const_base (Const_int 0))], loc) + Lprim (Pjscomp Cneq, [arg; Lconst (const_int 0)], loc) in Lifthenelse (condition, present, absent) | Test_boolean_value {if_false; if_true} -> @@ -2707,9 +2703,7 @@ let partial_function loc () = (Const_block ( Blk_tuple, [ - Const_base (Const_string (fname, None)); - Const_base (Const_int line); - Const_base (Const_int char); + Const_string (fname, None); const_int line; const_int char; ] )); ], loc ); diff --git a/compiler/ml/parmatch.ml b/compiler/ml/parmatch.ml index 5abfce99543..a688e05e72f 100644 --- a/compiler/ml/parmatch.ml +++ b/compiler/ml/parmatch.ml @@ -157,14 +157,12 @@ let all_coherent column = match (c1, c2) with | Const_char _, Const_char _ | Const_int _, Const_int _ - | Const_int32 _, Const_int32 _ - | Const_int64 _, Const_int64 _ | Const_bigint _, Const_bigint _ | Const_float _, Const_float _ | Const_string _, Const_string _ -> true - | ( ( Const_char _ | Const_int _ | Const_int32 _ | Const_int64 _ - | Const_bigint _ | Const_float _ | Const_string _ ), + | ( ( Const_char _ | Const_int _ | Const_bigint _ | Const_float _ + | Const_string _ ), _ ) -> false) | Tpat_tuple l1, Tpat_tuple l2 -> List.length l1 = List.length l2 @@ -374,8 +372,6 @@ let pretty_const c = | Const_char i -> Printf.sprintf "%s" (Pprintast.string_of_int_as_char i) | Const_string (s, _) -> Printf.sprintf "%S" s | Const_float f -> Printf.sprintf "%s" f - | Const_int32 i -> Printf.sprintf "%ldl" i - | Const_int64 i -> Printf.sprintf "%LdL" i | Const_bigint (sign, i) -> Printf.sprintf "%s" (Bigint_utils.to_string sign i) @@ -1072,22 +1068,6 @@ let build_other ext env : Typedtree.pattern = (function | i -> Tpat_constant (Const_char i)) 0 succ p env - | (({pat_desc = Tpat_constant (Const_int32 _)} as p), _) :: _ -> - build_other_constant - (function - | Tpat_constant (Const_int32 i) -> i - | _ -> assert false) - (function - | i -> Tpat_constant (Const_int32 i)) - 0l Int32.succ p env - | (({pat_desc = Tpat_constant (Const_int64 _)} as p), _) :: _ -> - build_other_constant - (function - | Tpat_constant (Const_int64 i) -> i - | _ -> assert false) - (function - | i -> Tpat_constant (Const_int64 i)) - 0L Int64.succ p env | (({pat_desc = Tpat_constant (Const_bigint _)} as p), _) :: _ -> build_other_constant (function @@ -2270,9 +2250,7 @@ let inactive ~partial pat = | Tpat_constant c -> ( match c with | Const_string _ -> true (*Config.safe_string*) - | Const_int _ | Const_char _ | Const_float _ | Const_int32 _ - | Const_int64 _ | Const_bigint _ -> - true) + | Const_int _ | Const_char _ | Const_float _ | Const_bigint _ -> true) | Tpat_tuple ps | Tpat_construct (_, _, ps) -> List.for_all (fun p -> loop p) ps | Tpat_alias (p, _, _) | Tpat_variant (_, Some p, _) -> loop p diff --git a/compiler/ml/printlambda.ml b/compiler/ml/printlambda.ml index 36e2e4a8802..2698e38d253 100644 --- a/compiler/ml/printlambda.ml +++ b/compiler/ml/printlambda.ml @@ -18,16 +18,11 @@ open Asttypes open Lambda let rec struct_const ppf = function - | Const_base (Const_int n) -> fprintf ppf "%i" n - | Const_base (Const_char i) -> - fprintf ppf "%s" (Pprintast.string_of_int_as_char i) - | Const_base (Const_string (s, _)) -> fprintf ppf "%S" s - | Const_immstring s -> fprintf ppf "#%S" s - | Const_base (Const_float f) -> fprintf ppf "%s" f - | Const_base (Const_int32 n) -> fprintf ppf "%lil" n - | Const_base (Const_int64 n) -> fprintf ppf "%LiL" n - | Const_base (Const_bigint (sign, n)) -> - fprintf ppf "%sn" (Bigint_utils.to_string sign n) + | Const_int n -> fprintf ppf "%ld" n + | Const_char i -> fprintf ppf "%s" (Pprintast.string_of_int_as_char i) + | Const_string (s, _) -> fprintf ppf "%S" s + | Const_float f -> fprintf ppf "%s" f + | Const_bigint (sign, n) -> fprintf ppf "%sn" (Bigint_utils.to_string sign n) | Const_pointer (Pt_constructor {name}) -> fprintf ppf "`%s" name | Const_pointer (Pt_variant {name}) -> fprintf ppf "`%s" name | Const_pointer Pt_module_alias -> fprintf ppf "module_alias" diff --git a/compiler/ml/printtyped.ml b/compiler/ml/printtyped.ml index 3e36d2d3c0b..7c00393f84a 100644 --- a/compiler/ml/printtyped.ml +++ b/compiler/ml/printtyped.ml @@ -55,8 +55,6 @@ let fmt_constant f x = | Const_string (s, Some delim) -> fprintf f "Const_string (%S,Some %S)" s delim | Const_float s -> fprintf f "Const_float %s" s - | Const_int32 i -> fprintf f "Const_int32 %ld" i - | Const_int64 i -> fprintf f "Const_int64 %Ld" i | Const_bigint (sign, i) -> fprintf f "Const_bigint %s" (Bigint_utils.to_string sign i) diff --git a/compiler/ml/transl_recmodule.ml b/compiler/ml/transl_recmodule.ml index 6a0aa657da8..30c88dd58a5 100644 --- a/compiler/ml/transl_recmodule.ml +++ b/compiler/ml/transl_recmodule.ml @@ -15,15 +15,11 @@ let undefined_location loc = Lconst (Const_block ( Lambda.Blk_tuple, - [ - Const_base (Const_string (fname, None)); - Const_base (Const_int line); - Const_base (Const_int char); - ] )) + [Const_string (fname, None); const_int line; const_int char] )) let init_shape modl = let add_name x id = - Const_block (Blk_tuple, [x; Const_base (Const_string (Ident.name id, None))]) + Const_block (Blk_tuple, [x; Const_string (Ident.name id, None)]) in let module_tag_info : Lambda.tag_info = Blk_constructor diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 11fcdd73ad9..b37a7b0372f 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -464,13 +464,12 @@ let lambda_of_inline_const (c : External_ffi_types.inline_const) : | Some DBackQuotes -> Some "bq" | None -> Some "js" in - Const_base (Const_string (s, raw_delim)) + Const_string (s, raw_delim) | Const_bool true -> Const_true | Const_bool false -> Const_false - | Const_int i -> Const_base (Const_int32 i) - | Const_bigint {negative; digits} -> - Const_base (Const_bigint (negative, digits)) - | Const_float f -> Const_base (Const_float f) + | Const_int i -> Const_int i + | Const_bigint {negative; digits} -> Const_bigint (negative, digits) + | Const_float f -> Const_float f (* The argument of the dynamic-import primitive is a module reference, never an expression: resolve it here, at translation, from the typedtree. @@ -743,23 +742,23 @@ let lam_of_loc kind loc = (Const_block ( Blk_tuple, [ - Const_immstring file; - Const_base (Const_int lnum); - Const_base (Const_int cnum); - Const_base (Const_int enum); + Const_string (file, None); + const_int lnum; + const_int cnum; + const_int enum; ] )) - | Loc_FILE -> Lconst (Const_immstring file) + | Loc_FILE -> Lconst (Const_string (file, None)) | Loc_MODULE -> let filename = Filename.basename file in let name = Env.get_unit_name () in let module_name = if name = "" then "//" ^ filename ^ "//" else name in - Lconst (Const_immstring module_name) + Lconst (Const_string (module_name, None)) | Loc_LOC -> let loc = Printf.sprintf "File %S, line %d, characters %d-%d" file lnum cnum enum in - Lconst (Const_immstring loc) - | Loc_LINE -> Lconst (Const_base (Const_int lnum)) + Lconst (Const_string (loc, None)) + | Loc_LINE -> Lconst (const_int lnum) (* Eta-expand a primitive *) @@ -918,9 +917,7 @@ let assert_failed exp = (Const_block ( Blk_tuple, [ - Const_base (Const_string (fname, None)); - Const_base (Const_int line); - Const_base (Const_int char); + Const_string (fname, None); const_int line; const_int char; ] )); ], exp.exp_loc ); @@ -1049,7 +1046,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = transl_primitive e.exp_loc p e.exp_env e.exp_type ~val_type:vd.val_type | Texp_ident (path, _, {val_kind = Val_reg}) -> transl_value_path ~loc:e.exp_loc e.exp_env path - | Texp_constant cst -> Lconst (Const_base cst) + | Texp_constant cst -> Lconst (const_of_typed cst) | Texp_let (rec_flag, pat_expr_list, body) -> transl_let ~js_hoist:None rec_flag pat_expr_list (transl_exp body) | Texp_function {params = fparams; body; async} -> @@ -1147,11 +1144,11 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = (* an external: expand its FFI spec here; %raw parses and classifies its snippet *) match (p.prim_name, argl) with - | "#raw_expr", [Lconst (Const_base (Const_string (code, _)))] -> + | "#raw_expr", [Lconst (Const_string (code, _))] -> let kind = Classify_function.classify code in wrap (Lprim (Praw_js_code {code; code_info = Exp kind}, [], e.exp_loc)) - | "#raw_stmt", [Lconst (Const_base (Const_string (code, _)))] -> + | "#raw_stmt", [Lconst (Const_string (code, _))] -> let kind = Classify_function.classify_stmt code in wrap (Lprim (Praw_js_code {code; code_info = Stmt kind}, [], e.exp_loc)) @@ -1254,15 +1251,9 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = | Some arg -> ( let lam = transl_exp arg in let tag_info = Blk_poly_var l in - try - Lconst - (Const_block - (tag_info, [Const_base (Const_int tag); extract_constant lam])) + try Lconst (Const_block (tag_info, [const_int tag; extract_constant lam])) with Not_constant -> - Lprim - ( Pmakeblock tag_info, - [Lconst (Const_base (Const_int tag)); lam], - e.exp_loc ))) + Lprim (Pmakeblock tag_info, [Lconst (const_int tag); lam], e.exp_loc))) | Texp_record {fields; representation; extended_expression} -> transl_record e.exp_loc e.exp_env fields representation extended_expression | Texp_field (arg, _, lbl) -> ( diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 2e804ab5d38..1dd091d0f65 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -265,9 +265,7 @@ let type_constant = function | Const_char _ -> instance_def Predef.type_char | Const_string _ -> instance_def Predef.type_string | Const_float _ -> instance_def Predef.type_float - | Const_int64 _ -> assert false | Const_bigint _ -> instance_def Predef.type_bigint - | Const_int32 _ -> assert false let constant : Parsetree.constant -> (Asttypes.constant, error) result = function diff --git a/compiler/ml/untypeast.ml b/compiler/ml/untypeast.ml index 1ae24b62dcc..34dab0e2b10 100644 --- a/compiler/ml/untypeast.ml +++ b/compiler/ml/untypeast.ml @@ -20,8 +20,6 @@ let constant = function | Const_char c -> Pconst_char c | Const_string (s, d) -> Pconst_string (s, d) | Const_int i -> Pconst_integer (string_of_int i, None) - | Const_int32 i -> Pconst_integer (Int32.to_string i, Some 'l') - | Const_int64 i -> Pconst_integer (Int64.to_string i, Some 'L') | Const_bigint (sign, i) -> Pconst_integer (Bigint_utils.to_string sign i, Some 'n') | Const_float f -> Pconst_float (f, None) diff --git a/tests/tests/src/UntaggedVariants.mjs b/tests/tests/src/UntaggedVariants.mjs index 29c3349792e..1b8f5bc5514 100644 --- a/tests/tests/src/UntaggedVariants.mjs +++ b/tests/tests/src/UntaggedVariants.mjs @@ -620,7 +620,15 @@ let OnlyOne = { onlyOne: "OnlyOne" }; -function should_not_merge(x) { +function shareEquivalentStringActions(x) { + if (typeof x === "boolean") { + return "boolean"; + } else { + return "do not merge"; + } +} + +function can_merge(x) { if (Array.isArray(x)) { return "do not merge"; } @@ -629,29 +637,60 @@ function should_not_merge(x) { } switch (typeof x) { case "boolean" : - return "boolean"; case "object" : - return "do not merge"; + return "merge"; } } -function can_merge(x) { +function shareAlphaEquivalentStringActions(value) { + if (value > 2 || value < 0) { + return [ + sideEffect(), + "fallback" + ]; + } + if (value === 1) { + return [ + sideEffect(), + "different" + ]; + } + let result = sideEffect(); + return [ + result, + "shared" + ]; +} + +function preserveDiscriminatorGroups(x) { if (Array.isArray(x)) { - return "do not merge"; + while (keepGoing()) { + sideEffect(); + }; + return; } if (x instanceof Date) { - return "do not merge"; + while (keepGoing()) { + sideEffect(); + }; + return; } switch (typeof x) { case "boolean" : + return; case "object" : - return "merge"; + while (keepGoing()) { + sideEffect(); + }; + return; } } let MergeCases = { - should_not_merge: should_not_merge, - can_merge: can_merge + shareEquivalentStringActions: shareEquivalentStringActions, + can_merge: can_merge, + shareAlphaEquivalentStringActions: shareAlphaEquivalentStringActions, + preserveDiscriminatorGroups: preserveDiscriminatorGroups }; function printLength(json) { diff --git a/tests/tests/src/UntaggedVariants.res b/tests/tests/src/UntaggedVariants.res index 1d0eafe49fd..051bd70cd09 100644 --- a/tests/tests/src/UntaggedVariants.res +++ b/tests/tests/src/UntaggedVariants.res @@ -470,6 +470,9 @@ module OnlyOne = { module MergeCases = { type obj = {name: string} + @val external sideEffect: unit => int = "sideEffect" + @val external keepGoing: unit => bool = "keepGoing" + @unboxed type t = | Boolean(bool) @@ -477,7 +480,8 @@ module MergeCases = { | Array(array) | Date(Date.t) - let should_not_merge = x => + // Equivalent string actions can be shared before untagged matching is lowered. + let shareEquivalentStringActions = x => switch x { | Object(_) => "do not merge" | Array(_) => "do not merge" @@ -492,6 +496,40 @@ module MergeCases = { | Date(_) => "do not merge" | Boolean(_) => "merge" } + + // The actions are alpha-equivalent, not merely identical constants. + let shareAlphaEquivalentStringActions = value => + switch value { + | 0 => { + let result = sideEffect() + (result, "shared") + } + | 1 => (sideEffect(), "different") + | 2 => { + let result = sideEffect() + (result, "shared") + } + | _ => (sideEffect(), "fallback") + } + + // Keep coverage for late case merging across Array.isArray, instanceof, + // and typeof dispatch groups. Lambda.make_key deliberately rejects loops. + let preserveDiscriminatorGroups = x => + switch x { + | Object(_) => + while keepGoing() { + ignore(sideEffect()) + } + | Array(_) => + while keepGoing() { + ignore(sideEffect()) + } + | Date(_) => + while keepGoing() { + ignore(sideEffect()) + } + | Boolean(_) => () + } } module ObjectAndNull = { From e5d34a41f53561e40ab793dc366dd5f2023b9a4b Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 31 Aug 2026 13:45:48 +0200 Subject: [PATCH 12/13] Store parsed string delimiters in Lambda constants Give Lambda Const_string the same structured payload used by Lam, and move processed-delimiter decoding into External_arg_spec so Lambda producers can store the final delimiter directly. Remove the inline-constant delimiter round-trip, cover every processed delimiter encoding, and consolidate the branch changelog into review-facing entries. Signed-off-by: Cristiano Calcagno --- CHANGELOG.md | 15 ++------- compiler/core/lam_constant_convert.ml | 4 +-- compiler/frontend/ast_utf8_string_interp.ml | 9 +----- compiler/ml/external_arg_spec.ml | 7 ++++ compiler/ml/external_arg_spec.mli | 2 ++ compiler/ml/lambda.ml | 7 ++-- compiler/ml/lambda.mli | 3 +- compiler/ml/matching.ml | 5 ++- compiler/ml/printlambda.ml | 2 +- compiler/ml/transl_recmodule.ml | 4 +-- compiler/ml/translcore.ml | 32 ++++++------------- .../ounit_lambda_constant_tests.ml | 18 +++++++++++ tests/ounit_tests/ounit_tests_main.ml | 1 + 13 files changed, 53 insertions(+), 56 deletions(-) create mode 100644 tests/ounit_tests/ounit_lambda_constant_tests.ml diff --git a/CHANGELOG.md b/CHANGELOG.md index f3d3e840056..b5db7a2e04d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -70,19 +70,8 @@ - Represent optional parameters with defaults structurally, removing downstream name-based detection and producing more consistent JavaScript parameter names. https://github.com/rescript-lang/rescript/pull/8580 - Sync the platform npm package's compiler binaries (`packages/@rescript//bin`) via dune promotion on every `dune build`, instead of Makefile/CI copy steps that only ran when make did: a plain `dune build` can no longer leave `cli/*.js` and the test harnesses running a stale compiler. https://github.com/rescript-lang/rescript/pull/8560 - Remove unused compiler IR definitions, modules, helpers, error variants, and Typedtree fields. https://github.com/rescript-lang/rescript/pull/8551 https://github.com/rescript-lang/rescript/pull/8555 -- Remove the unused OCaml pipe primitives `%revapply`/`%apply` and the `Ploc` Lambda constructor. `__LOC__` and friends still compile to location constants in `translcore`. -- Lower exception packing in `translcore` instead of convert, drop unused `raise_kind` / reraise tracking, and emit `RE_EXN_ID` string equality from matching instead of `Pextension_slot_eq`. -- Remove the `Pwrap_exn` / `%wrap_exn` primitive. Exception packing, `Promise.catch`, and `JsExn.anyToExnInternal` call `Primitive_exceptions.internalToException` as a normal module function. -- Split `let rec` groups into actual recursive clusters when Lambda is produced (`Lambda_scc.bind_rec`). Convert `Lletrec` is identity; `Lam_scc` is removed. JS compile only sorts functions before values for dummy/`updateDummy` init. -- Remove the dense int-switch-to-add peephole (`happens_to_be_diff`) from Lambda-to-Lam conversion. Convert `Lswitch` is identity. -- Remove the switcher-offset peephole from Lambda-to-Lam conversion. Convert `Llet` is identity. -- Convert `Lstaticcatch` / `Lstaticraise` are identity. Drop exit aliasing (`exit_map`); `Lam_pass_exits` already inlines a catch whose handler is a tiny `Lstaticraise`. -- Drop the unused `exports` argument from Lambda-to-Lam conversion. -- Represent `%identity` / `%ignore` / unary `+` as `Peliminated` on both Lambda and Lam. `Lambda.mk_prim` expands them so they never appear as `Lprim` nodes; Lam matches `assert false`. -- Use a single `int32` integer constant on Lambda and Lam (`Const_int of int32`). Assert-false is a dedicated constant (`Const_assertfalse`), not a tagged `0`. -- Drop dead typedtree constants `Const_int32` and `Const_int64`. Integer literals are `Const_int` (native `int`) or `Const_bigint`. -- Put char, string, float, and bigint constants on Lambda and drop `Const_base`. -- Drop Lambda `Const_immstring`; location primitives use `Const_string`, and matching can share equivalent string-valued actions. +- Make Lambda-to-Lam conversion structural for lets, switches, static exits, recursive binding groups, exception packing, and eliminated identity operations. Semantic rewrites now happen during Lambda production or in named Lam passes; obsolete conversion state and `Lam_scc` are removed. +- Remove obsolete Lambda and Lam primitives and align their scalar constant representations. Lambda and Lam now use `int32` integers and matching char, string, float, and bigint cases; Lambda strings carry their parsed output delimiter, assert-false is distinct from integer zero, and dead typedtree integer variants are removed. - Make locally abstract value constraints (`let f: type a. t = value`) structural in the parsetree, remove the obsolete `Pexp_newtype` and `Texp_newtype` wrapper metadata, and keep the old encoding confined to the frozen external-PPX bridge. The CMT magic number is bumped to `Caml1999T024`. https://github.com/rescript-lang/rescript/pull/8575 - Eliminate the `Pjs_fn_make`/`Pjs_fn_make_unit` arity-adjustment primitives and the `unsafe_adjust_to_arity` machinery: with structural arity, functions are constructed at their final arity, so the enforcement layer (and the active-pattern currying split it compensated for) is deleted. Generated code improves: no adapter closures for patterns on mutable fields, better constant propagation and name preservation, and recursive modules whose members are plain functions compile statically without the runtime bootstrap. https://github.com/rescript-lang/rescript/pull/8570 - Cleanups enabled by structural arity: remove the unreachable `Too_many_arguments` error and the `?in_function` threading through the type checker that existed only to decorate it; remove the dead `function$`-vs-arrow unification bridge, `Ctype.arity`, and the unused parsetree arity helpers; deduplicate the analysis arrow-flattening helpers. https://github.com/rescript-lang/rescript/pull/8569 diff --git a/compiler/core/lam_constant_convert.ml b/compiler/core/lam_constant_convert.ml index 38469765de6..80fe10a0d87 100644 --- a/compiler/core/lam_constant_convert.ml +++ b/compiler/core/lam_constant_convert.ml @@ -26,9 +26,7 @@ let rec convert_constant (const : Lambda.structured_constant) : Lam_constant.t = match const with | Const_int i -> Const_int i | Const_char i -> Const_char i - | Const_string (s, opt) -> - let delim = Ast_utf8_string_interp.parse_processed_delim opt in - Const_string {s; delim} + | Const_string {s; delim} -> Const_string {s; delim} | Const_float i -> Const_float i | Const_bigint (sign, i) -> Const_bigint (sign, i) | Const_pointer (Pt_constructor {name = "()"}) -> diff --git a/compiler/frontend/ast_utf8_string_interp.ml b/compiler/frontend/ast_utf8_string_interp.ml index 7c9a92d9da9..54671716407 100644 --- a/compiler/frontend/ast_utf8_string_interp.ml +++ b/compiler/frontend/ast_utf8_string_interp.ml @@ -271,13 +271,6 @@ let transform_test s = List.rev cxt.segments module Delim = struct - let parse_processed = function - | None -> Some External_arg_spec.DNone - | Some "json" -> Some DNoQuotes - | Some "*j" -> Some DStarJ - | Some "bq" -> Some DBackQuotes - | _ -> None - type interpolation = | BackQuotes (* string interpolation *) | Js (* simple double quoted string *) @@ -333,4 +326,4 @@ let transform_pat (p : Parsetree.pattern) s delim : Parsetree.pattern = } | Unrecognized -> p -let parse_processed_delim = Delim.parse_processed +let parse_processed_delim = External_arg_spec.parse_processed_delim diff --git a/compiler/ml/external_arg_spec.ml b/compiler/ml/external_arg_spec.ml index 04c43a51578..d7238532397 100644 --- a/compiler/ml/external_arg_spec.ml +++ b/compiler/ml/external_arg_spec.ml @@ -26,6 +26,13 @@ type delim = DNone | DStarJ | DNoQuotes | DBackQuotes +let parse_processed_delim = function + | None -> Some DNone + | Some "json" -> Some DNoQuotes + | Some "*j" -> Some DStarJ + | Some "bq" -> Some DBackQuotes + | _ -> None + type cst = Arg_int_lit of int | Arg_string_lit of string * delim type label_noname = Arg_label | Arg_empty | Arg_optional diff --git a/compiler/ml/external_arg_spec.mli b/compiler/ml/external_arg_spec.mli index 6c79a3380ab..ac99e6dea2a 100644 --- a/compiler/ml/external_arg_spec.mli +++ b/compiler/ml/external_arg_spec.mli @@ -24,6 +24,8 @@ type delim = DNone | DStarJ | DNoQuotes | DBackQuotes +val parse_processed_delim : string option -> delim option + type cst = private Arg_int_lit of int | Arg_string_lit of string * delim type attr = diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index 3a3e2f5d24f..b9f2243f2d1 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -336,7 +336,7 @@ type pointer_info = type structured_constant = | Const_int of int32 | Const_char of int - | Const_string of string * string option + | Const_string of {s: string; delim: External_arg_spec.delim option} | Const_float of string | Const_bigint of bool * string | Const_pointer of pointer_info @@ -423,11 +423,14 @@ and lambda_switch = lambda switch *) let const_int (i : int) = Const_int (Int32.of_int i) +let const_string s delim = + Const_string {s; delim = External_arg_spec.parse_processed_delim delim} + let const_of_typed (c : Asttypes.constant) : structured_constant = match c with | Asttypes.Const_int i -> Const_int (Int32.of_int i) | Asttypes.Const_char i -> Const_char i - | Asttypes.Const_string (s, d) -> Const_string (s, d) + | Asttypes.Const_string (s, d) -> const_string s d | Asttypes.Const_float f -> Const_float f | Asttypes.Const_bigint (sign, i) -> Const_bigint (sign, i) diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index 75f4fe003ae..5f5bdb29a90 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -292,7 +292,7 @@ and value_kind = Pgenval type structured_constant = | Const_int of int32 | Const_char of int - | Const_string of string * string option + | Const_string of {s: string; delim: External_arg_spec.delim option} | Const_float of string | Const_bigint of bool * string | Const_pointer of pointer_info @@ -403,6 +403,7 @@ and lambda_switch = lambda switch val make_key : lambda -> lambda option val const_int : int -> structured_constant +val const_string : string -> string option -> structured_constant val const_of_typed : constant -> structured_constant val const_unit : structured_constant val lambda_assert_false : lambda diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index 6098e20201c..83734fcc90f 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -2702,9 +2702,8 @@ let partial_function loc () = Lconst (Const_block ( Blk_tuple, - [ - Const_string (fname, None); const_int line; const_int char; - ] )); + [const_string fname None; const_int line; const_int char] + )); ], loc ); ], diff --git a/compiler/ml/printlambda.ml b/compiler/ml/printlambda.ml index 2698e38d253..e4740acbe40 100644 --- a/compiler/ml/printlambda.ml +++ b/compiler/ml/printlambda.ml @@ -20,7 +20,7 @@ open Lambda let rec struct_const ppf = function | Const_int n -> fprintf ppf "%ld" n | Const_char i -> fprintf ppf "%s" (Pprintast.string_of_int_as_char i) - | Const_string (s, _) -> fprintf ppf "%S" s + | Const_string {s} -> fprintf ppf "%S" s | Const_float f -> fprintf ppf "%s" f | Const_bigint (sign, n) -> fprintf ppf "%sn" (Bigint_utils.to_string sign n) | Const_pointer (Pt_constructor {name}) -> fprintf ppf "`%s" name diff --git a/compiler/ml/transl_recmodule.ml b/compiler/ml/transl_recmodule.ml index 30c88dd58a5..ead654d2709 100644 --- a/compiler/ml/transl_recmodule.ml +++ b/compiler/ml/transl_recmodule.ml @@ -15,11 +15,11 @@ let undefined_location loc = Lconst (Const_block ( Lambda.Blk_tuple, - [Const_string (fname, None); const_int line; const_int char] )) + [const_string fname None; const_int line; const_int char] )) let init_shape modl = let add_name x id = - Const_block (Blk_tuple, [x; Const_string (Ident.name id, None)]) + Const_block (Blk_tuple, [x; const_string (Ident.name id) None]) in let module_tag_info : Lambda.tag_info = Blk_constructor diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index b37a7b0372f..da17510c5dc 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -451,20 +451,7 @@ let warn_polymorphic_comparison loc prim args = let lambda_of_inline_const (c : External_ffi_types.inline_const) : Lambda.structured_constant = match c with - | Const_str {s; delim} -> - (* [Lam_constant_convert] re-parses the delimiter with - [Ast_utf8_string_interp.parse_processed_delim]; pick its exact - preimage. A parsed [None] (unrecognized delimiter) round-trips - through "js", which the processed-delimiter parser does not accept. *) - let raw_delim = - match delim with - | Some DNone -> None - | Some DNoQuotes -> Some "json" - | Some DStarJ -> Some "*j" - | Some DBackQuotes -> Some "bq" - | None -> Some "js" - in - Const_string (s, raw_delim) + | Const_str {s; delim} -> Const_string {s; delim} | Const_bool true -> Const_true | Const_bool false -> Const_false | Const_int i -> Const_int i @@ -742,22 +729,22 @@ let lam_of_loc kind loc = (Const_block ( Blk_tuple, [ - Const_string (file, None); + const_string file None; const_int lnum; const_int cnum; const_int enum; ] )) - | Loc_FILE -> Lconst (Const_string (file, None)) + | Loc_FILE -> Lconst (const_string file None) | Loc_MODULE -> let filename = Filename.basename file in let name = Env.get_unit_name () in let module_name = if name = "" then "//" ^ filename ^ "//" else name in - Lconst (Const_string (module_name, None)) + Lconst (const_string module_name None) | Loc_LOC -> let loc = Printf.sprintf "File %S, line %d, characters %d-%d" file lnum cnum enum in - Lconst (Const_string (loc, None)) + Lconst (const_string loc None) | Loc_LINE -> Lconst (const_int lnum) (* Eta-expand a primitive *) @@ -916,9 +903,8 @@ let assert_failed exp = Lconst (Const_block ( Blk_tuple, - [ - Const_string (fname, None); const_int line; const_int char; - ] )); + [const_string fname None; const_int line; const_int char] + )); ], exp.exp_loc ); ], @@ -1144,11 +1130,11 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = (* an external: expand its FFI spec here; %raw parses and classifies its snippet *) match (p.prim_name, argl) with - | "#raw_expr", [Lconst (Const_string (code, _))] -> + | "#raw_expr", [Lconst (Const_string {s = code})] -> let kind = Classify_function.classify code in wrap (Lprim (Praw_js_code {code; code_info = Exp kind}, [], e.exp_loc)) - | "#raw_stmt", [Lconst (Const_string (code, _))] -> + | "#raw_stmt", [Lconst (Const_string {s = code})] -> let kind = Classify_function.classify_stmt code in wrap (Lprim (Praw_js_code {code; code_info = Stmt kind}, [], e.exp_loc)) diff --git a/tests/ounit_tests/ounit_lambda_constant_tests.ml b/tests/ounit_tests/ounit_lambda_constant_tests.ml new file mode 100644 index 00000000000..ef285a8a559 --- /dev/null +++ b/tests/ounit_tests/ounit_lambda_constant_tests.ml @@ -0,0 +1,18 @@ +open OUnit + +let ( =~ ) = OUnit.assert_equal + +let assert_string_constant raw_delim expected_delim = + Lambda.const_string "value" raw_delim + =~ Lambda.Const_string {s = "value"; delim = expected_delim} + +let suites = + __FILE__ + >::: [ + ( "processed string delimiters" >:: fun _ -> + assert_string_constant None (Some DNone); + assert_string_constant (Some "json") (Some DNoQuotes); + assert_string_constant (Some "*j") (Some DStarJ); + assert_string_constant (Some "bq") (Some DBackQuotes); + assert_string_constant (Some "js") None ); + ] diff --git a/tests/ounit_tests/ounit_tests_main.ml b/tests/ounit_tests/ounit_tests_main.ml index 4573f83582d..ebe2df98590 100644 --- a/tests/ounit_tests/ounit_tests_main.ml +++ b/tests/ounit_tests/ounit_tests_main.ml @@ -19,6 +19,7 @@ let suites = Ounit_unicode_tests.suites; Ounit_util_tests.suites; Ounit_rec_check_tests.suites; + Ounit_lambda_constant_tests.suites; Ounit_ast_mapper0_tests.suites; Ounit_object_mutability_tests.suites; Ounit_pattern_printer_tests.suites; From 262cd0b263f835863cb439a5e7d89a39884df56e Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 31 Aug 2026 13:49:27 +0200 Subject: [PATCH 13/13] Link Lambda-to-Lam cleanup changelog to PR 8604 Signed-off-by: Cristiano Calcagno --- CHANGELOG.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index b5db7a2e04d..d819e75070a 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -70,8 +70,8 @@ - Represent optional parameters with defaults structurally, removing downstream name-based detection and producing more consistent JavaScript parameter names. https://github.com/rescript-lang/rescript/pull/8580 - Sync the platform npm package's compiler binaries (`packages/@rescript//bin`) via dune promotion on every `dune build`, instead of Makefile/CI copy steps that only ran when make did: a plain `dune build` can no longer leave `cli/*.js` and the test harnesses running a stale compiler. https://github.com/rescript-lang/rescript/pull/8560 - Remove unused compiler IR definitions, modules, helpers, error variants, and Typedtree fields. https://github.com/rescript-lang/rescript/pull/8551 https://github.com/rescript-lang/rescript/pull/8555 -- Make Lambda-to-Lam conversion structural for lets, switches, static exits, recursive binding groups, exception packing, and eliminated identity operations. Semantic rewrites now happen during Lambda production or in named Lam passes; obsolete conversion state and `Lam_scc` are removed. -- Remove obsolete Lambda and Lam primitives and align their scalar constant representations. Lambda and Lam now use `int32` integers and matching char, string, float, and bigint cases; Lambda strings carry their parsed output delimiter, assert-false is distinct from integer zero, and dead typedtree integer variants are removed. +- Make Lambda-to-Lam conversion structural for lets, switches, static exits, recursive binding groups, exception packing, and eliminated identity operations. Semantic rewrites now happen during Lambda production or in named Lam passes; obsolete conversion state and `Lam_scc` are removed. https://github.com/rescript-lang/rescript/pull/8604 +- Remove obsolete Lambda and Lam primitives and align their scalar constant representations. Lambda and Lam now use `int32` integers and matching char, string, float, and bigint cases; Lambda strings carry their parsed output delimiter, assert-false is distinct from integer zero, and dead typedtree integer variants are removed. https://github.com/rescript-lang/rescript/pull/8604 - Make locally abstract value constraints (`let f: type a. t = value`) structural in the parsetree, remove the obsolete `Pexp_newtype` and `Texp_newtype` wrapper metadata, and keep the old encoding confined to the frozen external-PPX bridge. The CMT magic number is bumped to `Caml1999T024`. https://github.com/rescript-lang/rescript/pull/8575 - Eliminate the `Pjs_fn_make`/`Pjs_fn_make_unit` arity-adjustment primitives and the `unsafe_adjust_to_arity` machinery: with structural arity, functions are constructed at their final arity, so the enforcement layer (and the active-pattern currying split it compensated for) is deleted. Generated code improves: no adapter closures for patterns on mutable fields, better constant propagation and name preservation, and recursive modules whose members are plain functions compile statically without the runtime bootstrap. https://github.com/rescript-lang/rescript/pull/8570 - Cleanups enabled by structural arity: remove the unreachable `Too_many_arguments` error and the `?in_function` threading through the type checker that existed only to decorate it; remove the dead `function$`-vs-arrow unification bridge, `Ctype.arity`, and the unused parsetree arity helpers; deduplicate the analysis arrow-flattening helpers. https://github.com/rescript-lang/rescript/pull/8569