From 3245b09f1a853958b4d54382c312f6163a06cc58 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 31 Aug 2026 15:16:27 +0200 Subject: [PATCH 01/46] Classify erasing builtins in the primitive table `%identity`, `%component_identity`, `%ignore`, and unary `+` erase at translation: they have no IR form. They were encoded as `Peliminated`, a constructor present in both `Lambda.primitive` and `Lam_primitive.t` that neither IR can hold - `Lambda.mk_prim` expanded it before it could reach an `Lprim`, and every Lam consumer answered it with `assert false`. Give the primitive table an element type that says what a `%name` means: type builtin = Primitive of primitive | Eliminated of eliminated `builtin` is a lookup type in `translcore`, not an IR type, so it needs no Lam counterpart. Both primitive types lose `Peliminated`, along with its four `assert false` sites, the unreachable `printlambda` case, and the `lam_convert` pass-through for a case that could not occur. `Unified_ops` had the same problem in its own table, where unary `+` was `Peliminated Identity` in a field of operations. Its cells now carry a lowering, `Lower of Lambda.primitive | Pass_through`, so `Ignore` is not representable there and the module depends on `Lambda.primitive` only. The `option` alone answers the type checker's question of whether an operand type is supported. `make_key`, `subst_lambda`, and matching's `make_prim` rebuilt an `Lprim` through `mk_prim`, so a substitution nominally carried the power to change term shape; they construct `Lprim` directly now. Generated JavaScript is unchanged for the runtime, Belt, and tests/tests. Signed-Off-By: Cristiano Calcagno Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/core/lam_analysis.ml | 1 - compiler/core/lam_compile_primitive.ml | 1 - compiler/core/lam_convert.ml | 1 - compiler/core/lam_primitive.ml | 2 - compiler/core/lam_primitive.mli | 1 - compiler/core/lam_print.ml | 1 - compiler/ml/lambda.ml | 39 +++---- compiler/ml/lambda.mli | 12 ++- compiler/ml/matching.ml | 2 +- compiler/ml/printlambda.ml | 4 - compiler/ml/translcore.ml | 110 +++++++++++-------- compiler/ml/unified_ops.ml | 141 ++++++++++++++----------- compiler/ml/unified_ops.mli | 14 ++- 13 files changed, 181 insertions(+), 148 deletions(-) diff --git a/compiler/core/lam_analysis.ml b/compiler/core/lam_analysis.ml index 5fd3f44efec..35f358c1e08 100644 --- a/compiler/core/lam_analysis.ml +++ b/compiler/core/lam_analysis.ml @@ -45,7 +45,6 @@ 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 eb1540a5773..789ed9e5ed9 100644 --- a/compiler/core/lam_compile_primitive.ml +++ b/compiler/core/lam_compile_primitive.ml @@ -74,7 +74,6 @@ 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 fe3c1dd052c..18c3aee2246 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -32,7 +32,6 @@ let prim = Lam.prim *) let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = match p with - | 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 diff --git a/compiler/core/lam_primitive.ml b/compiler/core/lam_primitive.ml index 4d5f64c7029..fac944c81ff 100644 --- a/compiler/core/lam_primitive.ml +++ b/compiler/core/lam_primitive.ml @@ -27,7 +27,6 @@ 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 @@ -188,7 +187,6 @@ 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 5b1114a978b..32b791b63ff 100644 --- a/compiler/core/lam_primitive.mli +++ b/compiler/core/lam_primitive.mli @@ -25,7 +25,6 @@ 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 c9d837bfd98..8749ed63968 100644 --- a/compiler/core/lam_print.ml +++ b/compiler/core/lam_print.ml @@ -40,7 +40,6 @@ 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 b9f2243f2d1..0130a8db172 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -170,12 +170,11 @@ 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. *) +(* `%identity` / `%ignore` / unary `+`: builtins that erase at translation + rather than primitives. See [builtin]. *) type eliminated = Identity | Ignore type primitive = - | Peliminated of eliminated | Pdebugger | Ptypeof | Pnull @@ -343,6 +342,12 @@ type structured_constant = | Const_block of tag_info * structured_constant list | Const_false | Const_true + +(* What a `%builtin` name in the primitive table means. Only [Primitive] + reaches the IR: [mk_builtin] erases the other cases at translation, so + they need no [primitive] constructor to stand in for them. *) +type builtin = Primitive of primitive | Eliminated of eliminated + type inline_attribute = | Always_inline (* [@inline] or [@inline always] *) | Never_inline (* [@inline never] *) @@ -443,19 +448,17 @@ 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 mk_builtin b args loc = + match b with + | Primitive p -> Lprim (p, args, loc) + | Eliminated Identity -> ( + match args with + | [arg] -> arg + | _ -> assert false) + | Eliminated Ignore -> ( + match args with + | [arg] -> Lsequence (arg, lambda_unit) + | _ -> assert false) let default_function_attribute = { @@ -507,7 +510,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, _) -> mk_prim p (tr_recs env es) Location.none + | Lprim (p, es, _) -> Lprim (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 @@ -715,7 +718,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) -> mk_prim p (List.map subst args) loc + | Lprim (p, args, loc) -> Lprim (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 5f5bdb29a90..ea721e0b237 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -136,10 +136,11 @@ type import_source = name; [] means the external is the module itself *) } +(* `%identity` / `%ignore` / unary `+`: builtins that erase at translation + rather than primitives. See [builtin]. *) type eliminated = Identity | Ignore type primitive = - | Peliminated of eliminated | Pdebugger | Ptypeof | Pnull @@ -300,6 +301,11 @@ type structured_constant = | Const_false | Const_true +(* What a `%builtin` name in the primitive table means. Only [Primitive] + reaches the IR: [mk_builtin] erases the other cases at translation, so + they need no [primitive] constructor to stand in for them. *) +type builtin = Primitive of primitive | Eliminated of eliminated + type inline_attribute = | Always_inline (* [@inline] or [@inline always] *) | Never_inline (* [@inline never] *) @@ -409,8 +415,8 @@ 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 mk_builtin : builtin -> lambda list -> Location.t -> lambda +(** Expands the non-[Primitive] builtins, which have no IR form. *) 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 83734fcc90f..692293e04f0 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -1641,7 +1641,7 @@ module S_arg = struct type act = Lambda.lambda - let make_prim p args = mk_prim p args Location.none + let make_prim p args = Lprim (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 e4740acbe40..47fd39289a1 100644 --- a/compiler/ml/printlambda.ml +++ b/compiler/ml/printlambda.ml @@ -92,10 +92,6 @@ let print_taginfo ppf = function fprintf ppf "[%s]" (String.concat ";" (List.map fst (Array.to_list ss))) let primitive ppf = function - | 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 da17510c5dc..0235b640409 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -54,32 +54,40 @@ let transl_extension_constructor env path ext = (* Translation of primitives *) +let builtin_of_lowering (l : Unified_ops.lowering) : Lambda.builtin = + match l with + | Lower p -> Primitive p + | Pass_through -> Eliminated Identity + (** This is ad-hoc translation for unifying specific primitive operations See [Unified_ops] module for detailed explanation. *) let translate_unified_ops (prim : Primitive.description) (env : Env.t) - (lhs_type : type_expr) : Lambda.primitive option = + (lhs_type : type_expr) : Lambda.builtin option = (* lhs_type is already unified in type-level *) let entry = Hashtbl.find_opt Unified_ops.index_by_name prim.prim_name in - match entry with - | Some {specialization} -> ( - match specialization with - | {int} - when is_base_type env lhs_type Predef.path_int - || maybe_pointer_type env lhs_type = Immediate -> - Some int - | {float = Some float} when is_base_type env lhs_type Predef.path_float -> - Some float - | {bigint = Some bigint} when is_base_type env lhs_type Predef.path_bigint - -> - Some bigint - | {string = Some string} when is_base_type env lhs_type Predef.path_string - -> - Some string - | {bool = Some bool} when is_base_type env lhs_type Predef.path_bool -> - Some bool - | {int} -> Some int) - | _ -> None + let lowering = + match entry with + | Some {specialization} -> ( + match specialization with + | {int} + when is_base_type env lhs_type Predef.path_int + || maybe_pointer_type env lhs_type = Immediate -> + Some int + | {float = Some float} when is_base_type env lhs_type Predef.path_float -> + Some float + | {bigint = Some bigint} when is_base_type env lhs_type Predef.path_bigint + -> + Some bigint + | {string = Some string} when is_base_type env lhs_type Predef.path_string + -> + Some string + | {bool = Some bool} when is_base_type env lhs_type Predef.path_bool -> + Some bool + | {int} -> Some int) + | _ -> None + in + Option.map builtin_of_lowering lowering type specialized = { objcomp: Lambda.primitive; @@ -237,12 +245,19 @@ let comparisons_table = } ); |] -let primitives_table = - create_hashtable +(* Builtins with no primitive form: [Lambda.mk_builtin] erases them at + translation. *) +let erased_builtins : (string * Lambda.builtin) array = + [| + ("%identity", Eliminated Identity); + ("%component_identity", Eliminated Identity); + ("%ignore", Eliminated Ignore); + |] + +let primitive_builtins : (string * Lambda.builtin) array = + Array.map + (fun (name, p) -> (name, Lambda.Primitive p)) [| - ("%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)); @@ -395,7 +410,10 @@ let primitives_table = ("%obj_field", Parrayrefu); |] -let find_primitive prim_name = Hashtbl.find primitives_table prim_name +let builtins_table : (string, Lambda.builtin) Hashtbl.t = + create_hashtable (Array.append erased_builtins primitive_builtins) + +let find_builtin prim_name = Hashtbl.find builtins_table prim_name let specialize_comparison ({objcomp; intcomp; floatcomp; stringcomp; bigintcomp; boolcomp} : @@ -423,25 +441,25 @@ let specialize_primitive p env ty (* ~has_constant_constructor *) = | None -> None in match unified with - | Some primitive -> primitive + | Some builtin -> builtin | None -> ( try let table = Hashtbl.find comparisons_table p.prim_name in match fn_expr with - | Some (lhs, _rhs) -> specialize_comparison table env lhs - | None -> table.objcomp - with Not_found -> find_primitive p.prim_name) + | Some (lhs, _rhs) -> Primitive (specialize_comparison table env lhs) + | None -> Primitive table.objcomp + with Not_found -> find_builtin p.prim_name) let is_null_undefined_constant = function | Lprim ((Pnull | Pundefined), [], _) -> true | _ -> false -let warn_polymorphic_comparison loc prim args = - match (prim, args) with - | Pobjcomp (Ceq | Cneq), [arg1; arg2] +let warn_polymorphic_comparison loc (builtin : Lambda.builtin) args = + match (builtin, args) with + | Primitive (Pobjcomp (Ceq | Cneq)), [arg1; arg2] when is_null_undefined_constant arg1 || is_null_undefined_constant arg2 -> () - | (Pobjcomp _ | Pobjorder | Pobjmin | Pobjmax), _ -> + | Primitive (Pobjcomp _ | Pobjorder | Pobjmin | Pobjmax), _ -> Location.prerr_warning loc Warnings.Bs_polymorphic_comparison | _ -> () @@ -797,8 +815,8 @@ let transl_primitive loc p env ty ~val_type = (List.map (fun id -> Lvar id) params) ~transformed_jsx:false; } - | Some prim -> - warn_polymorphic_comparison loc prim []; + | Some builtin -> + warn_polymorphic_comparison loc builtin []; let rec make_params n total = if n <= 0 then [] else @@ -806,7 +824,8 @@ 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 mk_prim prim [] loc + if p.prim_from_constructor || prim_arity = 0 then + mk_builtin builtin [] loc else let params = if prim_arity = 1 then [Ident.create "prim"] @@ -817,13 +836,12 @@ let transl_primitive loc p env ty ~val_type = params; attr = default_function_attribute; loc; - body = mk_prim prim (List.map (fun id -> Lvar id) params) loc; + body = mk_builtin builtin (List.map (fun id -> Lvar id) params) loc; }) (* [None] means the primitive is an external whose application must be expanded from its FFI spec *) -let transl_primitive_application loc prim env ty args : Lambda.primitive option - = +let transl_primitive_application loc prim env ty args : Lambda.builtin option = let prim_name = prim.prim_name in let unified = match args with @@ -831,14 +849,14 @@ let transl_primitive_application loc prim env ty args : Lambda.primitive option | _ -> None in match unified with - | Some primitive -> Some primitive + | Some builtin -> Some builtin | None -> ( try match args with | [arg1; _] when is_base_type env arg1.exp_type Predef.path_bool && Hashtbl.mem comparisons_table prim_name -> - Some (Hashtbl.find comparisons_table prim_name).boolcomp + Some (Primitive (Hashtbl.find comparisons_table prim_name).boolcomp) | _ -> let has_constant_constructor = match args with @@ -866,7 +884,7 @@ let transl_primitive_application loc prim env ty args : Lambda.primitive option if has_constant_constructor then match Hashtbl.find_opt comparisons_table prim_name with | Some table when table.simplify_constant_constructor -> - Some table.intcomp + Some (Primitive table.intcomp) | Some _ | None -> Some (specialize_primitive prim env ty) (* ~has_constant_constructor*) else Some (specialize_primitive prim env ty) @@ -1143,9 +1161,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 -> - warn_polymorphic_comparison e.exp_loc prim argl; - wrap (mk_prim prim argl e.exp_loc)))) + | Some builtin -> + warn_polymorphic_comparison e.exp_loc builtin argl; + wrap (mk_builtin builtin 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 4debc8b1e40..6cce6c65577 100644 --- a/compiler/ml/unified_ops.ml +++ b/compiler/ml/unified_ops.ml @@ -36,13 +36,20 @@ open Misc type form = Unary | Binary -(* Note: unified op must support int type *) +(* How an operator lowers for one operand type. *) +type lowering = + | Lower of Lambda.primitive + | Pass_through (** the operand is already the result: unary [+] *) + +(* [None] means the operand type is not supported by the operator; the payload + says how the supported ones lower. + Note: unified op must support int type *) type specialization = { - int: Lambda.primitive; - bool: Lambda.primitive option; - float: Lambda.primitive option; - bigint: Lambda.primitive option; - string: Lambda.primitive option; + int: lowering; + bool: lowering option; + float: lowering option; + bigint: lowering option; + string: lowering option; } type entry = { @@ -53,209 +60,215 @@ type entry = { specialization: specialization; } -let builtin x = Primitive_modules.pervasives ^ "." ^ x +let pervasives_path x = Primitive_modules.pervasives ^ "." ^ x let entries = [| { - path = builtin "~+"; + path = pervasives_path "~+"; name = "%plus"; form = Unary; specialization = { - int = Peliminated Identity; + int = Pass_through; bool = None; - float = Some (Peliminated Identity); - bigint = Some (Peliminated Identity); + float = Some Pass_through; + bigint = Some Pass_through; string = None; }; }; { - path = builtin "~-"; + path = pervasives_path "~-"; name = "%neg"; form = Unary; specialization = { - int = Pnegint; + int = Lower Pnegint; bool = None; - float = Some Pnegfloat; - bigint = Some Pnegbigint; + float = Some (Lower Pnegfloat); + bigint = Some (Lower Pnegbigint); string = None; }; }; { - path = builtin "+"; + path = pervasives_path "+"; name = "%add"; form = Binary; specialization = { - int = Paddint; + int = Lower Paddint; bool = None; - float = Some Paddfloat; - bigint = Some Paddbigint; - string = Some Pstringadd; + float = Some (Lower Paddfloat); + bigint = Some (Lower Paddbigint); + string = Some (Lower Pstringadd); }; }; { - path = builtin "-"; + path = pervasives_path "-"; name = "%sub"; form = Binary; specialization = { - int = Psubint; + int = Lower Psubint; bool = None; - float = Some Psubfloat; - bigint = Some Psubbigint; + float = Some (Lower Psubfloat); + bigint = Some (Lower Psubbigint); string = None; }; }; { - path = builtin "*"; + path = pervasives_path "*"; name = "%mul"; form = Binary; specialization = { - int = Pmulint; + int = Lower Pmulint; bool = None; - float = Some Pmulfloat; - bigint = Some Pmulbigint; + float = Some (Lower Pmulfloat); + bigint = Some (Lower Pmulbigint); string = None; }; }; { - path = builtin "/"; + path = pervasives_path "/"; name = "%div"; form = Binary; specialization = { - int = Pdivint; + int = Lower Pdivint; bool = None; - float = Some Pdivfloat; - bigint = Some Pdivbigint; + float = Some (Lower Pdivfloat); + bigint = Some (Lower Pdivbigint); string = None; }; }; { - path = builtin "%"; + path = pervasives_path "%"; name = "%mod"; form = Binary; specialization = { - int = Pmodint; + int = Lower Pmodint; bool = None; - float = Some Pmodfloat; - bigint = Some Pmodbigint; + float = Some (Lower Pmodfloat); + bigint = Some (Lower Pmodbigint); string = None; }; }; { - path = builtin "<<"; + path = pervasives_path "<<"; name = "%lsl"; form = Binary; specialization = { - int = Plslint; + int = Lower Plslint; bool = None; float = None; - bigint = Some Plslbigint; + bigint = Some (Lower Plslbigint); string = None; }; }; { - path = builtin ">>"; + path = pervasives_path ">>"; name = "%asr"; form = Binary; specialization = { - int = Pasrint; + int = Lower Pasrint; bool = None; float = None; - bigint = Some Pasrbigint; + bigint = Some (Lower Pasrbigint); string = None; }; }; { - path = builtin ">>>"; + path = pervasives_path ">>>"; name = "%lsr"; form = Binary; specialization = - {int = Plsrint; bool = None; float = None; bigint = None; string = None}; + { + int = Lower Plsrint; + bool = None; + float = None; + bigint = None; + string = None; + }; }; { - path = builtin "mod"; + path = pervasives_path "mod"; name = "%mod"; form = Binary; specialization = { - int = Pmodint; + int = Lower Pmodint; bool = None; - float = Some Pmodfloat; - bigint = Some Pmodbigint; + float = Some (Lower Pmodfloat); + bigint = Some (Lower Pmodbigint); string = None; }; }; { - path = builtin "**"; + path = pervasives_path "**"; name = "%pow"; form = Binary; specialization = { - int = Ppowint; + int = Lower Ppowint; bool = None; - float = Some Ppowfloat; - bigint = Some Ppowbigint; + float = Some (Lower Ppowfloat); + bigint = Some (Lower Ppowbigint); string = None; }; }; { - path = builtin "~~~"; + path = pervasives_path "~~~"; name = "%bitnot"; form = Unary; specialization = { - int = Pnotint; + int = Lower Pnotint; bool = None; float = None; - bigint = Some Pnotbigint; + bigint = Some (Lower Pnotbigint); string = None; }; }; { - path = builtin "|||"; + path = pervasives_path "|||"; name = "%bitor"; form = Binary; specialization = { - int = Porint; + int = Lower Porint; bool = None; float = None; - bigint = Some Porbigint; + bigint = Some (Lower Porbigint); string = None; }; }; { - path = builtin "^^^"; + path = pervasives_path "^^^"; name = "%bitxor"; form = Binary; specialization = { - int = Pxorint; + int = Lower Pxorint; bool = None; float = None; - bigint = Some Pxorbigint; + bigint = Some (Lower Pxorbigint); string = None; }; }; { - path = builtin "&&&"; + path = pervasives_path "&&&"; name = "%bitand"; form = Binary; specialization = { - int = Pandint; + int = Lower Pandint; bool = None; float = None; - bigint = Some Pandbigint; + bigint = Some (Lower Pandbigint); string = None; }; }; diff --git a/compiler/ml/unified_ops.mli b/compiler/ml/unified_ops.mli index b52e052a559..2cf4440f0a3 100644 --- a/compiler/ml/unified_ops.mli +++ b/compiler/ml/unified_ops.mli @@ -1,11 +1,15 @@ type form = Unary | Binary +type lowering = + | Lower of Lambda.primitive + | Pass_through (** the operand is already the result: unary [+] *) + type specialization = { - int: Lambda.primitive; - bool: Lambda.primitive option; - float: Lambda.primitive option; - bigint: Lambda.primitive option; - string: Lambda.primitive option; + int: lowering; + bool: lowering option; + float: lowering option; + bigint: lowering option; + string: lowering option; } type entry = { From 29ba6e88028ae08ff6ccea2809b0cc43aefa15b8 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 31 Aug 2026 16:17:38 +0200 Subject: [PATCH 02/46] Give Lambda the JavaScript null and undefined constants `%null` and `%undefined` were zero-argument primitives whose only job was to become constants in conversion, so a value spelled `Nullable.null` was not a constant at Lambda level. They are now `Constant` entries in the builtin table, and `Pnull` / `Pundefined` are gone from `Lambda.primitive`. `Const_js_null` and `Const_js_undefined` join `Lambda.structured_constant`. Unit becomes `Const_js_undefined {is_unit = true}` rather than a constant constructor named `"()"`, and a constructor with an optional shape produces the undefined constant directly, so `Pt_shape_none` is gone. Conversion of all four forms is now the identity. Constant constructors, polymorphic variants and the module alias are built through `Lambda.const_constructor` / `const_polyvar` / `const_module_alias`, and `pointer_info` is `private` so nothing outside `lambda.ml` can build one. That is what keeps the unit constructor from escaping as a pointer: the unit check lives in `const_constructor`, and the type system now enforces that every producer goes through it. Redefining `()` is already rejected for source and PPX-generated declarations by `Bs_ast_invariant`. The polymorphic-comparison warning check reads the constant forms instead of the primitives, deliberately excluding `is_unit = true`: unit shares the undefined constant but is not a `%null` / `%undefined` literal, and comparing it never suppressed the warning. `tests/build_tests/super_errors` covers both directions. Generated JavaScript changes in two option-representation tests, as intended: `Some(Nullable.null)` and friends are constants now, so they fold at compile time and let calls with constant arguments inline. Runtime and Belt output is unchanged. Signed-Off-By: Cristiano Calcagno Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/core/lam_constant_convert.ml | 5 ++- compiler/core/lam_convert.ml | 2 -- compiler/core/polyvar_pattern_match.ml | 6 ++-- compiler/frontend/lam_constant.ml | 2 -- compiler/frontend/lam_constant.mli | 2 -- compiler/ml/lambda.ml | 33 +++++++++++++++---- compiler/ml/lambda.mli | 18 +++++++--- compiler/ml/printlambda.ml | 6 ++-- compiler/ml/transl_recmodule.ml | 8 ++--- compiler/ml/translcore.ml | 29 ++++++++-------- .../src/Records.res.js | 16 ++++----- tests/tests/src/option_repr_test.mjs | 32 +++++++----------- tests/tests/src/option_wrapping_test.mjs | 8 ++--- 13 files changed, 87 insertions(+), 80 deletions(-) diff --git a/compiler/core/lam_constant_convert.ml b/compiler/core/lam_constant_convert.ml index 80fe10a0d87..7ece5e455c9 100644 --- a/compiler/core/lam_constant_convert.ml +++ b/compiler/core/lam_constant_convert.ml @@ -29,14 +29,13 @@ let rec convert_constant (const : Lambda.structured_constant) : Lam_constant.t = | 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 = "()"}) -> - Const_js_undefined {is_unit = true} + | Const_js_null -> Const_js_null + | Const_js_undefined {is_unit} -> Const_js_undefined {is_unit} | Const_false -> Const_js_false | Const_true -> Const_js_true | Const_pointer p -> ( match p with | Pt_module_alias -> Const_module_alias - | Pt_shape_none -> Lam_constant.lam_none | Pt_assertfalse -> Const_assertfalse | Pt_constructor {tag_type = Some (Variant_runtime.Int v)} -> (* A constructor represented as a number is a genuine number at diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index 18c3aee2246..8a549cabbf9 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -32,8 +32,6 @@ let prim = Lam.prim *) let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = match p with - | 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 | Pgetglobal _ -> assert false | Pmakeblock info -> ( diff --git a/compiler/core/polyvar_pattern_match.ml b/compiler/core/polyvar_pattern_match.ml index d325fcacf51..8dc691ef411 100644 --- a/compiler/core/polyvar_pattern_match.ml +++ b/compiler/core/polyvar_pattern_match.ml @@ -62,9 +62,7 @@ let or_list (arg : lam) (hash_names : (int * string) list) = | (hash, name) :: rest -> let init : lam = Lprim - ( Pintcomp Ceq, - [arg; Lconst (Const_pointer (Pt_variant {name}))], - Location.none ) + (Pintcomp Ceq, [arg; Lconst (Lambda.const_polyvar name)], Location.none) in Ext_list.fold_left rest init (fun acc (hash, name) -> Lambda.Lprim @@ -73,7 +71,7 @@ let or_list (arg : lam) (hash_names : (int * string) list) = acc; Lprim ( Pintcomp Ceq, - [arg; Lconst (Const_pointer (Pt_variant {name}))], + [arg; Lconst (Lambda.const_polyvar name)], Location.none ); ], Location.none )) diff --git a/compiler/frontend/lam_constant.ml b/compiler/frontend/lam_constant.ml index 851a565f7ae..90602ae4e9c 100644 --- a/compiler/frontend/lam_constant.ml +++ b/compiler/frontend/lam_constant.ml @@ -90,8 +90,6 @@ let rec eq_approx (x : t) (y : t) = | Const_some iy -> eq_approx ix iy | _ -> false) -let lam_none : t = Const_js_undefined {is_unit = false} - let rec is_allocating (c : t) : bool = match c with | Const_some t -> is_allocating t diff --git a/compiler/frontend/lam_constant.mli b/compiler/frontend/lam_constant.mli index 93096c98971..80ed6531111 100644 --- a/compiler/frontend/lam_constant.mli +++ b/compiler/frontend/lam_constant.mli @@ -46,6 +46,4 @@ type t = val eq_approx : t -> t -> bool -val lam_none : t - val is_allocating : t -> bool diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index 0130a8db172..fa05ca84a8a 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -177,8 +177,6 @@ type eliminated = Identity | Ignore type primitive = | Pdebugger | Ptypeof - | Pnull - | Pundefined | Pfn_arity | Pgetglobal of Ident.t (* Operations on heap blocks *) @@ -329,7 +327,6 @@ type pointer_info = | Pt_constructor of Variant_runtime.tag | Pt_variant of {name: string} | Pt_module_alias - | Pt_shape_none | Pt_assertfalse type structured_constant = @@ -342,11 +339,18 @@ type structured_constant = | Const_block of tag_info * structured_constant list | Const_false | Const_true + | Const_js_null + | Const_js_undefined of {is_unit: bool} + (** [is_unit] tells the unit value apart from JS [undefined]; both emit + [undefined]. *) (* What a `%builtin` name in the primitive table means. Only [Primitive] reaches the IR: [mk_builtin] erases the other cases at translation, so they need no [primitive] constructor to stand in for them. *) -type builtin = Primitive of primitive | Eliminated of eliminated +type builtin = + | Primitive of primitive + | Eliminated of eliminated + | Constant of structured_constant type inline_attribute = | Always_inline (* [@inline] or [@inline always] *) @@ -439,18 +443,33 @@ let const_of_typed (c : Asttypes.constant) : structured_constant = | 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}) +let const_unit = Const_js_undefined {is_unit = true} + +(* The JS value of a constant constructor. Unit is the one constructor with a + dedicated constant, so producers cannot leave it as a pointer. *) +let const_constructor (tag : Variant_runtime.tag) = + if tag.name = "()" then const_unit else Const_pointer (Pt_constructor tag) + +(* A constructor with an optional shape carries no payload when constant. *) +let const_shape_none = Const_js_undefined {is_unit = false} + +let const_polyvar name = Const_pointer (Pt_variant {name}) + +let const_module_alias = Const_pointer Pt_module_alias let lambda_assert_false = Lconst (Const_pointer Pt_assertfalse) -let lambda_module_alias = Lconst (Const_pointer Pt_module_alias) +let lambda_module_alias = Lconst const_module_alias let lambda_unit = Lconst const_unit let mk_builtin b args loc = match b with | Primitive p -> Lprim (p, args, loc) + | Constant c -> ( + match args with + | [] -> Lconst c + | _ -> assert false) | Eliminated Identity -> ( match args with | [arg] -> arg diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index ea721e0b237..0d117cdb441 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -114,11 +114,10 @@ val fld_record_extension_set : Types.label_description -> set_field_dbg_info type immediate_or_pointer = Immediate | Pointer -type pointer_info = +type pointer_info = private | Pt_constructor of Variant_runtime.tag | Pt_variant of {name: string} | Pt_module_alias - | Pt_shape_none | Pt_assertfalse (* The target of a dynamic [import], resolved at translation: the argument @@ -143,8 +142,6 @@ type eliminated = Identity | Ignore type primitive = | Pdebugger | Ptypeof - | Pnull - | Pundefined | Pfn_arity | Pgetglobal of Ident.t (* Operations on heap blocks *) @@ -300,11 +297,18 @@ type structured_constant = | Const_block of tag_info * structured_constant list | Const_false | Const_true + | Const_js_null + | Const_js_undefined of {is_unit: bool} + (** [is_unit] tells the unit value apart from JS [undefined]; both emit + [undefined]. *) (* What a `%builtin` name in the primitive table means. Only [Primitive] reaches the IR: [mk_builtin] erases the other cases at translation, so they need no [primitive] constructor to stand in for them. *) -type builtin = Primitive of primitive | Eliminated of eliminated +type builtin = + | Primitive of primitive + | Eliminated of eliminated + | Constant of structured_constant type inline_attribute = | Always_inline (* [@inline] or [@inline always] *) @@ -412,6 +416,10 @@ 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 const_constructor : Variant_runtime.tag -> structured_constant +val const_shape_none : structured_constant +val const_polyvar : string -> structured_constant +val const_module_alias : structured_constant val lambda_assert_false : lambda val lambda_unit : lambda diff --git a/compiler/ml/printlambda.ml b/compiler/ml/printlambda.ml index 47fd39289a1..1e8f45ab6ba 100644 --- a/compiler/ml/printlambda.ml +++ b/compiler/ml/printlambda.ml @@ -26,8 +26,10 @@ let rec struct_const ppf = function | 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" - | Const_pointer Pt_shape_none -> fprintf ppf "shape_none" | Const_pointer Pt_assertfalse -> fprintf ppf "assertfalse" + | Const_js_null -> fprintf ppf "null" + | Const_js_undefined {is_unit = true} -> fprintf ppf "unit" + | Const_js_undefined {is_unit = false} -> fprintf ppf "undefined" | Const_block (tag_info, []) -> let tag = Lambda.tag_label_of_tag_info tag_info in fprintf ppf "[%s]" tag @@ -94,8 +96,6 @@ let print_taginfo ppf = function let primitive ppf = function | Pdebugger -> fprintf ppf "debugger" | Ptypeof -> fprintf ppf "typeof" - | Pnull -> fprintf ppf "null" - | Pundefined -> fprintf ppf "undefined" | Pfn_arity -> fprintf ppf "fn.length" | Pgetglobal id -> fprintf ppf "global %a" Ident.print id | Pmakeblock taginfo -> fprintf ppf "makeblock %a" print_taginfo taginfo diff --git a/compiler/ml/transl_recmodule.ml b/compiler/ml/transl_recmodule.ml index ead654d2709..ce04184da80 100644 --- a/compiler/ml/transl_recmodule.ml +++ b/compiler/ml/transl_recmodule.ml @@ -40,8 +40,7 @@ let init_shape modl = let rec init_shape_mod env mty = match Mtype.scrape env mty with | Mty_ident _ -> raise Not_found - | Mty_alias _ -> - Const_block (value_tag_info, [Const_pointer Pt_module_alias]) + | Mty_alias _ -> Const_block (value_tag_info, [const_module_alias]) | Mty_signature sg -> Const_block (module_tag_info, [Const_block (Blk_tuple, init_shape_struct env sg)]) @@ -59,9 +58,8 @@ let init_shape modl = let init_v = match Ctype.expand_head env ty with | t when is_function t -> - Const_pointer - (Pt_constructor - (Ast_untagged_variants.constructor_tag ~name:"Function" [])) + const_constructor + (Ast_untagged_variants.constructor_tag ~name:"Function" []) | _ -> raise Not_found in add_name init_v id :: init_shape_struct env rem diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 0235b640409..9b96526e1ce 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -252,6 +252,11 @@ let erased_builtins : (string * Lambda.builtin) array = ("%identity", Eliminated Identity); ("%component_identity", Eliminated Identity); ("%ignore", Eliminated Ignore); + ("%null", Constant Const_js_null); + ("%undefined", Constant (Const_js_undefined {is_unit = false})); + (* FIXME: Core compatibility *) + ("#null", Constant Const_js_null); + ("#undefined", Constant (Const_js_undefined {is_unit = false})); |] let primitive_builtins : (string * Lambda.builtin) array = @@ -381,8 +386,6 @@ let primitive_builtins : (string * Lambda.builtin) array = ("%unsafe_le", Pjscomp Cle); ("%unsafe_gt", Pjscomp Cgt); ("%unsafe_ge", Pjscomp Cge); - ("%null", Pnull); - ("%undefined", Pundefined); ("%is_nullable", Pisnullable); ("%null_to_opt", Pnull_to_opt); ("%nullable_to_opt", Pnullable_to_opt); @@ -399,8 +402,6 @@ let primitive_builtins : (string * Lambda.builtin) array = ("%unsafe_to_method", Pjs_fn_method); (* Compiler internals, never expose to ReScript files *) (* FIXME: Core compatibility *) - ("#null", Pnull); - ("#undefined", Pundefined); ("#typeof", Ptypeof); ("#is_nullable", Pisnullable); ("#null_to_opt", Pnull_to_opt); @@ -450,8 +451,11 @@ let specialize_primitive p env ty (* ~has_constant_constructor *) = | None -> Primitive table.objcomp with Not_found -> find_builtin p.prim_name) +(* [is_unit] excluded: unit shares the undefined constant but is not a + [%null] / [%undefined] literal, and comparing it never suppressed the + warning. *) let is_null_undefined_constant = function - | Lprim ((Pnull | Pundefined), [], _) -> true + | Lconst (Const_js_null | Const_js_undefined {is_unit = false}) -> true | _ -> false let warn_polymorphic_comparison loc (builtin : Lambda.builtin) args = @@ -1205,13 +1209,12 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = match cstr.cstr_kind with | Ordinary_constructor _ when cstr.cstr_args = [] -> Lconst - (Const_pointer - (if Datarepr.constructor_has_optional_shape cstr then Pt_shape_none - else - Pt_constructor - (match Datarepr.constructor_case cstr with - | Constant tag -> tag - | Block _ -> assert false))) + (if Datarepr.constructor_has_optional_shape cstr then const_shape_none + else + const_constructor + (match Datarepr.constructor_case cstr with + | Constant tag -> tag + | Block _ -> assert false)) | Ordinary_constructor _ -> ( let runtime = match Datarepr.constructor_case cstr with @@ -1251,7 +1254,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = | Texp_variant (l, arg) -> ( let tag = Btype.hash_variant l in match arg with - | None -> Lconst (Const_pointer (Pt_variant {name = l})) + | None -> Lconst (const_polyvar l) | Some arg -> ( let lam = transl_exp arg in let tag_info = Blk_poly_var l in diff --git a/tests/gentype_tests/typescript-react-example/src/Records.res.js b/tests/gentype_tests/typescript-react-example/src/Records.res.js index cc58487d4db..bd78028a8ff 100644 --- a/tests/gentype_tests/typescript-react-example/src/Records.res.js +++ b/tests/gentype_tests/typescript-react-example/src/Records.res.js @@ -69,16 +69,6 @@ function findAddress2(business) { })); } -let someBusiness2_owner = null; - -let someBusiness2_address2 = null; - -let someBusiness2 = { - name: "SomeBusiness", - owner: someBusiness2_owner, - address2: someBusiness2_address2 -}; - function computeArea3(o) { return (o.x * o.y | 0) * Belt_Option.mapWithDefault(Primitive_option.fromNullable(o.z), 1, n => n) | 0; } @@ -130,6 +120,12 @@ let someBusiness = { address: undefined }; +let someBusiness2 = { + name: "SomeBusiness", + owner: null, + address2: null +}; + export { origin, computeArea, diff --git a/tests/tests/src/option_repr_test.mjs b/tests/tests/src/option_repr_test.mjs index 5ef9b6b614c..02ae0cb4304 100644 --- a/tests/tests/src/option_repr_test.mjs +++ b/tests/tests/src/option_repr_test.mjs @@ -151,14 +151,10 @@ Mocha.describe("Option_repr_test", () => { Test_utils.ok("File \"option_repr_test.res\", line 120, characters 7-14", Primitive_object.lessthan(undefined, Primitive_option.some(undefined))); Test_utils.ok("File \"option_repr_test.res\", line 121, characters 7-14", Primitive_object.greaterthan(Primitive_option.some(undefined), undefined)); }); - Mocha.test("option greater than operations", () => { - let xs_0 = gtx(Primitive_option.some(null), Primitive_option.some(undefined)); - let xs = { - hd: xs_0, - tl: /* [] */0 - }; - Test_utils.ok("File \"option_repr_test.res\", line 125, characters 7-14", Stdlib_List.every(xs, x => x)); - }); + Mocha.test("option greater than operations", () => Test_utils.ok("File \"option_repr_test.res\", line 125, characters 7-14", Stdlib_List.every({ + hd: Primitive_object.greaterthan(null, Primitive_option.some(undefined)) && Primitive_object.lessthan(Primitive_option.some(undefined), null), + tl: /* [] */0 + }, x => x))); Mocha.test("option less than operations", () => { let xs_0 = Primitive_object.lessthan(Primitive_option.some(undefined), 3) && Primitive_object.greaterthan(3, Primitive_option.some(undefined)); let xs_1 = { @@ -176,11 +172,11 @@ Mocha.describe("Option_repr_test", () => { tl: { hd: Primitive_object.lessthan(undefined, Primitive_option.some(undefined)) && Primitive_object.greaterthan(Primitive_option.some(undefined), undefined), tl: { - hd: ltx(undefined, null), + hd: Primitive_object.lessthan(undefined, null) && Primitive_object.greaterthan(null, undefined), tl: { hd: ltx(undefined, x => x), tl: { - hd: ltx(null, 3), + hd: Primitive_object.lessthan(null, 3) && Primitive_object.greaterthan(3, null), tl: /* [] */0 } } @@ -198,9 +194,10 @@ Mocha.describe("Option_repr_test", () => { }; Test_utils.ok("File \"option_repr_test.res\", line 130, characters 6-13", Stdlib_List.every(xs, x => x)); }); - Mocha.test("option equality operations", () => { - let xs_1 = { - hd: neqx(undefined, null), + Mocha.test("option equality operations", () => Test_utils.ok("File \"option_repr_test.res\", line 149, characters 6-13", Stdlib_List.every({ + hd: true, + tl: { + hd: undefined !== null && null !== undefined, tl: { hd: Primitive_object.equal(Primitive_option.some(undefined), Primitive_option.some(undefined)) && Primitive_object.equal(Primitive_option.some(undefined), Primitive_option.some(undefined)), tl: { @@ -211,13 +208,8 @@ Mocha.describe("Option_repr_test", () => { } } } - }; - let xs = { - hd: true, - tl: xs_1 - }; - Test_utils.ok("File \"option_repr_test.res\", line 149, characters 6-13", Stdlib_List.every(xs, x => x)); - }); + } + }, x => x))); }); let f7; diff --git a/tests/tests/src/option_wrapping_test.mjs b/tests/tests/src/option_wrapping_test.mjs index 9b6e41bc759..1f008f8ad27 100644 --- a/tests/tests/src/option_wrapping_test.mjs +++ b/tests/tests/src/option_wrapping_test.mjs @@ -16,10 +16,6 @@ let x7 = [ let x8 = () => {}; -let x10 = null; - -let x11 = Primitive_option.some(undefined); - let x20 = null; let x21 = new Date(); @@ -89,6 +85,10 @@ let x5 = { x: 42 }; +let x10 = null; + +let x11 = Primitive_option.some(undefined); + let x12 = "test"; let x39 = true; From c50631e9ab54a75352c1081d1ea55111bf23c3af Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 31 Aug 2026 16:51:21 +0200 Subject: [PATCH 03/46] Produce the polymorphic variant runtime name at translation A polymorphic variant with a payload is `{NAME, VAL}` at runtime. The name was stored twice: `translcore` put `Btype.hash_variant l` in the block and the name in `Blk_poly_var`, and conversion then threw the hash away and rebuilt the name from the descriptor. The hash is meaningless for this target - it is OCaml's runtime discriminator, kept when the encoding changed to an object - and the descriptor's copy was read by nothing except the printer and that rebuild. `translcore` now emits the final name, decided once by `Lambda.const_polyvar_name`: numeric-looking names are numbers at runtime, everything else is a string. `Blk_poly_var` becomes a payload-free shape marker like `Blk_tuple`, so both conversions lose their special case and the `assert false` guarding a two-element shape they could not express. Every code-generation site keeps reading the name where it always did, from the block, so the JavaScript layer is unchanged apart from the constructor arity. `Btype.hash_variant` is no longer emitted anywhere; its one remaining use is a deterministic sort key in `matching`. Generated JavaScript is unchanged for the runtime, Belt, and tests/tests. Signed-Off-By: Cristiano Calcagno Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/core/js_dump.ml | 4 ++-- compiler/core/js_exp_make.ml | 2 +- compiler/core/js_of_lam_variant.ml | 2 +- compiler/core/lam.ml | 2 +- compiler/core/lam_constant_convert.ml | 14 ++------------ compiler/core/lam_convert.ml | 18 +++--------------- compiler/ml/lambda.ml | 16 +++++++++++----- compiler/ml/lambda.mli | 3 ++- compiler/ml/printlambda.ml | 2 +- compiler/ml/translcore.ml | 7 +++---- 10 files changed, 27 insertions(+), 43 deletions(-) diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index 0584e3852b2..6ea15a0a242 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -156,7 +156,7 @@ let rec exp_need_paren ?(arrow = false) (e : J.expression) = | Caml_block ( _, _, - ( Blk_record _ | Blk_module _ | Blk_poly_var _ | Blk_extension + ( Blk_record _ | Blk_module _ | Blk_poly_var | Blk_extension | Blk_record_ext _ | Blk_record_inlined _ | Blk_constructor _ ) ) | Object _ -> true @@ -943,7 +943,7 @@ and expression_desc cxt ~(level : int) f x : cxt = | _ -> Some (Js_op.Lit f, x)) in expression_desc cxt ~level f (Object (None, fields)) - | Caml_block (el, _, Blk_poly_var _) -> ( + | Caml_block (el, _, Blk_poly_var) -> ( match el with | [tag; value] -> expression_desc cxt ~level f diff --git a/compiler/core/js_exp_make.ml b/compiler/core/js_exp_make.ml index a10df47a627..fa9f08b1d1e 100644 --- a/compiler/core/js_exp_make.ml +++ b/compiler/core/js_exp_make.ml @@ -315,7 +315,7 @@ let dummy_obj ?comment (info : Lam_tag_info.t) : t = *) match info with | Blk_record _ | Blk_module _ | Blk_constructor _ | Blk_record_inlined _ - | Blk_poly_var _ | Blk_extension | Blk_record_ext _ -> + | Blk_poly_var | Blk_extension | Blk_record_ext _ -> {comment; source_loc = None; expression_desc = Object (None, [])} | Blk_tuple | Blk_module_export _ -> {comment; source_loc = None; expression_desc = Array []} diff --git a/compiler/core/js_of_lam_variant.ml b/compiler/core/js_of_lam_variant.ml index 8cb33ed7dae..cc5b185ffe9 100644 --- a/compiler/core/js_of_lam_variant.ml +++ b/compiler/core/js_of_lam_variant.ml @@ -64,7 +64,7 @@ let eval (arg : J.expression) (dispatches : (string * string) list) : E.t = let eval_as_event (arg : J.expression) (dispatches : (string * string) list option) = match arg.expression_desc with - | Caml_block ([{expression_desc = Str {txt}}; cb], _, Blk_poly_var _) + | Caml_block ([{expression_desc = Str {txt}}; cb], _, Blk_poly_var) when Js_analyzer.no_side_effect_expression cb -> let v = match dispatches with diff --git a/compiler/core/lam.ml b/compiler/core/lam.ml index 67c346d85c6..6197bbc02f5 100644 --- a/compiler/core/lam.ml +++ b/compiler/core/lam.ml @@ -305,7 +305,7 @@ let switch lam (lam_switch : lambda_switch) : t = match tag_info with | Lambda.Blk_constructor {runtime} | Blk_record_inlined {runtime} -> Some runtime - | Blk_tuple | Blk_poly_var _ | Blk_record _ | Blk_record_ext _ + | Blk_tuple | Blk_poly_var | Blk_record _ | Blk_record_ext _ | Blk_module _ | Blk_module_export _ | Blk_extension | Blk_some | Blk_some_not_nested -> None diff --git a/compiler/core/lam_constant_convert.ml b/compiler/core/lam_constant_convert.ml index 7ece5e455c9..4606ddb1377 100644 --- a/compiler/core/lam_constant_convert.ml +++ b/compiler/core/lam_constant_convert.ml @@ -53,15 +53,5 @@ let rec convert_constant (const : Lambda.structured_constant) : Lam_constant.t = | Blk_some -> Const_some (convert_constant (Ext_list.singleton_exn xs)) | Blk_constructor _ | Blk_tuple | Blk_record _ | Blk_module _ | Blk_module_export _ | Blk_extension | Blk_record_inlined _ - | Blk_record_ext _ -> - Const_block (t, Ext_list.map xs convert_constant) - | Blk_poly_var s -> ( - match xs with - | [_; value] -> - let tag_val : Lam_constant.t = - if Ext_string.is_valid_hash_number s then - 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]) - | _ -> assert false)) + | Blk_record_ext _ | Blk_poly_var -> + Const_block (t, Ext_list.map xs convert_constant)) diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index 8a549cabbf9..ca57ec30a5e 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -40,21 +40,9 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = | Blk_some_not_nested -> prim ~primitive:Psome_not_nest ~args loc | Blk_some -> prim ~primitive:Psome ~args loc | Blk_constructor _ | Blk_tuple | Blk_record _ | Blk_record_inlined _ - | Blk_module _ | Blk_module_export _ | Blk_extension | Blk_record_ext _ -> - prim ~primitive:(Pmakeblock (info, mutable_flag)) ~args loc - | Blk_poly_var s -> ( - match args with - | [_; value] -> - let tag_val : Lam_constant.t = - if Ext_string.is_valid_hash_number s then - Const_int (Ext_string.hash_number_as_i32_exn s) - else Const_string {s; delim = None} - in - prim - ~primitive:(Pmakeblock (info, mutable_flag)) - ~args:[Lam.const tag_val; value] - loc - | _ -> assert false)) + | Blk_module _ | Blk_module_export _ | Blk_extension | Blk_record_ext _ + | Blk_poly_var -> + prim ~primitive:(Pmakeblock (info, mutable_flag)) ~args loc) | Pfn_arity -> prim ~primitive:Pfn_arity ~args loc | Pdebugger -> prim ~primitive:Pdebugger ~args loc | Ptypeof -> prim ~primitive:Ptypeof ~args loc diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index fa05ca84a8a..e0d40a8ad5a 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -29,7 +29,7 @@ type tag_info = runtime: Variant_runtime.block_runtime; } | Blk_tuple - | Blk_poly_var of string + | Blk_poly_var | Blk_record of { fields: (string * bool (* optional *)) array; mutable_flag: Asttypes.mutable_flag; @@ -50,9 +50,8 @@ type tag_info = let tag_label_of_tag_info (tag : tag_info) = match tag with | Blk_constructor {name} | Blk_record_inlined {name} -> name - | Blk_tuple | Blk_poly_var _ | Blk_record _ | Blk_module _ - | Blk_module_export _ | Blk_extension | Blk_some | Blk_some_not_nested - | Blk_record_ext _ -> + | Blk_tuple | Blk_poly_var | Blk_record _ | Blk_module _ | Blk_module_export _ + | Blk_extension | Blk_some | Blk_some_not_nested | Blk_record_ext _ -> "0" let mutable_flag_of_tag_info (tag : tag_info) = @@ -61,7 +60,7 @@ let mutable_flag_of_tag_info (tag : tag_info) = | Blk_record {mutable_flag} | Blk_record_ext {mutable_flag} -> mutable_flag - | Blk_tuple | Blk_constructor _ | Blk_poly_var _ | Blk_module _ + | Blk_tuple | Blk_constructor _ | Blk_poly_var | Blk_module _ | Blk_module_export _ | Blk_extension | Blk_some_not_nested | Blk_some -> Immutable @@ -455,6 +454,13 @@ let const_shape_none = Const_js_undefined {is_unit = false} let const_polyvar name = Const_pointer (Pt_variant {name}) +(* The JS value of a polymorphic variant's name: a numeric-looking name is a + number at runtime, anything else is a string. *) +let const_polyvar_name name = + if Ext_string.is_valid_hash_number name then + Const_int (Ext_string.hash_number_as_i32_exn name) + else Const_string {s = name; delim = None} + let const_module_alias = Const_pointer Pt_module_alias let lambda_assert_false = Lconst (Const_pointer Pt_assertfalse) diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index 0d117cdb441..c5928f85b98 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -33,7 +33,7 @@ type tag_info = runtime: Variant_runtime.block_runtime; } | Blk_tuple - | Blk_poly_var of string + | Blk_poly_var | Blk_record of { fields: (string * bool (* optional *)) array; mutable_flag: mutable_flag; @@ -419,6 +419,7 @@ val const_unit : structured_constant val const_constructor : Variant_runtime.tag -> structured_constant val const_shape_none : structured_constant val const_polyvar : string -> structured_constant +val const_polyvar_name : string -> structured_constant val const_module_alias : structured_constant val lambda_assert_false : lambda val lambda_unit : lambda diff --git a/compiler/ml/printlambda.ml b/compiler/ml/printlambda.ml index 1e8f45ab6ba..debde84f038 100644 --- a/compiler/ml/printlambda.ml +++ b/compiler/ml/printlambda.ml @@ -83,7 +83,7 @@ let print_taginfo ppf = function | Blk_tuple -> fprintf ppf "tuple" | Blk_constructor {name; num_nonconst} -> fprintf ppf "%s/%i" name num_nonconst - | Blk_poly_var name -> fprintf ppf "`%s" name + | Blk_poly_var -> fprintf ppf "polyvar" | Blk_record {fields = ss} -> fprintf ppf "[%s]" (String.concat ";" (List.map fst (Array.to_list ss))) | Blk_module ss -> fprintf ppf "[%s]" (String.concat ";" ss) diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 9b96526e1ce..6e6e1e1d069 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -1252,15 +1252,14 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = e.exp_loc )) | Texp_extension_constructor (_, path) -> transl_extension_path e.exp_env path | Texp_variant (l, arg) -> ( - let tag = Btype.hash_variant l in match arg with | None -> Lconst (const_polyvar l) | Some arg -> ( let lam = transl_exp arg in - let tag_info = Blk_poly_var l in - try Lconst (Const_block (tag_info, [const_int tag; extract_constant lam])) + let name = const_polyvar_name l in + try Lconst (Const_block (Blk_poly_var, [name; extract_constant lam])) with Not_constant -> - Lprim (Pmakeblock tag_info, [Lconst (const_int tag); lam], e.exp_loc))) + Lprim (Pmakeblock Blk_poly_var, [Lconst name; 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) -> ( From 60d65b7501579502d635af7aca6e508bcb4eb4f1 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 31 Aug 2026 16:55:29 +0200 Subject: [PATCH 04/46] Check polymorphic variant name range in the type checker A polymorphic variant whose numeric name exceeds the int32 range crashed the compiler with `Failure("Int32.of_string")` when it carried a payload or appeared in a pattern: let x = #99999999999("a") switch x { | #99999999999 => 1 | _ => 2 } The range check lived in the frontend AST pass and matched only `Pexp_variant (s, None)`, so those two positions reached `hash_number_as_i32_exn` unvalidated, with no location and no message. Move it to `Typecore`, next to the integer literal decoding whose overflow error it mirrors, and call it from both label positions. That follows what the compiler already does for numeric literals: the parser keeps the text and never judges ranges, and the hard error is raised where the value is decoded. It also means the check covers a position once rather than once per syntactic form, and lets `Lambda.const_polyvar_name` and the constant converter keep decoding with the `_exn` function, now with a guarantee behind it. A bare `type t = [#99999999999]` still compiles: nothing decodes a row field name, so it cannot crash, and reporting it would belong in `Typetexp`. Signed-Off-By: Cristiano Calcagno Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/frontend/bs_ast_invariant.ml | 6 ------ compiler/ml/typecore.ml | 16 ++++++++++++++++ compiler/ml/typecore.mli | 1 + tests/ERROR_VARIANTS.md | 1 + .../expected/polyvar_int_overflow.res.expected | 8 ++++++++ .../polyvar_int_overflow_pattern.res.expected | 11 +++++++++++ .../polyvar_int_overflow_payload.res.expected | 8 ++++++++ .../fixtures/polyvar_int_overflow.res | 1 + .../fixtures/polyvar_int_overflow_pattern.res | 5 +++++ .../fixtures/polyvar_int_overflow_payload.res | 1 + 10 files changed, 52 insertions(+), 6 deletions(-) create mode 100644 tests/build_tests/super_errors/expected/polyvar_int_overflow.res.expected create mode 100644 tests/build_tests/super_errors/expected/polyvar_int_overflow_pattern.res.expected create mode 100644 tests/build_tests/super_errors/expected/polyvar_int_overflow_payload.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/polyvar_int_overflow.res create mode 100644 tests/build_tests/super_errors/fixtures/polyvar_int_overflow_pattern.res create mode 100644 tests/build_tests/super_errors/fixtures/polyvar_int_overflow_payload.res diff --git a/compiler/frontend/bs_ast_invariant.ml b/compiler/frontend/bs_ast_invariant.ml index 07accd4efef..6aaf07f2a74 100644 --- a/compiler/frontend/bs_ast_invariant.ml +++ b/compiler/frontend/bs_ast_invariant.ml @@ -91,12 +91,6 @@ let emit_external_warnings : iterator = (fun self ({pexp_loc = loc} as a) -> match a.pexp_desc with | Pexp_constant const -> check_constant loc const - | Pexp_variant (s, None) when Ext_string.is_valid_hash_number s -> ( - try ignore (Ext_string.hash_number_as_i32_exn s : int32) - with _ -> - Location.raise_errorf ~loc - "Integer literal exceeds int32 range. Use float or BigInt if \ - larger values are required.") | _ -> super.expr self a); label_declaration = (fun self lbl -> diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 1dd091d0f65..2d2e1c180d3 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -80,6 +80,7 @@ type error = | Break_outside_loop | Continue_outside_loop | Literal_overflow of string + | Polyvar_literal_overflow | Unknown_literal of string * char | Illegal_letrec_pat | Empty_record_literal @@ -286,6 +287,15 @@ let constant_or_raise env loc cst = | Ok c -> c | Error err -> raise (Error (loc, env, err)) +(* A numeric polymorphic variant name is its own runtime value, so it has to + fit the int32 range the name is emitted in. Checked here, where every label + position is typed, so that decoding it downstream cannot fail. *) +let check_polyvar_name env loc name = + if Ext_string.is_valid_hash_number name then + match Int32.of_string_opt name with + | Some _ -> () + | None -> raise (Error (loc, env, Polyvar_literal_overflow)) + (* Specific version of type_option, using newty rather than newgenty *) let type_option ty = newty (Tconstr (Predef.path_option, [ty], ref Mnil)) @@ -1465,6 +1475,7 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp pat_env = !env; }) | Ppat_variant (l, sarg) -> ( + check_polyvar_name !env loc l; let arg_type = match sarg with | None -> [] @@ -2713,6 +2724,7 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp | Pexp_construct (lid, sarg) -> type_construct ~context env loc lid sarg ty_expected sexp.pexp_attributes | Pexp_variant (l, sarg) -> ( + check_polyvar_name env loc l; (* Keep sharing *) let ty_expected0 = instance env ty_expected in try @@ -5230,6 +5242,10 @@ let report_error env loc ppf error = fprintf ppf "Integer literal exceeds the range of representable integers of type %s" ty + | Polyvar_literal_overflow -> + fprintf ppf + "Integer literal exceeds int32 range. Use float or BigInt if larger \ + values are required." | Unknown_literal (n, m) -> fprintf ppf "Unknown modifier '%c' for literal %s%c" m n m | Illegal_letrec_pat -> diff --git a/compiler/ml/typecore.mli b/compiler/ml/typecore.mli index 42b5d4ce685..432f9c45df7 100644 --- a/compiler/ml/typecore.mli +++ b/compiler/ml/typecore.mli @@ -113,6 +113,7 @@ type error = | Break_outside_loop | Continue_outside_loop | Literal_overflow of string + | Polyvar_literal_overflow | Unknown_literal of string * char | Illegal_letrec_pat | Empty_record_literal diff --git a/tests/ERROR_VARIANTS.md b/tests/ERROR_VARIANTS.md index 0c57b4748de..4d681bf6db1 100644 --- a/tests/ERROR_VARIANTS.md +++ b/tests/ERROR_VARIANTS.md @@ -240,6 +240,7 @@ Source: [typecore.ml:27](../compiler/ml/typecore.ml). | `Break_outside_loop` | ✓ | `break_outside_loop.res`, `break_in_nested_function.res` | | | `Continue_outside_loop` | ✓ | `continue_outside_loop.res`, `continue_in_nested_function.res` | | | `Literal_overflow` | ✓ | `intoverflow.res` | | +| `Polyvar_literal_overflow` | ✓ | `polyvar_int_overflow.res`, `polyvar_int_overflow_payload.res`, `polyvar_int_overflow_pattern.res` | | | `Unknown_literal` | ✓ | `unknown_literal.res` | | | `Illegal_letrec_pat` | ✓ | `illegal_letrec_pat.res` | | | `Empty_record_literal` | ✓ | `empty_record_literal.res` | | diff --git a/tests/build_tests/super_errors/expected/polyvar_int_overflow.res.expected b/tests/build_tests/super_errors/expected/polyvar_int_overflow.res.expected new file mode 100644 index 00000000000..1b426d85bc7 --- /dev/null +++ b/tests/build_tests/super_errors/expected/polyvar_int_overflow.res.expected @@ -0,0 +1,8 @@ + + We've found a bug for you! + /.../fixtures/polyvar_int_overflow.res:1:9-20 + + 1 │ let x = #99999999999 + 2 │ + + Integer literal exceeds int32 range. Use float or BigInt if larger values are required. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/polyvar_int_overflow_pattern.res.expected b/tests/build_tests/super_errors/expected/polyvar_int_overflow_pattern.res.expected new file mode 100644 index 00000000000..e1e0edd2d80 --- /dev/null +++ b/tests/build_tests/super_errors/expected/polyvar_int_overflow_pattern.res.expected @@ -0,0 +1,11 @@ + + We've found a bug for you! + /.../fixtures/polyvar_int_overflow_pattern.res:3:5-16 + + 1 │ let f = x => + 2 │ switch x { + 3 │ | #99999999999 => 1 + 4 │ | _ => 2 + 5 │ } + + Integer literal exceeds int32 range. Use float or BigInt if larger values are required. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/polyvar_int_overflow_payload.res.expected b/tests/build_tests/super_errors/expected/polyvar_int_overflow_payload.res.expected new file mode 100644 index 00000000000..7f2e11b90c8 --- /dev/null +++ b/tests/build_tests/super_errors/expected/polyvar_int_overflow_payload.res.expected @@ -0,0 +1,8 @@ + + We've found a bug for you! + /.../fixtures/polyvar_int_overflow_payload.res:1:9-25 + + 1 │ let x = #99999999999("a") + 2 │ + + Integer literal exceeds int32 range. Use float or BigInt if larger values are required. \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/polyvar_int_overflow.res b/tests/build_tests/super_errors/fixtures/polyvar_int_overflow.res new file mode 100644 index 00000000000..5f94eb66db7 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/polyvar_int_overflow.res @@ -0,0 +1 @@ +let x = #99999999999 diff --git a/tests/build_tests/super_errors/fixtures/polyvar_int_overflow_pattern.res b/tests/build_tests/super_errors/fixtures/polyvar_int_overflow_pattern.res new file mode 100644 index 00000000000..86bab872d3d --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/polyvar_int_overflow_pattern.res @@ -0,0 +1,5 @@ +let f = x => + switch x { + | #99999999999 => 1 + | _ => 2 + } diff --git a/tests/build_tests/super_errors/fixtures/polyvar_int_overflow_payload.res b/tests/build_tests/super_errors/fixtures/polyvar_int_overflow_payload.res new file mode 100644 index 00000000000..4473ed610fe --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/polyvar_int_overflow_payload.res @@ -0,0 +1 @@ +let x = #99999999999("a") From 2c9a0bfaf439acfda459245850b10bc80bbb428c Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 1 Sep 2026 10:02:32 +0200 Subject: [PATCH 05/46] Own the constant representation in Lambda and drop the converter Conversion of constants was a fan-out: one `Const_pointer of pointer_info` became five Lam constants, option blocks became `Const_some`, and the boolean names differed. All of it is decided at Lambda production now, so `Lam_constant.t` is a manifest re-export of `Lambda.structured_constant` and `lam_constant_convert.ml` is deleted - `Lconst` passes straight through. Three moves: Options. `Const_some` and the `Psome` / `Psome_not_nest` primitives move to Lambda, and `translcore` emits them instead of a block that conversion had to reinterpret. `Blk_some` / `Blk_some_not_nested` leave `tag_info`, which also retires a dead `Const_block (Blk_some, _)` case in `lam_pass_remove_alias` and an `assert false` in `js_exp_make`. Pointers. `Const_constructor`, `Const_polyvar`, `Const_assertfalse` and `Const_module_alias` become explicit constants, so `Const_pointer` and `pointer_info` are gone. The two decisions conversion used to make happen once, in `const_constructor` (unit first, then integer-tagged constructors as ordinary integers so folding sees their runtime representation) and in `const_polyvar` (numeric-looking names as integers). `const_polyvar_name`, the name field of a variant carrying a payload, is defined in terms of the latter, so the choice exists in exactly one place. Lam's `Const_pointer of string` is renamed to `Const_polyvar` to match. Booleans. Lambda's `Const_false` / `Const_true` take the Lam names. Generated JavaScript is unchanged for the runtime, Belt, and tests/tests; each of the three moves was verified output-neutral on its own. Signed-Off-By: Cristiano Calcagno Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/core/js_dump.ml | 3 +- compiler/core/js_exp_make.ml | 1 - compiler/core/lam.ml | 7 ++- compiler/core/lam_analysis.ml | 4 +- compiler/core/lam_compile_const.ml | 2 +- compiler/core/lam_constant_convert.ml | 57 ------------------------- compiler/core/lam_constant_convert.mli | 25 ----------- compiler/core/lam_convert.ml | 6 +-- compiler/core/lam_eta_conversion.ml | 2 +- compiler/core/lam_pass_lets_dce.ml | 2 +- compiler/core/lam_pass_remove_alias.ml | 1 - compiler/core/lam_print.ml | 2 +- compiler/frontend/lam_constant.ml | 34 +++++++-------- compiler/frontend/lam_constant.mli | 28 ++++++------ compiler/ml/lambda.ml | 59 +++++++++++++++----------- compiler/ml/lambda.mli | 26 ++++++------ compiler/ml/printlambda.ml | 17 ++++---- compiler/ml/translcore.ml | 45 +++++++++++--------- 18 files changed, 128 insertions(+), 193 deletions(-) delete mode 100644 compiler/core/lam_constant_convert.ml delete mode 100644 compiler/core/lam_constant_convert.mli diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index 6ea15a0a242..048c04bc179 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -1014,8 +1014,7 @@ and expression_desc cxt ~(level : int) f x : cxt = | _ -> J.Object (None, objs) in expression_desc cxt ~level f exp - | Caml_block (_, _, (Blk_module_export _ | Blk_some | Blk_some_not_nested)) -> - assert false + | Caml_block (_, _, Blk_module_export _) -> assert false | Caml_block (el, _, Blk_tuple) -> expression_desc cxt ~level f (Array el) | Caml_block_tag (e, tag) -> P.group f 1 (fun _ -> diff --git a/compiler/core/js_exp_make.ml b/compiler/core/js_exp_make.ml index fa9f08b1d1e..d75a036d5a4 100644 --- a/compiler/core/js_exp_make.ml +++ b/compiler/core/js_exp_make.ml @@ -319,7 +319,6 @@ let dummy_obj ?comment (info : Lam_tag_info.t) : t = {comment; source_loc = None; expression_desc = Object (None, [])} | Blk_tuple | Blk_module_export _ -> {comment; source_loc = None; expression_desc = Array []} - | Blk_some | Blk_some_not_nested -> assert false (* TODO: complete pure ... diff --git a/compiler/core/lam.ml b/compiler/core/lam.ml index 6197bbc02f5..02264fdd777 100644 --- a/compiler/core/lam.ml +++ b/compiler/core/lam.ml @@ -306,8 +306,7 @@ let switch lam (lam_switch : lambda_switch) : t = | Lambda.Blk_constructor {runtime} | Blk_record_inlined {runtime} -> Some runtime | Blk_tuple | Blk_poly_var | Blk_record _ | Blk_record_ext _ - | Blk_module _ | Blk_module_export _ | Blk_extension | Blk_some - | Blk_some_not_nested -> + | Blk_module _ | Blk_module_export _ | Blk_extension -> None in let action = @@ -397,7 +396,7 @@ let prim ~primitive:(prim : Lam_primitive.t) ~args loc : t = Lift.bool (Lam_compat.cmp_float cmp (float_of_string a) (float_of_string b)) | Pbigintcomp cmp, Const_bigint _, Const_bigint _ -> default () - | Pintcomp ((Ceq | Cneq) as op), Const_pointer a, Const_pointer b -> + | Pintcomp ((Ceq | Cneq) as op), Const_polyvar a, Const_polyvar b -> Lift.bool (match op with | Ceq -> a = (b : string) @@ -521,7 +520,7 @@ let rec eval_const_as_bool (v : Lam_constant.t) : bool option = | Const_js_false | Const_js_null | Const_module_alias | Const_js_undefined _ -> Some false - | Const_js_true | Const_string _ | Const_pointer _ | Const_float _ + | Const_js_true | Const_string _ | Const_polyvar _ | Const_float _ | Const_bigint _ | Const_block _ -> Some true | Const_some b -> eval_const_as_bool b diff --git a/compiler/core/lam_analysis.ml b/compiler/core/lam_analysis.ml index 35f358c1e08..d3930e86054 100644 --- a/compiler/core/lam_analysis.ml +++ b/compiler/core/lam_analysis.ml @@ -191,7 +191,7 @@ let rec size (lam : Lam.t) = and size_constant x = match x with | Const_int _ | Const_assertfalse | Const_constructor _ | Const_char _ - | Const_float _ | Const_bigint _ | Const_pointer _ | Const_js_null + | Const_float _ | Const_bigint _ | Const_polyvar _ | Const_js_null | Const_js_undefined _ | Const_module_alias | Const_js_true | Const_js_false -> 1 @@ -267,7 +267,7 @@ let safe_to_inline (lam : Lam.t) = match lam with | Lfunction _ -> true | Lconst - ( Const_pointer _ | Const_constructor _ | Const_js_true | Const_js_false + ( Const_polyvar _ | Const_constructor _ | Const_js_true | Const_js_false | Const_js_undefined _ ) -> true | _ -> false diff --git a/compiler/core/lam_compile_const.ml b/compiler/core/lam_compile_const.ml index 46e0919c706..83dd8bcb520 100644 --- a/compiler/core/lam_compile_const.ml +++ b/compiler/core/lam_compile_const.ml @@ -62,7 +62,7 @@ and translate (x : Lam_constant.t) : J.expression = | Const_float f -> E.float f (* TODO: preserve float *) | Const_string {s; delim = None | Some DNoQuotes} -> E.str s | Const_string {s; delim = Some delim} -> E.str ~delim s - | Const_pointer name -> E.str name + | Const_polyvar name -> E.str name | Const_block (tag_info, xs) -> Js_of_lam_block.make_block NA tag_info (Ext_list.map xs translate) diff --git a/compiler/core/lam_constant_convert.ml b/compiler/core/lam_constant_convert.ml deleted file mode 100644 index 4606ddb1377..00000000000 --- a/compiler/core/lam_constant_convert.ml +++ /dev/null @@ -1,57 +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. *) - -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; delim} -> Const_string {s; delim} - | Const_float i -> Const_float i - | Const_bigint (sign, i) -> Const_bigint (sign, i) - | Const_js_null -> Const_js_null - | Const_js_undefined {is_unit} -> Const_js_undefined {is_unit} - | Const_false -> Const_js_false - | Const_true -> Const_js_true - | Const_pointer p -> ( - match p with - | Pt_module_alias -> Const_module_alias - | 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 (Int32.of_int v) - | Pt_constructor runtime -> Const_constructor runtime - | Pt_variant {name} -> - if Ext_string.is_valid_hash_number name then - Const_int (Ext_string.hash_number_as_i32_exn name) - else Const_pointer name) - | Const_block (t, xs) -> ( - match t with - | Blk_some_not_nested -> - Const_some (convert_constant (Ext_list.singleton_exn xs)) - | Blk_some -> Const_some (convert_constant (Ext_list.singleton_exn xs)) - | Blk_constructor _ | Blk_tuple | Blk_record _ | Blk_module _ - | Blk_module_export _ | Blk_extension | Blk_record_inlined _ - | Blk_record_ext _ | Blk_poly_var -> - Const_block (t, Ext_list.map xs convert_constant)) diff --git a/compiler/core/lam_constant_convert.mli b/compiler/core/lam_constant_convert.mli deleted file mode 100644 index d0bf02048fc..00000000000 --- a/compiler/core/lam_constant_convert.mli +++ /dev/null @@ -1,25 +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. *) - -val convert_constant : Lambda.structured_constant -> Lam_constant.t diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index ca57ec30a5e..a8ed338bc75 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -37,14 +37,14 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = | Pmakeblock info -> ( let mutable_flag = Lambda.mutable_flag_of_tag_info info in match info with - | Blk_some_not_nested -> prim ~primitive:Psome_not_nest ~args loc - | Blk_some -> prim ~primitive:Psome ~args loc | Blk_constructor _ | Blk_tuple | Blk_record _ | Blk_record_inlined _ | Blk_module _ | Blk_module_export _ | Blk_extension | Blk_record_ext _ | Blk_poly_var -> prim ~primitive:(Pmakeblock (info, mutable_flag)) ~args loc) | Pfn_arity -> prim ~primitive:Pfn_arity ~args loc | Pdebugger -> prim ~primitive:Pdebugger ~args loc + | Psome -> prim ~primitive:Psome ~args loc + | Psome_not_nest -> prim ~primitive:Psome_not_nest ~args loc | Ptypeof -> prim ~primitive:Ptypeof ~args loc | Pisnullable -> prim ~primitive:Pis_null_undefined ~args loc | Pnull_to_opt -> prim ~primitive:Pnull_to_opt ~args loc @@ -183,7 +183,7 @@ let convert (lam : Lambda.lambda) : Lam.t * Lam_module_ident.Hash_set.t = let rec convert_aux (lam : Lambda.lambda) : Lam.t = match lam with | Lvar x -> Lam.var x - | Lconst x -> Lam.const (Lam_constant_convert.convert_constant x) + | Lconst x -> Lam.const x | Lapply { ap_func = fn; diff --git a/compiler/core/lam_eta_conversion.ml b/compiler/core/lam_eta_conversion.ml index bd0f7decd14..2f038ea306e 100644 --- a/compiler/core/lam_eta_conversion.ml +++ b/compiler/core/lam_eta_conversion.ml @@ -44,7 +44,7 @@ let transform_under_supply n ap_info fn args = | Lconst ( Const_int _ | Const_assertfalse | Const_constructor _ | Const_char _ | Const_string _ | Const_float _ | Const_bigint _ - | Const_pointer _ | Const_js_true | Const_js_false + | Const_polyvar _ | Const_js_true | Const_js_false | Const_js_undefined _ ) | Lprim {primitive = Pfield (_, Fld_module _); _} | Lfunction _ -> diff --git a/compiler/core/lam_pass_lets_dce.ml b/compiler/core/lam_pass_lets_dce.ml index 80956f4b9e6..2d6ccc819a8 100644 --- a/compiler/core/lam_pass_lets_dce.ml +++ b/compiler/core/lam_pass_lets_dce.ml @@ -52,7 +52,7 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = | ( _, ( Lconst ( Const_int _ | Const_assertfalse | Const_constructor _ - | Const_char _ | Const_float _ | Const_bigint _ | Const_pointer _ + | Const_char _ | Const_float _ | Const_bigint _ | Const_polyvar _ | Const_js_true | Const_js_false | Const_js_undefined _ ) (* could be poly-variant [`A] -> [65a]*) | Lprim {primitive = Pfield _; args = [Lglobal_module _]} ) ) diff --git a/compiler/core/lam_pass_remove_alias.ml b/compiler/core/lam_pass_remove_alias.ml index cdd31e5940e..55423f20aca 100644 --- a/compiler/core/lam_pass_remove_alias.ml +++ b/compiler/core/lam_pass_remove_alias.ml @@ -44,7 +44,6 @@ let id_is_for_sure_true_in_boolean (tbl : Lam_stats.ident_tbl) id = let is_const_some (cst : Lam_constant.t) : bool = match cst with | Const_some _ -> true - | Const_block ((Lambda.Blk_some | Lambda.Blk_some_not_nested), _) -> true | _ -> false let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = diff --git a/compiler/core/lam_print.ml b/compiler/core/lam_print.ml index 8749ed63968..a7e3f201e6b 100644 --- a/compiler/core/lam_print.ml +++ b/compiler/core/lam_print.ml @@ -26,7 +26,7 @@ let rec struct_const ppf (cst : Lam_constant.t) = | Const_string {s} -> fprintf ppf "%S" s | Const_float f -> fprintf ppf "%s" f | Const_bigint (sign, i) -> fprintf ppf "%sn" (Bigint_utils.to_string sign i) - | Const_pointer name -> fprintf ppf "`%s" name + | Const_polyvar name -> fprintf ppf "`%s" name | Const_constructor {name} -> fprintf ppf "`%s" name | Const_some n -> fprintf ppf "[some-c]%a" struct_const n | Const_block (i, []) -> fprintf ppf "[%s]" (Lambda.tag_label_of_tag_info i) diff --git a/compiler/frontend/lam_constant.ml b/compiler/frontend/lam_constant.ml index 90602ae4e9c..aa34e1cc4b5 100644 --- a/compiler/frontend/lam_constant.ml +++ b/compiler/frontend/lam_constant.ml @@ -22,27 +22,27 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type t = - | Const_js_null - | Const_js_undefined of {is_unit: bool} - | Const_js_true - | Const_js_false +(* The constant representation is owned by [Lambda]; this module is the + operations on it. *) +type t = Lambda.structured_constant = | 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 *) | Const_char of int | Const_string of {s: string; delim: External_arg_spec.delim option} | Const_float of string | Const_bigint of bool * string - | Const_pointer of string | Const_block of Lambda.tag_info * t list - | Const_some of t + | Const_constructor of Variant_runtime.tag + (** Constant constructor of a nominal variant, from its canonical + runtime descriptor. Integer-represented ones are [Const_int]. *) + | Const_polyvar of string + (** Tagless polymorphic variant; numeric-looking names are [Const_int]. *) + | Const_assertfalse | Const_module_alias -(* eventually we can remove it, since we know - [constant] is [undefined] or not -*) + | Const_js_false + | Const_js_true + | Const_js_null + | Const_some of t + | Const_js_undefined of {is_unit: bool} let rec eq_approx (x : t) (y : t) = match x with @@ -76,9 +76,9 @@ let rec eq_approx (x : t) (y : t) = match y with | Const_bigint (sy, iy) -> sx = sy && ix = iy | _ -> false) - | Const_pointer ix -> ( + | Const_polyvar ix -> ( match y with - | Const_pointer iy -> ix = iy + | Const_polyvar iy -> ix = iy | _ -> false) | Const_block (ix, ixs) -> ( match y with @@ -96,6 +96,6 @@ let rec is_allocating (c : t) : bool = | Const_block _ -> true | Const_js_null | Const_js_undefined _ | Const_js_true | Const_js_false | Const_int _ | Const_assertfalse | Const_constructor _ | Const_char _ - | Const_string _ | Const_float _ | Const_bigint _ | Const_pointer _ + | Const_string _ | Const_float _ | Const_bigint _ | Const_polyvar _ | Const_module_alias -> false diff --git a/compiler/frontend/lam_constant.mli b/compiler/frontend/lam_constant.mli index 80ed6531111..ff01439dab6 100644 --- a/compiler/frontend/lam_constant.mli +++ b/compiler/frontend/lam_constant.mli @@ -22,27 +22,27 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type t = - | Const_js_null - | Const_js_undefined of {is_unit: bool} - | Const_js_true - | Const_js_false +(* The constant representation is owned by [Lambda]; this module is the + operations on it. *) +type t = Lambda.structured_constant = | 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 *) | Const_char of int | Const_string of {s: string; delim: External_arg_spec.delim option} | Const_float of string | Const_bigint of bool * string - | Const_pointer of string | Const_block of Lambda.tag_info * t list - | Const_some of t - (* eventually we can remove it, since we know - [constant] is [undefined] or not - *) + | Const_constructor of Variant_runtime.tag + (** Constant constructor of a nominal variant, from its canonical + runtime descriptor. Integer-represented ones are [Const_int]. *) + | Const_polyvar of string + (** Tagless polymorphic variant; numeric-looking names are [Const_int]. *) + | Const_assertfalse | Const_module_alias + | Const_js_false + | Const_js_true + | Const_js_null + | Const_some of t + | Const_js_undefined of {is_unit: bool} val eq_approx : t -> t -> bool diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index e0d40a8ad5a..219214027f3 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -37,9 +37,6 @@ type tag_info = | Blk_module of string list | Blk_module_export of Ident.t list | Blk_extension - | Blk_some - | Blk_some_not_nested - (* ['a option] where ['a] can not inhabit a non-like value *) | Blk_record_ext of { fields: string array; mutable_flag: Asttypes.mutable_flag; @@ -51,7 +48,7 @@ let tag_label_of_tag_info (tag : tag_info) = match tag with | Blk_constructor {name} | Blk_record_inlined {name} -> name | Blk_tuple | Blk_poly_var | Blk_record _ | Blk_module _ | Blk_module_export _ - | Blk_extension | Blk_some | Blk_some_not_nested | Blk_record_ext _ -> + | Blk_extension | Blk_record_ext _ -> "0" let mutable_flag_of_tag_info (tag : tag_info) = @@ -61,7 +58,7 @@ let mutable_flag_of_tag_info (tag : tag_info) = | Blk_record_ext {mutable_flag} -> mutable_flag | Blk_tuple | Blk_constructor _ | Blk_poly_var | Blk_module _ - | Blk_module_export _ | Blk_extension | Blk_some_not_nested | Blk_some -> + | Blk_module_export _ | Blk_extension -> Immutable type label = Types.label_description @@ -176,6 +173,10 @@ type eliminated = Identity | Ignore type primitive = | Pdebugger | Ptypeof + | Psome + | Psome_not_nest + (** [Some x] where [x] cannot itself be [undefined], so no wrapping is + needed. *) | Pfn_arity | Pgetglobal of Ident.t (* Operations on heap blocks *) @@ -322,23 +323,24 @@ and comparison = Ceq | Cneq | Clt | Cgt | Cle | Cge and value_kind = Pgenval -type pointer_info = - | Pt_constructor of Variant_runtime.tag - | Pt_variant of {name: string} - | Pt_module_alias - | Pt_assertfalse - type structured_constant = | Const_int of int32 | Const_char of int | 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 | Const_block of tag_info * structured_constant list - | Const_false - | Const_true + | Const_constructor of Variant_runtime.tag + (** Constant constructor of a nominal variant, from its canonical + runtime descriptor. Integer-represented ones are [Const_int]. *) + | Const_polyvar of string + (** Tagless polymorphic variant; numeric-looking names are [Const_int]. *) + | Const_assertfalse + | Const_module_alias + | Const_js_false + | Const_js_true | Const_js_null + | Const_some of structured_constant | Const_js_undefined of {is_unit: bool} (** [is_unit] tells the unit value apart from JS [undefined]; both emit [undefined]. *) @@ -444,26 +446,35 @@ let const_of_typed (c : Asttypes.constant) : structured_constant = let const_unit = Const_js_undefined {is_unit = true} -(* The JS value of a constant constructor. Unit is the one constructor with a - dedicated constant, so producers cannot leave it as a pointer. *) +(* The JS value of a constant constructor: unit has its own constant, and a + constructor represented as a number is a genuine number at runtime, so + folding sees it as an ordinary integer. *) let const_constructor (tag : Variant_runtime.tag) = - if tag.name = "()" then const_unit else Const_pointer (Pt_constructor tag) + if tag.name = "()" then const_unit + else + match tag.tag_type with + | Some (Variant_runtime.Int v) -> Const_int (Int32.of_int v) + | _ -> Const_constructor tag (* A constructor with an optional shape carries no payload when constant. *) let const_shape_none = Const_js_undefined {is_unit = false} -let const_polyvar name = Const_pointer (Pt_variant {name}) - (* The JS value of a polymorphic variant's name: a numeric-looking name is a - number at runtime, anything else is a string. *) -let const_polyvar_name name = + number at runtime, anything else is a string. Used both for a tagless + variant and for the name field of one carrying a payload. *) +let const_polyvar name = if Ext_string.is_valid_hash_number name then Const_int (Ext_string.hash_number_as_i32_exn name) - else Const_string {s = name; delim = None} + else Const_polyvar name + +let const_polyvar_name name = + match const_polyvar name with + | Const_polyvar s -> Const_string {s; delim = None} + | c -> c -let const_module_alias = Const_pointer Pt_module_alias +let const_module_alias = Const_module_alias -let lambda_assert_false = Lconst (Const_pointer Pt_assertfalse) +let lambda_assert_false = Lconst Const_assertfalse let lambda_module_alias = Lconst const_module_alias diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index c5928f85b98..a3ee0f5cba2 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -50,9 +50,6 @@ type tag_info = [A, x, y] ]} *) - | Blk_some - | Blk_some_not_nested - (* ['a option] where ['a] can not inhabit a non-like value *) | Blk_record_ext of {fields: string array; mutable_flag: mutable_flag} val find_name : Parsetree.attribute -> Asttypes.label option @@ -114,12 +111,6 @@ val fld_record_extension_set : Types.label_description -> set_field_dbg_info type immediate_or_pointer = Immediate | Pointer -type pointer_info = private - | Pt_constructor of Variant_runtime.tag - | Pt_variant of {name: string} - | Pt_module_alias - | Pt_assertfalse - (* The target of a dynamic [import], resolved at translation: the argument of the import primitive is a module reference, never an expression. *) type import_source = @@ -142,6 +133,10 @@ type eliminated = Identity | Ignore type primitive = | Pdebugger | Ptypeof + | Psome + | Psome_not_nest + (** [Some x] where [x] cannot itself be [undefined], so no wrapping is + needed. *) | Pfn_arity | Pgetglobal of Ident.t (* Operations on heap blocks *) @@ -293,11 +288,18 @@ type structured_constant = | 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 | Const_block of tag_info * structured_constant list - | Const_false - | Const_true + | Const_constructor of Variant_runtime.tag + (** Constant constructor of a nominal variant, from its canonical + runtime descriptor. Integer-represented ones are [Const_int]. *) + | Const_polyvar of string + (** Tagless polymorphic variant; numeric-looking names are [Const_int]. *) + | Const_assertfalse + | Const_module_alias + | Const_js_false + | Const_js_true | Const_js_null + | Const_some of structured_constant | Const_js_undefined of {is_unit: bool} (** [is_unit] tells the unit value apart from JS [undefined]; both emit [undefined]. *) diff --git a/compiler/ml/printlambda.ml b/compiler/ml/printlambda.ml index debde84f038..8bc30c5cc8c 100644 --- a/compiler/ml/printlambda.ml +++ b/compiler/ml/printlambda.ml @@ -23,11 +23,12 @@ let rec struct_const ppf = function | 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" - | Const_pointer Pt_assertfalse -> fprintf ppf "assertfalse" + | Const_constructor {name} -> fprintf ppf "`%s" name + | Const_polyvar name -> fprintf ppf "`%s" name + | Const_module_alias -> fprintf ppf "module_alias" + | Const_assertfalse -> fprintf ppf "assertfalse" | Const_js_null -> fprintf ppf "null" + | Const_some c -> fprintf ppf "some(%a)" struct_const c | Const_js_undefined {is_unit = true} -> fprintf ppf "unit" | Const_js_undefined {is_unit = false} -> fprintf ppf "undefined" | Const_block (tag_info, []) -> @@ -39,8 +40,8 @@ let rec struct_const ppf = function List.iter (fun sc -> fprintf ppf "@ %a" struct_const sc) scl in fprintf ppf "@[<1>[%s:@ @[%a%a@]]@]" tag struct_const sc1 sconsts scl - | Const_false -> fprintf ppf "false" - | Const_true -> fprintf ppf "true" + | Const_js_false -> fprintf ppf "false" + | Const_js_true -> fprintf ppf "true" let value_kind = function | Pgenval -> "" @@ -87,8 +88,6 @@ let print_taginfo ppf = function | Blk_record {fields = ss} -> fprintf ppf "[%s]" (String.concat ";" (List.map fst (Array.to_list ss))) | Blk_module ss -> fprintf ppf "[%s]" (String.concat ";" ss) - | Blk_some -> fprintf ppf "some" - | Blk_some_not_nested -> fprintf ppf "some_not_nested" | Blk_module_export _ -> fprintf ppf "module/exports" | Blk_record_inlined {fields = ss} -> fprintf ppf "[%s]" (String.concat ";" (List.map fst (Array.to_list ss))) @@ -96,6 +95,8 @@ let print_taginfo ppf = function let primitive ppf = function | Pdebugger -> fprintf ppf "debugger" | Ptypeof -> fprintf ppf "typeof" + | Psome -> fprintf ppf "some" + | Psome_not_nest -> fprintf ppf "some_not_nest" | Pfn_arity -> fprintf ppf "fn.length" | Pgetglobal id -> fprintf ppf "global %a" Ident.print id | Pmakeblock taginfo -> fprintf ppf "makeblock %a" print_taginfo taginfo diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 6e6e1e1d069..48cb57295f0 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -474,8 +474,8 @@ let lambda_of_inline_const (c : External_ffi_types.inline_const) : Lambda.structured_constant = match c with | Const_str {s; delim} -> Const_string {s; delim} - | Const_bool true -> Const_true - | Const_bool false -> Const_false + | Const_bool true -> Const_js_true + | Const_bool false -> Const_js_false | Const_int i -> Const_int i | Const_bigint {negative; digits} -> Const_bigint (negative, digits) | Const_float f -> Const_float f @@ -1197,8 +1197,8 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = let ll = transl_list el in try Lconst (Const_block (Blk_tuple, List.map extract_constant ll)) with Not_constant -> Lprim (Pmakeblock Blk_tuple, ll, e.exp_loc)) - | Texp_construct ({txt = Lident "false"}, _, []) -> Lconst Const_false - | Texp_construct ({txt = Lident "true"}, _, []) -> Lconst Const_true + | Texp_construct ({txt = Lident "false"}, _, []) -> Lconst Const_js_false + | Texp_construct ({txt = Lident "true"}, _, []) -> Lconst Const_js_true | Texp_construct (_, cstr, args) -> ( let ll = transl_list args in if cstr.cstr_inlined <> None then @@ -1225,23 +1225,30 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = match ll with | [value] -> value | _ -> assert false + else if Datarepr.constructor_has_optional_shape cstr then + let value = + match ll with + | [value] -> value + | _ -> assert false + in + let primitive : Lambda.primitive = + match args with + | [arg] + when Typeopt.type_cannot_contain_undefined arg.exp_type + arg.exp_env -> + Psome_not_nest + | _ -> Psome + in + try Lconst (Const_some (extract_constant value)) + with Not_constant -> Lprim (primitive, ll, e.exp_loc) else let tag_info : Lambda.tag_info = - if Datarepr.constructor_has_optional_shape cstr then - match args with - | [arg] - when Typeopt.type_cannot_contain_undefined arg.exp_type - arg.exp_env -> - (* Format.fprintf Format.err_formatter "@[special boxingl@]@."; *) - Blk_some_not_nested - | _ -> Blk_some - else - Blk_constructor - { - name = cstr.cstr_name; - num_nonconst = num_nonconst_constructors cstr; - runtime; - } + Blk_constructor + { + name = cstr.cstr_name; + num_nonconst = num_nonconst_constructors cstr; + runtime; + } in try Lconst (Const_block (tag_info, List.map extract_constant ll)) with Not_constant -> Lprim (Pmakeblock tag_info, ll, e.exp_loc)) From 0ca8d9a933c08bfefe38f96df3c9b95c2d7db85c Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 1 Sep 2026 10:27:11 +0200 Subject: [PATCH 06/46] Delete the curried-application machinery MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit A call whose arity was unknown used to be emitted as `Primitive_curry._N(f, …)`, which discovered the real arity at runtime and applied, re-applied, or returned a closure collecting more arguments. Uncurried-by-default plus structural arity removed the need: every call site now knows how many arguments the callee takes. The state that drove it is unreachable. `ap_status` is only ever set to `App_uncurry` (conversion) or `App_infer_full` (alpha conversion), so `App_na` - the only source of `arity = NA` outside the applier it gated - is never constructed. With it gone, `Full` is the only value `Js_call_info.arity` can hold, so the field goes too, and with it `Curry_gen`, the curried print branch, and the `curry_id` import injection. `%curry_apply1`..`8` were declared only by `Primitive_curry.res` and used only by that module's own fast paths, so the primitive and its table entries go with the runtime module. `Pcurry_apply` already discarded its arity during conversion, making it `Pjs_apply` with a vestigial integer. Generated JavaScript is unchanged for the runtime, Belt, tests/tests and gentype, apart from the deleted module itself. `packages/artifacts.json` is regenerated. Signed-Off-By: Cristiano Calcagno Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/core/js_block_runtime.ml | 3 - compiler/core/js_call_info.ml | 13 +- compiler/core/js_call_info.mli | 6 +- compiler/core/js_dump.ml | 151 ++---- compiler/core/lam.ml | 2 +- compiler/core/lam.mli | 2 +- compiler/core/lam_compile.ml | 74 +-- compiler/core/lam_compile_external_call.ml | 14 +- compiler/core/lam_compile_primitive.ml | 3 +- compiler/core/lam_convert.ml | 1 - compiler/ext/primitive_modules.ml | 2 - compiler/ml/lambda.ml | 1 - compiler/ml/lambda.mli | 1 - compiler/ml/printlambda.ml | 1 - compiler/ml/translcore.ml | 8 - .../@rescript/runtime/Primitive_curry.res | 336 -------------- .../@rescript/runtime/Primitive_curry.resi | 32 -- .../runtime/lib/es6/Primitive_curry.mjs | 438 ------------------ .../runtime/lib/js/Primitive_curry.cjs | 436 ----------------- packages/artifacts.json | 6 - 20 files changed, 66 insertions(+), 1464 deletions(-) delete mode 100644 packages/@rescript/runtime/Primitive_curry.res delete mode 100644 packages/@rescript/runtime/Primitive_curry.resi delete mode 100644 packages/@rescript/runtime/lib/es6/Primitive_curry.mjs delete mode 100644 packages/@rescript/runtime/lib/js/Primitive_curry.cjs diff --git a/compiler/core/js_block_runtime.ml b/compiler/core/js_block_runtime.ml index b328237ec96..1d235210f5d 100644 --- a/compiler/core/js_block_runtime.ml +++ b/compiler/core/js_block_runtime.ml @@ -24,10 +24,7 @@ let option_id = Ident.create_persistent Primitive_modules.option -let curry_id = Ident.create_persistent Primitive_modules.curry - let check_additional_id (x : J.expression) : Ident.t option = match x.expression_desc with | Optional_block (_, false) -> Some option_id - | Call (_, _, {arity = NA}) -> Some curry_id | _ -> None diff --git a/compiler/core/js_call_info.ml b/compiler/core/js_call_info.ml index c58aad901f0..09a991636b0 100644 --- a/compiler/core/js_call_info.ml +++ b/compiler/core/js_call_info.ml @@ -22,8 +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. *) -type arity = Full | NA - type call_info = | Call_ml (* called by plain ocaml expression *) | Call_builtin_runtime (* built-in externals *) @@ -33,15 +31,12 @@ type call_info = {[ fun x y -> (f x y) === f ]} when [f] is an atom *) -type t = {call_info: call_info; arity: arity; call_transformed_jsx: bool} - -let dummy = {arity = NA; call_info = Call_na; call_transformed_jsx = false} +type t = {call_info: call_info; call_transformed_jsx: bool} let builtin_runtime_call = - {arity = Full; call_info = Call_builtin_runtime; call_transformed_jsx = false} + {call_info = Call_builtin_runtime; call_transformed_jsx = false} -let ml_full_call = - {arity = Full; call_info = Call_ml; call_transformed_jsx = false} +let ml_full_call = {call_info = Call_ml; call_transformed_jsx = false} let na_full_call transformed_jsx = - {arity = Full; call_info = Call_na; call_transformed_jsx = transformed_jsx} + {call_info = Call_na; call_transformed_jsx = transformed_jsx} diff --git a/compiler/core/js_call_info.mli b/compiler/core/js_call_info.mli index ff0d3ad875e..3696e778ce8 100644 --- a/compiler/core/js_call_info.mli +++ b/compiler/core/js_call_info.mli @@ -24,8 +24,6 @@ (** Type for collecting call site information, used in JS IR *) -type arity = Full | NA - type call_info = | Call_ml (* called by plain ocaml expression *) | Call_builtin_runtime (* built-in externals *) @@ -35,9 +33,7 @@ type call_info = {[ fun x y -> f x y === f ]} when [f] is an atom *) -type t = {call_info: call_info; arity: arity; call_transformed_jsx: bool} - -val dummy : t +type t = {call_info: call_info; call_transformed_jsx: bool} val builtin_runtime_call : t diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index 048c04bc179..b24c5b8a587 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -56,7 +56,6 @@ module S = Js_stmt_make module L = Js_dump_lit (* There modules are dynamically inserted in the last stage - {Caml_curry} {Caml_option} They can appear anywhere so even if you have a module @@ -72,26 +71,6 @@ module L = Js_dump_lit (our call Js_fun_env.get_unbounded env) is not precise *) -module Curry_gen = struct - let pp_curry_dot f = - P.string f Primitive_modules.curry; - P.string f L.dot - - let pp_optimize_curry (f : P.t) (len : int) = - pp_curry_dot f; - P.string f "__"; - P.string f (Printf.sprintf "%d" len) - - let pp_app_any (f : P.t) = - pp_curry_dot f; - P.string f "app" - - let pp_app (f : P.t) (len : int) = - pp_curry_dot f; - P.string f "_"; - P.string f (Printf.sprintf "%d" len) -end - type cxt = Ext_pp_scope.t let semi f = P.string f L.semi @@ -279,12 +258,6 @@ f/122 --> else check last bumped id, increase it and register *) -(** - Turn [function f (x,y) { return a (x,y)} ] into [Curry.__2(a)], - The idea is that [Curry.__2] will guess the arity of [a], if it does - hit, then there is no cost when passed -*) - let is_var (b : J.expression) a = match b.expression_desc with | Var (Id i) -> Ident.same i a @@ -313,11 +286,7 @@ let default_fn_exp_state = No_name {single_arg = false} (* TODO: refactoring Note that {!pp_function} could print both statement and expression when [No_name] is given *) -let rec try_optimize_curry cxt f len function_id = - Curry_gen.pp_optimize_curry f len; - P.paren_group f 1 (fun _ -> expression ~level:1 cxt f function_id) - -and pp_function ~return_unit ~async ~is_method ?directive cxt (f : P.t) +let rec pp_function ~return_unit ~async ~is_method ?directive cxt (f : P.t) ~fn_state (l : Ident.t list) (b : J.block) (env : Js_fun_env.t) : cxt = match b with | [ @@ -327,35 +296,28 @@ and pp_function ~return_unit ~async ~is_method ?directive cxt (f : P.t) { expression_desc = Call - ( ({expression_desc = Var v; _} as function_id), + ( {expression_desc = Var v; _}, ls, - { - arity = (Full | NA) as arity (* see #234*); - (* TODO: need a case to justify it*) - call_info = Call_builtin_runtime | Call_ml; - } ); + {call_info = Call_builtin_runtime | Call_ml} ); }; }; ] - when (* match such case: - {[ function(x,y){ return u(x,y) } ]} - it can be optimized in to either [u] or [Curry.__n(u)] - *) + when (* Eta reduce a wrapper around a saturated call: + {[ function(x,y){ return u(x,y) } ]} prints as [u]. + Only for a ReScript callee of exactly this arity: [Call_na] is an + FFI name, where the wrapper truncates extra arguments the JS callee + would otherwise see, defers the name's resolution to call time, and + keeps it from capturing a local of the same name. *) (not is_method) && params_match_call l ls v -> ( - let optimize len ~p cxt f v = - if p then try_optimize_curry cxt f len function_id else vident cxt f v - in - let len = List.length l in - (* length *) match fn_state with | Name_top i | Name_non_top i -> let cxt = pp_var_assign cxt f i in - let cxt = optimize len ~p:(arity = NA && len <= 8) cxt f v in + let cxt = vident cxt f v in semi f; cxt | Is_return | No_name _ -> if fn_state = Is_return then return_sp f; - optimize len ~p:(arity = NA && len <= 8) cxt f v) + vident cxt f v) | _ -> let set_env : Set_ident.t = (* identifiers will be printed following*) @@ -685,61 +647,46 @@ and expression_desc cxt ~(level : int) f x : cxt = | _ -> (* This should not happen, we fallback to the general case *) expression_desc cxt ~level f - (Call - ( e, - el, - {call_transformed_jsx = false; arity = Full; call_info = Call_ml} - ))) - | Call (e, el, info) -> + (Call (e, el, {call_transformed_jsx = false; call_info = Call_ml}))) + | Call (e, el, _info) -> P.cond_paren_group f (level > 15) (fun _ -> P.group f 0 (fun _ -> - match (info, el) with - | {arity = Full}, _ | _, [] -> - let cxt = - P.cond_paren_group f - (match e.expression_desc with - | Fun _ -> true - | _ -> false) - (fun () -> expression ~level:15 cxt f e) - in - P.paren_group f 0 (fun _ -> - match el with - | [ - { - expression_desc = - Fun - { - is_method; - params; - body; - env; - return_unit; - async; - directive; - }; - }; - ] -> - pp_function ?directive ~is_method ~return_unit ~async - ~fn_state:(No_name {single_arg = true}) - cxt f params body env - | _ -> - let el = - match el with - | [e] when e.expression_desc = Undefined {is_unit = true} - -> - (* omit passing undefined when the call is f() *) - [] - | _ -> el - in - arguments cxt f el) - | _, _ -> - let len = List.length el in - if 1 <= len && len <= 8 then ( - Curry_gen.pp_app f len; - P.paren_group f 0 (fun _ -> arguments cxt f (e :: el))) - else ( - Curry_gen.pp_app_any f; - P.paren_group f 0 (fun _ -> arguments cxt f [e; E.array el])))) + let cxt = + P.cond_paren_group f + (match e.expression_desc with + | Fun _ -> true + | _ -> false) + (fun () -> expression ~level:15 cxt f e) + in + P.paren_group f 0 (fun _ -> + match el with + | [ + { + expression_desc = + Fun + { + is_method; + params; + body; + env; + return_unit; + async; + directive; + }; + }; + ] -> + pp_function ?directive ~is_method ~return_unit ~async + ~fn_state:(No_name {single_arg = true}) + cxt f params body env + | _ -> + let el = + match el with + | [e] when e.expression_desc = Undefined {is_unit = true} -> + (* omit passing undefined when the call is f() *) + [] + | _ -> el + in + arguments 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/lam.ml b/compiler/core/lam.ml index 02264fdd777..3351c67ba32 100644 --- a/compiler/core/lam.ml +++ b/compiler/core/lam.ml @@ -23,7 +23,7 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) type ident = Ident.t -type apply_status = App_na | App_infer_full | App_uncurry +type apply_status = App_infer_full | App_uncurry type ap_info = { ap_loc: Location.t; diff --git a/compiler/core/lam.mli b/compiler/core/lam.mli index 82dbd1e0d6d..5793c6c97c8 100644 --- a/compiler/core/lam.mli +++ b/compiler/core/lam.mli @@ -22,7 +22,7 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type apply_status = App_na | App_infer_full | App_uncurry +type apply_status = App_infer_full | App_uncurry type ap_info = { ap_loc: Location.t; diff --git a/compiler/core/lam_compile.ml b/compiler/core/lam_compile.ml index ffbdc779051..c3aba23ec93 100644 --- a/compiler/core/lam_compile.ml +++ b/compiler/core/lam_compile.ml @@ -93,47 +93,8 @@ let call_info_of_ap_status call_transformed_jsx (ap_status : Lam.apply_status) : Js_call_info.t = (* XXX *) match ap_status with - | App_infer_full -> {arity = Full; call_info = Call_ml; call_transformed_jsx} - | App_uncurry -> {arity = Full; call_info = Call_na; call_transformed_jsx} - | App_na -> {arity = NA; call_info = Call_ml; call_transformed_jsx} - -let rec apply_with_arity_aux (fn : J.expression) (arity : int list) - (args : E.t list) (len : int) : E.t = - if len = 0 then fn (* All arguments consumed so far *) - else - match arity with - | x :: rest -> - let x = if x = 0 then 1 else x in - (* Relax when x = 0 *) - if len >= x then - let first_part, continue = Ext_list.split_at args x in - apply_with_arity_aux - (E.call ~info:Js_call_info.ml_full_call fn first_part) - rest continue (len - x) - else if - (* GPR #1423 *) - Ext_list.for_all args Js_analyzer.is_okay_to_duplicate - then - let params = - Ext_list.init (x - len) (fun _ -> Ext_ident.create "param") - in - E.ocaml_fun params ~return_unit:false (* unknown info *) - ~async:false ~one_unit_arg:false - [ - S.return_stmt - (E.call ~info:Js_call_info.ml_full_call fn - (Ext_list.append args @@ Ext_list.map params E.var)); - ] - else E.call ~info:Js_call_info.dummy fn args - (* alpha conversion now? -- - Since we did an alpha conversion before so it is not here - *) - | [] -> - (* can not happen, unless it's an exception ? *) - E.call ~info:Js_call_info.dummy fn args - -let apply_with_arity ~arity fn args = - apply_with_arity_aux fn arity args (List.length args) + | App_infer_full -> {call_info = Call_ml; call_transformed_jsx} + | App_uncurry -> {call_info = Call_na; call_transformed_jsx} let change_tail_type_in_try (x : Lam_compile_context.tail_type) : Lam_compile_context.tail_type = @@ -383,17 +344,11 @@ let compile output_prefix = let fn = E.ml_var_dot module_id ident_info.name in let expression = - match appinfo.ap_info.ap_status with - | (App_infer_full | App_uncurry) as ap_status -> - E.call - ~info:(call_info_of_ap_status appinfo.ap_transformed_jsx ap_status) - fn args - | App_na -> ( - match ident_info.arity with - | Submodule _ | Single Arity_na -> - E.call ~info:Js_call_info.dummy fn args - | Single x -> - apply_with_arity fn ~arity:(Lam_arity.extract_arity x) args) + E.call + ~info: + (call_info_of_ap_status appinfo.ap_transformed_jsx + appinfo.ap_info.ap_status) + fn args in let expression = with_source_loc appinfo.ap_info.ap_loc expression in Js_output.output_of_block_and_expression lambda_cxt.continuation args_code @@ -1567,21 +1522,6 @@ let compile output_prefix = (Ext_list.append_one b (S.if_ e then_output ~else_:else_output)))) and compile_apply (appinfo : Lam.apply) (lambda_cxt : Lam_compile_context.t) = match appinfo with - | { - ap_func = - Lapply {ap_func; ap_args; ap_info = {ap_status = App_na; ap_inlined}}; - ap_info = {ap_status = App_na} as outer_ap_info; - ap_transformed_jsx; - } -> - (* After inlining, we can generate such code, see {!Ari_regress_test}*) - let ap_info = - if outer_ap_info.ap_inlined = ap_inlined then outer_ap_info - else {outer_ap_info with ap_inlined} - in - compile_lambda lambda_cxt - (Lam.apply ap_func - (Ext_list.append ap_args appinfo.ap_args) - ap_info ~ap_transformed_jsx) (* External function call: it can not be tailcall in this case*) | { ap_func = diff --git a/compiler/core/lam_compile_external_call.ml b/compiler/core/lam_compile_external_call.ml index bfc4c24364c..5979215b04c 100644 --- a/compiler/core/lam_compile_external_call.ml +++ b/compiler/core/lam_compile_external_call.ml @@ -335,12 +335,7 @@ let translate_ffi ?(transformed_jsx = false) (cxt : Lam_compile_context.t) let args, eff = assemble_args_no_splice arg_types args in add_eff eff @@ E.call - ~info: - { - arity = Full; - call_info = Call_na; - call_transformed_jsx = transformed_jsx; - } + ~info:{call_info = Call_na; call_transformed_jsx = transformed_jsx} fn args | Decl_new {name = fn}, _ -> if splice then @@ -368,12 +363,7 @@ let translate_ffi ?(transformed_jsx = false) (cxt : Lam_compile_context.t) add_eff eff (let self = translate_scoped_access scopes self in E.call - ~info: - { - arity = Full; - call_info = Call_na; - call_transformed_jsx = transformed_jsx; - } + ~info:{call_info = Call_na; call_transformed_jsx = transformed_jsx} (E.dot self name) args) else let args, eff = assemble_args_no_splice arg_types args in diff --git a/compiler/core/lam_compile_primitive.ml b/compiler/core/lam_compile_primitive.ml index 789ed9e5ed9..28440be2253 100644 --- a/compiler/core/lam_compile_primitive.ml +++ b/compiler/core/lam_compile_primitive.ml @@ -48,8 +48,7 @@ let get_module_system () = | [module_system] -> module_system | _ -> Commonjs -let call_info = - {Js_call_info.arity = Full; call_info = Call_na; call_transformed_jsx = false} +let call_info = {Js_call_info.call_info = Call_na; call_transformed_jsx = false} let import_of_path path = E.call ~info:call_info (E.js_global "import") [E.str path] diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index a8ed338bc75..1ae0dce1d81 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -160,7 +160,6 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = | Phash_mixint -> prim ~primitive:Phash_mixint ~args loc | Phash_mixstring -> prim ~primitive:Phash_mixstring ~args loc | Phash_finalmix -> prim ~primitive:Phash_finalmix ~args loc - | Pcurry_apply _ -> prim ~primitive:Pjs_apply ~args loc | Pis_poly_var_block -> prim ~primitive:Pis_poly_var_block ~args loc | Pjs_call {prim_name; arg_types; ffi; transformed_jsx} -> prim diff --git a/compiler/ext/primitive_modules.ml b/compiler/ext/primitive_modules.ml index 3a567de5242..dc87480a872 100644 --- a/compiler/ext/primitive_modules.ml +++ b/compiler/ext/primitive_modules.ml @@ -50,8 +50,6 @@ let hash = "Primitive_hash" let exceptions = "Primitive_exceptions" -let curry = "Primitive_curry" - let util = "Primitive_util" let js_extern = "Primitive_js_extern" diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index 219214027f3..07361620803 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -306,7 +306,6 @@ type primitive = (* exn *) | Pcreate_extension of string (* js *) - | Pcurry_apply of int | Pjscomp of comparison | Pnull_to_opt | Pnullable_to_opt diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index a3ee0f5cba2..ba0e64f4a1a 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -266,7 +266,6 @@ type primitive = (* exn *) | Pcreate_extension of string (* js *) - | Pcurry_apply of int | Pjscomp of comparison | Pnull_to_opt | Pnullable_to_opt diff --git a/compiler/ml/printlambda.ml b/compiler/ml/printlambda.ml index 8bc30c5cc8c..7d382f1ed2a 100644 --- a/compiler/ml/printlambda.ml +++ b/compiler/ml/printlambda.ml @@ -235,7 +235,6 @@ let primitive ppf = function | Phash_mixint -> fprintf ppf "hash_mix_int" | Phash_mixstring -> fprintf ppf "hash_mix_string" | Phash_finalmix -> fprintf ppf "hash_final_mix" - | Pcurry_apply i -> fprintf ppf "apply[%d]" i | Pjscomp Ceq -> fprintf ppf "==" | Pjscomp Cneq -> fprintf ppf "!=" | Pjscomp Clt -> fprintf ppf "<" diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 48cb57295f0..bdf8061f7ad 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -390,14 +390,6 @@ let primitive_builtins : (string * Lambda.builtin) array = ("%null_to_opt", Pnull_to_opt); ("%nullable_to_opt", Pnullable_to_opt); ("%function_arity", Pfn_arity); - ("%curry_apply1", Pcurry_apply 1); - ("%curry_apply2", Pcurry_apply 2); - ("%curry_apply3", Pcurry_apply 3); - ("%curry_apply4", Pcurry_apply 4); - ("%curry_apply5", Pcurry_apply 5); - ("%curry_apply6", Pcurry_apply 6); - ("%curry_apply7", Pcurry_apply 7); - ("%curry_apply8", Pcurry_apply 8); ("%makemutablelist", Pmakelist); ("%unsafe_to_method", Pjs_fn_method); (* Compiler internals, never expose to ReScript files *) diff --git a/packages/@rescript/runtime/Primitive_curry.res b/packages/@rescript/runtime/Primitive_curry.res deleted file mode 100644 index 9bf7acb6fb2..00000000000 --- a/packages/@rescript/runtime/Primitive_curry.res +++ /dev/null @@ -1,336 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017- Hongbo Zhang, Authors of ReScript - * - * SPDX-License-Identifier: MIT - */ - -module Array = Primitive_array_extern -module Obj = Primitive_object_extern - -@@uncurried - -external function_arity: 'a => int = "%function_arity" - -@send external apply_args: ('a => 'b, Primitive_js_extern.null<_>, array<_>) => 'b = "apply" -let apply_args = (f, args) => apply_args(f, Primitive_js_extern.null, args) - -/* Public */ -let rec app = (f, args) => { - let init_arity = function_arity(f) - let arity = if init_arity == 0 { - 1 - } else { - init_arity - } /* arity fixing */ - let len = Array.length(args) - let d = arity - len - if d == 0 { - apply_args(f, args) /* f.apply (null,args) */ - } else if d < 0 { - /* TODO: could avoid copy by tracking the index */ - app(Obj.magic(apply_args(f, Array.slice(args, 0, arity))), Array.slice(args, arity, len)) - } else { - Obj.magic(x => app(f, Array.concat(args, [x]))) - } -} - -external apply1: ('a0 => 'a1, 'a0) => 'a1 = "%curry_apply1" -external apply2: (('a0, 'a1) => 'a2, 'a0, 'a1) => 'a2 = "%curry_apply2" -external apply3: (('a0, 'a1, 'a2) => 'a3, 'a0, 'a1, 'a2) => 'a3 = "%curry_apply3" -external apply4: (('a0, 'a1, 'a2, 'a3) => 'a4, 'a0, 'a1, 'a2, 'a3) => 'a4 = "%curry_apply4" -external apply5: (('a0, 'a1, 'a2, 'a3, 'a4) => 'a5, 'a0, 'a1, 'a2, 'a3, 'a4) => 'a5 = - "%curry_apply5" -external apply6: (('a0, 'a1, 'a2, 'a3, 'a4, 'a5) => 'a6, 'a0, 'a1, 'a2, 'a3, 'a4, 'a5) => 'a6 = - "%curry_apply6" -external apply7: ( - ('a0, 'a1, 'a2, 'a3, 'a4, 'a5, 'a6) => 'a7, - 'a0, - 'a1, - 'a2, - 'a3, - 'a4, - 'a5, - 'a6, -) => 'a7 = "%curry_apply7" -external apply8: ( - ('a0, 'a1, 'a2, 'a3, 'a4, 'a5, 'a6, 'a7) => 'a8, - 'a0, - 'a1, - 'a2, - 'a3, - 'a4, - 'a5, - 'a6, - 'a7, -) => 'a8 = "%curry_apply8" - -let curry_1 = (o, a0, arity) => - switch arity { - | 1 => apply1(Obj.magic(o), a0) - | 2 => param => apply2(Obj.magic(o), a0, param) - | 3 => Obj.magic((param, \"param$1") => apply3(Obj.magic(o), a0, param, \"param$1")) - | 4 => - Obj.magic((param, \"param$1", \"param$2") => - apply4(Obj.magic(o), a0, param, \"param$1", \"param$2") - ) - | 5 => - Obj.magic((param, \"param$1", \"param$2", \"param$3") => - apply5(Obj.magic(o), a0, param, \"param$1", \"param$2", \"param$3") - ) - | 6 => - Obj.magic((param, \"param$1", \"param$2", \"param$3", \"param$4") => - apply6(Obj.magic(o), a0, param, \"param$1", \"param$2", \"param$3", \"param$4") - ) - | 7 => - Obj.magic((param, \"param$1", \"param$2", \"param$3", \"param$4", \"param$5") => - apply7(Obj.magic(o), a0, param, \"param$1", \"param$2", \"param$3", \"param$4", \"param$5") - ) - | _ => Obj.magic(app(o, [a0])) - } - -let _1 = (o, a0) => { - let arity = function_arity(o) - if arity == 1 { - apply1(o, a0) - } else { - curry_1(o, a0, arity) - } -} - -let __1 = o => { - let arity = function_arity(o) - if arity == 1 { - o - } else { - a0 => _1(o, a0) - } -} - -let curry_2 = (o, a0, a1, arity) => - switch arity { - | 1 => app(apply1(Obj.magic(o), a0), [a1]) - | 2 => apply2(Obj.magic(o), a0, a1) - | 3 => param => apply3(Obj.magic(o), a0, a1, param) - | 4 => Obj.magic((param, \"param$1") => apply4(Obj.magic(o), a0, a1, param, \"param$1")) - | 5 => - Obj.magic((param, \"param$1", \"param$2") => - apply5(Obj.magic(o), a0, a1, param, \"param$1", \"param$2") - ) - | 6 => - Obj.magic((param, \"param$1", \"param$2", \"param$3") => - apply6(Obj.magic(o), a0, a1, param, \"param$1", \"param$2", \"param$3") - ) - | 7 => - Obj.magic((param, \"param$1", \"param$2", \"param$3", \"param$4") => - apply7(Obj.magic(o), a0, a1, param, \"param$1", \"param$2", \"param$3", \"param$4") - ) - | _ => Obj.magic(app(o, [a0, a1])) - } - -let _2 = (o, a0, a1) => { - let arity = function_arity(o) - if arity == 2 { - apply2(o, a0, a1) - } else { - curry_2(Obj.magic(o), a0, a1, arity) - } -} - -let __2 = o => { - let arity = function_arity(o) - if arity == 2 { - o - } else { - (a0, a1) => _2(o, a0, a1) - } -} - -let curry_3 = (o, a0, a1, a2, arity) => - switch arity { - | 1 => app(apply1(Obj.magic(o), a0), [a1, a2]) - | 2 => app(apply2(Obj.magic(o), a0, a1), [a2]) - | 3 => apply3(Obj.magic(o), a0, a1, a2) - | 4 => param => apply4(Obj.magic(o), a0, a1, a2, param) - | 5 => Obj.magic((param, \"param$1") => apply5(Obj.magic(o), a0, a1, a2, param, \"param$1")) - | 6 => - Obj.magic((param, \"param$1", \"param$2") => - apply6(Obj.magic(o), a0, a1, a2, param, \"param$1", \"param$2") - ) - | 7 => - Obj.magic((param, \"param$1", \"param$2", \"param$3") => - apply7(Obj.magic(o), a0, a1, a2, param, \"param$1", \"param$2", \"param$3") - ) - | _ => Obj.magic(app(o, [a0, a1, a2])) - } - -let _3 = (o, a0, a1, a2) => { - let arity = function_arity(o) - if arity == 3 { - apply3(o, a0, a1, a2) - } else { - curry_3(Obj.magic(o), a0, a1, a2, arity) - } -} - -let __3 = o => { - let arity = function_arity(o) - if arity == 3 { - o - } else { - (a0, a1, a2) => _3(o, a0, a1, a2) - } -} - -let curry_4 = (o, a0, a1, a2, a3, arity) => - switch arity { - | 1 => app(apply1(Obj.magic(o), a0), [a1, a2, a3]) - | 2 => app(apply2(Obj.magic(o), a0, a1), [a2, a3]) - | 3 => app(apply3(Obj.magic(o), a0, a1, a2), [a3]) - | 4 => apply4(Obj.magic(o), a0, a1, a2, a3) - | 5 => param => apply5(Obj.magic(o), a0, a1, a2, a3, param) - | 6 => Obj.magic((param, \"param$1") => apply6(Obj.magic(o), a0, a1, a2, a3, param, \"param$1")) - | 7 => - Obj.magic((param, \"param$1", \"param$2") => - apply7(Obj.magic(o), a0, a1, a2, a3, param, \"param$1", \"param$2") - ) - | _ => Obj.magic(app(o, [a0, a1, a2, a3])) - } - -let _4 = (o, a0, a1, a2, a3) => { - let arity = function_arity(o) - if arity == 4 { - apply4(o, a0, a1, a2, a3) - } else { - curry_4(Obj.magic(o), a0, a1, a2, a3, arity) - } -} - -let __4 = o => { - let arity = function_arity(o) - if arity == 4 { - o - } else { - (a0, a1, a2, a3) => _4(o, a0, a1, a2, a3) - } -} - -let curry_5 = (o, a0, a1, a2, a3, a4, arity) => - switch arity { - | 1 => app(apply1(Obj.magic(o), a0), [a1, a2, a3, a4]) - | 2 => app(apply2(Obj.magic(o), a0, a1), [a2, a3, a4]) - | 3 => app(apply3(Obj.magic(o), a0, a1, a2), [a3, a4]) - | 4 => app(apply4(Obj.magic(o), a0, a1, a2, a3), [a4]) - | 5 => apply5(Obj.magic(o), a0, a1, a2, a3, a4) - | 6 => param => apply6(Obj.magic(o), a0, a1, a2, a3, a4, param) - | 7 => - Obj.magic((param, \"param$1") => apply7(Obj.magic(o), a0, a1, a2, a3, a4, param, \"param$1")) - | _ => Obj.magic(app(o, [a0, a1, a2, a3, a4])) - } - -let _5 = (o, a0, a1, a2, a3, a4) => { - let arity = function_arity(o) - if arity == 5 { - apply5(o, a0, a1, a2, a3, a4) - } else { - curry_5(Obj.magic(o), a0, a1, a2, a3, a4, arity) - } -} - -let __5 = o => { - let arity = function_arity(o) - if arity == 5 { - o - } else { - (a0, a1, a2, a3, a4) => _5(o, a0, a1, a2, a3, a4) - } -} - -let curry_6 = (o, a0, a1, a2, a3, a4, a5, arity) => - switch arity { - | 1 => app(apply1(Obj.magic(o), a0), [a1, a2, a3, a4, a5]) - | 2 => app(apply2(Obj.magic(o), a0, a1), [a2, a3, a4, a5]) - | 3 => app(apply3(Obj.magic(o), a0, a1, a2), [a3, a4, a5]) - | 4 => app(apply4(Obj.magic(o), a0, a1, a2, a3), [a4, a5]) - | 5 => app(apply5(Obj.magic(o), a0, a1, a2, a3, a4), [a5]) - | 6 => apply6(Obj.magic(o), a0, a1, a2, a3, a4, a5) - | 7 => param => apply7(Obj.magic(o), a0, a1, a2, a3, a4, a5, param) - | _ => Obj.magic(app(o, [a0, a1, a2, a3, a4, a5])) - } - -let _6 = (o, a0, a1, a2, a3, a4, a5) => { - let arity = function_arity(o) - if arity == 6 { - apply6(o, a0, a1, a2, a3, a4, a5) - } else { - curry_6(Obj.magic(o), a0, a1, a2, a3, a4, a5, arity) - } -} - -let __6 = o => { - let arity = function_arity(o) - if arity == 6 { - o - } else { - (a0, a1, a2, a3, a4, a5) => _6(o, a0, a1, a2, a3, a4, a5) - } -} - -let curry_7 = (o, a0, a1, a2, a3, a4, a5, a6, arity) => - switch arity { - | 1 => app(apply1(Obj.magic(o), a0), [a1, a2, a3, a4, a5, a6]) - | 2 => app(apply2(Obj.magic(o), a0, a1), [a2, a3, a4, a5, a6]) - | 3 => app(apply3(Obj.magic(o), a0, a1, a2), [a3, a4, a5, a6]) - | 4 => app(apply4(Obj.magic(o), a0, a1, a2, a3), [a4, a5, a6]) - | 5 => app(apply5(Obj.magic(o), a0, a1, a2, a3, a4), [a5, a6]) - | 6 => app(apply6(Obj.magic(o), a0, a1, a2, a3, a4, a5), [a6]) - | 7 => apply7(Obj.magic(o), a0, a1, a2, a3, a4, a5, a6) - | _ => Obj.magic(app(o, [a0, a1, a2, a3, a4, a5, a6])) - } - -let _7 = (o, a0, a1, a2, a3, a4, a5, a6) => { - let arity = function_arity(o) - if arity == 7 { - apply7(o, a0, a1, a2, a3, a4, a5, a6) - } else { - curry_7(Obj.magic(o), a0, a1, a2, a3, a4, a5, a6, arity) - } -} - -let __7 = o => { - let arity = function_arity(o) - if arity == 7 { - o - } else { - (a0, a1, a2, a3, a4, a5, a6) => _7(o, a0, a1, a2, a3, a4, a5, a6) - } -} - -let curry_8 = (o, a0, a1, a2, a3, a4, a5, a6, a7, arity) => - switch arity { - | 1 => app(apply1(Obj.magic(o), a0), [a1, a2, a3, a4, a5, a6, a7]) - | 2 => app(apply2(Obj.magic(o), a0, a1), [a2, a3, a4, a5, a6, a7]) - | 3 => app(apply3(Obj.magic(o), a0, a1, a2), [a3, a4, a5, a6, a7]) - | 4 => app(apply4(Obj.magic(o), a0, a1, a2, a3), [a4, a5, a6, a7]) - | 5 => app(apply5(Obj.magic(o), a0, a1, a2, a3, a4), [a5, a6, a7]) - | 6 => app(apply6(Obj.magic(o), a0, a1, a2, a3, a4, a5), [a6, a7]) - | 7 => app(apply7(Obj.magic(o), a0, a1, a2, a3, a4, a5, a6), [a7]) - | _ => Obj.magic(app(o, [a0, a1, a2, a3, a4, a5, a6, a7])) - } - -let _8 = (o, a0, a1, a2, a3, a4, a5, a6, a7) => { - let arity = function_arity(o) - if arity == 8 { - apply8(o, a0, a1, a2, a3, a4, a5, a6, a7) - } else { - curry_8(Obj.magic(o), a0, a1, a2, a3, a4, a5, a6, a7, arity) - } -} - -let __8 = o => { - let arity = function_arity(o) - if arity == 8 { - o - } else { - (a0, a1, a2, a3, a4, a5, a6, a7) => _8(o, a0, a1, a2, a3, a4, a5, a6, a7) - } -} diff --git a/packages/@rescript/runtime/Primitive_curry.resi b/packages/@rescript/runtime/Primitive_curry.resi deleted file mode 100644 index 753d6bb3980..00000000000 --- a/packages/@rescript/runtime/Primitive_curry.resi +++ /dev/null @@ -1,32 +0,0 @@ -// let _1: ('a => 'b => 'c, 'a) => 'b => 'c -let __1: ('a => 'b => 'c) => 'a => 'b => 'c - -// let _2: (('a, 'a) => 'b => 'c, 'a, 'a) => 'b => 'c -let __2: (('a, 'a) => 'b => 'c) => ('a, 'a) => 'b => 'c - -// let _3: (('a, 'a, 'a) => 'b => 'c, 'a, 'a, 'a) => 'b => 'c -let __3: (('a, 'a, 'a) => 'b => 'c) => ('a, 'a, 'a) => 'b => 'c - -// let _4: (('a, 'a, 'a, 'a) => 'b => 'c, 'a, 'a, 'a, 'a) => 'b => 'c -let __4: (('a, 'a, 'a, 'a) => 'b => 'c) => ('a, 'a, 'a, 'a) => 'b => 'c - -// let _5: (('a, 'a, 'a, 'a, 'a) => 'b => 'c, 'a, 'a, 'a, 'a, 'a) => 'b => 'c -let __5: (('a, 'a, 'a, 'a, 'a) => 'b => 'c) => ('a, 'a, 'a, 'a, 'a) => 'b => 'c - -// let _6: (('a, 'a, 'a, 'a, 'a, 'a) => 'b => 'c, 'a, 'a, 'a, 'a, 'a, 'a) => 'b => 'c -let __6: (('a, 'a, 'a, 'a, 'a, 'a) => 'b => 'c) => ('a, 'a, 'a, 'a, 'a, 'a) => 'b => 'c - -// let _7: (('a, 'a, 'a, 'a, 'a, 'a, 'a) => 'b => 'c, 'a, 'a, 'a, 'a, 'a, 'a, 'a) => 'b => 'c -let __7: (('a, 'a, 'a, 'a, 'a, 'a, 'a) => 'b => 'c) => ('a, 'a, 'a, 'a, 'a, 'a, 'a) => 'b => 'c - -// let _8: (('a, 'a, 'a, 'a, 'a, 'a, 'a, 'a) => 'b => 'c, 'a, 'a, 'a, 'a, 'a, 'a, 'a, 'a) => 'b => 'c -let __8: (('a, 'a, 'a, 'a, 'a, 'a, 'a, 'a) => 'b => 'c) => ( - 'a, - 'a, - 'a, - 'a, - 'a, - 'a, - 'a, - 'a, -) => 'b => 'c diff --git a/packages/@rescript/runtime/lib/es6/Primitive_curry.mjs b/packages/@rescript/runtime/lib/es6/Primitive_curry.mjs deleted file mode 100644 index dc32d8492c2..00000000000 --- a/packages/@rescript/runtime/lib/es6/Primitive_curry.mjs +++ /dev/null @@ -1,438 +0,0 @@ - - - -function app(_f, _args) { - while (true) { - let args = _args; - let f = _f; - let init_arity = f.length; - let arity = init_arity === 0 ? 1 : init_arity; - let len = args.length; - let d = arity - len | 0; - if (d === 0) { - return f.apply(null, args); - } - if (d >= 0) { - return x => app(f, args.concat([x])); - } - _args = args.slice(arity, len); - _f = f.apply(null, args.slice(0, arity)); - continue; - }; -} - -function __1(o) { - let arity = o.length; - if (arity === 1) { - return o; - } else { - return a0 => { - let arity = o.length; - if (arity === 1) { - return o(a0); - } else { - switch (arity) { - case 1 : - return o(a0); - case 2 : - return param => o(a0, param); - case 3 : - return (param, param$1) => o(a0, param, param$1); - case 4 : - return (param, param$1, param$2) => o(a0, param, param$1, param$2); - case 5 : - return (param, param$1, param$2, param$3) => o(a0, param, param$1, param$2, param$3); - case 6 : - return (param, param$1, param$2, param$3, param$4) => o(a0, param, param$1, param$2, param$3, param$4); - case 7 : - return (param, param$1, param$2, param$3, param$4, param$5) => o(a0, param, param$1, param$2, param$3, param$4, param$5); - default: - return app(o, [a0]); - } - } - }; - } -} - -function __2(o) { - let arity = o.length; - if (arity === 2) { - return o; - } else { - return (a0, a1) => { - let arity = o.length; - if (arity === 2) { - return o(a0, a1); - } else { - switch (arity) { - case 1 : - return app(o(a0), [a1]); - case 2 : - return o(a0, a1); - case 3 : - return param => o(a0, a1, param); - case 4 : - return (param, param$1) => o(a0, a1, param, param$1); - case 5 : - return (param, param$1, param$2) => o(a0, a1, param, param$1, param$2); - case 6 : - return (param, param$1, param$2, param$3) => o(a0, a1, param, param$1, param$2, param$3); - case 7 : - return (param, param$1, param$2, param$3, param$4) => o(a0, a1, param, param$1, param$2, param$3, param$4); - default: - return app(o, [ - a0, - a1 - ]); - } - } - }; - } -} - -function __3(o) { - let arity = o.length; - if (arity === 3) { - return o; - } else { - return (a0, a1, a2) => { - let arity = o.length; - if (arity === 3) { - return o(a0, a1, a2); - } else { - switch (arity) { - case 1 : - return app(o(a0), [ - a1, - a2 - ]); - case 2 : - return app(o(a0, a1), [a2]); - case 3 : - return o(a0, a1, a2); - case 4 : - return param => o(a0, a1, a2, param); - case 5 : - return (param, param$1) => o(a0, a1, a2, param, param$1); - case 6 : - return (param, param$1, param$2) => o(a0, a1, a2, param, param$1, param$2); - case 7 : - return (param, param$1, param$2, param$3) => o(a0, a1, a2, param, param$1, param$2, param$3); - default: - return app(o, [ - a0, - a1, - a2 - ]); - } - } - }; - } -} - -function __4(o) { - let arity = o.length; - if (arity === 4) { - return o; - } else { - return (a0, a1, a2, a3) => { - let arity = o.length; - if (arity === 4) { - return o(a0, a1, a2, a3); - } else { - switch (arity) { - case 1 : - return app(o(a0), [ - a1, - a2, - a3 - ]); - case 2 : - return app(o(a0, a1), [ - a2, - a3 - ]); - case 3 : - return app(o(a0, a1, a2), [a3]); - case 4 : - return o(a0, a1, a2, a3); - case 5 : - return param => o(a0, a1, a2, a3, param); - case 6 : - return (param, param$1) => o(a0, a1, a2, a3, param, param$1); - case 7 : - return (param, param$1, param$2) => o(a0, a1, a2, a3, param, param$1, param$2); - default: - return app(o, [ - a0, - a1, - a2, - a3 - ]); - } - } - }; - } -} - -function __5(o) { - let arity = o.length; - if (arity === 5) { - return o; - } else { - return (a0, a1, a2, a3, a4) => { - let arity = o.length; - if (arity === 5) { - return o(a0, a1, a2, a3, a4); - } else { - switch (arity) { - case 1 : - return app(o(a0), [ - a1, - a2, - a3, - a4 - ]); - case 2 : - return app(o(a0, a1), [ - a2, - a3, - a4 - ]); - case 3 : - return app(o(a0, a1, a2), [ - a3, - a4 - ]); - case 4 : - return app(o(a0, a1, a2, a3), [a4]); - case 5 : - return o(a0, a1, a2, a3, a4); - case 6 : - return param => o(a0, a1, a2, a3, a4, param); - case 7 : - return (param, param$1) => o(a0, a1, a2, a3, a4, param, param$1); - default: - return app(o, [ - a0, - a1, - a2, - a3, - a4 - ]); - } - } - }; - } -} - -function __6(o) { - let arity = o.length; - if (arity === 6) { - return o; - } else { - return (a0, a1, a2, a3, a4, a5) => { - let arity = o.length; - if (arity === 6) { - return o(a0, a1, a2, a3, a4, a5); - } else { - switch (arity) { - case 1 : - return app(o(a0), [ - a1, - a2, - a3, - a4, - a5 - ]); - case 2 : - return app(o(a0, a1), [ - a2, - a3, - a4, - a5 - ]); - case 3 : - return app(o(a0, a1, a2), [ - a3, - a4, - a5 - ]); - case 4 : - return app(o(a0, a1, a2, a3), [ - a4, - a5 - ]); - case 5 : - return app(o(a0, a1, a2, a3, a4), [a5]); - case 6 : - return o(a0, a1, a2, a3, a4, a5); - case 7 : - return param => o(a0, a1, a2, a3, a4, a5, param); - default: - return app(o, [ - a0, - a1, - a2, - a3, - a4, - a5 - ]); - } - } - }; - } -} - -function __7(o) { - let arity = o.length; - if (arity === 7) { - return o; - } else { - return (a0, a1, a2, a3, a4, a5, a6) => { - let arity = o.length; - if (arity === 7) { - return o(a0, a1, a2, a3, a4, a5, a6); - } else { - switch (arity) { - case 1 : - return app(o(a0), [ - a1, - a2, - a3, - a4, - a5, - a6 - ]); - case 2 : - return app(o(a0, a1), [ - a2, - a3, - a4, - a5, - a6 - ]); - case 3 : - return app(o(a0, a1, a2), [ - a3, - a4, - a5, - a6 - ]); - case 4 : - return app(o(a0, a1, a2, a3), [ - a4, - a5, - a6 - ]); - case 5 : - return app(o(a0, a1, a2, a3, a4), [ - a5, - a6 - ]); - case 6 : - return app(o(a0, a1, a2, a3, a4, a5), [a6]); - case 7 : - return o(a0, a1, a2, a3, a4, a5, a6); - default: - return app(o, [ - a0, - a1, - a2, - a3, - a4, - a5, - a6 - ]); - } - } - }; - } -} - -function __8(o) { - let arity = o.length; - if (arity === 8) { - return o; - } else { - return (a0, a1, a2, a3, a4, a5, a6, a7) => { - let arity = o.length; - if (arity === 8) { - return o(a0, a1, a2, a3, a4, a5, a6, a7); - } else { - switch (arity) { - case 1 : - return app(o(a0), [ - a1, - a2, - a3, - a4, - a5, - a6, - a7 - ]); - case 2 : - return app(o(a0, a1), [ - a2, - a3, - a4, - a5, - a6, - a7 - ]); - case 3 : - return app(o(a0, a1, a2), [ - a3, - a4, - a5, - a6, - a7 - ]); - case 4 : - return app(o(a0, a1, a2, a3), [ - a4, - a5, - a6, - a7 - ]); - case 5 : - return app(o(a0, a1, a2, a3, a4), [ - a5, - a6, - a7 - ]); - case 6 : - return app(o(a0, a1, a2, a3, a4, a5), [ - a6, - a7 - ]); - case 7 : - return app(o(a0, a1, a2, a3, a4, a5, a6), [a7]); - default: - return app(o, [ - a0, - a1, - a2, - a3, - a4, - a5, - a6, - a7 - ]); - } - } - }; - } -} - -export { - __1, - __2, - __3, - __4, - __5, - __6, - __7, - __8, -} -/* No side effect */ diff --git a/packages/@rescript/runtime/lib/js/Primitive_curry.cjs b/packages/@rescript/runtime/lib/js/Primitive_curry.cjs deleted file mode 100644 index 755967faf1e..00000000000 --- a/packages/@rescript/runtime/lib/js/Primitive_curry.cjs +++ /dev/null @@ -1,436 +0,0 @@ -'use strict'; - - -function app(_f, _args) { - while (true) { - let args = _args; - let f = _f; - let init_arity = f.length; - let arity = init_arity === 0 ? 1 : init_arity; - let len = args.length; - let d = arity - len | 0; - if (d === 0) { - return f.apply(null, args); - } - if (d >= 0) { - return x => app(f, args.concat([x])); - } - _args = args.slice(arity, len); - _f = f.apply(null, args.slice(0, arity)); - continue; - }; -} - -function __1(o) { - let arity = o.length; - if (arity === 1) { - return o; - } else { - return a0 => { - let arity = o.length; - if (arity === 1) { - return o(a0); - } else { - switch (arity) { - case 1 : - return o(a0); - case 2 : - return param => o(a0, param); - case 3 : - return (param, param$1) => o(a0, param, param$1); - case 4 : - return (param, param$1, param$2) => o(a0, param, param$1, param$2); - case 5 : - return (param, param$1, param$2, param$3) => o(a0, param, param$1, param$2, param$3); - case 6 : - return (param, param$1, param$2, param$3, param$4) => o(a0, param, param$1, param$2, param$3, param$4); - case 7 : - return (param, param$1, param$2, param$3, param$4, param$5) => o(a0, param, param$1, param$2, param$3, param$4, param$5); - default: - return app(o, [a0]); - } - } - }; - } -} - -function __2(o) { - let arity = o.length; - if (arity === 2) { - return o; - } else { - return (a0, a1) => { - let arity = o.length; - if (arity === 2) { - return o(a0, a1); - } else { - switch (arity) { - case 1 : - return app(o(a0), [a1]); - case 2 : - return o(a0, a1); - case 3 : - return param => o(a0, a1, param); - case 4 : - return (param, param$1) => o(a0, a1, param, param$1); - case 5 : - return (param, param$1, param$2) => o(a0, a1, param, param$1, param$2); - case 6 : - return (param, param$1, param$2, param$3) => o(a0, a1, param, param$1, param$2, param$3); - case 7 : - return (param, param$1, param$2, param$3, param$4) => o(a0, a1, param, param$1, param$2, param$3, param$4); - default: - return app(o, [ - a0, - a1 - ]); - } - } - }; - } -} - -function __3(o) { - let arity = o.length; - if (arity === 3) { - return o; - } else { - return (a0, a1, a2) => { - let arity = o.length; - if (arity === 3) { - return o(a0, a1, a2); - } else { - switch (arity) { - case 1 : - return app(o(a0), [ - a1, - a2 - ]); - case 2 : - return app(o(a0, a1), [a2]); - case 3 : - return o(a0, a1, a2); - case 4 : - return param => o(a0, a1, a2, param); - case 5 : - return (param, param$1) => o(a0, a1, a2, param, param$1); - case 6 : - return (param, param$1, param$2) => o(a0, a1, a2, param, param$1, param$2); - case 7 : - return (param, param$1, param$2, param$3) => o(a0, a1, a2, param, param$1, param$2, param$3); - default: - return app(o, [ - a0, - a1, - a2 - ]); - } - } - }; - } -} - -function __4(o) { - let arity = o.length; - if (arity === 4) { - return o; - } else { - return (a0, a1, a2, a3) => { - let arity = o.length; - if (arity === 4) { - return o(a0, a1, a2, a3); - } else { - switch (arity) { - case 1 : - return app(o(a0), [ - a1, - a2, - a3 - ]); - case 2 : - return app(o(a0, a1), [ - a2, - a3 - ]); - case 3 : - return app(o(a0, a1, a2), [a3]); - case 4 : - return o(a0, a1, a2, a3); - case 5 : - return param => o(a0, a1, a2, a3, param); - case 6 : - return (param, param$1) => o(a0, a1, a2, a3, param, param$1); - case 7 : - return (param, param$1, param$2) => o(a0, a1, a2, a3, param, param$1, param$2); - default: - return app(o, [ - a0, - a1, - a2, - a3 - ]); - } - } - }; - } -} - -function __5(o) { - let arity = o.length; - if (arity === 5) { - return o; - } else { - return (a0, a1, a2, a3, a4) => { - let arity = o.length; - if (arity === 5) { - return o(a0, a1, a2, a3, a4); - } else { - switch (arity) { - case 1 : - return app(o(a0), [ - a1, - a2, - a3, - a4 - ]); - case 2 : - return app(o(a0, a1), [ - a2, - a3, - a4 - ]); - case 3 : - return app(o(a0, a1, a2), [ - a3, - a4 - ]); - case 4 : - return app(o(a0, a1, a2, a3), [a4]); - case 5 : - return o(a0, a1, a2, a3, a4); - case 6 : - return param => o(a0, a1, a2, a3, a4, param); - case 7 : - return (param, param$1) => o(a0, a1, a2, a3, a4, param, param$1); - default: - return app(o, [ - a0, - a1, - a2, - a3, - a4 - ]); - } - } - }; - } -} - -function __6(o) { - let arity = o.length; - if (arity === 6) { - return o; - } else { - return (a0, a1, a2, a3, a4, a5) => { - let arity = o.length; - if (arity === 6) { - return o(a0, a1, a2, a3, a4, a5); - } else { - switch (arity) { - case 1 : - return app(o(a0), [ - a1, - a2, - a3, - a4, - a5 - ]); - case 2 : - return app(o(a0, a1), [ - a2, - a3, - a4, - a5 - ]); - case 3 : - return app(o(a0, a1, a2), [ - a3, - a4, - a5 - ]); - case 4 : - return app(o(a0, a1, a2, a3), [ - a4, - a5 - ]); - case 5 : - return app(o(a0, a1, a2, a3, a4), [a5]); - case 6 : - return o(a0, a1, a2, a3, a4, a5); - case 7 : - return param => o(a0, a1, a2, a3, a4, a5, param); - default: - return app(o, [ - a0, - a1, - a2, - a3, - a4, - a5 - ]); - } - } - }; - } -} - -function __7(o) { - let arity = o.length; - if (arity === 7) { - return o; - } else { - return (a0, a1, a2, a3, a4, a5, a6) => { - let arity = o.length; - if (arity === 7) { - return o(a0, a1, a2, a3, a4, a5, a6); - } else { - switch (arity) { - case 1 : - return app(o(a0), [ - a1, - a2, - a3, - a4, - a5, - a6 - ]); - case 2 : - return app(o(a0, a1), [ - a2, - a3, - a4, - a5, - a6 - ]); - case 3 : - return app(o(a0, a1, a2), [ - a3, - a4, - a5, - a6 - ]); - case 4 : - return app(o(a0, a1, a2, a3), [ - a4, - a5, - a6 - ]); - case 5 : - return app(o(a0, a1, a2, a3, a4), [ - a5, - a6 - ]); - case 6 : - return app(o(a0, a1, a2, a3, a4, a5), [a6]); - case 7 : - return o(a0, a1, a2, a3, a4, a5, a6); - default: - return app(o, [ - a0, - a1, - a2, - a3, - a4, - a5, - a6 - ]); - } - } - }; - } -} - -function __8(o) { - let arity = o.length; - if (arity === 8) { - return o; - } else { - return (a0, a1, a2, a3, a4, a5, a6, a7) => { - let arity = o.length; - if (arity === 8) { - return o(a0, a1, a2, a3, a4, a5, a6, a7); - } else { - switch (arity) { - case 1 : - return app(o(a0), [ - a1, - a2, - a3, - a4, - a5, - a6, - a7 - ]); - case 2 : - return app(o(a0, a1), [ - a2, - a3, - a4, - a5, - a6, - a7 - ]); - case 3 : - return app(o(a0, a1, a2), [ - a3, - a4, - a5, - a6, - a7 - ]); - case 4 : - return app(o(a0, a1, a2, a3), [ - a4, - a5, - a6, - a7 - ]); - case 5 : - return app(o(a0, a1, a2, a3, a4), [ - a5, - a6, - a7 - ]); - case 6 : - return app(o(a0, a1, a2, a3, a4, a5), [ - a6, - a7 - ]); - case 7 : - return app(o(a0, a1, a2, a3, a4, a5, a6), [a7]); - default: - return app(o, [ - a0, - a1, - a2, - a3, - a4, - a5, - a6, - a7 - ]); - } - } - }; - } -} - -exports.__1 = __1; -exports.__2 = __2; -exports.__3 = __3; -exports.__4 = __4; -exports.__5 = __5; -exports.__6 = __6; -exports.__7 = __7; -exports.__8 = __8; -/* No side effect */ diff --git a/packages/artifacts.json b/packages/artifacts.json index 074d94e85cd..58a471db3dd 100644 --- a/packages/artifacts.json +++ b/packages/artifacts.json @@ -288,12 +288,6 @@ "lib/ocaml/Primitive_char_extern.cmj", "lib/ocaml/Primitive_char_extern.cmt", "lib/ocaml/Primitive_char_extern.res", - "lib/ocaml/Primitive_curry.cmi", - "lib/ocaml/Primitive_curry.cmj", - "lib/ocaml/Primitive_curry.cmt", - "lib/ocaml/Primitive_curry.cmti", - "lib/ocaml/Primitive_curry.res", - "lib/ocaml/Primitive_curry.resi", "lib/ocaml/Primitive_dict.cmi", "lib/ocaml/Primitive_dict.cmj", "lib/ocaml/Primitive_dict.cmt", From a1b16876b330a2ba5e4f82b4453835665199719f Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 1 Sep 2026 10:28:52 +0200 Subject: [PATCH 07/46] Remove the %function_arity primitive `Pfn_arity` emitted `f.length`. Its only declaration site in the tree was `Primitive_curry.res`, which used it to discover a callee's real arity at runtime; with the curry machinery gone nothing names `%function_arity` any more, and the arity a call site needs is now known statically. `E.function_length` had no other caller and goes with it. Note this is user-visible: an `external` declared as `"%function_arity"` was accepted before and is now rejected as an unknown builtin primitive. Signed-Off-By: Cristiano Calcagno Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/core/js_exp_make.ml | 8 -------- compiler/core/js_exp_make.mli | 2 -- compiler/core/lam_analysis.ml | 4 ++-- compiler/core/lam_compile_primitive.ml | 1 - compiler/core/lam_convert.ml | 1 - compiler/core/lam_primitive.ml | 10 ++++------ compiler/core/lam_primitive.mli | 1 - 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 | 1 - 12 files changed, 6 insertions(+), 26 deletions(-) diff --git a/compiler/core/js_exp_make.ml b/compiler/core/js_exp_make.ml index d75a036d5a4..8aac48b7de7 100644 --- a/compiler/core/js_exp_make.ml +++ b/compiler/core/js_exp_make.ml @@ -639,14 +639,6 @@ let string_length ?comment (e : t) : t = (* No optimization for {j||j}*) | _ -> {expression_desc = Length e; comment; source_loc = None} -let function_length ?comment (e : t) : t = - match e.expression_desc with - | Fun {is_method; params} -> - let params_length = List.length params in - int ?comment - (Int32.of_int (if is_method then params_length - 1 else params_length)) - | _ -> {expression_desc = Length e; comment; source_loc = None} - let rec string_append ?comment (e : t) (el : t) : t = let concat a b ~delim = {e with expression_desc = Str {txt = a ^ b; delim}} in match (e.expression_desc, el.expression_desc) with diff --git a/compiler/core/js_exp_make.mli b/compiler/core/js_exp_make.mli index 95e599fc53e..2ed4db798be 100644 --- a/compiler/core/js_exp_make.mli +++ b/compiler/core/js_exp_make.mli @@ -132,8 +132,6 @@ val array_length : ?comment:string -> t -> t val string_length : ?comment:string -> t -> t -val function_length : ?comment:string -> t -> t - val string_append : ?comment:string -> t -> t -> t (** When in ES6 mode, we can use Symbol to guarantee its uniquess, diff --git a/compiler/core/lam_analysis.ml b/compiler/core/lam_analysis.ml index d3930e86054..9adb4ea71e1 100644 --- a/compiler/core/lam_analysis.ml +++ b/compiler/core/lam_analysis.ml @@ -85,8 +85,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 | Phash | Phash_mixstring - | Phash_mixint | Phash_finalmix + | Poffsetint _ | Pstringadd | 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 28440be2253..89a92d9193c 100644 --- a/compiler/core/lam_compile_primitive.ml +++ b/compiler/core/lam_compile_primitive.ml @@ -163,7 +163,6 @@ let translate output_prefix loc (cxt : Lam_compile_context.t) match path with | [] -> import | _ :: _ -> wrap_then_path import path)) - | Pfn_arity -> E.function_length (Ext_list.singleton_exn args) | Pobjsize -> E.obj_length (Ext_list.singleton_exn args) | Pis_null -> E.is_null (Ext_list.singleton_exn args) | Pis_undefined -> E.is_undef (Ext_list.singleton_exn args) diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index 1ae0dce1d81..1863586a8d6 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -41,7 +41,6 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = | Blk_module _ | Blk_module_export _ | Blk_extension | Blk_record_ext _ | Blk_poly_var -> prim ~primitive:(Pmakeblock (info, mutable_flag)) ~args loc) - | Pfn_arity -> prim ~primitive:Pfn_arity ~args loc | Pdebugger -> prim ~primitive:Pdebugger ~args loc | Psome -> prim ~primitive:Psome ~args loc | Psome_not_nest -> prim ~primitive:Psome_not_nest ~args loc diff --git a/compiler/core/lam_primitive.ml b/compiler/core/lam_primitive.ml index fac944c81ff..3ec171025f7 100644 --- a/compiler/core/lam_primitive.ml +++ b/compiler/core/lam_primitive.ml @@ -161,7 +161,6 @@ type t = | Pis_null_undefined | Pimport of Lambda.import_source | Ptypeof - | Pfn_arity | Pcreate_extension of string | Pis_not_none (* no info about its type *) | Pval_from_option @@ -215,11 +214,10 @@ let eq_primitive_approx (lhs : t) (rhs : t) = (* etc *) | 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 - | Phash_finalmix | Precord_rest _ -> + | Pis_undefined | Pis_null_undefined | Ptypeof | Pis_poly_var_block + | Pdebugger | Pinit_mod | Pupdate_mod | Pduprecord | Pmakearray | Parraylength + | Parrayrefu | Parraysetu | Parrayrefs | Parraysets | Pjs_fn_method | Phash + | Phash_mixstring | Phash_mixint | Phash_finalmix | Precord_rest _ -> rhs = lhs (* Reachable only via the optimizer's term-equality comparison, which the test suite doesn't exercise for tagged templates. *) diff --git a/compiler/core/lam_primitive.mli b/compiler/core/lam_primitive.mli index 32b791b63ff..b07aa0f325a 100644 --- a/compiler/core/lam_primitive.mli +++ b/compiler/core/lam_primitive.mli @@ -151,7 +151,6 @@ type t = | Pis_null_undefined | Pimport of Lambda.import_source | Ptypeof - | Pfn_arity | 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 a7e3f201e6b..a8d5807f831 100644 --- a/compiler/core/lam_print.ml +++ b/compiler/core/lam_print.ml @@ -49,7 +49,6 @@ let primitive ppf (prim : Lam_primitive.t) = | Ptagged_template -> fprintf ppf "#tagged_template" [@coverage off] | Pjs_object_get name -> fprintf ppf "js_object_get[%s]" name | Pjs_object_set name -> fprintf ppf "js_object_set[%s]" name - | Pfn_arity -> fprintf ppf "fn.length" | Pjs_fn_method -> fprintf ppf "js_fn_method" | Pdebugger -> fprintf ppf "debugger" | Praw_js_code _ -> fprintf ppf "[raw]" diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index 07361620803..49cb85089da 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -177,7 +177,6 @@ type primitive = | Psome_not_nest (** [Some x] where [x] cannot itself be [undefined], so no wrapping is needed. *) - | Pfn_arity | Pgetglobal of Ident.t (* Operations on heap blocks *) | Pmakeblock of tag_info diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index ba0e64f4a1a..6de8e358642 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -137,7 +137,6 @@ type primitive = | Psome_not_nest (** [Some x] where [x] cannot itself be [undefined], so no wrapping is needed. *) - | Pfn_arity | Pgetglobal of Ident.t (* Operations on heap blocks *) | Pmakeblock of tag_info diff --git a/compiler/ml/printlambda.ml b/compiler/ml/printlambda.ml index 7d382f1ed2a..8658c94835b 100644 --- a/compiler/ml/printlambda.ml +++ b/compiler/ml/printlambda.ml @@ -97,7 +97,6 @@ let primitive ppf = function | Ptypeof -> fprintf ppf "typeof" | Psome -> fprintf ppf "some" | Psome_not_nest -> fprintf ppf "some_not_nest" - | Pfn_arity -> fprintf ppf "fn.length" | 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 bdf8061f7ad..855e51240f0 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -389,7 +389,6 @@ let primitive_builtins : (string * Lambda.builtin) array = ("%is_nullable", Pisnullable); ("%null_to_opt", Pnull_to_opt); ("%nullable_to_opt", Pnullable_to_opt); - ("%function_arity", Pfn_arity); ("%makemutablelist", Pmakelist); ("%unsafe_to_method", Pjs_fn_method); (* Compiler internals, never expose to ReScript files *) From 4235bab21236ac94529331d5f05a3782394b3db8 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 1 Sep 2026 12:30:00 +0200 Subject: [PATCH 08/46] Rename Lam_pass_alpha_conversion to Lam_pass_apply_arity The pass renames nothing - there is no alpha conversion anywhere in it. What it does is normalize applications against the callee's arity: saturate an under-supplied call by eta expansion, split an over-supplied one, and record on the rest that the arity is known. The name is OCaml lineage, where a pass in this position did rename bound variables. `alpha_conversion` becomes `normalize`, and the `-debug-ir` dump labels follow. Signed-Off-By: Cristiano Calcagno Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/core/lam_compile_main.ml | 10 +++++----- ...ass_alpha_conversion.ml => lam_pass_apply_arity.ml} | 6 +++++- ...s_alpha_conversion.mli => lam_pass_apply_arity.mli} | 2 +- 3 files changed, 11 insertions(+), 7 deletions(-) rename compiler/core/{lam_pass_alpha_conversion.ml => lam_pass_apply_arity.ml} (94%) rename compiler/core/{lam_pass_alpha_conversion.mli => lam_pass_apply_arity.mli} (96%) diff --git a/compiler/core/lam_compile_main.ml b/compiler/core/lam_compile_main.ml index e68358bcccd..9a58b04e6d8 100644 --- a/compiler/core/lam_compile_main.ml +++ b/compiler/core/lam_compile_main.ml @@ -305,16 +305,16 @@ let compile (output_prefix : string) export_idents hoisted (lam : Lambda.lambda) let lam = Lam_pass_deep_flatten.deep_flatten lam in let () = Lam_pass_collect.collect_info meta lam in let lam = - lam |> d "alpha_before" - |> Lam_pass_alpha_conversion.alpha_conversion meta - |> d "alpha_after" |> Lam_pass_exits.simplify_exits + lam |> d "apply_arity_before" + |> Lam_pass_apply_arity.normalize meta + |> d "apply_arity_after" |> Lam_pass_exits.simplify_exits in let () = Lam_pass_collect.collect_info meta lam in lam |> d "simplify_alias_before" |> Lam_pass_remove_alias.simplify_alias meta - |> d "alpha_conversion" - |> Lam_pass_alpha_conversion.alpha_conversion meta + |> d "apply_arity_before2" + |> Lam_pass_apply_arity.normalize meta |> d "before-simplify_lets" (* we should investigate a better way to put different passes : )*) |> Lam_pass_lets_dce.simplify_lets diff --git a/compiler/core/lam_pass_alpha_conversion.ml b/compiler/core/lam_pass_apply_arity.ml similarity index 94% rename from compiler/core/lam_pass_alpha_conversion.ml rename to compiler/core/lam_pass_apply_arity.ml index b83e930bb33..79d86bb53cf 100644 --- a/compiler/core/lam_pass_alpha_conversion.ml +++ b/compiler/core/lam_pass_apply_arity.ml @@ -22,7 +22,11 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -let alpha_conversion (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = +(* Normalize applications against the callee's arity: saturate an + under-supplied call by eta expansion, split an over-supplied one, and record + on the rest that the arity is known. Despite its former name this pass + renames nothing. *) +let normalize (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = let rec populate_apply_info ?(ap_transformed_jsx = false) (args_arity : int list) (len : int) (fn : Lam.t) (args : Lam.t list) ap_info : Lam.t = diff --git a/compiler/core/lam_pass_alpha_conversion.mli b/compiler/core/lam_pass_apply_arity.mli similarity index 96% rename from compiler/core/lam_pass_alpha_conversion.mli rename to compiler/core/lam_pass_apply_arity.mli index d32e3438ef6..2767c106033 100644 --- a/compiler/core/lam_pass_alpha_conversion.mli +++ b/compiler/core/lam_pass_apply_arity.mli @@ -24,4 +24,4 @@ (** alpha conversion based on arity *) -val alpha_conversion : Lam_stats.t -> Lam.t -> Lam.t +val normalize : Lam_stats.t -> Lam.t -> Lam.t From 0d55dedc3b32725982725504baf43c34cf521565 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 1 Sep 2026 12:39:48 +0200 Subject: [PATCH 09/46] Query the callee's arity where it is used `ap_info` carried `ap_status`, a cache of "is the callee's arity known and does this call saturate it". Conversion stamped `App_uncurry` on every application and `Lam_pass_apply_arity` later rewrote the saturated ones to `App_infer_full`, so the field was optimizer state living in the IR, populated by one pass and read by one consumer: the emitter, deciding whether a call may be printed as `Call_ml` and so allow the printer to eta reduce a wrapper around it. The fact belongs to the callee, not to each call site. `Lam_compile_context.t` already carries `meta`, so the emitter asks `Lam_arity_analysis.get_arity` directly, and the field, the `apply_status` type and both stamping sites go. Conversion no longer attaches optimizer state to the applications it builds. Generated JavaScript is unchanged for the runtime, Belt, tests/tests and gentype: the query returns what the cache held, including across the `simplify_lets` that runs between the old stamping point and emission. Signed-Off-By: Cristiano Calcagno Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/core/lam.ml | 8 +------ compiler/core/lam.mli | 8 +------ compiler/core/lam_compile.ml | 31 ++++++++++++++++++--------- compiler/core/lam_convert.ml | 3 +-- compiler/core/lam_pass_apply_arity.ml | 10 +++------ 5 files changed, 27 insertions(+), 33 deletions(-) diff --git a/compiler/core/lam.ml b/compiler/core/lam.ml index 3351c67ba32..ca35f8dc401 100644 --- a/compiler/core/lam.ml +++ b/compiler/core/lam.ml @@ -23,13 +23,7 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) type ident = Ident.t -type apply_status = App_infer_full | App_uncurry - -type ap_info = { - ap_loc: Location.t; - ap_inlined: Lambda.inline_attribute; - ap_status: apply_status; -} +type ap_info = {ap_loc: Location.t; ap_inlined: Lambda.inline_attribute} module Types = struct type lambda_switch = t Lambda.switch diff --git a/compiler/core/lam.mli b/compiler/core/lam.mli index 5793c6c97c8..923196817b3 100644 --- a/compiler/core/lam.mli +++ b/compiler/core/lam.mli @@ -22,13 +22,7 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type apply_status = App_infer_full | App_uncurry - -type ap_info = { - ap_loc: Location.t; - ap_inlined: Lambda.inline_attribute; - ap_status: apply_status; -} +type ap_info = {ap_loc: Location.t; ap_inlined: Lambda.inline_attribute} type ident = Ident.t diff --git a/compiler/core/lam_compile.ml b/compiler/core/lam_compile.ml index c3aba23ec93..070e01ef28b 100644 --- a/compiler/core/lam_compile.ml +++ b/compiler/core/lam_compile.ml @@ -89,12 +89,23 @@ let args_either_function_or_const (args : Lam.t list) = | Lfunction _ | Lconst _ -> true | _ -> false) -let call_info_of_ap_status call_transformed_jsx (ap_status : Lam.apply_status) : - Js_call_info.t = - (* XXX *) - match ap_status with - | App_infer_full -> {call_info = Call_ml; call_transformed_jsx} - | App_uncurry -> {call_info = Call_na; call_transformed_jsx} +(* Whether the callee's arity is known and this call saturates it. The printer + uses it to decide whether a wrapper around the call may be eta reduced, + which is only sound for a ReScript value of exactly that arity - never for + an FFI name, whose wrapper carries argument adaptation. Looked up here + rather than stamped on the application by an earlier pass. *) +let call_info_of_apply (meta : Lam_stats.t) call_transformed_jsx + (appinfo : Lam.apply) : Js_call_info.t = + let saturated = + match + Lam_arity.extract_arity + (Lam_arity_analysis.get_arity meta appinfo.ap_func) + with + | x :: _ -> x = List.length appinfo.ap_args + | [] -> false + in + if saturated then {call_info = Call_ml; call_transformed_jsx} + else {call_info = Call_na; call_transformed_jsx} let change_tail_type_in_try (x : Lam_compile_context.tail_type) : Lam_compile_context.tail_type = @@ -346,8 +357,8 @@ let compile output_prefix = let expression = E.call ~info: - (call_info_of_ap_status appinfo.ap_transformed_jsx - appinfo.ap_info.ap_status) + (call_info_of_apply lambda_cxt.meta appinfo.ap_transformed_jsx + appinfo) fn args in let expression = with_source_loc appinfo.ap_info.ap_loc expression in @@ -1602,8 +1613,8 @@ let compile output_prefix = (with_source_loc appinfo.ap_info.ap_loc (E.call ~info: - (call_info_of_ap_status appinfo.ap_transformed_jsx - appinfo.ap_info.ap_status) + (call_info_of_apply lambda_cxt.meta appinfo.ap_transformed_jsx + appinfo) fn_code args))) and compile_prim (prim_info : Lam.prim_info) (lambda_cxt : Lam_compile_context.t) = diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index 1863586a8d6..ba52f3c165c 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -193,8 +193,7 @@ let convert (lam : Lambda.lambda) : Lam.t * Lam_module_ident.Hash_set.t = (* we need do this eargly in case [aux fn] add some wrapper *) Lam.apply (convert_aux fn) (Ext_list.map args convert_aux) - {ap_loc = loc; ap_inlined; ap_status = App_uncurry} - ~ap_transformed_jsx + {ap_loc = loc; ap_inlined} ~ap_transformed_jsx | Lfunction {params; body; attr; loc} -> Lam.function_ ~loc ~attr ~arity:(List.length params) ~params ~body:(convert_aux body) diff --git a/compiler/core/lam_pass_apply_arity.ml b/compiler/core/lam_pass_apply_arity.ml index 79d86bb53cf..fca0439faeb 100644 --- a/compiler/core/lam_pass_apply_arity.ml +++ b/compiler/core/lam_pass_apply_arity.ml @@ -35,20 +35,16 @@ let normalize (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = Lam.apply (simpl fn) (Ext_list.map args simpl) ap_info ~ap_transformed_jsx | x :: _ -> if x = len then - Lam.apply (simpl fn) (Ext_list.map args simpl) - {ap_info with ap_status = App_infer_full} + Lam.apply (simpl fn) (Ext_list.map args simpl) ap_info ~ap_transformed_jsx else if x > len then let fn = simpl fn in let args = Ext_list.map args simpl in - Lam_eta_conversion.transform_under_supply (x - len) - {ap_info with ap_status = App_infer_full} - fn args + Lam_eta_conversion.transform_under_supply (x - len) ap_info fn args else let first, rest = Ext_list.split_at args x in Lam.apply ~ap_transformed_jsx - (Lam.apply (simpl fn) (Ext_list.map first simpl) - {ap_info with ap_status = App_infer_full}) + (Lam.apply (simpl fn) (Ext_list.map first simpl) ap_info) (Ext_list.map rest simpl) ap_info (* TODO refien *) and simpl (lam : Lam.t) = From 0d29fd5c29f7fbe1fda61104377d74a4bd938380 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 1 Sep 2026 12:43:28 +0200 Subject: [PATCH 10/46] Delete Lam_pass_apply_arity and Lam_eta_conversion With the arity fact queried where it is used, the pass had nothing left to do but re-group applications that do not match the callee's arity: eta expand an under-supplied call, split an over-supplied one. Neither happens. Instrumenting the four branches over the runtime, Belt and tests/tests - 14346 applications - gives 12510 exact, 1836 arity unknown, and zero under- or over-supplied. Deliberate attempts to provoke them (partial application `f(1, ...)`, an over-applied `mk()(1, 2)`, a partially applied argument passed to a higher order function, a partially applied external) all stay exact: uncurried ReScript saturates applications at Lambda production, and `translcore` already eta expands partial application before conversion. `Lam_eta_conversion` goes with it - `transform_under_supply` was its only export and this pass its only caller. Note the branches are removed rather than proven unreachable: `get_arity` is conservative, so a mismatched application could in principle still be built by inlining. Emitting such a call as written is correct for this target, where a JavaScript call with a mismatched argument count is well defined. Generated JavaScript is unchanged for the runtime, Belt, tests/tests and gentype. Signed-Off-By: Cristiano Calcagno Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/core/lam_compile_main.ml | 8 +- compiler/core/lam_eta_conversion.ml | 76 ----------------- compiler/core/lam_eta_conversion.mli | 31 ------- compiler/core/lam_pass_apply_arity.ml | 114 ------------------------- compiler/core/lam_pass_apply_arity.mli | 27 ------ 5 files changed, 1 insertion(+), 255 deletions(-) delete mode 100644 compiler/core/lam_eta_conversion.ml delete mode 100644 compiler/core/lam_eta_conversion.mli delete mode 100644 compiler/core/lam_pass_apply_arity.ml delete mode 100644 compiler/core/lam_pass_apply_arity.mli diff --git a/compiler/core/lam_compile_main.ml b/compiler/core/lam_compile_main.ml index 9a58b04e6d8..5da51039a4f 100644 --- a/compiler/core/lam_compile_main.ml +++ b/compiler/core/lam_compile_main.ml @@ -304,17 +304,11 @@ let compile (output_prefix : string) export_idents hoisted (lam : Lambda.lambda) let lam = Lam_pass_remove_alias.simplify_alias meta lam in let lam = Lam_pass_deep_flatten.deep_flatten lam in let () = Lam_pass_collect.collect_info meta lam in - let lam = - lam |> d "apply_arity_before" - |> Lam_pass_apply_arity.normalize meta - |> d "apply_arity_after" |> Lam_pass_exits.simplify_exits - in + let lam = lam |> Lam_pass_exits.simplify_exits in let () = Lam_pass_collect.collect_info meta lam in lam |> d "simplify_alias_before" |> Lam_pass_remove_alias.simplify_alias meta - |> d "apply_arity_before2" - |> Lam_pass_apply_arity.normalize meta |> d "before-simplify_lets" (* we should investigate a better way to put different passes : )*) |> Lam_pass_lets_dce.simplify_lets diff --git a/compiler/core/lam_eta_conversion.ml b/compiler/core/lam_eta_conversion.ml deleted file mode 100644 index 2f038ea306e..00000000000 --- a/compiler/core/lam_eta_conversion.ml +++ /dev/null @@ -1,76 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - 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. *) - -(* - let f x y = x + y - Invariant: there is no currying - here since f's arity is 2, no side effect - f 3 --> function(y) -> f 3 y -*) - -(** - [transform n loc status fn args] - n is the number of missing arguments required for [fn]. - Return a function of airty [n] -*) -let transform_under_supply n ap_info fn args = - let extra_args = Ext_list.init n (fun _ -> Ident.create Literals.param) in - let extra_lambdas = Ext_list.map extra_args Lam.var in - match - Ext_list.fold_right (fn :: args) ([], []) (fun (lam : Lam.t) (acc, bind) -> - match lam with - | Lvar _ - | Lconst - ( Const_int _ | Const_assertfalse | Const_constructor _ - | Const_char _ | Const_string _ | Const_float _ | Const_bigint _ - | Const_polyvar _ | Const_js_true | Const_js_false - | Const_js_undefined _ ) - | Lprim {primitive = Pfield (_, Fld_module _); _} - | Lfunction _ -> - (lam :: acc, bind) - | _ -> - let v = Ident.create Literals.partial_arg in - (Lam.var v :: acc, (v, lam) :: bind)) - with - | fn :: args, [] -> - (* More than no side effect in the [args], - we try to avoid computation, so even if - [x + y] is side effect free, we need eval it only once - *) - (* TODO: Note we could adjust [fn] if [fn] is already a function - But it is dangerous to change the arity - of an existing function which may cause inconsistency - *) - Lam.function_ ~loc:Location.none ~arity:n ~params:extra_args - ~attr:Lambda.default_function_attribute - ~body:(Lam.apply fn (Ext_list.append args extra_lambdas) ap_info) - | fn :: args, bindings -> - let rest : Lam.t = - Lam.function_ ~loc:Location.none ~arity:n ~params:extra_args - ~attr:Lambda.default_function_attribute - ~body:(Lam.apply fn (Ext_list.append args extra_lambdas) ap_info) - in - Ext_list.fold_left bindings rest (fun lam (id, x) -> - Lam.let_ Strict id x lam) - | _, _ -> assert false diff --git a/compiler/core/lam_eta_conversion.mli b/compiler/core/lam_eta_conversion.mli deleted file mode 100644 index 9696587e2c6..00000000000 --- a/compiler/core/lam_eta_conversion.mli +++ /dev/null @@ -1,31 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - 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. *) - -(** - [transform n loc status fn args] - n is the number of missing arguments required for [fn]. - Return a function of airty [n] -*) - -val transform_under_supply : int -> Lam.ap_info -> Lam.t -> Lam.t list -> Lam.t diff --git a/compiler/core/lam_pass_apply_arity.ml b/compiler/core/lam_pass_apply_arity.ml deleted file mode 100644 index fca0439faeb..00000000000 --- a/compiler/core/lam_pass_apply_arity.ml +++ /dev/null @@ -1,114 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - 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. *) - -(* Normalize applications against the callee's arity: saturate an - under-supplied call by eta expansion, split an over-supplied one, and record - on the rest that the arity is known. Despite its former name this pass - renames nothing. *) -let normalize (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = - let rec populate_apply_info ?(ap_transformed_jsx = false) - (args_arity : int list) (len : int) (fn : Lam.t) (args : Lam.t list) - ap_info : Lam.t = - match args_arity with - | 0 :: _ | [] -> - Lam.apply (simpl fn) (Ext_list.map args simpl) ap_info ~ap_transformed_jsx - | x :: _ -> - if x = len then - Lam.apply (simpl fn) (Ext_list.map args simpl) ap_info - ~ap_transformed_jsx - else if x > len then - let fn = simpl fn in - let args = Ext_list.map args simpl in - Lam_eta_conversion.transform_under_supply (x - len) ap_info fn args - else - let first, rest = Ext_list.split_at args x in - Lam.apply ~ap_transformed_jsx - (Lam.apply (simpl fn) (Ext_list.map first simpl) ap_info) - (Ext_list.map rest simpl) ap_info - (* TODO refien *) - and simpl (lam : Lam.t) = - match lam with - | Lconst _ -> lam - | Lvar _ -> lam - | Lapply {ap_func; ap_args; ap_info; ap_transformed_jsx} -> - (* detect functor application *) - let args_arity = - Lam_arity.extract_arity (Lam_arity_analysis.get_arity meta ap_func) - in - let len = List.length ap_args in - populate_apply_info ~ap_transformed_jsx args_arity len ap_func ap_args - ap_info - | Llet (str, v, l1, l2) -> Lam.let_ str v (simpl l1) (simpl l2) - | Lletrec (bindings, body) -> - let bindings = Ext_list.map_snd bindings simpl in - Lam.letrec bindings (simpl body) - | Lglobal_module _ -> lam - | Lprim {primitive; args; loc} -> - Lam.prim ~primitive ~args:(Ext_list.map args simpl) loc - | Lfunction {arity; params; body; attr; loc} -> - (* Lam_mk.lfunction kind params (simpl l) *) - Lam.function_ ~loc ~arity ~params ~body:(simpl body) ~attr - | Lswitch - ( l, - { - sw_failaction; - sw_consts; - sw_blocks; - sw_blocks_full; - sw_consts_full; - sw_dispatch; - } ) -> - Lam.switch (simpl l) - { - sw_consts = Ext_list.map_snd sw_consts simpl; - sw_blocks = Ext_list.map_snd sw_blocks simpl; - sw_consts_full; - sw_blocks_full; - sw_failaction = Ext_option.map sw_failaction simpl; - sw_dispatch; - } - | Lstringswitch (l, sw, d) -> - Lam.stringswitch (simpl l) - (Ext_list.map_snd sw simpl) - (Ext_option.map d simpl) - | Lstaticraise (i, ls) -> Lam.staticraise i (Ext_list.map ls simpl) - | Lstaticcatch (l1, ids, l2) -> Lam.staticcatch (simpl l1) ids (simpl l2) - | Ltrywith (l1, v, l2) -> Lam.try_ (simpl l1) v (simpl l2) - | Lifthenelse (l1, l2, l3) -> Lam.if_ (simpl l1) (simpl l2) (simpl l3) - | Lsequence (l1, l2) -> Lam.seq (simpl l1) (simpl l2) - | Lbreak -> Lam.break - | Lcontinue -> Lam.continue - | Lwhile (l1, l2) -> Lam.while_ (simpl l1) (simpl l2) - | Lfor (flag, l1, l2, dir, l3) -> - Lam.for_ flag (simpl l1) (simpl l2) dir (simpl l3) - | Lfor_of (flag, l1, l2) -> Lam.for_of flag (simpl l1) (simpl l2) - | Lfor_await_of (flag, l1, l2) -> - Lam.for_await_of flag (simpl l1) (simpl l2) - | Lassign (v, l) -> - (* Lalias-bound variables are never assigned, so don't increase - v's refsimpl *) - Lam.assign v (simpl l) - in - - simpl lam diff --git a/compiler/core/lam_pass_apply_arity.mli b/compiler/core/lam_pass_apply_arity.mli deleted file mode 100644 index 2767c106033..00000000000 --- a/compiler/core/lam_pass_apply_arity.mli +++ /dev/null @@ -1,27 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - 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. *) - -(** alpha conversion based on arity *) - -val normalize : Lam_stats.t -> Lam.t -> Lam.t From c6b836b375d71590f190fb00a08bc814c7d1f701 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 1 Sep 2026 13:12:55 +0200 Subject: [PATCH 11/46] Drop the two collect_info calls that nothing can observe `Lam_pass_collect.collect_info` writes identifier information into `meta.ident_tbl`, which `simplify_alias`, `get_arity`, `Lam_stats_export` and `Lam_coercion` later look up. Two of its five calls sit immediately before a `simplify_exits` that is immediately followed by another `collect_info`. `Lam_pass_exits.simplify_exits : Lam.t -> Lam.t` takes no `meta`, so it cannot consult the table, and nothing else runs in between. Neither call can therefore be observed before the following one rewrites what it wrote from the same term. The only entries they contributed that the following call does not are those for identifiers `simplify_exits` had just deleted - unreachable from the term, and never removed, since nothing ever removes from this table. Three traversals of the term instead of five, and fewer stale rows in a table that is only ever added to. Generated JavaScript is unchanged for the runtime, Belt, tests/tests and gentype. Signed-Off-By: Cristiano Calcagno Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/core/lam_compile_main.ml | 2 -- 1 file changed, 2 deletions(-) diff --git a/compiler/core/lam_compile_main.ml b/compiler/core/lam_compile_main.ml index 5da51039a4f..87d8a6788c3 100644 --- a/compiler/core/lam_compile_main.ml +++ b/compiler/core/lam_compile_main.ml @@ -284,7 +284,6 @@ let compile (output_prefix : string) export_idents hoisted (lam : Lambda.lambda) let lam = Lam_pass_deep_flatten.deep_flatten lam in let lam = d "flatten0" lam in let meta : Lam_stats.t = Lam_stats.make ~export_idents ~export_ident_sets in - let () = Lam_pass_collect.collect_info meta lam in let lam = let lam = lam |> d "flatten1" |> Lam_pass_exits.simplify_exits |> d "simplify_exits" @@ -303,7 +302,6 @@ let compile (output_prefix : string) export_idents hoisted (lam : Lambda.lambda) let () = Lam_pass_collect.collect_info meta lam in let lam = Lam_pass_remove_alias.simplify_alias meta lam in let lam = Lam_pass_deep_flatten.deep_flatten lam in - let () = Lam_pass_collect.collect_info meta lam in let lam = lam |> Lam_pass_exits.simplify_exits in let () = Lam_pass_collect.collect_info meta lam in From b4bec2afb81eb7dd5bdc303862b13c2397979440 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 1 Sep 2026 13:16:08 +0200 Subject: [PATCH 12/46] Record identifier info with replace instead of add `Hash_ident.add` conses onto the bucket, so an existing binding stays underneath: `find_opt` reads the newest and sees the update, but the old row is never reclaimed, since nothing ever removes from `meta.ident_tbl`. Both sites are updates, not new bindings. `annotate` re-records a function on every collect round with a refined arity and a fresh lambda, and `alias_ident_or_global` re-records an alias's kind. Their keys already exist by the second round, so each round leaked a row per function and per alias. `replace` is observationally identical - every consumer of the table is a `find_opt` lookup, and `find_all` is used nowhere in `compiler/core`, so the shadowing was never read. Duplicate rows for one function in a probe drop from 7 to 3; the 3 remaining are the parameter bindings, which keep using `add` because their keys are freshly stamped and genuinely new. The stale commented-out alternative above `annotate` is replaced by a note saying why it is an update. Generated JavaScript is unchanged for the runtime, Belt, tests/tests and gentype. Signed-Off-By: Cristiano Calcagno Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/core/lam_pass_collect.ml | 24 ++++++------------------ compiler/core/lam_util.ml | 4 ++-- 2 files changed, 8 insertions(+), 20 deletions(-) diff --git a/compiler/core/lam_pass_collect.ml b/compiler/core/lam_pass_collect.ml index df60477a455..943ee00bcc3 100644 --- a/compiler/core/lam_pass_collect.ml +++ b/compiler/core/lam_pass_collect.ml @@ -27,27 +27,15 @@ how about guarantee that [Lassign] only check the local ref and we track which ids are [Lassign]ed *) -(** - might not be the same due to refinement - assert (old.arity = v) -*) +(* An update, not a new binding: the arity is refined on each collect round, + and the recorded lambda has to be replaced because an older one may mention + identifiers that later passes removed (see #3609). [add] would leave the + stale row underneath - invisible to [find_opt], which reads the newest, but + never reclaimed, since nothing removes from this table. *) let annotate (meta : Lam_stats.t) rec_flag (k : Ident.t) (arity : Lam_arity.t) lambda = - Hash_ident.add meta.ident_tbl k + Hash_ident.replace meta.ident_tbl k (FunctionId {arity; lambda = Some (lambda, rec_flag)}) -(* see #3609 - we have to update since bounded function lambda - may contain stale unbounded varaibles -*) -(* match Hash_ident.find_opt meta.ident_tbl k with - | None -> (** FIXME: need do a sanity check of arity is NA or Determin(_,[],_) *) - - | Some (FunctionId old) -> - Hash_ident.add meta.ident_tbl k - (FunctionId {arity; lambda = Some (lambda, rec_flag) }) - (* old.arity <- arity *) - (* due to we keep refining arity analysis after each round*) - | _ -> assert false *) (* TODO -- avoid exception *) (** it only make senses recording arities for diff --git a/compiler/core/lam_util.ml b/compiler/core/lam_util.ml index aba0e6ea212..7c4663ced2a 100644 --- a/compiler/core/lam_util.ml +++ b/compiler/core/lam_util.ml @@ -140,8 +140,8 @@ let alias_ident_or_global (meta : Lam_stats.t) (k : Ident.t) (v : Ident.t) | NA -> ( match Hash_ident.find_opt meta.ident_tbl v with | None -> () - | Some ident_info -> Hash_ident.add meta.ident_tbl k ident_info) - | ident_info -> Hash_ident.add meta.ident_tbl k ident_info + | Some ident_info -> Hash_ident.replace meta.ident_tbl k ident_info) + | ident_info -> Hash_ident.replace meta.ident_tbl k ident_info (* share -- it is safe to share most properties, for arity, we might be careful, only [Alias] can share, From 2b19e302cce7a80e2e5162b4ccc912d73e23ab14 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 1 Sep 2026 14:17:07 +0200 Subject: [PATCH 13/46] Give Lambda the isout offset and the Lam nullable names Two rewrites conversion was doing to primitives. `Pisout` tested a range against an argument that `matching` had first shifted with `Poffsetint`, and conversion folded the shift back into `Pisout of int` - the form Lam has always had. The offset is known where the test is built: the `Switch` functor calls `make_isout` with the bound it is shifting by, so it can pass it instead. That also collapses the `l = 0` special case, since an offset of zero is no offset, and leaves `make_offset` with no callers, so it goes from the `Switch` argument signature too. `Pisnullable` and `Pnullable_to_opt` are renamed to their Lam spellings, `Pis_null_undefined` and `Pnull_undefined_to_opt`. All three conversion cases are now the identity. Generated JavaScript is unchanged for the runtime, Belt, tests/tests and gentype. Signed-Off-By: Cristiano Calcagno Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/core/lam_convert.ml | 10 +++------- compiler/ml/lambda.ml | 6 +++--- compiler/ml/lambda.mli | 6 +++--- compiler/ml/matching.ml | 9 +++------ compiler/ml/printlambda.ml | 6 +++--- compiler/ml/switch.ml | 29 ++++++++++------------------- compiler/ml/switch.mli | 5 ++--- compiler/ml/translcore.ml | 10 +++++----- 8 files changed, 32 insertions(+), 49 deletions(-) diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index ba52f3c165c..82dcb4258cd 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -45,9 +45,9 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = | Psome -> prim ~primitive:Psome ~args loc | Psome_not_nest -> prim ~primitive:Psome_not_nest ~args loc | Ptypeof -> prim ~primitive:Ptypeof ~args loc - | Pisnullable -> prim ~primitive:Pis_null_undefined ~args loc + | Pis_null_undefined -> prim ~primitive:Pis_null_undefined ~args loc | Pnull_to_opt -> prim ~primitive:Pnull_to_opt ~args loc - | Pnullable_to_opt -> prim ~primitive:Pnull_undefined_to_opt ~args loc + | Pnull_undefined_to_opt -> prim ~primitive:Pnull_undefined_to_opt ~args loc | Pis_not_none -> prim ~primitive:Pis_not_none ~args loc | Pval_from_option -> prim ~primitive:Pval_from_option ~args loc | Pval_from_option_not_nest -> @@ -98,11 +98,7 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = | Pstringadd -> prim ~primitive:Pstringadd ~args loc | Pstringrefs -> prim ~primitive:Pstringrefs ~args loc | Pisint -> prim ~primitive:Pisint ~args loc - | Pisout -> ( - match args with - | [range; Lprim {primitive = Poffsetint i; args = [x]}] -> - prim ~primitive:(Pisout i) ~args:[range; x] loc - | _ -> prim ~primitive:(Pisout 0) ~args loc) + | Pisout i -> prim ~primitive:(Pisout i) ~args loc | Pintoffloat -> prim ~primitive:Pintoffloat ~args loc | Pfloatofint -> prim ~primitive:Pfloatofint ~args loc | Pnegfloat -> prim ~primitive:Pnegfloat ~args loc diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index 49cb85089da..4d10f308a98 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -299,15 +299,15 @@ type primitive = (* Test if the argument is a block or an immediate integer *) | Pisint (* Test if the (integer) argument is outside an interval *) - | Pisout + | Pisout of int (* Test if the argument is null or undefined *) - | Pisnullable + | Pis_null_undefined (* exn *) | Pcreate_extension of string (* js *) | Pjscomp of comparison | Pnull_to_opt - | Pnullable_to_opt + | Pnull_undefined_to_opt | Pis_not_none | Pval_from_option | Pval_from_option_not_nest diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index 6de8e358642..73d05b32ff4 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -259,15 +259,15 @@ type primitive = (* Test if the argument is a block or an immediate integer *) | Pisint (* Test if the (integer) argument is outside an interval *) - | Pisout + | Pisout of int (* Test if the argument is null or undefined *) - | Pisnullable + | Pis_null_undefined (* exn *) | Pcreate_extension of string (* js *) | Pjscomp of comparison | Pnull_to_opt - | Pnullable_to_opt + | Pnull_undefined_to_opt | Pis_not_none | Pval_from_option | Pval_from_option_not_nest diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index 692293e04f0..8908c119117 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -1642,10 +1642,6 @@ module S_arg = struct type act = Lambda.lambda let make_prim p args = Lprim (p, args, Location.none) - let make_offset arg n = - match n with - | 0 -> arg - | _ -> Lprim (Poffsetint n, [arg], Location.none) let bind arg body = let newvar, newarg = @@ -1657,8 +1653,9 @@ module S_arg = struct in bind Alias newvar arg (body newarg) 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_isout h arg ~offset = Lprim (Pisout offset, [h; arg], Location.none) + let make_isin h arg ~offset = + Lprim (Pnot, [make_isout h arg ~offset], Location.none) let make_if cond ifso ifnot = Lifthenelse (cond, ifso, ifnot) let make_switch loc arg cases acts ~offset = let l = ref [] in diff --git a/compiler/ml/printlambda.ml b/compiler/ml/printlambda.ml index 8658c94835b..9e726f5071a 100644 --- a/compiler/ml/printlambda.ml +++ b/compiler/ml/printlambda.ml @@ -220,8 +220,8 @@ let primitive ppf = function | Pmakedict -> fprintf ppf "makedict" | Pdict_has -> fprintf ppf "dict.has" | Pisint -> fprintf ppf "isint" - | Pisout -> fprintf ppf "isout" - | Pisnullable -> fprintf ppf "isnullable" + | Pisout i -> fprintf ppf "isout %d" i + | Pis_null_undefined -> fprintf ppf "isnullable" | Pcreate_extension s -> fprintf ppf "extension[%s]" s | Pawait -> fprintf ppf "await" | Pimport (Import_module {module_; path}) -> @@ -241,7 +241,7 @@ let primitive ppf = function | Pjscomp Cgt -> fprintf ppf ">" | Pjscomp Cge -> fprintf ppf ">=" | Pnull_to_opt -> fprintf ppf "null_to_opt" - | Pnullable_to_opt -> fprintf ppf "nullable_to_opt" + | Pnull_undefined_to_opt -> fprintf ppf "nullable_to_opt" | Pis_not_none -> fprintf ppf "#is_not_none" | Pval_from_option -> fprintf ppf "#val_from_option" | Pval_from_option_not_nest -> fprintf ppf "#val_from_option_not_nest" diff --git a/compiler/ml/switch.ml b/compiler/ml/switch.ml index 85d3b022471..2ff81e70be1 100644 --- a/compiler/ml/switch.ml +++ b/compiler/ml/switch.ml @@ -99,10 +99,9 @@ module type S = sig val bind : act -> (act -> act) -> act val make_const : int -> act - val make_offset : act -> int -> act val make_prim : primitive -> act list -> act - val make_isout : act -> act -> act - val make_isin : act -> act -> act + val make_isout : act -> act -> offset:int -> act + val make_isin : act -> act -> offset:int -> act val make_if : act -> act -> act -> act val make_switch : Location.t -> act -> int array -> act array -> offset:int -> act @@ -480,27 +479,19 @@ let rec pkey chan = function and make_if_ne arg i ifso ifnot = make_if_test Arg.neint arg i ifso ifnot - let do_make_if_out h arg ifso ifno = - Arg.make_if (Arg.make_isout h arg) ifso ifno + let do_make_if_out h arg ~offset ifso ifno = + Arg.make_if (Arg.make_isout h arg ~offset) ifso ifno let make_if_out ctx l d mk_ifso mk_ifno = - match l with - | 0 -> do_make_if_out (Arg.make_const d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) - | _ -> - do_make_if_out (Arg.make_const d) - (Arg.make_offset ctx.arg (-l)) - (mk_ifso ctx) (mk_ifno ctx) + do_make_if_out (Arg.make_const d) ctx.arg ~offset:(-l) (mk_ifso ctx) + (mk_ifno ctx) - let do_make_if_in h arg ifso ifno = - Arg.make_if (Arg.make_isin h arg) ifso ifno + let do_make_if_in h arg ~offset ifso ifno = + Arg.make_if (Arg.make_isin h arg ~offset) ifso ifno let make_if_in ctx l d mk_ifso mk_ifno = - match l with - | 0 -> do_make_if_in (Arg.make_const d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) - | _ -> - do_make_if_in (Arg.make_const d) - (Arg.make_offset ctx.arg (-l)) - (mk_ifso ctx) (mk_ifno ctx) + do_make_if_in (Arg.make_const d) ctx.arg ~offset:(-l) (mk_ifso ctx) + (mk_ifno ctx) let rec c_test ctx ({cases; actions} as s) = let lcases = Array.length cases in diff --git a/compiler/ml/switch.mli b/compiler/ml/switch.mli index 2b3b5e7c178..6dc605ee48f 100644 --- a/compiler/ml/switch.mli +++ b/compiler/ml/switch.mli @@ -70,10 +70,9 @@ module type S = sig adding one integer, etc. *) val bind : act -> (act -> act) -> act val make_const : int -> act - val make_offset : act -> int -> act val make_prim : primitive -> act list -> act - val make_isout : act -> act -> act - val make_isin : act -> act -> act + val make_isout : act -> act -> offset:int -> act + val make_isin : act -> act -> offset:int -> act val make_if : act -> act -> act -> act (* construct an actual switch : diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 855e51240f0..036dae185a1 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -386,17 +386,17 @@ let primitive_builtins : (string * Lambda.builtin) array = ("%unsafe_le", Pjscomp Cle); ("%unsafe_gt", Pjscomp Cgt); ("%unsafe_ge", Pjscomp Cge); - ("%is_nullable", Pisnullable); + ("%is_nullable", Pis_null_undefined); ("%null_to_opt", Pnull_to_opt); - ("%nullable_to_opt", Pnullable_to_opt); + ("%nullable_to_opt", Pnull_undefined_to_opt); ("%makemutablelist", Pmakelist); ("%unsafe_to_method", Pjs_fn_method); (* Compiler internals, never expose to ReScript files *) (* FIXME: Core compatibility *) ("#typeof", Ptypeof); - ("#is_nullable", Pisnullable); + ("#is_nullable", Pis_null_undefined); ("#null_to_opt", Pnull_to_opt); - ("#nullable_to_opt", Pnullable_to_opt); + ("#nullable_to_opt", Pnull_undefined_to_opt); ("#makemutablelist", Pmakelist); (* FIXME: Deprecated *) ("%obj_field", Parrayrefu); @@ -560,7 +560,7 @@ let external_result_wrap loc (result_type : External_ffi_types.return_wrapper) match result_type with | Return_unset when returns_unit -> Lsequence (result, Lconst const_unit) | Return_null_to_opt -> Lprim (Pnull_to_opt, [result], loc) - | Return_null_undefined_to_opt -> Lprim (Pnullable_to_opt, [result], loc) + | Return_null_undefined_to_opt -> Lprim (Pnull_undefined_to_opt, [result], loc) | Return_unset | Return_identity -> result (* Does importing this external as a value require the FFI adaptation a From 9082652d6b4f1c569afeaee9cc8168c748aa5716 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 1 Sep 2026 14:17:54 +0200 Subject: [PATCH 14/46] Fix a recursive module with an empty signature losing its effects Conversion rewrote `Pinit_mod` and `Pupdate_mod` to unit when the module's shape had no fields. For `Pupdate_mod` that discarded the primitive's arguments, and one of them is the module's right hand side, so module rec M: {} = { let () = log("side effect") } emitted nothing at all for M. The elision itself is right - a shape with no fields has nothing to initialize and nothing to patch - so make it at the producer, where the right hand side is still in hand: `eval_rec_bindings_aux` binds unit instead of calling `Pinit_mod`, and sequences the right hand side itself instead of calling `Pupdate_mod`. Conversion of both primitives is now the identity. Output for such a module gains its effects and keeps the elision: no `Primitive_module` call is emitted. The test is snapshot based, as the suite is - `rec_module_test` now has an empty-signature module beside one with a field, and both `record` calls have to appear in the checked-in output. Verified to fail before the fix. Signed-Off-By: Cristiano Calcagno Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/core/lam_convert.ml | 10 ++-------- compiler/ml/transl_recmodule.ml | 27 ++++++++++++++++++--------- tests/tests/src/rec_module_test.mjs | 25 +++++++++++++++++++++++++ tests/tests/src/rec_module_test.res | 15 +++++++++++++++ 4 files changed, 60 insertions(+), 17 deletions(-) diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index 82dcb4258cd..8af0bf67639 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -143,14 +143,8 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = | Pdict_has -> prim ~primitive:Pdict_has ~args loc | Pawait -> prim ~primitive:Pawait ~args loc | Pimport src -> prim ~primitive:(Pimport src) ~args loc - | Pinit_mod -> ( - match args with - | [_loc; Lconst (Const_block (_, [Const_block (_, [])]))] -> Lam.unit - | _ -> prim ~primitive:Pinit_mod ~args loc) - | Pupdate_mod -> ( - match args with - | [Lconst (Const_block (_, [Const_block (_, [])])); _; _] -> Lam.unit - | _ -> prim ~primitive:Pupdate_mod ~args loc) + | Pinit_mod -> prim ~primitive:Pinit_mod ~args loc + | Pupdate_mod -> prim ~primitive:Pupdate_mod ~args loc | Phash -> prim ~primitive:Phash ~args loc | Phash_mixint -> prim ~primitive:Phash_mixint ~args loc | Phash_mixstring -> prim ~primitive:Phash_mixstring ~args loc diff --git a/compiler/ml/transl_recmodule.ml b/compiler/ml/transl_recmodule.ml index ce04184da80..4a22f99bb70 100644 --- a/compiler/ml/transl_recmodule.ml +++ b/compiler/ml/transl_recmodule.ml @@ -123,18 +123,25 @@ type shape = t type binding = Ident.t * (loc * shape) option * t +(* A shape with no fields: the module has nothing to initialize and nothing to + patch, so the runtime dummy and its update are both pointless. The right + hand side still has to run for its effects. *) +let shape_is_empty (shape : Lambda.lambda) = + match shape with + | Lambda.Lconst (Const_block (_, [Const_block (_, [])])) -> true + | _ -> false + let eval_rec_bindings_aux (bindings : binding list) (cont : t) : t = let rec bind_inits args acc = match args with | [] -> acc | (_id, None, _rhs) :: rem -> bind_inits rem acc | (id, Some (loc, shape), _rhs) :: rem -> - Lambda.Llet - ( Strict, - Pgenval, - id, - Lprim (Pinit_mod, [loc; shape], Location.none), - bind_inits rem acc ) + let init = + if shape_is_empty shape then Lambda.lambda_unit + else Lambda.Lprim (Pinit_mod, [loc; shape], Location.none) + in + Lambda.Llet (Strict, Pgenval, id, init, bind_inits rem acc) in let rec bind_strict args acc = match args with @@ -148,9 +155,11 @@ let eval_rec_bindings_aux (bindings : binding list) (cont : t) : t = | [] -> cont | (_id, None, _rhs) :: rem -> patch_forwards rem | (id, Some (_loc, shape), rhs) :: rem -> - Lsequence - ( Lprim (Pupdate_mod, [shape; Lvar id; rhs], Location.none), - patch_forwards rem ) + let patch = + if shape_is_empty shape then rhs + else Lambda.Lprim (Pupdate_mod, [shape; Lvar id; rhs], Location.none) + in + Lsequence (patch, patch_forwards rem) in bind_inits bindings (bind_strict bindings (patch_forwards bindings)) diff --git a/tests/tests/src/rec_module_test.mjs b/tests/tests/src/rec_module_test.mjs index 38f42a7db05..05c2bf00924 100644 --- a/tests/tests/src/rec_module_test.mjs +++ b/tests/tests/src/rec_module_test.mjs @@ -92,6 +92,27 @@ Mocha.describe("Rec_module_test", () => { Mocha.test("test5", () => Test_utils.eq("File \"rec_module_test.res\", line 91, characters 7-14", false, B.odd(2))); }); +let effects = { + contents: /* [] */0 +}; + +function record(s) { + effects.contents = { + hd: s, + tl: effects.contents + }; +} + +record("with field"); + +let WithField = { + n: 1 +}; + +record("empty signature"); + +let EmptySig; + export { A, B, @@ -99,5 +120,9 @@ export { BB, Even, Odd, + effects, + record, + EmptySig, + WithField, } /* Not a pure module */ diff --git a/tests/tests/src/rec_module_test.res b/tests/tests/src/rec_module_test.res index 25ab6595dc3..ad826153c52 100644 --- a/tests/tests/src/rec_module_test.res +++ b/tests/tests/src/rec_module_test.res @@ -91,3 +91,18 @@ describe(__MODULE__, () => { eq(__LOC__, false, B.odd(2)) }) }) + +/* A recursive module whose signature has no fields still has to run its right + hand side: the shape is empty, so no runtime dummy is created and nothing is + patched, but the effects must survive. Both calls below have to appear in the + generated output. */ +let effects = ref(list{}) +let record = s => effects := list{s, ...effects.contents} + +module rec EmptySig: {} = { + let () = record("empty signature") +} +and WithField: {let n: int} = { + let () = record("with field") + let n = 1 +} From 45ce2b5a010591b1c01e261fd1f7fb8a5769318d Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 1 Sep 2026 14:19:02 +0200 Subject: [PATCH 15/46] Derive a block's mutability from its shape `Lam_primitive.Pmakeblock` carried a `mutable_flag` beside its tag info, but conversion was the only place in the Lam layer that ever built one, and it set the flag to `Lambda.mutable_flag_of_tag_info info` - the shape decides it. Drop the field and derive it where it is read, through `Lam_primitive.is_immutable_block`. Conversion of `Pmakeblock` is now the identity. The cost is at the nine sites that discriminated on the flag: they become guards rather than patterns, and one or-pattern in `lam_pass_deep_flatten` has to split, since a `when` cannot appear inside one. Generated JavaScript is unchanged for the runtime, Belt, tests/tests and gentype. Signed-Off-By: Cristiano Calcagno Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/core/lam.ml | 2 +- compiler/core/lam_beta_reduce.ml | 6 ++++-- compiler/core/lam_compile.ml | 11 +++++------ compiler/core/lam_compile_main.ml | 7 +++---- compiler/core/lam_compile_primitive.ml | 3 ++- compiler/core/lam_convert.ml | 8 +------- compiler/core/lam_pass_collect.ml | 3 ++- compiler/core/lam_pass_deep_flatten.ml | 10 +++++++--- compiler/core/lam_pass_lets_dce.ml | 18 +++++------------- compiler/core/lam_primitive.ml | 11 ++++++++--- compiler/core/lam_primitive.mli | 4 +++- compiler/core/lam_print.ml | 4 ++-- compiler/core/lam_stats_export.ml | 3 ++- 13 files changed, 45 insertions(+), 45 deletions(-) diff --git a/compiler/core/lam.ml b/compiler/core/lam.ml index ca35f8dc401..885931c323a 100644 --- a/compiler/core/lam.ml +++ b/compiler/core/lam.ml @@ -442,7 +442,7 @@ let prim ~primitive:(prim : Lam_primitive.t) ~args loc : t = | _ -> default ()) | _ -> ( match prim with - | Pmakeblock (Blk_module fields, _) -> ( + | Pmakeblock (Blk_module fields) -> ( let rec aux fields args (var : Ident.t) i = match (fields, args) with | [], [] -> true diff --git a/compiler/core/lam_beta_reduce.ml b/compiler/core/lam_beta_reduce.ml index ed930c68eab..0cf3d2531c9 100644 --- a/compiler/core/lam_beta_reduce.ml +++ b/compiler/core/lam_beta_reduce.ml @@ -68,7 +68,8 @@ let propagate_beta_reduce (meta : Lam_stats.t) (params : Ident.t list) order. *) Ext_list.fold_left rest_bindings new_body (fun l (param, arg) -> (match arg with - | Lprim {primitive = Pmakeblock (_, Immutable); args; _} -> + | Lprim {primitive = Pmakeblock info; args; _} + when Lam_primitive.is_immutable_block info -> Hash_ident.replace meta.ident_tbl param (Lam_util.kind_of_lambda_block args) | Lprim {primitive = Psome | Psome_not_nest; args = [v]; _} -> @@ -110,7 +111,8 @@ let propagate_beta_reduce_with_map (meta : Lam_stats.t) (* See above: fold left so arguments evaluate in call order. *) Ext_list.fold_left rest_bindings new_body (fun l (param, (arg : Lam.t)) -> (match arg with - | Lprim {primitive = Pmakeblock (_, Immutable); args} -> + | Lprim {primitive = Pmakeblock info; args} + when Lam_primitive.is_immutable_block info -> Hash_ident.replace meta.ident_tbl param (Lam_util.kind_of_lambda_block args) | Lprim {primitive = Psome | Psome_not_nest; args = [v]} -> diff --git a/compiler/core/lam_compile.ml b/compiler/core/lam_compile.ml index 070e01ef28b..4050739a113 100644 --- a/compiler/core/lam_compile.ml +++ b/compiler/core/lam_compile.ml @@ -444,7 +444,7 @@ let compile output_prefix = result ~no_effects:(lazy (Lam_analysis.no_side_effects arg)), [] ) - | Lprim {primitive = Pmakeblock (_, _); args} + | Lprim {primitive = Pmakeblock _; args} when args_either_function_or_const args -> (compile_lambda {cxt with continuation = Declare (Alias, id)} arg, []) (* case of lazy blocks, treat it as usual *) @@ -452,10 +452,9 @@ let compile output_prefix = { primitive = Pmakeblock - ( (( Blk_record _ - | Blk_constructor {num_nonconst = 1} - | Blk_record_inlined {num_nonconst = 1} ) as tag_info), - _ ); + (( Blk_record _ + | Blk_constructor {num_nonconst = 1} + | Blk_record_inlined {num_nonconst = 1} ) as tag_info); args = ls; } when Ext_list.for_all ls (fun x -> @@ -496,7 +495,7 @@ let compile output_prefix = | Lconst x -> Lam_compile_const.translate x | _ -> assert false)))), [] ) - | Lprim {primitive = Pmakeblock (tag_info, _)} -> ( + | Lprim {primitive = Pmakeblock tag_info} -> ( (* Lconst should not appear here if we do [scc] optimization, since it's faked recursive value, however it would affect scope issues, we have to declare it first diff --git a/compiler/core/lam_compile_main.ml b/compiler/core/lam_compile_main.ml index 87d8a6788c3..08af22919a7 100644 --- a/compiler/core/lam_compile_main.ml +++ b/compiler/core/lam_compile_main.ml @@ -148,8 +148,8 @@ let js_hoisted_aliases (export_ids : Ident.t list) | Lam.Lprim {primitive = Lam_primitive.Pfield (pos, _); args = [base]} as lam -> ( match fst (resolve_binding seen base) with - | Lam.Lprim - {primitive = Lam_primitive.Pmakeblock (Blk_module _, _); args} -> ( + | Lam.Lprim {primitive = Lam_primitive.Pmakeblock (Blk_module _); args} + -> ( match List.nth_opt args pos with | Some field -> resolve_binding seen field | None -> (lam, None)) @@ -172,8 +172,7 @@ let js_hoisted_aliases (export_ids : Ident.t list) | field :: fields -> ( match resolve Set_ident.empty lam with | Lam.Lprim - {primitive = Lam_primitive.Pmakeblock (Blk_module names, _); args} - -> ( + {primitive = Lam_primitive.Pmakeblock (Blk_module names); args} -> ( match find_field field 0 names args with | Some (pos, arg) -> find_path arg fields ((pos, field) :: positions) | None -> None) diff --git a/compiler/core/lam_compile_primitive.ml b/compiler/core/lam_compile_primitive.ml index 89a92d9193c..56f8400dfb6 100644 --- a/compiler/core/lam_compile_primitive.ml +++ b/compiler/core/lam_compile_primitive.ml @@ -187,7 +187,8 @@ let translate output_prefix loc (cxt : Lam_compile_context.t) E.optional_not_nest_block arg | _ -> E.optional_block arg) | Psome_not_nest -> E.optional_not_nest_block (Ext_list.singleton_exn args) - | Pmakeblock (tag_info, mutable_flag) -> + | Pmakeblock tag_info -> + let mutable_flag = Lambda.mutable_flag_of_tag_info tag_info in (* RUNTIME *) Js_of_lam_block.make_block (Js_op_util.of_lam_mutable_flag mutable_flag) diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index 8af0bf67639..5a6e0e30509 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -34,13 +34,7 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = match p with | Pcreate_extension s -> prim ~primitive:(Pcreate_extension s) ~args loc | Pgetglobal _ -> assert false - | Pmakeblock info -> ( - let mutable_flag = Lambda.mutable_flag_of_tag_info info in - match info with - | Blk_constructor _ | Blk_tuple | Blk_record _ | Blk_record_inlined _ - | Blk_module _ | Blk_module_export _ | Blk_extension | Blk_record_ext _ - | Blk_poly_var -> - prim ~primitive:(Pmakeblock (info, mutable_flag)) ~args loc) + | Pmakeblock info -> prim ~primitive:(Pmakeblock info) ~args loc | Pdebugger -> prim ~primitive:Pdebugger ~args loc | Psome -> prim ~primitive:Psome ~args loc | Psome_not_nest -> prim ~primitive:Psome_not_nest ~args loc diff --git a/compiler/core/lam_pass_collect.ml b/compiler/core/lam_pass_collect.ml index 943ee00bcc3..158ae02fcab 100644 --- a/compiler/core/lam_pass_collect.ml +++ b/compiler/core/lam_pass_collect.ml @@ -46,7 +46,8 @@ let collect_info (meta : Lam_stats.t) (lam : Lam.t) = let rec collect_bind rec_flag (ident : Ident.t) (lam : Lam.t) = match lam with | Lconst v -> Hash_ident.replace meta.ident_tbl ident (Constant v) - | Lprim {primitive = Pmakeblock (_, Immutable); args = ls} -> + | Lprim {primitive = Pmakeblock info; args = ls} + when Lam_primitive.is_immutable_block info -> Hash_ident.replace meta.ident_tbl ident (Lam_util.kind_of_lambda_block ls); List.iter collect ls | Lprim {primitive = Psome | Psome_not_nest; args = [v]} -> diff --git a/compiler/core/lam_pass_deep_flatten.ml b/compiler/core/lam_pass_deep_flatten.ml index bd630b7a956..72c22b25b04 100644 --- a/compiler/core/lam_pass_deep_flatten.ml +++ b/compiler/core/lam_pass_deep_flatten.ml @@ -119,8 +119,11 @@ let rec rhs_is_beta_residue (lam : Lam.t) = | Llet ( (Alias | Strict | StrictOpt), _, - (Lprim {primitive = Pmakeblock (_, Immutable)} | Lvar _), - rest ) -> + Lprim {primitive = Pmakeblock info}, + rest ) + when Lam_primitive.is_immutable_block info -> + rhs_is_beta_residue rest + | Llet ((Alias | Strict | StrictOpt), _, Lvar _, rest) -> rhs_is_beta_residue rest | Lapply _ -> true | _ -> false @@ -175,7 +178,8 @@ let deep_flatten (lam : Lam.t) : Lam.t = match (id.name, str, res) with | ( ("match" | "include" | "param"), (Alias | Strict | StrictOpt), - Lprim {primitive = Pmakeblock (_, Immutable); args} ) -> ( + Lprim {primitive = Pmakeblock info; args} ) + when Lam_primitive.is_immutable_block info -> ( match eliminate_tuple id body Map_int.empty with | Some (tuple_mapping, body) -> flatten diff --git a/compiler/core/lam_pass_lets_dce.ml b/compiler/core/lam_pass_lets_dce.ml index 2d6ccc819a8..e4b3befd7a0 100644 --- a/compiler/core/lam_pass_lets_dce.ml +++ b/compiler/core/lam_pass_lets_dce.ml @@ -24,13 +24,9 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = | Llet ( (Strict as kind), v, - Lprim - { - primitive = Pmakeblock (_, Mutable) as primitive; - args = [linit]; - loc; - }, - lbody ) -> ( + Lprim {primitive = Pmakeblock info as primitive; args = [linit]; loc}, + lbody ) + when not (Lam_primitive.is_immutable_block info) -> ( let slinit = simplif linit in let slbody = simplif lbody in try @@ -93,12 +89,8 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = then simplif lbody (* GPR #1476 *) else match l1 with - | Lprim - { - primitive = Pmakeblock (_, Mutable) as primitive; - args = [linit]; - loc; - } -> ( + | Lprim {primitive = Pmakeblock info as primitive; args = [linit]; loc} + when not (Lam_primitive.is_immutable_block info) -> ( let slinit = simplif linit in let slbody = simplif lbody in try diff --git a/compiler/core/lam_primitive.ml b/compiler/core/lam_primitive.ml index 3ec171025f7..f97d7ac4c7f 100644 --- a/compiler/core/lam_primitive.ml +++ b/compiler/core/lam_primitive.ml @@ -28,7 +28,7 @@ type ident = Ident.t type t = (* Operations on heap blocks *) - | Pmakeblock of Lam_tag_info.t * Asttypes.mutable_flag + | Pmakeblock of Lam_tag_info.t | Pfield of int * Lam_compat.field_dbg_info | Psetfield of int * Lam_compat.set_field_dbg_info (* could have field info at least for record *) @@ -184,6 +184,11 @@ let eq_set_field_dbg_info (x : Lam_compat.set_field_dbg_info) let eq_tag_info (x : Lam_tag_info.t) y = x = y +(* The mutability of a block is a property of its shape, so it is derived + rather than stored alongside it. *) +let is_immutable_block (info : Lam_tag_info.t) = + Lambda.mutable_flag_of_tag_info info = Immutable + let eq_primitive_approx (lhs : t) (rhs : t) = match lhs with | Praise @@ -239,9 +244,9 @@ let eq_primitive_approx (lhs : t) (rhs : t) = match rhs with | Psetfield (i1, info1) -> i0 = i1 && eq_set_field_dbg_info info0 info1 | _ -> false) - | Pmakeblock (info0, flag0) -> ( + | Pmakeblock info0 -> ( match rhs with - | Pmakeblock (info1, flag1) -> flag0 = flag1 && eq_tag_info info0 info1 + | Pmakeblock info1 -> eq_tag_info info0 info1 | _ -> false) | Pjs_call {prim_name; arg_types; ffi; _} -> ( match rhs with diff --git a/compiler/core/lam_primitive.mli b/compiler/core/lam_primitive.mli index b07aa0f325a..b2e35fc24a9 100644 --- a/compiler/core/lam_primitive.mli +++ b/compiler/core/lam_primitive.mli @@ -25,7 +25,7 @@ type ident = Ident.t type t = - | Pmakeblock of Lam_tag_info.t * Asttypes.mutable_flag + | Pmakeblock of Lam_tag_info.t | Pfield of int * Lambda.field_dbg_info | Psetfield of int * Lambda.set_field_dbg_info | Pduprecord @@ -162,4 +162,6 @@ type t = | Phash_mixint | Phash_finalmix +val is_immutable_block : Lam_tag_info.t -> bool + val eq_primitive_approx : t -> t -> bool diff --git a/compiler/core/lam_print.ml b/compiler/core/lam_print.ml index a8d5807f831..ad598679c11 100644 --- a/compiler/core/lam_print.ml +++ b/compiler/core/lam_print.ml @@ -64,9 +64,9 @@ let primitive ppf (prim : Lam_primitive.t) = | Pis_undefined -> fprintf ppf "[?undefined]" | Pis_null_undefined -> fprintf ppf "[?null?undefined]" | Pimport _ -> fprintf ppf "[import]" - | Pmakeblock (i, Immutable) -> + | Pmakeblock i when Lambda.mutable_flag_of_tag_info i = Immutable -> fprintf ppf "makeblock %s" (Lambda.tag_label_of_tag_info i) - | Pmakeblock (i, Mutable) -> + | Pmakeblock i -> fprintf ppf "makemutable %s" (Lambda.tag_label_of_tag_info i) | Pfield (n, field_info) -> ( match Lam_compat.str_of_field_info field_info with diff --git a/compiler/core/lam_stats_export.ml b/compiler/core/lam_stats_export.ml index 7bf33c0cefd..3bbe21a7a35 100644 --- a/compiler/core/lam_stats_export.ml +++ b/compiler/core/lam_stats_export.ml @@ -41,7 +41,8 @@ let values_of_export (meta : Lam_stats.t) (export_map : Lam.t Map_ident.t) : | SimpleForm lam -> Lam_arity_analysis.get_arity meta lam)) | Some _ | None -> ( match Map_ident.find_opt export_map x with - | Some (Lprim {primitive = Pmakeblock (_, Immutable); args}) -> + | Some (Lprim {primitive = Pmakeblock info; args}) + when Lam_primitive.is_immutable_block info -> Submodule (Ext_array.of_list_map args (fun lam -> Lam_arity_analysis.get_arity meta lam)) From df2dc39e5f61c68790fbc791663bb0adec146247 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 1 Sep 2026 14:52:42 +0200 Subject: [PATCH 16/46] Fix Int.Ref.increment evaluating its argument twice BUG FIX - needs a changelog entry when the branch gets one. `%incr` / `%decr` lowered to `E.assign v (E.offset v n)` where `v` is the field access on the argument, so the argument expression was emitted twice: Int.Ref.increment(mkRef()) => mkRef().contents = mkRef().contents + 1 | 0; // called twice The primitive was `Poffsetref`, surviving into both IRs. It only had to be a primitive so far as the caller's optimizer needed a form it could recognise: `Lam_pass_eliminate_ref` unboxes a local reference when every use is a field read or a field write, and a call through a library function would defeat that, since the reference would appear in argument position and have to be assumed to escape. Primitives are expanded at the application site, in the caller's own module, so expanding to the field write directly gives the analysis exactly what it already reads - and lets the expansion bind the argument. `Offset_ref` joins `Lambda.builtin`, and `mk_builtin` expands it to `r := r.contents + delta`, binding the reference unless it is already a variable: let ref = mkRef(); ref.contents = ref.contents + 1 | 0; `test_incr_ref` pins the expression case. Local references still unbox, escaping ones still compile to the same field write, and a first-class use still eta expands. One other test changes: `gpr_1762_test` no longer inlines a function whose body is an increment, because `Lam_analysis.size` counted `Poffsetref` as a single node while it stood for a read-modify-write. The inlining decision is now taken on the code that is actually there. Signed-Off-By: Cristiano Calcagno Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/ml/lambda.ml | 31 +++++++++++++++++++++++++++++++ compiler/ml/lambda.mli | 3 +++ compiler/ml/translcore.ml | 4 ++-- tests/tests/src/gpr_1762_test.mjs | 2 +- tests/tests/src/test_incr_ref.mjs | 6 ++++++ tests/tests/src/test_incr_ref.res | 6 ++++++ 6 files changed, 49 insertions(+), 3 deletions(-) diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index 4d10f308a98..189f1049caa 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -350,6 +350,9 @@ type builtin = | Primitive of primitive | Eliminated of eliminated | Constant of structured_constant + | Offset_ref of int + (** [%incr] / [%decr]: an assignment through the reference, expanded here + so the caller's own IR carries the form its escape analysis reads. *) type inline_attribute = | Always_inline (* [@inline] or [@inline always] *) @@ -478,6 +481,30 @@ let lambda_module_alias = Lconst const_module_alias let lambda_unit = Lconst const_unit +(* [r := r.contents + delta]. The reference is mentioned twice, so bind it + unless it is already a variable. *) +let offset_ref ~delta r loc = + let assign r = + Lprim + ( Psetfield (0, ref_field_set_info), + [ + r; + Lprim + ( Paddint, + [ + Lprim (Pfield (0, ref_field_info), [r], loc); + Lconst (const_int delta); + ], + loc ); + ], + loc ) + in + match r with + | Lvar _ -> assign r + | _ -> + let id = Ident.create "ref" in + Llet (Strict, Pgenval, id, r, assign (Lvar id)) + let mk_builtin b args loc = match b with | Primitive p -> Lprim (p, args, loc) @@ -485,6 +512,10 @@ let mk_builtin b args loc = match args with | [] -> Lconst c | _ -> assert false) + | Offset_ref delta -> ( + match args with + | [r] -> offset_ref ~delta r loc + | _ -> assert false) | Eliminated Identity -> ( match args with | [arg] -> arg diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index 73d05b32ff4..519c034c6d1 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -309,6 +309,9 @@ type builtin = | Primitive of primitive | Eliminated of eliminated | Constant of structured_constant + | Offset_ref of int + (** [%incr] / [%decr]: an assignment through the reference, expanded here + so the caller's own IR carries the form its escape analysis reads. *) type inline_attribute = | Always_inline (* [@inline] or [@inline always] *) diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 036dae185a1..769374322e8 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -252,6 +252,8 @@ let erased_builtins : (string * Lambda.builtin) array = ("%identity", Eliminated Identity); ("%component_identity", Eliminated Identity); ("%ignore", Eliminated Ignore); + ("%incr", Offset_ref 1); + ("%decr", Offset_ref (-1)); ("%null", Constant Const_js_null); ("%undefined", Constant (Const_js_undefined {is_unit = false})); (* FIXME: Core compatibility *) @@ -267,8 +269,6 @@ let primitive_builtins : (string * Lambda.builtin) array = ("%makeref", Pmakeblock Lambda.ref_tag_info); ("%refset", Psetfield (0, Lambda.ref_field_set_info)); ("%refget", Pfield (0, Lambda.ref_field_info)); - ("%incr", Poffsetref 1); - ("%decr", Poffsetref (-1)); (* Finish Triples for ref data type *) ("%field0", Pfield (0, Fld_tuple)); ("%field1", Pfield (1, Fld_tuple)); diff --git a/tests/tests/src/gpr_1762_test.mjs b/tests/tests/src/gpr_1762_test.mjs index e276e2a5618..776e266c272 100644 --- a/tests/tests/src/gpr_1762_test.mjs +++ b/tests/tests/src/gpr_1762_test.mjs @@ -12,7 +12,7 @@ function update() { return true; } -v.contents = v.contents + 1 | 0; +update(); Mocha.describe("Gpr_1762_test", () => { Mocha.test("gpr_1762 ref increment test", () => Test_utils.eq("File \"gpr_1762_test.res\", line 21, characters 7-14", v.contents, 4)); diff --git a/tests/tests/src/test_incr_ref.mjs b/tests/tests/src/test_incr_ref.mjs index 6e22f1919fb..f5a7945013f 100644 --- a/tests/tests/src/test_incr_ref.mjs +++ b/tests/tests/src/test_incr_ref.mjs @@ -7,7 +7,13 @@ u = u + 1 | 0; let v; +function onExpression() { + let ref = mkRef(); + ref.contents = ref.contents + 1 | 0; +} + export { v, + onExpression, } /* v Not a pure module */ diff --git a/tests/tests/src/test_incr_ref.res b/tests/tests/src/test_incr_ref.res index 8605ac49a15..83eed023945 100644 --- a/tests/tests/src/test_incr_ref.res +++ b/tests/tests/src/test_incr_ref.res @@ -6,3 +6,9 @@ include ( let v: unit } ) + +/* The reference is an expression, not a variable, so it has to be bound: it + must be evaluated once, not once per mention. */ +@val external mkRef: unit => ref = "mkRef" + +let onExpression = () => Int.Ref.increment(mkRef()) From 80f7dea60c83d41036d2f76f36f1fa5d57e2e0bc Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 1 Sep 2026 14:53:33 +0200 Subject: [PATCH 17/46] Delete Poffsetref With `%incr` and `%decr` expanded at the construction site, nothing builds a `Poffsetref` any more. Its lowering, its conversion case and the arm of `Lam_pass_eliminate_ref` that rewrote it all go; the `Psetfield` arm above that one already covers the expanded form, and the read arm already rewrites the field access on an eliminated reference. Generated JavaScript is unchanged for the runtime, Belt, tests/tests and gentype. Signed-Off-By: Cristiano Calcagno Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/core/lam_analysis.ml | 2 +- compiler/core/lam_compile_primitive.ml | 7 ------- compiler/core/lam_convert.ml | 1 - compiler/core/lam_pass_eliminate_ref.ml | 4 ---- compiler/core/lam_primitive.ml | 5 ----- compiler/core/lam_primitive.mli | 1 - compiler/core/lam_print.ml | 1 - compiler/ml/lambda.ml | 1 - compiler/ml/lambda.mli | 1 - compiler/ml/printlambda.ml | 1 - 10 files changed, 1 insertion(+), 23 deletions(-) diff --git a/compiler/core/lam_analysis.ml b/compiler/core/lam_analysis.ml index 9adb4ea71e1..c24a0bf0dc0 100644 --- a/compiler/core/lam_analysis.ml +++ b/compiler/core/lam_analysis.ml @@ -100,7 +100,7 @@ let rec no_side_effects (lam : Lam.t) : bool = (* TODO *) | Praw_js_code _ (* byte swap *) - | Parraysets | Parraysetu | Poffsetref _ | Praise | Psetfield _ -> + | Parraysets | Parraysetu | Praise | Psetfield _ -> false) | Llet (_, _, arg, body) -> no_side_effects arg && no_side_effects body | Lswitch (_, _) -> false diff --git a/compiler/core/lam_compile_primitive.ml b/compiler/core/lam_compile_primitive.ml index 56f8400dfb6..49416dde580 100644 --- a/compiler/core/lam_compile_primitive.ml +++ b/compiler/core/lam_compile_primitive.ml @@ -368,13 +368,6 @@ let translate output_prefix loc (cxt : Lam_compile_context.t) | Pfloatofint -> Ext_list.singleton_exn args | Pnot -> E.not (Ext_list.singleton_exn args) | Poffsetint n -> E.offset (Ext_list.singleton_exn args) n - | Poffsetref n -> - let v = - Js_of_lam_block.field Lambda.ref_field_info - (Ext_list.singleton_exn args) - 0l - in - E.seq (E.assign v (E.offset v n)) E.unit | Psequand -> ( (* TODO: rhs is possibly a tail call *) match args with diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index 5a6e0e30509..7ef0553cde8 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -124,7 +124,6 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = | Pbigintmax -> prim ~primitive:Pbigintmax ~args loc | Pintcomp x -> prim ~primitive:(Pintcomp x) ~args loc | Poffsetint x -> prim ~primitive:(Poffsetint x) ~args loc - | Poffsetref x -> prim ~primitive:(Poffsetref x) ~args loc | Pfloatcomp x -> prim ~primitive:(Pfloatcomp x) ~args loc | Pmakearray -> prim ~primitive:Pmakearray ~args loc | Parraylength -> prim ~primitive:Parraylength ~args loc diff --git a/compiler/core/lam_pass_eliminate_ref.ml b/compiler/core/lam_pass_eliminate_ref.ml index 3f1ef7d441a..804daeade20 100644 --- a/compiler/core/lam_pass_eliminate_ref.ml +++ b/compiler/core/lam_pass_eliminate_ref.ml @@ -47,10 +47,6 @@ let rec eliminate_ref id (lam : Lam.t) = | Lprim {primitive = Psetfield (0, _); args = [Lvar v; e]} when Ident.same v id -> Lam.assign id (eliminate_ref id e) - | Lprim {primitive = Poffsetref delta; args = [Lvar v]; loc} - when Ident.same v id -> - Lam.assign id - (Lam.prim ~primitive:(Poffsetint delta) ~args:[Lam.var id] loc) | Lconst _ -> lam | Lapply {ap_func = e1; ap_args = el; ap_info; ap_transformed_jsx} -> Lam.apply ~ap_transformed_jsx (eliminate_ref id e1) diff --git a/compiler/core/lam_primitive.ml b/compiler/core/lam_primitive.ml index f97d7ac4c7f..92f65fb5171 100644 --- a/compiler/core/lam_primitive.ml +++ b/compiler/core/lam_primitive.ml @@ -78,7 +78,6 @@ type t = | Plsrint | Pasrint | Poffsetint of int - | Poffsetref of int | Pintcomp of Lam_compat.comparison | Pintorder | Pintmin @@ -285,10 +284,6 @@ let eq_primitive_approx (lhs : t) (rhs : t) = match rhs with | Poffsetint i1 -> i0 = i1 | _ -> false) - | Poffsetref i0 -> ( - match rhs with - | Poffsetref i1 -> i0 = i1 - | _ -> false) | Pjs_object_get name -> ( match rhs with | Pjs_object_get rhs_name -> name = rhs_name diff --git a/compiler/core/lam_primitive.mli b/compiler/core/lam_primitive.mli index b2e35fc24a9..84efdaeecae 100644 --- a/compiler/core/lam_primitive.mli +++ b/compiler/core/lam_primitive.mli @@ -72,7 +72,6 @@ type t = | Plsrint | Pasrint | Poffsetint of int - | Poffsetref of int | Pintcomp of Lam_compat.comparison | Pintorder | Pintmin diff --git a/compiler/core/lam_print.ml b/compiler/core/lam_print.ml index ad598679c11..d954db6609d 100644 --- a/compiler/core/lam_print.ml +++ b/compiler/core/lam_print.ml @@ -129,7 +129,6 @@ let primitive ppf (prim : Lam_primitive.t) = | Pintmin -> fprintf ppf "min" | Pintmax -> fprintf ppf "max" | Poffsetint n -> fprintf ppf "%i+" n - | Poffsetref n -> fprintf ppf "+:=%i" n | Pintoffloat -> fprintf ppf "int_of_float" | Pfloatofint -> fprintf ppf "float_of_int" | Pnegfloat -> fprintf ppf "~." diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index 189f1049caa..f342d588bbe 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -231,7 +231,6 @@ type primitive = | Pintmin | Pintmax | Poffsetint of int - | Poffsetref of int (* Float operations *) | Pintoffloat | Pfloatofint diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index 519c034c6d1..3567907336d 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -191,7 +191,6 @@ type primitive = | Pintmin | Pintmax | Poffsetint of int - | Poffsetref of int (* Float operations *) | Pintoffloat | Pfloatofint diff --git a/compiler/ml/printlambda.ml b/compiler/ml/printlambda.ml index 9e726f5071a..9cbaecd0db9 100644 --- a/compiler/ml/printlambda.ml +++ b/compiler/ml/printlambda.ml @@ -156,7 +156,6 @@ let primitive ppf = function | Pintmin -> fprintf ppf "min" | Pintmax -> fprintf ppf "max" | Poffsetint n -> fprintf ppf "%i+" n - | Poffsetref n -> fprintf ppf "+:=%i" n | Pintoffloat -> fprintf ppf "int_of_float" | Pfloatofint -> fprintf ppf "float_of_int" | Pnegfloat -> fprintf ppf "~-." From a05d98b229229221c065d66d73297df91f197ae6 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 1 Sep 2026 14:55:44 +0200 Subject: [PATCH 18/46] Delete Poffsetint and the %succint / %predint builtins MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit With `Poffsetref` gone, the arm of `Lam_pass_eliminate_ref` that rewrote it was the only thing producing a `Poffsetint` in Lam, and `%succint` / `%predint` were the only things producing one in Lambda. Both go, with their lowering, their conversion case, the `compile_assign` peephole that recognised them (the general path emits the same `x = x + 1 | 0`) and the `for … to finish - 1` alternative, which keeps its `Psubint` form. Note this is user-visible in the same narrow way `%function_arity` was: an `external` declared as `"%succint"` or `"%predint"` was accepted before and is now rejected as an unknown builtin. Their only declaration site in the tree was `test_per`, which pins the OCaml-compatible surface; the two cases are removed there rather than reimplemented, since they existed to exercise the primitives. Generated JavaScript is unchanged for the runtime, Belt, tests/tests and gentype. Signed-Off-By: Cristiano Calcagno Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H Co-Authored-By: Claude Opus 5 (1M context) --- compiler/core/lam_analysis.ml | 3 +-- compiler/core/lam_compile.ml | 9 +++------ compiler/core/lam_compile_primitive.ml | 1 - compiler/core/lam_convert.ml | 1 - compiler/core/lam_primitive.ml | 5 ----- compiler/core/lam_primitive.mli | 1 - 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 | 2 -- tests/tests/src/rec_module_test.res | 4 +++- tests/tests/src/test_incr_ref.res | 2 +- tests/tests/src/test_per.res | 2 -- 14 files changed, 8 insertions(+), 26 deletions(-) diff --git a/compiler/core/lam_analysis.ml b/compiler/core/lam_analysis.ml index c24a0bf0dc0..09b31f4b0b6 100644 --- a/compiler/core/lam_analysis.ml +++ b/compiler/core/lam_analysis.ml @@ -85,8 +85,7 @@ let rec no_side_effects (lam : Lam.t) : bool = | Pisout _ (* Operations on big arrays: (unsafe, #dimensions, kind, layout) *) (* Compile time constants *) - | Poffsetint _ | Pstringadd | Phash | Phash_mixstring | Phash_mixint - | Phash_finalmix + | Pstringadd | 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.ml b/compiler/core/lam_compile.ml index 4050739a113..428f55bf1bd 100644 --- a/compiler/core/lam_compile.ml +++ b/compiler/core/lam_compile.ml @@ -1324,9 +1324,6 @@ let compile output_prefix = and compile_assign id (lambda : Lam.t) (lambda_cxt : Lam_compile_context.t) = let block = match lambda with - | Lprim {primitive = Poffsetint v; args = [Lvar bid]} - when Ident.same id bid -> - [S.exp (E.assign (E.var id) (E.int32_add (E.var id) (E.small_int v)))] | _ -> ( match compile_lambda @@ -1938,9 +1935,9 @@ let compile output_prefix = | Lfor (id, start, finish, direction, body) -> ( match (direction, finish) with | ( Upto, - ( Lprim - {primitive = Psubint; args = [new_finish; Lconst (Const_int 1l)]} - | Lprim {primitive = Poffsetint -1; args = [new_finish]} ) ) -> + Lprim + {primitive = Psubint; args = [new_finish; Lconst (Const_int 1l)]} ) + -> compile_for id start new_finish Up body lambda_cxt | _ -> compile_for id start finish diff --git a/compiler/core/lam_compile_primitive.ml b/compiler/core/lam_compile_primitive.ml index 49416dde580..61bb7b2e655 100644 --- a/compiler/core/lam_compile_primitive.ml +++ b/compiler/core/lam_compile_primitive.ml @@ -367,7 +367,6 @@ let translate output_prefix loc (cxt : Lam_compile_context.t) | _ -> assert false) | Pfloatofint -> Ext_list.singleton_exn args | Pnot -> E.not (Ext_list.singleton_exn args) - | Poffsetint n -> E.offset (Ext_list.singleton_exn args) n | Psequand -> ( (* TODO: rhs is possibly a tail call *) match args with diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index 7ef0553cde8..8d1884a1b89 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -123,7 +123,6 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = | Pbigintmin -> prim ~primitive:Pbigintmin ~args loc | Pbigintmax -> prim ~primitive:Pbigintmax ~args loc | Pintcomp x -> prim ~primitive:(Pintcomp x) ~args loc - | Poffsetint x -> prim ~primitive:(Poffsetint x) ~args loc | Pfloatcomp x -> prim ~primitive:(Pfloatcomp x) ~args loc | Pmakearray -> prim ~primitive:Pmakearray ~args loc | Parraylength -> prim ~primitive:Parraylength ~args loc diff --git a/compiler/core/lam_primitive.ml b/compiler/core/lam_primitive.ml index 92f65fb5171..4a853ea1e2f 100644 --- a/compiler/core/lam_primitive.ml +++ b/compiler/core/lam_primitive.ml @@ -77,7 +77,6 @@ type t = | Plslint | Plsrint | Pasrint - | Poffsetint of int | Pintcomp of Lam_compat.comparison | Pintorder | Pintmin @@ -280,10 +279,6 @@ let eq_primitive_approx (lhs : t) (rhs : t) = match rhs with | Pjscomp comparison1 -> Lam_compat.eq_comparison comparison comparison1 | _ -> false) - | Poffsetint i0 -> ( - match rhs with - | Poffsetint i1 -> i0 = i1 - | _ -> false) | Pjs_object_get name -> ( match rhs with | Pjs_object_get rhs_name -> name = rhs_name diff --git a/compiler/core/lam_primitive.mli b/compiler/core/lam_primitive.mli index 84efdaeecae..7e71d87610a 100644 --- a/compiler/core/lam_primitive.mli +++ b/compiler/core/lam_primitive.mli @@ -71,7 +71,6 @@ type t = | Plslint | Plsrint | Pasrint - | Poffsetint of int | Pintcomp of Lam_compat.comparison | Pintorder | Pintmin diff --git a/compiler/core/lam_print.ml b/compiler/core/lam_print.ml index d954db6609d..dcdc966d904 100644 --- a/compiler/core/lam_print.ml +++ b/compiler/core/lam_print.ml @@ -128,7 +128,6 @@ let primitive ppf (prim : Lam_primitive.t) = | Pintorder -> fprintf ppf "compare" | Pintmin -> fprintf ppf "min" | Pintmax -> fprintf ppf "max" - | Poffsetint n -> fprintf ppf "%i+" n | Pintoffloat -> fprintf ppf "int_of_float" | Pfloatofint -> fprintf ppf "float_of_int" | Pnegfloat -> fprintf ppf "~." diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index f342d588bbe..399f2b025c8 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -230,7 +230,6 @@ type primitive = | Pintorder | Pintmin | Pintmax - | Poffsetint of int (* Float operations *) | Pintoffloat | Pfloatofint diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index 3567907336d..08a42250eb2 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -190,7 +190,6 @@ type primitive = | Pintorder | Pintmin | Pintmax - | Poffsetint of int (* Float operations *) | Pintoffloat | Pfloatofint diff --git a/compiler/ml/printlambda.ml b/compiler/ml/printlambda.ml index 9cbaecd0db9..51b58b32e2e 100644 --- a/compiler/ml/printlambda.ml +++ b/compiler/ml/printlambda.ml @@ -155,7 +155,6 @@ let primitive ppf = function | Pintorder -> fprintf ppf "compare" | Pintmin -> fprintf ppf "min" | Pintmax -> fprintf ppf "max" - | Poffsetint n -> fprintf ppf "%i+" n | Pintoffloat -> fprintf ppf "int_of_float" | Pfloatofint -> fprintf ppf "float_of_int" | Pnegfloat -> fprintf ppf "~-." diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 769374322e8..a9c26497783 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -288,8 +288,6 @@ let primitive_builtins : (string * Lambda.builtin) array = (* int primitives *) ("%obj_is_int", Pisint); ("%negint", Pnegint); - ("%succint", Poffsetint 1); - ("%predint", Poffsetint (-1)); ("%addint", Paddint); ("%subint", Psubint); ("%mulint", Pmulint); diff --git a/tests/tests/src/rec_module_test.res b/tests/tests/src/rec_module_test.res index ad826153c52..4480d06444a 100644 --- a/tests/tests/src/rec_module_test.res +++ b/tests/tests/src/rec_module_test.res @@ -102,7 +102,9 @@ let record = s => effects := list{s, ...effects.contents} module rec EmptySig: {} = { let () = record("empty signature") } -and WithField: {let n: int} = { +and WithField: { + let n: int +} = { let () = record("with field") let n = 1 } diff --git a/tests/tests/src/test_incr_ref.res b/tests/tests/src/test_incr_ref.res index 83eed023945..34485d403dd 100644 --- a/tests/tests/src/test_incr_ref.res +++ b/tests/tests/src/test_incr_ref.res @@ -8,7 +8,7 @@ include ( ) /* The reference is an expression, not a variable, so it has to be bound: it - must be evaluated once, not once per mention. */ + must be evaluated once, not once per mention. */ @val external mkRef: unit => ref = "mkRef" let onExpression = () => Int.Ref.increment(mkRef()) diff --git a/tests/tests/src/test_per.res b/tests/tests/src/test_per.res index da968bff30a..835873593ea 100644 --- a/tests/tests/src/test_per.res +++ b/tests/tests/src/test_per.res @@ -57,8 +57,6 @@ external \"||": (bool, bool) => bool = "%sequor" external \"~-": int => int = "%negint" external \"~+": int => int = "%identity" -external succ: int => int = "%succint" -external pred: int => int = "%predint" external \"+": (int, int) => int = "%addint" external \"-": (int, int) => int = "%subint" external \"*": (int, int) => int = "%mulint" From 243e4d64b6d4e28cf555a27b4e03715c52c08544 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 1 Sep 2026 15:14:17 +0200 Subject: [PATCH 19/46] Make a module reference a name in Lambda too `Lprim (Pgetglobal id, [], loc)` encoded a reference to another compilation unit as an application of a nullary operation. A module reference computes nothing: it is a name the module system resolves, closer to `Lvar` than to any primitive - which is how Lam has always represented it, as the `Lglobal_module` leaf that later passes match against to recognise cross module field access. Give Lambda the same leaf and delete `Pgetglobal`. Every traversal that had to learn the case treats it as one, beside `Lvar` or `Lconst`. `transl_normal_path` is the single place that resolves a path, so the choice between the three forms is made there: a predefined exception is its own name at runtime and becomes that string constant, a global becomes the module reference, anything else stays a variable. Conversion was deriving the first of those itself, and no longer has to. Conversion of the reference is now structural apart from recording the module in `may_depends`. Generated JavaScript is unchanged for the runtime, Belt, tests/tests and gentype. Signed-Off-By: Cristiano Calcagno Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/core/lam_convert.ml | 12 +++--------- compiler/ml/lambda.ml | 21 ++++++++++++++------- compiler/ml/lambda.mli | 4 +++- compiler/ml/lambda_scc.ml | 1 + compiler/ml/printlambda.ml | 2 +- compiler/ml/translcore.ml | 9 +++------ 6 files changed, 25 insertions(+), 24 deletions(-) diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index 8d1884a1b89..7cbeed904c2 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -33,7 +33,6 @@ let prim = Lam.prim let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = match p with | Pcreate_extension s -> prim ~primitive:(Pcreate_extension s) ~args loc - | Pgetglobal _ -> assert false | Pmakeblock info -> prim ~primitive:(Pmakeblock info) ~args loc | Pdebugger -> prim ~primitive:Pdebugger ~args loc | Psome -> prim ~primitive:Psome ~args loc @@ -183,14 +182,9 @@ let convert (lam : Lambda.lambda) : Lam.t * Lam_module_ident.Hash_set.t = 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, _) -> - let args = Ext_list.map args convert_aux in - if Ident.is_predef_exn id then - Lam.const (Const_string {s = id.name; delim = None}) - else ( - may_depend may_depends (Lam_module_ident.of_ml id); - assert (args = []); - Lam.global_module id) + | Lglobal_module id -> + may_depend may_depends (Lam_module_ident.of_ml id); + Lam.global_module id | Lprim (primitive, args, loc) -> let args = Ext_list.map args convert_aux in lam_prim ~primitive ~args loc diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index 399f2b025c8..a96bcf8b661 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -177,7 +177,6 @@ type primitive = | Psome_not_nest (** [Some x] where [x] cannot itself be [undefined], so no wrapping is needed. *) - | Pgetglobal of Ident.t (* Operations on heap blocks *) | Pmakeblock of tag_info | Pfield of int * field_dbg_info @@ -370,6 +369,9 @@ type function_attribute = { type lambda = | Lvar of Ident.t + | Lglobal_module of Ident.t + (** A reference to another compilation unit: a name the module system + resolves, not a value this one computes. *) | Lconst of structured_constant | Lapply of lambda_apply | Lfunction of lfunction @@ -553,7 +555,7 @@ let make_key e = (* Too big ! *) match e with | Lvar id -> ( try Ident.find_same id env with Not_found -> e) - | Lconst _ -> e + | Lglobal_module _ | Lconst _ -> e | Lapply ap -> Lapply { @@ -623,7 +625,7 @@ let iter_opt f = function | Some e -> f e let iter f = function - | Lvar _ | Lconst _ -> () + | Lvar _ | Lglobal_module _ | Lconst _ -> () | Lapply {ap_func = fn; ap_args = args} -> f fn; List.iter f args @@ -694,9 +696,9 @@ let free_ids get l = | Lfor_of (v, _e1, _e2) | Lfor_await_of (v, _e1, _e2) -> fv := Ident_set.remove v !fv | Lassign (id, _e) -> fv := Ident_set.add id !fv - | Lvar _ | Lconst _ | Lapply _ | Lprim _ | Lswitch _ | Lstringswitch _ - | Lstaticraise _ | Lifthenelse _ | Lsequence _ | Lbreak | Lcontinue - | Lwhile _ -> + | Lvar _ | Lglobal_module _ | Lconst _ | Lapply _ | Lprim _ | Lswitch _ + | Lstringswitch _ | Lstaticraise _ | Lifthenelse _ | Lsequence _ | Lbreak + | Lcontinue | Lwhile _ -> () in free l; @@ -741,7 +743,11 @@ let rec patch_guarded patch = function let rec transl_normal_path = function | Path.Pident id -> - if Ident.global id then Lprim (Pgetglobal id, [], Location.none) + (* A predefined exception is its own name at runtime, so the reference is + that string rather than a module. *) + if Ident.is_predef_exn id then + Lconst (Const_string {s = id.name; delim = None}) + else if Ident.global id then Lglobal_module id else Lvar id | Pdot (p, s, pos) -> Lprim @@ -769,6 +775,7 @@ let transl_extension_path = transl_value_path let subst_lambda s lam = let rec subst = function | Lvar id as l -> ( try Ident.find_same id s with Not_found -> l) + | Lglobal_module _ as l -> l | Lconst _ as l -> l | Lapply ap -> Lapply diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index 08a42250eb2..64874419828 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -137,7 +137,6 @@ type primitive = | Psome_not_nest (** [Some x] where [x] cannot itself be [undefined], so no wrapping is needed. *) - | Pgetglobal of Ident.t (* Operations on heap blocks *) | Pmakeblock of tag_info | Pfield of int * field_dbg_info @@ -340,6 +339,9 @@ type function_attribute = { type lambda = | Lvar of Ident.t + | Lglobal_module of Ident.t + (** A reference to another compilation unit: a name the module system + resolves, not a value this one computes. *) | Lconst of structured_constant | Lapply of lambda_apply | Lfunction of lfunction diff --git a/compiler/ml/lambda_scc.ml b/compiler/ml/lambda_scc.ml index e216d5b092b..09435aa5231 100644 --- a/compiler/ml/lambda_scc.ml +++ b/compiler/ml/lambda_scc.ml @@ -58,6 +58,7 @@ let exists_var (p : Ident.t -> bool) (l : lambda) : bool = || hit_opt sw.sw_failaction | Lstringswitch (arg, cases, default, _) -> hit arg || hit_list_snd cases || hit_opt default + | Lglobal_module _ -> false in hit l diff --git a/compiler/ml/printlambda.ml b/compiler/ml/printlambda.ml index 51b58b32e2e..13365417b2a 100644 --- a/compiler/ml/printlambda.ml +++ b/compiler/ml/printlambda.ml @@ -97,7 +97,6 @@ let primitive ppf = function | Ptypeof -> fprintf ppf "typeof" | Psome -> fprintf ppf "some" | Psome_not_nest -> fprintf ppf "some_not_nest" - | 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 | Psetfield (n, _) -> fprintf ppf "setfield %i" n @@ -264,6 +263,7 @@ let apply_inlined_attribute ppf = function let rec lam ppf = function | Lvar id -> Ident.print ppf id + | Lglobal_module id -> fprintf ppf "global %a" Ident.print id | Lconst cst -> struct_const ppf cst | Lapply ap -> let lams ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index a9c26497783..a386db17900 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -943,11 +943,8 @@ let wrap_exn loc arg = Lprim ( Pfield (0, Fld_module {name = "internalToException"}), [ - Lprim - ( Pgetglobal - (Ident.create_persistent Primitive_modules.exceptions), - [], - loc ); + Lglobal_module + (Ident.create_persistent Primitive_modules.exceptions); ], loc ); ap_args = [arg]; @@ -975,7 +972,7 @@ let exception_id_destructed (l : lambda) (fv : Ident.t) : bool = | 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 + | Lglobal_module _ | 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 From a1c9dea2152d6d615e483dd22295e93ff84e28cc Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 1 Sep 2026 15:20:03 +0200 Subject: [PATCH 20/46] Read the required modules off the Lambda term `convert` returned the set of modules this unit refers to alongside the translated term, accumulating it as a side effect while translating. The set is a property of the term as written - a reference the optimizer later deletes still has to be imported when the module it names is impure (#3852) - so it can be read off the Lambda term directly. `Lam_convert.required_modules` does that, in twelve lines, because `Lambda.iter` already visits every subterm. `convert` becomes `Lambda.lambda -> Lam.t`: a function of its input with nothing accumulated on the side, and every case of `convert_aux` a structural rebuild. It sits beside `convert` rather than in `Lambda` because `Lam_module_ident` lives in `compiler/core` and `Lambda` in `compiler/ml`, so the traversal has to be on the core side either way. Generated JavaScript is unchanged for the runtime, Belt, tests/tests and gentype. Signed-Off-By: Cristiano Calcagno Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/core/lam_compile_main.ml | 3 ++- compiler/core/lam_convert.ml | 27 +++++++++++++++++++-------- compiler/core/lam_convert.mli | 10 +++++++--- compiler/jsoo/jsoo_playground_main.ml | 2 +- 4 files changed, 29 insertions(+), 13 deletions(-) diff --git a/compiler/core/lam_compile_main.ml b/compiler/core/lam_compile_main.ml index 08af22919a7..14b73c88a3f 100644 --- a/compiler/core/lam_compile_main.ml +++ b/compiler/core/lam_compile_main.ml @@ -274,7 +274,8 @@ 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 lam in + let may_required_modules = Lam_convert.required_modules lam in + let lam = 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 7cbeed904c2..e9539ae2b90 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -154,11 +154,24 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = (* Does not exist since we compile array in js backend unlike native backend *) -let may_depend = Lam_module_ident.Hash_set.add - -let convert (lam : Lambda.lambda) : Lam.t * Lam_module_ident.Hash_set.t = - let may_depends = Lam_module_ident.Hash_set.create 0 in +(* Which other compilation units this one refers to. A reference that later + passes delete still has to be imported when the module it names is impure, + so the answer is taken from the term as written (see #3852). Read off the + Lambda term rather than accumulated while translating it, so that + translation stays a function of its input. *) +let required_modules (lam : Lambda.lambda) : Lam_module_ident.Hash_set.t = + let required = Lam_module_ident.Hash_set.create 0 in + let rec collect (lam : Lambda.lambda) = + (match lam with + | Lglobal_module id -> + Lam_module_ident.Hash_set.add required (Lam_module_ident.of_ml id) + | _ -> ()); + Lambda.iter collect lam + in + collect lam; + required +let convert (lam : Lambda.lambda) : Lam.t = let rec convert_aux (lam : Lambda.lambda) : Lam.t = match lam with | Lvar x -> Lam.var x @@ -182,9 +195,7 @@ let convert (lam : Lambda.lambda) : Lam.t * Lam_module_ident.Hash_set.t = 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) - | Lglobal_module id -> - may_depend may_depends (Lam_module_ident.of_ml id); - Lam.global_module id + | Lglobal_module id -> Lam.global_module id | Lprim (primitive, args, loc) -> let args = Ext_list.map args convert_aux in lam_prim ~primitive ~args loc @@ -223,4 +234,4 @@ let convert (lam : Lambda.lambda) : Lam.t * Lam_module_ident.Hash_set.t = sw_dispatch = s.sw_dispatch; } in - (convert_aux lam, may_depends) + convert_aux lam diff --git a/compiler/core/lam_convert.mli b/compiler/core/lam_convert.mli index dd3a3c74e6b..badee14d1cb 100644 --- a/compiler/core/lam_convert.mli +++ b/compiler/core/lam_convert.mli @@ -22,8 +22,12 @@ * 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 : 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 +val required_modules : Lambda.lambda -> Lam_module_ident.Hash_set.t +(** The other compilation units this one refers to, read off the Lambda term. + A reference the optimizer deletes still has to be imported when the module + it names is impure. *) + +val convert : Lambda.lambda -> Lam.t +(** [convert lam] translates Lambda to Lam. [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 2e4536b6958..275ac919033 100644 --- a/compiler/jsoo/jsoo_playground_main.ml +++ b/compiler/jsoo/jsoo_playground_main.ml @@ -547,7 +547,7 @@ module Compile = struct 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 lambda in + let lam = Lam_convert.convert lambda in let lam = Lam_print.lambda_to_string lam in let debug_attrs = Js.Unsafe. From abdcff14cd85310ebfa0bfe0d495d6efa6bded79 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 1 Sep 2026 15:28:09 +0200 Subject: [PATCH 21/46] Make conversion a 1-1 rebuild Two constructors stood between conversion and a mechanical rebuild. `Pjs_apply` had no producer left: it was reached only from `Pcurry_apply`, which went with the curried application machinery. Delete it. `Pis_null` and `Pis_undefined` existed only in Lam, produced by `Lam_pass_remove_alias` when it can prove which half of a nullable test is needed. Give them to Lambda as well. They are not built by translation, and the comment beside them says so - unlike the constructors removed earlier in this series, they are built by a pass over the term rather than by nothing at all, which is the status `Poffsetint` had through `eliminate_ref`. All 116 primitive cases and all 22 expression cases in `Lam_convert` are now a 1-1 rebuild. Generated JavaScript is unchanged for the runtime, Belt, tests/tests and gentype. Signed-Off-By: Cristiano Calcagno Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/core/lam_analysis.ml | 4 ++-- compiler/core/lam_compile_primitive.ml | 4 ---- compiler/core/lam_convert.ml | 2 ++ compiler/core/lam_primitive.ml | 3 +-- compiler/core/lam_primitive.mli | 1 - compiler/core/lam_print.ml | 1 - compiler/ml/lambda.ml | 3 +++ compiler/ml/lambda.mli | 3 +++ compiler/ml/printlambda.ml | 2 ++ 9 files changed, 13 insertions(+), 10 deletions(-) diff --git a/compiler/core/lam_analysis.ml b/compiler/core/lam_analysis.ml index 09b31f4b0b6..1d81fe88d84 100644 --- a/compiler/core/lam_analysis.ml +++ b/compiler/core/lam_analysis.ml @@ -92,8 +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_call _ | Pinit_mod | Pupdate_mod - | Pjs_object_get _ | Pjs_object_set _ | Pdebugger | Pjs_fn_method + | Ptagged_template | 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 61bb7b2e655..b3eb3039558 100644 --- a/compiler/core/lam_compile_primitive.ml +++ b/compiler/core/lam_compile_primitive.ml @@ -80,10 +80,6 @@ let translate output_prefix loc (cxt : Lam_compile_context.t) trim can not be done before syntax checking otherwise location is incorrect *) - | Pjs_apply -> ( - match args with - | fn :: rest -> E.call ~info:call_info fn rest - | _ -> assert false) | Ptagged_template -> ( (* [tag; strings_array; values_array] -> tag`...` *) match args with diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index e9539ae2b90..83b618aeb5a 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -40,6 +40,8 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = | Ptypeof -> prim ~primitive:Ptypeof ~args loc | Pis_null_undefined -> prim ~primitive:Pis_null_undefined ~args loc | Pnull_to_opt -> prim ~primitive:Pnull_to_opt ~args loc + | Pis_null -> prim ~primitive:Pis_null ~args loc + | Pis_undefined -> prim ~primitive:Pis_undefined ~args loc | Pnull_undefined_to_opt -> prim ~primitive:Pnull_undefined_to_opt ~args loc | Pis_not_none -> prim ~primitive:Pis_not_none ~args loc | Pval_from_option -> prim ~primitive:Pval_from_option ~args loc diff --git a/compiler/core/lam_primitive.ml b/compiler/core/lam_primitive.ml index 4a853ea1e2f..762daf64a5c 100644 --- a/compiler/core/lam_primitive.ml +++ b/compiler/core/lam_primitive.ml @@ -140,7 +140,6 @@ type t = | Pis_poly_var_block | Pisout of int | Pjscomp of Lam_compat.comparison - | Pjs_apply (*[f;arg0;arg1; arg2; ... argN]*) | Pdebugger | Pjs_object_get of string | Pjs_object_set of string @@ -215,7 +214,7 @@ let eq_primitive_approx (lhs : t) (rhs : t) = (* promise *) | Pawait (* etc *) - | Pjs_apply | Pval_from_option | Pval_from_option_not_nest | Pnull_to_opt + | 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 | Pis_poly_var_block | Pdebugger | Pinit_mod | Pupdate_mod | Pduprecord | Pmakearray | Parraylength diff --git a/compiler/core/lam_primitive.mli b/compiler/core/lam_primitive.mli index 7e71d87610a..ffc8664cc3e 100644 --- a/compiler/core/lam_primitive.mli +++ b/compiler/core/lam_primitive.mli @@ -134,7 +134,6 @@ type t = | Pis_poly_var_block | Pisout of int | Pjscomp of Lam_compat.comparison - | Pjs_apply (*[f;arg0;arg1; arg2; ... argN]*) | 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 dcdc966d904..b9c67648323 100644 --- a/compiler/core/lam_print.ml +++ b/compiler/core/lam_print.ml @@ -44,7 +44,6 @@ let primitive ppf (prim : Lam_primitive.t) = | Pcreate_extension s -> fprintf ppf "[ext-create]%S" s | Pinit_mod -> fprintf ppf "init_mod!" | Pupdate_mod -> fprintf ppf "update_mod!" - | Pjs_apply -> fprintf ppf "#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 diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index a96bcf8b661..0d363a61acc 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -305,6 +305,9 @@ type primitive = | Pjscomp of comparison | Pnull_to_opt | Pnull_undefined_to_opt + (* Produced by Lam_pass_remove_alias, not by translation *) + | Pis_null + | Pis_undefined | Pis_not_none | Pval_from_option | Pval_from_option_not_nest diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index 64874419828..26433dc2a0d 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -265,6 +265,9 @@ type primitive = | Pjscomp of comparison | Pnull_to_opt | Pnull_undefined_to_opt + (* Produced by Lam_pass_remove_alias, not by translation *) + | Pis_null + | Pis_undefined | Pis_not_none | Pval_from_option | Pval_from_option_not_nest diff --git a/compiler/ml/printlambda.ml b/compiler/ml/printlambda.ml index 13365417b2a..b19798345b6 100644 --- a/compiler/ml/printlambda.ml +++ b/compiler/ml/printlambda.ml @@ -218,6 +218,8 @@ let primitive ppf = function | Pdict_has -> fprintf ppf "dict.has" | Pisint -> fprintf ppf "isint" | Pisout i -> fprintf ppf "isout %d" i + | Pis_null -> fprintf ppf "is_null" + | Pis_undefined -> fprintf ppf "is_undefined" | Pis_null_undefined -> fprintf ppf "isnullable" | Pcreate_extension s -> fprintf ppf "extension[%s]" s | Pawait -> fprintf ppf "await" From 8634b2308004ce7346512e1f1db54229e816c5aa Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 1 Sep 2026 15:34:31 +0200 Subject: [PATCH 22/46] Drop the value_kind slot from Lambda's Llet `value_kind` had a single inhabitant, `Pgenval`, passed at all 31 construction sites and ignored at every pattern. It is a remnant of the native backend's unboxing information, which this target has no use for. `Llet` now has the same shape in both layers. Generated JavaScript is unchanged for the runtime, Belt, tests/tests and gentype. Signed-Off-By: Cristiano Calcagno Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/core/lam_convert.ml | 2 +- compiler/core/polyvar_pattern_match.ml | 1 - compiler/ml/lambda.ml | 29 ++++++++++++-------------- compiler/ml/lambda.mli | 4 +--- compiler/ml/lambda_scc.ml | 6 +++--- compiler/ml/matching.ml | 14 ++++++------- compiler/ml/printlambda.ml | 14 +++++-------- compiler/ml/transl_recmodule.ml | 10 ++++----- compiler/ml/translcore.ml | 16 +++++--------- compiler/ml/translmod.ml | 17 ++++----------- 10 files changed, 43 insertions(+), 70 deletions(-) diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index 83b618aeb5a..4d21ddf6e1f 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -193,7 +193,7 @@ let convert (lam : Lambda.lambda) : Lam.t = | Lfunction {params; body; attr; loc} -> Lam.function_ ~loc ~attr ~arity:(List.length params) ~params ~body:(convert_aux body) - | Llet (kind, Pgenval, id, e, body) -> + | Llet (kind, 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) diff --git a/compiler/core/polyvar_pattern_match.ml b/compiler/core/polyvar_pattern_match.ml index 8dc691ef411..9f0767b7e48 100644 --- a/compiler/core/polyvar_pattern_match.ml +++ b/compiler/core/polyvar_pattern_match.ml @@ -104,7 +104,6 @@ let call_switcher_variant_constr (loc : Location.t) (fail : lam option) let v = Ident.create "variant" in Llet ( Alias, - Pgenval, v, Lprim (Pfield (0, Fld_poly_var_tag), [arg], loc), call_switcher_variant_constant loc fail (Lvar v) int_lambda_list ) diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index 0d363a61acc..5cfe67539c7 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -319,8 +319,6 @@ type primitive = and comparison = Ceq | Cneq | Clt | Cgt | Cle | Cge -and value_kind = Pgenval - type structured_constant = | Const_int of int32 | Const_char of int @@ -378,7 +376,7 @@ type lambda = | Lconst of structured_constant | Lapply of lambda_apply | Lfunction of lfunction - | Llet of let_kind * value_kind * Ident.t * lambda * lambda + | Llet of let_kind * Ident.t * lambda * lambda | Lletrec of (Ident.t * lambda) list * lambda | Lprim of primitive * lambda list * Location.t | Lswitch of lambda * lambda_switch * Location.t @@ -506,7 +504,7 @@ let offset_ref ~delta r loc = | Lvar _ -> assign r | _ -> let id = Ident.create "ref" in - Llet (Strict, Pgenval, id, r, assign (Lvar id)) + Llet (Strict, id, r, assign (Lvar id)) let mk_builtin b args loc = match b with @@ -567,17 +565,17 @@ let make_key e = ap_args = tr_recs env ap.ap_args; ap_loc = Location.none; } - | Llet (Alias, _k, x, ex, e) -> + | Llet (Alias, x, ex, e) -> (* Ignore aliases -> substitute *) let ex = tr_rec env ex in tr_rec (Ident.add x ex env) e - | Llet ((Strict | StrictOpt), _k, x, ex, Lvar v) when Ident.same v x -> + | Llet ((Strict | StrictOpt), x, ex, Lvar v) when Ident.same v x -> tr_rec env ex - | Llet (str, k, x, ex, e) -> + | Llet (str, x, ex, e) -> (* Because of side effects, keep other lets with normalized names *) 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) + Llet (str, y, ex, tr_rec (Ident.add x (Lvar y) env) e) | Lprim (p, es, _) -> Lprim (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, _) -> @@ -621,7 +619,7 @@ let name_lambda strict arg fn = | Lvar id -> fn id | _ -> let id = Ident.create "let" in - Llet (strict, Pgenval, id, arg, fn id) + Llet (strict, id, arg, fn id) let iter_opt f = function | None -> () @@ -633,7 +631,7 @@ let iter f = function f fn; List.iter f args | Lfunction {body} -> f body - | Llet (_str, _k, _id, arg, body) -> + | Llet (_str, _id, arg, body) -> f arg; f body | Lletrec (decl, body) -> @@ -689,7 +687,7 @@ let free_ids get l = match l with | Lfunction {params} -> List.iter (fun param -> fv := Ident_set.remove param !fv) params - | Llet (_str, _k, id, _arg, _body) -> fv := Ident_set.remove id !fv + | Llet (_str, id, _arg, _body) -> fv := Ident_set.remove id !fv | Lletrec (decl, _body) -> List.iter (fun (id, _exp) -> fv := Ident_set.remove id !fv) decl | Lstaticcatch (_e1, (_, vars), _e2) -> @@ -732,14 +730,13 @@ let staticfail = Lstaticraise (0, []) let rec is_guarded = function | Lifthenelse (_cond, _body, Lstaticraise (0, [])) -> true - | Llet (_str, _k, _id, _lam, body) -> is_guarded body + | Llet (_str, _id, _lam, body) -> is_guarded body | _ -> false let rec patch_guarded patch = function | Lifthenelse (cond, body, Lstaticraise (0, [])) -> Lifthenelse (cond, body, patch) - | Llet (str, k, id, lam, body) -> - Llet (str, k, id, lam, patch_guarded patch body) + | Llet (str, id, lam, body) -> Llet (str, id, lam, patch_guarded patch body) | _ -> assert false (* Translate an access path *) @@ -789,7 +786,7 @@ let subst_lambda s lam = } | Lfunction {params; body; attr; loc} -> Lfunction {params; body = subst body; attr; loc} - | Llet (str, k, id, arg, body) -> Llet (str, k, id, subst arg, subst body) + | Llet (str, id, arg, body) -> Llet (str, 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) | Lswitch (arg, sw, loc) -> @@ -831,4 +828,4 @@ let subst_lambda s lam = let bind str var exp body = match exp with | Lvar var' when Ident.same var var' -> body - | _ -> Llet (str, Pgenval, var, exp, body) + | _ -> Llet (str, var, exp, body) diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index 26433dc2a0d..1db565cdf57 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -278,8 +278,6 @@ type primitive = and comparison = Ceq | Cneq | Clt | Cgt | Cle | Cge -and value_kind = Pgenval - type structured_constant = | Const_int of int32 | Const_char of int @@ -348,7 +346,7 @@ type lambda = | Lconst of structured_constant | Lapply of lambda_apply | Lfunction of lfunction - | Llet of let_kind * value_kind * Ident.t * lambda * lambda + | Llet of let_kind * Ident.t * lambda * lambda | Lletrec of (Ident.t * lambda) list * lambda | Lprim of primitive * lambda list * Location.t | Lswitch of lambda * lambda_switch * Location.t diff --git a/compiler/ml/lambda_scc.ml b/compiler/ml/lambda_scc.ml index 09435aa5231..b110fcc9b38 100644 --- a/compiler/ml/lambda_scc.ml +++ b/compiler/ml/lambda_scc.ml @@ -46,7 +46,7 @@ let exists_var (p : Ident.t -> bool) (l : lambda) : bool = | Lfor_await_of (_, e1, e2) -> hit e1 || hit e2 | Lfunction {body} -> hit body - | Llet (_, _, _, arg, body) -> hit arg || 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 @@ -88,7 +88,7 @@ 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) + else Llet (Strict, id, bind, body) | _ -> let domain, int_mapping, node_vec = preprocess_deps groups in let clusters = Ext_scc.graph node_vec in @@ -109,6 +109,6 @@ let bind_rec (groups : bindings) (body : lambda) : lambda = 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) + else Llet (Strict, id, lam, acc) | _ -> Lletrec (bindings, acc)) clusters body diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index 8908c119117..a727d40e540 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -451,7 +451,7 @@ let make_exit i = Lstaticraise (i, []) (* Introduce a catch, if worth it, delayed version *) let rec as_simple_exit = function | Lstaticraise (i, []) -> Some i - | Llet (Alias, _k, _, _, e) -> as_simple_exit e + | Llet (Alias, _, _, e) -> as_simple_exit e | _ -> None let make_catch_delayed handler = @@ -538,7 +538,6 @@ let simplify_or p = let bind_record_rest loc arg rest action = Llet ( Strict, - Pgenval, rest.rest_ident, Lprim (Precord_rest rest.excluded_runtime_labels, [arg], loc), action ) @@ -2167,7 +2166,7 @@ let combine_constructor loc arg ex_pat cstr partial ctx def rem )) extension_cases default in - Llet (Alias, Pgenval, tag, arg, tests) + Llet (Alias, tag, arg, tests) in (lambda1, jumps_union local_jumps total1) else @@ -2208,7 +2207,6 @@ let call_switcher_variant_constr loc fail arg int_lambda_list = let v = Ident.create "variant" in Llet ( Alias, - Pgenval, v, Lprim (Pfield (0, Fld_poly_var_tag), [arg], loc), call_switcher loc fail (Lvar v) min_int max_int @@ -2383,7 +2381,7 @@ let rec approx_present v = function | Lconst _ -> false | Lstaticraise (_, args) -> List.exists (fun lam -> approx_present v lam) args | Lprim (_, args, _) -> List.exists (fun lam -> approx_present v lam) args - | Llet (Alias, _k, _, l1, l2) -> approx_present v l1 || approx_present v l2 + | Llet (Alias, _, l1, l2) -> approx_present v l1 || approx_present v l2 | Lvar vv -> Ident.same v vv | _ -> true @@ -2404,9 +2402,9 @@ let rec lower_bind v arg lam = | Lswitch (ls, ({sw_consts = []; sw_blocks = [(i, act)]} as sw), loc) when not (approx_present v ls) -> Lswitch (ls, {sw with sw_blocks = [(i, lower_bind v arg act)]}, loc) - | Llet (Alias, k, vv, lv, l) -> + | Llet (Alias, vv, lv, l) -> if approx_present v lv then bind Alias v arg lam - else Llet (Alias, k, vv, lv, lower_bind v arg l) + else Llet (Alias, vv, lv, lower_bind v arg l) | Lvar u when Ident.same u v -> (* eliminate [let v = arg in v]; [lower_bind] is only used for alias bindings, so [arg] is pure *) @@ -2774,7 +2772,7 @@ let for_let loc param pat body = Lsequence (param, body) | Tpat_var (id, _) -> (* fast path, and keep track of simple bindings to unboxable numbers *) - Llet (Strict, Pgenval, id, param, body) + Llet (Strict, id, param, body) | _ -> simple_for_let loc param pat body (* Handling of tupled functions and matchings *) diff --git a/compiler/ml/printlambda.ml b/compiler/ml/printlambda.ml index b19798345b6..d1c8950934c 100644 --- a/compiler/ml/printlambda.ml +++ b/compiler/ml/printlambda.ml @@ -43,9 +43,6 @@ let rec struct_const ppf = function | Const_js_false -> fprintf ppf "false" | Const_js_true -> fprintf ppf "true" -let value_kind = function - | Pgenval -> "" - (* let field_kind = function | Pgenval -> "*" | Pintval -> "int" @@ -277,7 +274,7 @@ let rec lam ppf = function in fprintf ppf "@[<2>(function%a@ %a%a)@]" pr_params params function_attribute attr lam body - | Llet (str, k, id, arg, body) -> + | Llet (str, id, arg, body) -> let kind = function | Alias -> "a" | Strict -> "" @@ -285,14 +282,13 @@ let rec lam ppf = function | Variable -> "v" in let rec letbody = function - | Llet (str, k, id, arg, body) -> - fprintf ppf "@ @[<2>%a =%s%s@ %a@]" Ident.print id (kind str) - (value_kind k) lam arg; + | Llet (str, id, arg, body) -> + fprintf ppf "@ @[<2>%a =%s@ %a@]" Ident.print id (kind str) lam arg; letbody body | expr -> expr in - fprintf ppf "@[<2>(let@ @[(@[<2>%a =%s%s@ %a@]" Ident.print id - (kind str) (value_kind k) lam arg; + fprintf ppf "@[<2>(let@ @[(@[<2>%a =%s@ %a@]" Ident.print id + (kind str) lam arg; let expr = letbody body in fprintf ppf ")@]@ %a)@]" lam expr | Lletrec (id_arg_list, body) -> diff --git a/compiler/ml/transl_recmodule.ml b/compiler/ml/transl_recmodule.ml index 4a22f99bb70..572caec047c 100644 --- a/compiler/ml/transl_recmodule.ml +++ b/compiler/ml/transl_recmodule.ml @@ -141,13 +141,13 @@ let eval_rec_bindings_aux (bindings : binding list) (cont : t) : t = if shape_is_empty shape then Lambda.lambda_unit else Lambda.Lprim (Pinit_mod, [loc; shape], Location.none) in - Lambda.Llet (Strict, Pgenval, id, init, bind_inits rem acc) + Lambda.Llet (Strict, id, init, bind_inits rem acc) in let rec bind_strict args acc = match args with | [] -> acc | (id, None, rhs) :: rem -> - Lambda.Llet (Strict, Pgenval, id, rhs, bind_strict rem acc) + Lambda.Llet (Strict, id, rhs, bind_strict rem acc) | (_id, Some _, _rhs) :: rem -> bind_strict rem acc in let rec patch_forwards args = @@ -175,7 +175,7 @@ let rec is_function_or_const_block (lam : Lambda.lambda) acc = | Lvar id -> Set_ident.mem acc id | Lfunction _ | Lconst _ -> true | _ -> false) - | Llet (_, _, id, Lfunction _, cont) -> + | Llet (_, id, Lfunction _, cont) -> is_function_or_const_block cont (Set_ident.add acc id) | Lletrec (bindings, cont) -> ( let rec aux_bindings bindings acc = @@ -188,8 +188,8 @@ let rec is_function_or_const_block (lam : Lambda.lambda) acc = match aux_bindings bindings acc with | None -> false | Some acc -> is_function_or_const_block cont acc) - | Llet (_, _, _, Lconst _, cont) -> is_function_or_const_block cont acc - | Llet (_, _, id1, Lvar id2, cont) when Set_ident.mem acc id2 -> + | Llet (_, _, Lconst _, cont) -> is_function_or_const_block cont acc + | Llet (_, id1, Lvar id2, cont) when Set_ident.mem acc id2 -> is_function_or_const_block cont (Set_ident.add acc id1) | _ -> false diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index a386db17900..bdd2817d703 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -968,7 +968,7 @@ let exception_id_destructed (l : lambda) (fv : Ident.t) : bool = | 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 + | 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 @@ -990,10 +990,7 @@ let exception_id_destructed (l : lambda) (fv : Ident.t) : bool = 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, wrap_exn Location.none (Lvar raw_id), handler) - ) + (raw_id, Llet (StrictOpt, id, wrap_exn Location.none (Lvar raw_id), handler)) else (id, handler) let extract_directive_for_fn exp = @@ -1320,11 +1317,10 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = Lprim (Pjs_object_set nm.txt, [transl_exp expr; transl_exp value], e.exp_loc) | Texp_letmodule (id, _loc, modl, body) -> let defining_expr = !transl_module Tcoerce_none None modl in - Llet (Strict, Pgenval, id, defining_expr, transl_exp body) + Llet (Strict, id, defining_expr, transl_exp body) | Texp_letexception (cd, body) -> Llet ( Strict, - Pgenval, cd.ext_id, transl_extension_constructor e.exp_env None cd, transl_exp body ) @@ -1394,7 +1390,7 @@ and transl_apply ?(inlined = Default_inline) } in List.fold_left - (fun body (id, lam) -> Llet (Strict, Pgenval, id, lam, body)) + (fun body (id, lam) -> Llet (Strict, id, lam, body)) body !defs | (Some arg, optional) :: l -> build_apply lam ((arg, optional) :: args) l | [] -> lapply lam (List.rev_map fst args) @@ -1607,8 +1603,7 @@ and transl_record loc env fields repres opt_init_expr = in match opt_init_expr with | None -> lam - | Some init_expr -> - Llet (Strict, Pgenval, init_id, transl_exp init_expr, lam) + | Some init_expr -> Llet (Strict, init_id, transl_exp init_expr, lam) else (* Take a shallow copy of the init record, then mutate the fields of the copy *) @@ -1635,7 +1630,6 @@ and transl_record loc env fields repres opt_init_expr = | Some init_expr -> Llet ( Strict, - Pgenval, copy_id, Lprim (Pduprecord, [transl_exp init_expr], loc), Array.fold_left update_field (Lvar copy_id) fields )) diff --git a/compiler/ml/translmod.ml b/compiler/ml/translmod.ml index e75ca3fe277..6334c33d12d 100644 --- a/compiler/ml/translmod.ml +++ b/compiler/ml/translmod.ml @@ -65,7 +65,7 @@ let transl_type_extension env rootpath (tyext : Typedtree.type_extension) body : (field_path rootpath ext.ext_id) ext in - Lambda.Llet (Strict, Pgenval, ext.ext_id, lam, body)) + Lambda.Llet (Strict, ext.ext_id, lam, body)) tyext.tyext_constructors body (* Compile a coercion *) @@ -128,7 +128,6 @@ and wrap_id_pos_list loc id_pos_list get_field lam = let id'' = Ident.create (Ident.name id') in ( Lambda.Llet ( Alias, - Pgenval, id'', apply_coercion loc Alias c (get_field (Ident.name id') pos), lam ), @@ -255,8 +254,7 @@ let rec compile_functor mexp coercion root_path loc = let param' = Ident.rename param in let arg = apply_coercion loc_ Alias arg_coercion (Lvar param') in let body = - Lambda.Llet - (Alias, Pgenval, param, arg, transl_module res_coercion body_path body) + Lambda.Llet (Alias, param, arg, transl_module res_coercion body_path body) in Lambda.Lfunction { @@ -411,7 +409,6 @@ and transl_structure loc fields cc rootpath final_env = function in ( Llet ( Strict, - Pgenval, id, Translcore.transl_extension_constructor item.str_env path ext, body ), @@ -431,7 +428,7 @@ and transl_structure loc fields cc rootpath final_env = function Translattribute.add_inline_attribute module_body mb.mb_loc mb.mb_attributes in - (Llet (pure_module mb.mb_expr, Pgenval, id, module_body, body), size) + (Llet (pure_module mb.mb_expr, id, module_body, body), size) | Tstr_recmodule bindings -> let ext_fields = List.rev_append (List.map (fun mb -> mb.mb_id) bindings) fields @@ -456,7 +453,6 @@ and transl_structure loc fields cc rootpath final_env = function let body, size = rebind_idents (pos + 1) (id :: newfields) ids in ( Llet ( Alias, - Pgenval, id, Lprim ( Pfield (pos, Fld_module {name = Ident.name id}), @@ -466,12 +462,7 @@ and transl_structure loc fields cc rootpath final_env = function size ) in let body, size = rebind_idents 0 fields ids in - ( Llet - ( pure_module modl, - Pgenval, - mid, - transl_module Tcoerce_none None modl, - body ), + ( Llet (pure_module modl, mid, transl_module Tcoerce_none None modl, body), size ) | Tstr_primitive _ | Tstr_type _ | Tstr_modtype _ | Tstr_open _ | Tstr_attribute _ -> From cd8a8d89076a7f2953b74bdb5340d99310afb409 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 1 Sep 2026 15:39:19 +0200 Subject: [PATCH 23/46] Drop the arity field and the switch locations Two fields carried by one layer and not the other. `Lam.lfunction.arity` was always `List.length params`: conversion computed it that way and every pass threaded it through unchanged. Its one real reader, `Lam_arity_analysis`, derives it instead. `Lswitch` and `Lstringswitch` carried a `Location.t` in Lambda that conversion discarded, so nothing downstream ever saw it. Dropping it changes one file's output for the better: `matching` shares identical match actions by comparing Lambda terms structurally, and two actions differing only in a switch location compared unequal, so they were emitted twice. `mario_game` loses 16 lines, where two constructor cases now fall through to one body. `lfunction`, `Llet`, `Lswitch` and `Lstringswitch` now have the same shape in both layers. Signed-Off-By: Cristiano Calcagno Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/core/lam.ml | 4 +- compiler/core/lam.mli | 2 - compiler/core/lam_arity_analysis.ml | 3 +- compiler/core/lam_bounded_vars.ml | 4 +- compiler/core/lam_convert.ml | 7 ++- compiler/core/lam_iter.ml | 2 +- .../core/lam_pass_collapse_var_aliases.ml | 4 +- compiler/core/lam_pass_deep_flatten.ml | 4 +- compiler/core/lam_pass_exits.ml | 4 +- compiler/core/lam_pass_lets_dce.ml | 4 +- compiler/core/lam_pass_remove_alias.ml | 4 +- compiler/core/lam_subst.ml | 4 +- compiler/ml/lambda.ml | 26 ++++----- compiler/ml/lambda.mli | 5 +- compiler/ml/lambda_scc.ml | 4 +- compiler/ml/matching.ml | 17 +++--- compiler/ml/printlambda.ml | 4 +- compiler/ml/translcore.ml | 4 +- tests/tests/src/mario_game.mjs | 54 +++++++------------ 19 files changed, 67 insertions(+), 93 deletions(-) diff --git a/compiler/core/lam.ml b/compiler/core/lam.ml index 885931c323a..8467373ff88 100644 --- a/compiler/core/lam.ml +++ b/compiler/core/lam.ml @@ -29,7 +29,6 @@ module Types = struct type lambda_switch = t Lambda.switch and lfunction = { - arity: int; params: ident list; body: t; attr: Lambda.function_attribute; @@ -338,8 +337,7 @@ let var id : t = Lvar id let global_module id = Lglobal_module id let const ct : t = Lconst ct -let function_ ~loc ~attr ~arity ~params ~body : t = - Lfunction {arity; params; body; attr; loc} +let function_ ~loc ~attr ~params ~body : t = Lfunction {params; body; attr; loc} let let_ kind id e body : t = Llet (kind, id, e, body) let letrec bindings body : t = Lletrec (bindings, body) diff --git a/compiler/core/lam.mli b/compiler/core/lam.mli index 923196817b3..d649b0749fd 100644 --- a/compiler/core/lam.mli +++ b/compiler/core/lam.mli @@ -36,7 +36,6 @@ and apply = private { } and lfunction = { - arity: int; params: ident list; body: t; attr: Lambda.function_attribute; @@ -92,7 +91,6 @@ val apply : ?ap_transformed_jsx:bool -> t -> t list -> ap_info -> t val function_ : loc:Location.t -> attr:Lambda.function_attribute -> - arity:int -> params:ident list -> body:t -> t diff --git a/compiler/core/lam_arity_analysis.ml b/compiler/core/lam_arity_analysis.ml index ea14efb5a98..b0cd7ef6edf 100644 --- a/compiler/core/lam_arity_analysis.ml +++ b/compiler/core/lam_arity_analysis.ml @@ -96,7 +96,8 @@ let rec get_arity (meta : Lam_stats.t) (lam : Lam.t) : Lam_arity.t = *) in take xs (List.length args)) - | Lfunction {arity; body} -> Lam_arity.merge arity (get_arity meta body) + | Lfunction {params; body} -> + Lam_arity.merge (List.length params) (get_arity meta body) | Lswitch ( _, { diff --git a/compiler/core/lam_bounded_vars.ml b/compiler/core/lam_bounded_vars.ml index 64aa2caf845..9a1888736d5 100644 --- a/compiler/core/lam_bounded_vars.ml +++ b/compiler/core/lam_bounded_vars.ml @@ -88,10 +88,10 @@ let rewrite (map : _ Hash_ident.t) (lam : Lam.t) : Lam.t = in let body = aux body in Lam.letrec bindings body - | Lfunction {arity; params; body; attr; loc} -> + | Lfunction {params; body; attr; loc} -> let params = Ext_list.map params rebind in let body = aux body in - Lam.function_ ~loc ~arity ~params ~body ~attr + Lam.function_ ~loc ~params ~body ~attr | Lstaticcatch (l1, (i, xs), l2) -> let l1 = aux l1 in let xs = Ext_list.map xs rebind in diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index 4d21ddf6e1f..861147f194a 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -191,8 +191,7 @@ let convert (lam : Lambda.lambda) : Lam.t = (Ext_list.map args convert_aux) {ap_loc = loc; ap_inlined} ~ap_transformed_jsx | Lfunction {params; body; attr; loc} -> - Lam.function_ ~loc ~attr ~arity:(List.length params) ~params - ~body:(convert_aux body) + Lam.function_ ~loc ~attr ~params ~body:(convert_aux body) | Llet (kind, id, e, body) -> Lam.let_ kind id (convert_aux e) (convert_aux body) | Lletrec (bindings, body) -> @@ -201,8 +200,8 @@ let convert (lam : Lambda.lambda) : Lam.t = | Lprim (primitive, args, loc) -> let args = Ext_list.map args convert_aux in lam_prim ~primitive ~args loc - | Lswitch (e, s, _loc) -> convert_switch e s - | Lstringswitch (e, cases, default, _) -> + | Lswitch (e, s) -> convert_switch e s + | Lstringswitch (e, cases, default) -> Lam.stringswitch (convert_aux e) (Ext_list.map_snd cases convert_aux) (Ext_option.map default convert_aux) diff --git a/compiler/core/lam_iter.ml b/compiler/core/lam_iter.ml index f5902d82faa..157fd291812 100644 --- a/compiler/core/lam_iter.ml +++ b/compiler/core/lam_iter.ml @@ -31,7 +31,7 @@ let inner_exists (l : t) (f : t -> bool) : bool = | Lvar (_ : ident) | Lglobal_module _ | Lconst (_ : Lam_constant.t) -> false | Lapply {ap_func; ap_args; ap_info = _} -> f ap_func || Ext_list.exists ap_args f - | Lfunction {body; arity = _; params = _} -> f body + | Lfunction {body; params = _} -> f body | Llet (_str, _id, arg, body) -> f arg || f body | Lletrec (decl, body) -> f body || Ext_list.exists_snd decl f | Lswitch diff --git a/compiler/core/lam_pass_collapse_var_aliases.ml b/compiler/core/lam_pass_collapse_var_aliases.ml index fe76ff17ac5..55447406e9a 100644 --- a/compiler/core/lam_pass_collapse_var_aliases.ml +++ b/compiler/core/lam_pass_collapse_var_aliases.ml @@ -19,8 +19,8 @@ let collapse ~exports (lam : Lam.t) : Lam.t = | 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) + | Lfunction {params; body; attr; loc} -> + Lam.function_ ~loc ~attr ~params ~body:(go body) | Llet (Alias, id, Lvar u, body) -> let u = resolve tbl u in Hash_ident.add tbl id u; diff --git a/compiler/core/lam_pass_deep_flatten.ml b/compiler/core/lam_pass_deep_flatten.ml index 72c22b25b04..576dce3673a 100644 --- a/compiler/core/lam_pass_deep_flatten.ml +++ b/compiler/core/lam_pass_deep_flatten.ml @@ -251,8 +251,8 @@ let deep_flatten (lam : Lam.t) : Lam.t = | Lprim {primitive; args; loc} -> let args = Ext_list.map args aux in Lam.prim ~primitive ~args loc - | Lfunction {arity; params; body; attr; loc} -> - Lam.function_ ~loc ~arity ~params ~body:(aux body) ~attr + | Lfunction {params; body; attr; loc} -> + Lam.function_ ~loc ~params ~body:(aux body) ~attr | Lswitch ( l, { diff --git a/compiler/core/lam_pass_exits.ml b/compiler/core/lam_pass_exits.ml index 355ac011500..40127068e24 100644 --- a/compiler/core/lam_pass_exits.ml +++ b/compiler/core/lam_pass_exits.ml @@ -205,8 +205,8 @@ let subst_helper (subst : subst_tbl) (query : int -> int) (lam : Lam.t) : Lam.t Lam.apply (simplif ap_func) (Ext_list.map ap_args simplif) ap_info ~ap_transformed_jsx - | Lfunction {arity; params; body; attr; loc} -> - Lam.function_ ~loc ~arity ~params ~body:(simplif body) ~attr + | Lfunction {params; body; attr; loc} -> + Lam.function_ ~loc ~params ~body:(simplif body) ~attr | Llet (kind, v, l1, l2) -> Lam.let_ kind v (simplif l1) (simplif l2) | Lletrec (bindings, body) -> Lam.letrec (Ext_list.map_snd bindings simplif) (simplif body) diff --git a/compiler/core/lam_pass_lets_dce.ml b/compiler/core/lam_pass_lets_dce.ml index e4b3befd7a0..6adae73cf92 100644 --- a/compiler/core/lam_pass_lets_dce.ml +++ b/compiler/core/lam_pass_lets_dce.ml @@ -139,8 +139,8 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = | Lapply {ap_func = l1; ap_args = ll; ap_info; ap_transformed_jsx} -> Lam.apply (simplif l1) (Ext_list.map ll simplif) ap_info ~ap_transformed_jsx - | Lfunction {arity; params; body; attr; loc} -> - Lam.function_ ~loc ~arity ~params ~body:(simplif body) ~attr + | Lfunction {params; body; attr; loc} -> + Lam.function_ ~loc ~params ~body:(simplif body) ~attr | Lconst _ -> lam | Lletrec (bindings, body) -> Lam.letrec (Ext_list.map_snd bindings simplif) (simplif body) diff --git a/compiler/core/lam_pass_remove_alias.ml b/compiler/core/lam_pass_remove_alias.ml index 55423f20aca..b3ac7cee2c5 100644 --- a/compiler/core/lam_pass_remove_alias.ml +++ b/compiler/core/lam_pass_remove_alias.ml @@ -241,8 +241,8 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = (* simpl (Lam_beta_reduce.propogate_beta_reduce meta params body args) *) | Lapply {ap_func = l1; ap_args = ll; ap_info; ap_transformed_jsx} -> Lam.apply (simpl l1) (Ext_list.map ll simpl) ap_info ~ap_transformed_jsx - | Lfunction {arity; params; body; attr; loc} -> - Lam.function_ ~loc ~arity ~params ~body:(simpl body) ~attr + | Lfunction {params; body; attr; loc} -> + Lam.function_ ~loc ~params ~body:(simpl body) ~attr | Lswitch ( l, { diff --git a/compiler/core/lam_subst.ml b/compiler/core/lam_subst.ml index 3be69db85fb..7778f78c7fb 100644 --- a/compiler/core/lam_subst.ml +++ b/compiler/core/lam_subst.ml @@ -35,8 +35,8 @@ let subst (s : Lam.t Map_ident.t) lam = | Lconst _ -> x | Lapply {ap_func; ap_args; ap_info} -> Lam.apply (subst_aux ap_func) (Ext_list.map ap_args subst_aux) ap_info - | Lfunction {arity; params; body; attr; loc} -> - Lam.function_ ~loc ~arity ~params ~body:(subst_aux body) ~attr + | Lfunction {params; body; attr; loc} -> + Lam.function_ ~loc ~params ~body:(subst_aux body) ~attr | Llet (str, id, arg, body) -> Lam.let_ str id (subst_aux arg) (subst_aux body) | Lletrec (decl, body) -> diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index 5cfe67539c7..fa26e2d45b2 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -379,9 +379,8 @@ type lambda = | Llet of let_kind * Ident.t * lambda * lambda | Lletrec of (Ident.t * lambda) list * lambda | Lprim of primitive * lambda list * Location.t - | Lswitch of lambda * lambda_switch * Location.t - | Lstringswitch of - lambda * (string * lambda) list * lambda option * Location.t + | Lswitch of lambda * lambda_switch + | Lstringswitch of lambda * (string * lambda) list * lambda option | Lstaticraise of int * lambda list | Lstaticcatch of lambda * (int * Ident.t list) * lambda | Ltrywith of lambda * Ident.t * lambda @@ -577,13 +576,12 @@ let make_key e = let y = make_key x in Llet (str, y, ex, tr_rec (Ident.add x (Lvar y) env) e) | Lprim (p, es, _) -> Lprim (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, _) -> + | Lswitch (e, sw) -> Lswitch (tr_rec env e, tr_sw env sw) + | Lstringswitch (e, sw, d) -> Lstringswitch ( tr_rec env e, List.map (fun (s, e) -> (s, tr_rec env e)) sw, - tr_opt env d, - Location.none ) + tr_opt env d ) | Lstaticraise (i, es) -> Lstaticraise (i, tr_recs env es) | Lstaticcatch (e1, xs, e2) -> Lstaticcatch (tr_rec env e1, xs, tr_rec env e2) @@ -638,12 +636,12 @@ let iter f = function f body; List.iter (fun (_id, exp) -> f exp) decl | Lprim (_p, args, _loc) -> List.iter f args - | Lswitch (arg, sw, _) -> + | Lswitch (arg, sw) -> f arg; List.iter (fun (_key, case) -> f case) sw.sw_consts; List.iter (fun (_key, case) -> f case) sw.sw_blocks; iter_opt f sw.sw_failaction - | Lstringswitch (arg, cases, default, _) -> + | Lstringswitch (arg, cases, default) -> f arg; List.iter (fun (_, act) -> f act) cases; iter_opt f default @@ -789,7 +787,7 @@ let subst_lambda s lam = | Llet (str, id, arg, body) -> Llet (str, 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) - | Lswitch (arg, sw, loc) -> + | Lswitch (arg, sw) -> Lswitch ( subst arg, { @@ -797,11 +795,9 @@ let subst_lambda s lam = sw_consts = List.map subst_case sw.sw_consts; sw_blocks = List.map subst_case sw.sw_blocks; sw_failaction = subst_opt sw.sw_failaction; - }, - loc ) - | Lstringswitch (arg, cases, default, loc) -> - Lstringswitch - (subst arg, List.map subst_strcase cases, subst_opt default, loc) + } ) + | Lstringswitch (arg, cases, default) -> + Lstringswitch (subst arg, List.map subst_strcase cases, subst_opt default) | Lstaticraise (i, args) -> Lstaticraise (i, List.map subst args) | Lstaticcatch (e1, io, e2) -> Lstaticcatch (subst e1, io, subst e2) | Ltrywith (e1, exn, e2) -> Ltrywith (subst e1, exn, subst e2) diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index 1db565cdf57..99f3ec774d8 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -349,11 +349,10 @@ type lambda = | Llet of let_kind * Ident.t * lambda * lambda | Lletrec of (Ident.t * lambda) list * lambda | Lprim of primitive * lambda list * Location.t - | Lswitch of lambda * lambda_switch * Location.t + | Lswitch of lambda * lambda_switch (* switch on strings, clauses are sorted by string order, strings are pairwise distinct *) - | Lstringswitch of - lambda * (string * lambda) list * lambda option * Location.t + | Lstringswitch of lambda * (string * lambda) list * lambda option | Lstaticraise of int * lambda list | Lstaticcatch of lambda * (int * Ident.t list) * lambda | Ltrywith of lambda * Ident.t * lambda diff --git a/compiler/ml/lambda_scc.ml b/compiler/ml/lambda_scc.ml index b110fcc9b38..1aded288e9f 100644 --- a/compiler/ml/lambda_scc.ml +++ b/compiler/ml/lambda_scc.ml @@ -53,10 +53,10 @@ let exists_var (p : Ident.t -> bool) (l : lambda) : bool = | 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, _) -> + | 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, _) -> + | Lstringswitch (arg, cases, default) -> hit arg || hit_list_snd cases || hit_opt default | Lglobal_module _ -> false in diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index a727d40e540..eb463f639bb 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -1656,7 +1656,7 @@ module S_arg = struct let make_isin h arg ~offset = Lprim (Pnot, [make_isout h arg ~offset], Location.none) let make_if cond ifso ifnot = Lifthenelse (cond, ifso, ifnot) - let make_switch loc arg cases acts ~offset = + let make_switch _loc arg cases acts ~offset = let l = ref [] in for i = Array.length cases - 1 downto 0 do l := (Switch_int (offset + i), acts.(cases.(i))) :: !l @@ -1670,8 +1670,7 @@ module S_arg = struct sw_blocks = []; sw_failaction = None; sw_dispatch = Switch_direct; - }, - loc ) + } ) let make_catch = make_catch_delayed let make_exit = make_exit end @@ -1982,7 +1981,7 @@ let combine_constant loc arg cst partial ctx def const_lambda_list in let hs, sw, fail = share_actions_tree sw fail in - hs (Lstringswitch (arg, sw, fail, loc)) + hs (Lstringswitch (arg, sw, fail)) | Const_float _ -> make_test_sequence loc fail (Pfloatcomp Cneq) (Pfloatcomp Clt) arg const_lambda_list @@ -2076,7 +2075,7 @@ let lower_constructor_matching_plan ~loc ~arg = function | Switch_on_constructors sw -> let hs, sw = share_actions_sw sw in let sw = reintroduce_fail sw in - hs (Lswitch (arg, sw, loc)) + hs (Lswitch (arg, sw)) let make_constructor_matching_plan ~cstr ~(layout : Variant_runtime.layout) ~fail_opt ~num_consts ~num_nonconsts ~tag_lambda_list ~consts ~nonconsts = @@ -2396,12 +2395,12 @@ let rec lower_bind v arg lam = | false, true, false -> Lifthenelse (cond, lower_bind v arg ifso, ifnot) | false, false, true -> Lifthenelse (cond, ifso, lower_bind v arg ifnot) | _, _, _ -> bind Alias v arg lam) - | Lswitch (ls, ({sw_consts = [(i, act)]; sw_blocks = []} as sw), loc) + | Lswitch (ls, ({sw_consts = [(i, act)]; sw_blocks = []} as sw)) when not (approx_present v ls) -> - Lswitch (ls, {sw with sw_consts = [(i, lower_bind v arg act)]}, loc) - | Lswitch (ls, ({sw_consts = []; sw_blocks = [(i, act)]} as sw), loc) + Lswitch (ls, {sw with sw_consts = [(i, lower_bind v arg act)]}) + | Lswitch (ls, ({sw_consts = []; sw_blocks = [(i, act)]} as sw)) when not (approx_present v ls) -> - Lswitch (ls, {sw with sw_blocks = [(i, lower_bind v arg act)]}, loc) + Lswitch (ls, {sw with sw_blocks = [(i, lower_bind v arg act)]}) | Llet (Alias, vv, lv, l) -> if approx_present v lv then bind Alias v arg lam else Llet (Alias, vv, lv, lower_bind v arg l) diff --git a/compiler/ml/printlambda.ml b/compiler/ml/printlambda.ml index d1c8950934c..4d19b03c4ec 100644 --- a/compiler/ml/printlambda.ml +++ b/compiler/ml/printlambda.ml @@ -305,7 +305,7 @@ let rec lam ppf = function | Lprim (prim, largs, _) -> let lams ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in fprintf ppf "@[<2>(%a%a)@]" primitive prim lams largs - | Lswitch (larg, sw, _loc) -> + | Lswitch (larg, sw) -> let switch ppf sw = let spc = ref false in List.iter @@ -339,7 +339,7 @@ let rec lam ppf = function | None -> "switch*" | _ -> "switch") lam larg switch sw - | Lstringswitch (arg, cases, default, _) -> + | Lstringswitch (arg, cases, default) -> let switch ppf cases = let spc = ref false in List.iter diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index bdd2817d703..b7f58b3536d 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -974,10 +974,10 @@ let exception_id_destructed (l : lambda) (fv : Ident.t) : bool = | Lfor_of (_, e1, e2) | Lfor_await_of (_, e1, e2) -> hit e1 || hit e2 | Lglobal_module _ | Lconst _ -> false | Lapply {ap_func; ap_args} -> hit ap_func || hit_list ap_args - | Lswitch (arg, sw, _) -> + | 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, _) -> + | 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 diff --git a/tests/tests/src/mario_game.mjs b/tests/tests/src/mario_game.mjs index 961add01bb8..43abdd9c486 100644 --- a/tests/tests/src/mario_game.mjs +++ b/tests/tests/src/mario_game.mjs @@ -1878,58 +1878,42 @@ function process_collision(dir, c1, c2, state) { } if (exit$4 === 4) { let exit$5 = 0; - let typ$2; switch (t1) { case "GKoopaShell" : - if (typeof t2$3 !== "object") { - if (t2$3 === "Brick") { - dec_health(o2$6); - reverse_left_right(o1$4); - return [ - undefined, - undefined - ]; - } - exit$5 = 5; - } else { - typ$2 = t2$3._0; - exit$5 = 6; - } - break; case "RKoopaShell" : - if (typeof t2$3 !== "object") { - if (t2$3 === "Brick") { - dec_health(o2$6); - reverse_left_right(o1$4); - return [ - undefined, - undefined - ]; - } - exit$5 = 5; - } else { - typ$2 = t2$3._0; - exit$5 = 6; - } + exit$5 = 5; break; default: - exit$5 = 5; + rev_dir(o1$4, t1, s1$3); + return [ + undefined, + undefined + ]; } - switch (exit$5) { - case 5 : + if (exit$5 === 5) { + if (typeof t2$3 !== "object") { + if (t2$3 === "Brick") { + dec_health(o2$6); + reverse_left_right(o1$4); + return [ + undefined, + undefined + ]; + } rev_dir(o1$4, t1, s1$3); return [ undefined, undefined ]; - case 6 : + } else { let updated_block$1 = evolve_block(o2$6, context); - let spawned_item$1 = spawn_above(o1$4.dir, o2$6, typ$2, context); + let spawned_item$1 = spawn_above(o1$4.dir, o2$6, t2$3._0, context); rev_dir(o1$4, t1, s1$3); return [ updated_block$1, spawned_item$1 ]; + } } } break; From f3aaa4875b5405b8f7e8038b0368e13a80d125a3 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 1 Sep 2026 15:51:06 +0200 Subject: [PATCH 24/46] Give Lambda's Lprim the same record as Lam's `Lprim` carried a tuple in Lambda and a record in Lam, with the same three components. Make Lambda's a record with Lam's field names and order, so the constructor differs only in that Lam's is private. The 61 call sites change mechanically, patterns and constructions alike. The line count is inflated by the formatter: a record literal wraps where a tuple fitted on one line. `compiler/ml/dune` gains `-30`, since `loc` now appears in both `lfunction` and `prim_info`. Lam has the same collision and is silent because `compiler/core/dune` already disables that warning; this makes the two agree. It does disable duplicate-definitions for all of `compiler/ml`, which is the price of the field names matching. Generated JavaScript is unchanged for the runtime, Belt, tests/tests and gentype. Signed-Off-By: Cristiano Calcagno Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/core/lam_convert.ml | 2 +- compiler/core/polyvar_pattern_match.ml | 31 ++- compiler/ml/dune | 2 +- compiler/ml/lambda.ml | 53 +++-- compiler/ml/lambda.mli | 4 +- compiler/ml/lambda_scc.ml | 3 +- compiler/ml/matching.ml | 169 ++++++++++---- compiler/ml/printlambda.ml | 2 +- compiler/ml/transl_recmodule.ml | 14 +- compiler/ml/translcore.ml | 302 ++++++++++++++++--------- compiler/ml/translmod.ml | 55 +++-- 11 files changed, 428 insertions(+), 209 deletions(-) diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index 861147f194a..79f2bf7b906 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -197,7 +197,7 @@ let convert (lam : Lambda.lambda) : Lam.t = | Lletrec (bindings, body) -> Lam.letrec (Ext_list.map_snd bindings convert_aux) (convert_aux body) | Lglobal_module id -> Lam.global_module id - | Lprim (primitive, args, loc) -> + | Lprim {primitive; args; loc} -> let args = Ext_list.map args convert_aux in lam_prim ~primitive ~args loc | Lswitch (e, s) -> convert_switch e s diff --git a/compiler/core/polyvar_pattern_match.ml b/compiler/core/polyvar_pattern_match.ml index 9f0767b7e48..4b7b340d4fa 100644 --- a/compiler/core/polyvar_pattern_match.ml +++ b/compiler/core/polyvar_pattern_match.ml @@ -62,19 +62,28 @@ let or_list (arg : lam) (hash_names : (int * string) list) = | (hash, name) :: rest -> let init : lam = Lprim - (Pintcomp Ceq, [arg; Lconst (Lambda.const_polyvar name)], Location.none) + { + primitive = Pintcomp Ceq; + args = [arg; Lconst (Lambda.const_polyvar name)]; + loc = Location.none; + } in Ext_list.fold_left rest init (fun acc (hash, name) -> Lambda.Lprim - ( Psequor, - [ - acc; - Lprim - ( Pintcomp Ceq, - [arg; Lconst (Lambda.const_polyvar name)], - Location.none ); - ], - Location.none )) + { + primitive = Psequor; + args = + [ + acc; + Lprim + { + primitive = Pintcomp Ceq; + args = [arg; Lconst (Lambda.const_polyvar name)]; + loc = Location.none; + }; + ]; + loc = Location.none; + }) | _ -> assert false let make_test_sequence_variant_constant (fail : lam option) (arg : lam) @@ -105,5 +114,5 @@ let call_switcher_variant_constr (loc : Location.t) (fail : lam option) Llet ( Alias, v, - Lprim (Pfield (0, Fld_poly_var_tag), [arg], loc), + Lprim {primitive = Pfield (0, Fld_poly_var_tag); args = [arg]; loc}, call_switcher_variant_constant loc fail (Lvar v) int_lambda_list ) diff --git a/compiler/ml/dune b/compiler/ml/dune index 7a286e14044..98a6ccc065f 100644 --- a/compiler/ml/dune +++ b/compiler/ml/dune @@ -1,7 +1,7 @@ (env (_ (flags - (:standard -w +a-4-42-40-41-44-45-9-48-67-70)))) + (:standard -w +a-4-42-40-41-44-45-9-48-67-70-30)))) ; The browser profile builds the playground compiler; this rule pair generates a module from platform/{native,playground}. diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index fa26e2d45b2..8f2a325a78b 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -378,7 +378,7 @@ type lambda = | Lfunction of lfunction | Llet of let_kind * Ident.t * lambda * lambda | Lletrec of (Ident.t * lambda) list * lambda - | Lprim of primitive * lambda list * Location.t + | Lprim of prim_info | Lswitch of lambda * lambda_switch | Lstringswitch of lambda * (string * lambda) list * lambda option | Lstaticraise of int * lambda list @@ -401,6 +401,8 @@ and lfunction = { loc: Location.t; } +and prim_info = {primitive: primitive; args: lambda list; loc: Location.t} + and lambda_apply = { ap_func: lambda; ap_args: lambda list; @@ -486,18 +488,25 @@ let lambda_unit = Lconst const_unit let offset_ref ~delta r loc = let assign r = Lprim - ( Psetfield (0, ref_field_set_info), - [ - r; - Lprim - ( Paddint, - [ - Lprim (Pfield (0, ref_field_info), [r], loc); - Lconst (const_int delta); - ], - loc ); - ], - loc ) + { + primitive = Psetfield (0, ref_field_set_info); + args = + [ + r; + Lprim + { + primitive = Paddint; + args = + [ + Lprim + {primitive = Pfield (0, ref_field_info); args = [r]; loc}; + Lconst (const_int delta); + ]; + loc; + }; + ]; + loc; + } in match r with | Lvar _ -> assign r @@ -507,7 +516,7 @@ let offset_ref ~delta r loc = let mk_builtin b args loc = match b with - | Primitive p -> Lprim (p, args, loc) + | Primitive p -> Lprim {primitive = p; args; loc} | Constant c -> ( match args with | [] -> Lconst c @@ -575,7 +584,8 @@ let make_key e = let ex = tr_rec env ex in let y = make_key x in Llet (str, y, ex, tr_rec (Ident.add x (Lvar y) env) e) - | Lprim (p, es, _) -> Lprim (p, tr_recs env es, Location.none) + | Lprim {primitive = p; args = es; loc = _} -> + Lprim {primitive = p; args = tr_recs env es; loc = Location.none} | Lswitch (e, sw) -> Lswitch (tr_rec env e, tr_sw env sw) | Lstringswitch (e, sw, d) -> Lstringswitch @@ -635,7 +645,7 @@ let iter f = function | Lletrec (decl, body) -> f body; List.iter (fun (_id, exp) -> f exp) decl - | Lprim (_p, args, _loc) -> List.iter f args + | Lprim {primitive = _p; args; loc = _loc} -> List.iter f args | Lswitch (arg, sw) -> f arg; List.iter (fun (_key, case) -> f case) sw.sw_consts; @@ -749,9 +759,11 @@ let rec transl_normal_path = function else Lvar id | Pdot (p, s, pos) -> Lprim - ( Pfield (pos, Fld_module {name = s}), - [transl_normal_path p], - Location.none ) + { + primitive = Pfield (pos, Fld_module {name = s}); + args = [transl_normal_path p]; + loc = Location.none; + } | Papply _ -> assert false (* Translation of identifiers *) @@ -786,7 +798,8 @@ let subst_lambda s lam = Lfunction {params; body = subst body; attr; loc} | Llet (str, id, arg, body) -> Llet (str, 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 {primitive = p; args; loc} -> + Lprim {primitive = p; args = List.map subst args; loc} | Lswitch (arg, sw) -> Lswitch ( subst arg, diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index 99f3ec774d8..ae1864b397e 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -348,7 +348,7 @@ type lambda = | Lfunction of lfunction | Llet of let_kind * Ident.t * lambda * lambda | Lletrec of (Ident.t * lambda) list * lambda - | Lprim of primitive * lambda list * Location.t + | Lprim of prim_info | Lswitch of lambda * lambda_switch (* switch on strings, clauses are sorted by string order, strings are pairwise distinct *) @@ -373,6 +373,8 @@ and lfunction = { loc: Location.t; } +and prim_info = {primitive: primitive; args: lambda list; loc: Location.t} + and lambda_apply = { ap_func: lambda; ap_args: lambda list; diff --git a/compiler/ml/lambda_scc.ml b/compiler/ml/lambda_scc.ml index 1aded288e9f..e3683b9fa8a 100644 --- a/compiler/ml/lambda_scc.ml +++ b/compiler/ml/lambda_scc.ml @@ -52,7 +52,8 @@ let exists_var (p : Ident.t -> bool) (l : lambda) : bool = 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 + | Lprim {primitive = _; args; loc = _} | 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 diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index eb463f639bb..cf966234bdf 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -539,7 +539,12 @@ let bind_record_rest loc arg rest action = Llet ( Strict, rest.rest_ident, - Lprim (Precord_rest rest.excluded_runtime_labels, [arg], loc), + Lprim + { + primitive = Precord_rest rest.excluded_runtime_labels; + args = [arg]; + loc; + }, action ) let simplify_cases args cls = @@ -1196,7 +1201,8 @@ let make_field_args ~fld_info loc binding_kind arg first_pos last_pos argl = let rec make_args pos = if pos > last_pos then argl else - (Lprim (Pfield (pos, fld_info), [arg], loc), binding_kind) + ( Lprim {primitive = Pfield (pos, fld_info); args = [arg]; loc}, + binding_kind ) :: make_args (pos + 1) in make_args first_pos @@ -1282,7 +1288,8 @@ let make_constr_matching p def ctx = function Pval_from_option_not_nest | _ -> Pval_from_option in - (Lprim (from_option, [arg], p.pat_loc), Alias) :: argl + (Lprim {primitive = from_option; args = [arg]; loc = p.pat_loc}, Alias) + :: argl | Ordinary_constructor _ -> make_field_args p.pat_loc Alias arg 0 (cstr.cstr_arity - 1) argl ~fld_info:(if cstr.cstr_name = "::" then Fld_cons else Fld_variant) @@ -1340,7 +1347,13 @@ let make_variant_matching_nonconst p lab def ctx = function { cases = []; args = - (Lprim (Pfield (1, Fld_poly_var_content), [arg], p.pat_loc), Alias) + ( Lprim + { + primitive = Pfield (1, Fld_poly_var_content); + args = [arg]; + loc = p.pat_loc; + }, + Alias ) :: argl; default = def; }; @@ -1413,7 +1426,7 @@ let make_tuple_matching loc arity def = function let rec make_args pos = if pos >= arity then argl else - (Lprim (Pfield (pos, Fld_tuple), [arg], loc), Alias) + (Lprim {primitive = Pfield (pos, Fld_tuple); args = [arg]; loc}, Alias) :: make_args (pos + 1) in { @@ -1462,16 +1475,28 @@ let make_record_matching loc all_labels def = function match lbl.lbl_repres with | Record_float_unused -> assert false | Record_regular -> - Lprim (Pfield (lbl.lbl_pos, Lambda.fld_record lbl), [arg], loc) + Lprim + { + primitive = Pfield (lbl.lbl_pos, Lambda.fld_record lbl); + args = [arg]; + loc; + } | Record_inlined _ -> Lprim - (Pfield (lbl.lbl_pos, Lambda.fld_record_inline lbl), [arg], loc) + { + primitive = Pfield (lbl.lbl_pos, Lambda.fld_record_inline lbl); + args = [arg]; + loc; + } | Record_unboxed _ -> arg | Record_extension -> Lprim - ( Pfield (lbl.lbl_pos + 1, Lambda.fld_record_extension lbl), - [arg], - loc ) + { + primitive = + Pfield (lbl.lbl_pos + 1, Lambda.fld_record_extension lbl); + args = [arg]; + loc; + } in let str = match lbl.lbl_mut with @@ -1515,7 +1540,13 @@ let make_array_matching p def ctx = function let rec make_args pos = if pos >= len then argl else - (Lprim (Parrayrefu, [arg; Lconst (const_int pos)], p.pat_loc), StrictOpt) + ( Lprim + { + primitive = Parrayrefu; + args = [arg; Lconst (const_int pos)]; + loc = p.pat_loc; + }, + StrictOpt ) :: make_args (pos + 1) in let def = make_default (matcher_array len) def and ctx = filter_ctx p ctx in @@ -1594,7 +1625,7 @@ let rec do_tests_fail loc fail tst arg = function | [] -> fail | (c, act) :: rem -> Lifthenelse - ( Lprim (tst, [arg; Lconst (const_of_typed c)], loc), + ( Lprim {primitive = tst; args = [arg; Lconst (const_of_typed c)]; loc}, do_tests_fail loc fail tst arg rem, act ) @@ -1603,7 +1634,7 @@ let rec do_tests_nofail loc tst arg = function | [(_, act)] -> act | (c, act) :: rem -> Lifthenelse - ( Lprim (tst, [arg; Lconst (const_of_typed c)], loc), + ( Lprim {primitive = tst; args = [arg; Lconst (const_of_typed c)]; loc}, do_tests_nofail loc tst arg rem, act ) @@ -1622,7 +1653,12 @@ 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_of_typed (fst (List.hd list2)))], loc), + ( Lprim + { + primitive = lt_tst; + args = [arg; Lconst (const_of_typed (fst (List.hd list2)))]; + loc; + }, make_test_sequence list1, make_test_sequence list2 ) in @@ -1640,7 +1676,7 @@ module S_arg = struct type act = Lambda.lambda - let make_prim p args = Lprim (p, args, Location.none) + let make_prim p args = Lprim {primitive = p; args; loc = Location.none} let bind arg body = let newvar, newarg = @@ -1652,9 +1688,11 @@ module S_arg = struct in bind Alias newvar arg (body newarg) let make_const i = Lconst (const_int i) - let make_isout h arg ~offset = Lprim (Pisout offset, [h; arg], Location.none) + let make_isout h arg ~offset = + Lprim {primitive = Pisout offset; args = [h; arg]; loc = Location.none} let make_isin h arg ~offset = - Lprim (Pnot, [make_isout h arg ~offset], Location.none) + Lprim + {primitive = Pnot; args = [make_isout h arg ~offset]; loc = Location.none} let make_if cond ifso ifnot = Lifthenelse (cond, ifso, ifnot) let make_switch _loc arg cases acts ~offset = let l = ref [] in @@ -2065,9 +2103,10 @@ let lower_constructor_matching_plan ~loc ~arg = function | Test_payload_presence {test; absent; present} -> let condition = match test with - | Is_present_option -> Lprim (Pis_not_none, [arg], loc) + | Is_present_option -> Lprim {primitive = Pis_not_none; args = [arg]; loc} | Is_nonempty_list -> - Lprim (Pjscomp Cneq, [arg; Lconst (const_int 0)], loc) + Lprim + {primitive = Pjscomp Cneq; args = [arg; Lconst (const_int 0)]; loc} in Lifthenelse (condition, present, absent) | Test_boolean_value {if_false; if_true} -> @@ -2152,15 +2191,22 @@ let combine_constructor loc arg ex_pat cstr partial ctx def let ext = transl_extension_path ex_pat.pat_env path in Lifthenelse ( Lprim - ( Pstringcomp Ceq, - [ - Lprim - ( Pfield (0, Fld_record {name = Literals.exception_id}), - [Lvar tag], - loc ); - ext; - ], - loc ), + { + primitive = Pstringcomp Ceq; + args = + [ + Lprim + { + primitive = + Pfield + (0, Fld_record {name = Literals.exception_id}); + args = [Lvar tag]; + loc; + }; + ext; + ]; + loc; + }, act, rem )) extension_cases default @@ -2207,7 +2253,7 @@ let call_switcher_variant_constr loc fail arg int_lambda_list = Llet ( Alias, v, - Lprim (Pfield (0, Fld_poly_var_tag), [arg], loc), + Lprim {primitive = Pfield (0, Fld_poly_var_tag); args = [arg]; loc}, call_switcher loc fail (Lvar v) min_int max_int (List.map (fun (a, (_, c)) -> (a, c)) int_lambda_list) ) @@ -2250,7 +2296,10 @@ let combine_variant loc row arg partial ctx def (tag_lambda_list, total1, _pats) row.row_fields else num_constr := max_int; let test_int_or_block arg if_int if_block = - Lifthenelse (Lprim (Pis_poly_var_block, [arg], loc), if_block, if_int) + Lifthenelse + ( Lprim {primitive = Pis_poly_var_block; args = [arg]; loc}, + if_block, + if_int ) in let sig_complete = List.length tag_lambda_list = !num_constr and one_action = same_actions tag_lambda_list in @@ -2298,7 +2347,9 @@ let combine_array loc arg partial ctx def (len_lambda_list, total1, _pats) = let switch = call_switcher loc fail (Lvar newvar) 0 max_int len_lambda_list in - bind Alias newvar (Lprim (Parraylength, [arg], loc)) switch + bind Alias newvar + (Lprim {primitive = Parraylength; args = [arg]; loc}) + switch in (lambda1, jumps_union local_jumps total1) @@ -2379,7 +2430,8 @@ let compile_test compile_fun partial divide combine ctx to_match = let rec approx_present v = function | Lconst _ -> false | Lstaticraise (_, args) -> List.exists (fun lam -> approx_present v lam) args - | Lprim (_, args, _) -> List.exists (fun lam -> approx_present v lam) args + | Lprim {primitive = _; args; loc = _} -> + List.exists (fun lam -> approx_present v lam) args | Llet (Alias, _, l1, l2) -> approx_present v l1 || approx_present v l2 | Lvar vv -> Ident.same v vv | _ -> true @@ -2687,21 +2739,30 @@ 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, - [ - Lprim - ( Pmakeblock Blk_extension, - [ - transl_normal_path Predef.path_match_failure; - Lconst - (Const_block - ( Blk_tuple, - [const_string fname None; const_int line; const_int char] - )); - ], - loc ); - ], - loc ) + { + primitive = Praise; + args = + [ + Lprim + { + primitive = Pmakeblock Blk_extension; + args = + [ + transl_normal_path Predef.path_match_failure; + Lconst + (Const_block + ( Blk_tuple, + [ + const_string fname None; + const_int line; + const_int char; + ] )); + ]; + loc; + }; + ]; + loc; + } let for_function loc repr param pat_act_list partial = compile_matching repr (partial_function loc) param pat_act_list partial @@ -2709,7 +2770,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, [param], Location.none)) + (fun () -> Lprim {primitive = Praise; args = [param]; loc = Location.none}) param pat_act_list Partial let simple_for_let loc param pat body = @@ -2858,14 +2919,22 @@ let do_for_multiple_match loc paraml pat_act_list partial = ( raise_num, { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; - args = [(Lprim (Pmakeblock Blk_tuple, paraml, loc), Strict)]; + args = + [ + ( Lprim {primitive = Pmakeblock Blk_tuple; args = paraml; loc}, + Strict ); + ]; default = [([[omega]], raise_num)]; } ) | _ -> ( -1, { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; - args = [(Lprim (Pmakeblock Blk_tuple, paraml, loc), Strict)]; + args = + [ + ( Lprim {primitive = Pmakeblock Blk_tuple; args = paraml; loc}, + Strict ); + ]; default = []; } ) in diff --git a/compiler/ml/printlambda.ml b/compiler/ml/printlambda.ml index 4d19b03c4ec..369c0ccfe45 100644 --- a/compiler/ml/printlambda.ml +++ b/compiler/ml/printlambda.ml @@ -302,7 +302,7 @@ let rec lam ppf = function in fprintf ppf "@[<2>(letrec@ (@[%a@])@ %a)@]" bindings id_arg_list lam body - | Lprim (prim, largs, _) -> + | Lprim {primitive = prim; args = largs; loc = _} -> let lams ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in fprintf ppf "@[<2>(%a%a)@]" primitive prim lams largs | Lswitch (larg, sw) -> diff --git a/compiler/ml/transl_recmodule.ml b/compiler/ml/transl_recmodule.ml index 572caec047c..d89857b73d6 100644 --- a/compiler/ml/transl_recmodule.ml +++ b/compiler/ml/transl_recmodule.ml @@ -139,7 +139,9 @@ let eval_rec_bindings_aux (bindings : binding list) (cont : t) : t = | (id, Some (loc, shape), _rhs) :: rem -> let init = if shape_is_empty shape then Lambda.lambda_unit - else Lambda.Lprim (Pinit_mod, [loc; shape], Location.none) + else + Lambda.Lprim + {primitive = Pinit_mod; args = [loc; shape]; loc = Location.none} in Lambda.Llet (Strict, id, init, bind_inits rem acc) in @@ -157,7 +159,13 @@ let eval_rec_bindings_aux (bindings : binding list) (cont : t) : t = | (id, Some (_loc, shape), rhs) :: rem -> let patch = if shape_is_empty shape then rhs - else Lambda.Lprim (Pupdate_mod, [shape; Lvar id; rhs], Location.none) + else + Lambda.Lprim + { + primitive = Pupdate_mod; + args = [shape; Lvar id; rhs]; + loc = Location.none; + } in Lsequence (patch, patch_forwards rem) in @@ -169,7 +177,7 @@ let eval_rec_bindings_aux (bindings : binding list) (cont : t) : t = *) let rec is_function_or_const_block (lam : Lambda.lambda) acc = match lam with - | Lprim (Pmakeblock _, args, _) -> + | Lprim {primitive = Pmakeblock _; args; loc = _} -> Ext_list.for_all args (fun x -> match x with | Lvar id -> Set_ident.mem acc id diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index b7f58b3536d..316c5202e42 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -49,7 +49,7 @@ let transl_extension_constructor env path ext = in let loc = ext.ext_loc in match ext.ext_kind with - | Text_decl _ -> Lprim (Pcreate_extension name, [], loc) + | Text_decl _ -> Lprim {primitive = Pcreate_extension name; args = []; loc} | Text_rebind (path, _lid) -> transl_extension_path ~loc env path (* Translation of primitives *) @@ -557,8 +557,9 @@ let external_result_wrap loc (result_type : External_ffi_types.return_wrapper) ~returns_unit result = match result_type with | Return_unset when returns_unit -> Lsequence (result, Lconst const_unit) - | Return_null_to_opt -> Lprim (Pnull_to_opt, [result], loc) - | Return_null_undefined_to_opt -> Lprim (Pnull_undefined_to_opt, [result], loc) + | Return_null_to_opt -> Lprim {primitive = Pnull_to_opt; args = [result]; loc} + | Return_null_undefined_to_opt -> + Lprim {primitive = Pnull_undefined_to_opt; args = [result]; loc} | Return_unset | Return_identity -> result (* Does importing this external as a value require the FFI adaptation a @@ -598,22 +599,25 @@ let transl_adapted_external_import loc env let returns_unit = external_returns_unit env p val_type in let send_call receiver args (kind : External_ffi_types.decl_kind) = Lprim - ( Pjs_call - { - prim_name = name; - arg_types = External_arg_spec.dummy :: arg_types; - ffi = - { - kind; - module_ = None; - scopes; - variadic; - effective_arity = List.length arg_types + 1; - }; - transformed_jsx = false; - }, - receiver :: args, - loc ) + { + primitive = + Pjs_call + { + prim_name = name; + arg_types = External_arg_spec.dummy :: arg_types; + ffi = + { + kind; + module_ = None; + scopes; + variadic; + effective_arity = List.length arg_types + 1; + }; + transformed_jsx = false; + }; + args = receiver :: args; + loc; + } in let m = Ident.create "m" in let adapted_value = @@ -647,25 +651,34 @@ let transl_adapted_external_import loc env } in Lprim - ( Pjs_call - { - prim_name = "then"; - arg_types = [External_arg_spec.dummy; External_arg_spec.dummy]; - ffi = + { + primitive = + Pjs_call + { + prim_name = "then"; + arg_types = [External_arg_spec.dummy; External_arg_spec.dummy]; + ffi = + { + kind = Decl_send {name = "then"}; + module_ = None; + scopes = []; + variadic = false; + effective_arity = 2; + }; + transformed_jsx = false; + }; + args = + [ + Lprim { - kind = Decl_send {name = "then"}; - module_ = None; - scopes = []; - variadic = false; - effective_arity = 2; + primitive = Pimport (Import_external {module_ = emn; path = []}); + args = []; + loc; }; - transformed_jsx = false; - }, - [ - Lprim (Pimport (Import_external {module_ = emn; path = []}), [], loc); - callback; - ], - loc ) + callback; + ]; + loc; + } let transl_dynamic_import loc (arg : Typedtree.expression) : Lambda.lambda = match arg.exp_desc with @@ -694,22 +707,25 @@ let transl_dynamic_import loc (arg : Typedtree.expression) : Lambda.lambda = when external_import_needs_adaptation arg_types decl return_wrapper -> transl_adapted_external_import loc arg.exp_env ~emn ~name ~scopes ~variadic ~arg_types ~return_wrapper p val_type - | _ -> Lprim (Pimport (import_source_of_arg arg), [], loc) + | _ -> Lprim {primitive = Pimport (import_source_of_arg arg); args = []; loc} let transl_external_application loc env (p : Primitive.description) ~(val_type : type_expr) argl ~transformed_jsx : Lambda.lambda = match p.prim_kind with | Kind_inline_const c -> Lconst (lambda_of_inline_const c) | Kind_external (Ffi_obj_create labels) -> - Lprim (Pjs_object_create labels, argl, loc) + Lprim {primitive = Pjs_object_create labels; args = argl; loc} | Kind_external (Ffi_bs (arg_types, result_type, decl)) -> external_result_wrap loc result_type ~returns_unit:(external_returns_unit env p val_type) (Lprim - ( Pjs_call - {prim_name = p.prim_name; arg_types; ffi = decl; transformed_jsx}, - argl, - loc )) + { + primitive = + Pjs_call + {prim_name = p.prim_name; arg_types; ffi = decl; transformed_jsx}; + args = argl; + loc; + }) | Kind_intrinsic -> Location.raise_errorf ~loc "@{Error:@} internal error, using unrecognized primitive %s" @@ -774,7 +790,9 @@ let transl_primitive loc p env ty ~val_type = params = [param]; attr = default_function_attribute; loc; - body = Lprim (Pmakeblock Blk_tuple, [lam; Lvar param], loc); + body = + Lprim + {primitive = Pmakeblock Blk_tuple; args = [lam; Lvar param]; loc}; } | _ -> assert false) | None -> ( @@ -905,21 +923,30 @@ let assert_failed exp = in let fname = Filename.basename fname in Lprim - ( Praise, - [ - Lprim - ( Pmakeblock Blk_extension, - [ - transl_normal_path Predef.path_assert_failure; - Lconst - (Const_block - ( Blk_tuple, - [const_string fname None; const_int line; const_int char] - )); - ], - exp.exp_loc ); - ], - exp.exp_loc ) + { + primitive = Praise; + args = + [ + Lprim + { + primitive = Pmakeblock Blk_extension; + args = + [ + transl_normal_path Predef.path_assert_failure; + Lconst + (Const_block + ( Blk_tuple, + [ + const_string fname None; + const_int line; + const_int char; + ] )); + ]; + loc = exp.exp_loc; + }; + ]; + loc = exp.exp_loc; + } let rec cut n l = if n = 0 then ([], l) @@ -941,12 +968,15 @@ let wrap_exn loc arg = { ap_func = Lprim - ( Pfield (0, Fld_module {name = "internalToException"}), - [ - Lglobal_module - (Ident.create_persistent Primitive_modules.exceptions); - ], - loc ); + { + primitive = Pfield (0, Fld_module {name = "internalToException"}); + args = + [ + Lglobal_module + (Ident.create_persistent Primitive_modules.exceptions); + ]; + loc; + }; ap_args = [arg]; ap_loc = loc; ap_inlined = Default_inline; @@ -961,8 +991,8 @@ let exception_id_destructed (l : lambda) (fv : Ident.t) : bool = 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 + | Lprim {primitive = Praise; args = [Lvar _]; loc = _} -> false + | Lprim {primitive = _; args; loc = _} -> 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 @@ -1083,9 +1113,11 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = | _ -> assert false in Lprim - ( Ptagged_template, - [transl_exp funct; transl_exp strings; transl_exp values], - e.exp_loc ) + { + primitive = Ptagged_template; + args = [transl_exp funct; transl_exp strings; transl_exp values]; + loc = e.exp_loc; + } | Texp_apply { funct = @@ -1125,7 +1157,13 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = | [] -> 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)) + wrap + (Lprim + { + primitive = Pmakeblock Blk_tuple; + args = lam :: argl; + loc = e.exp_loc; + }) | _ -> assert false) | None -> ( match @@ -1138,11 +1176,21 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = | "#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)) + (Lprim + { + primitive = Praw_js_code {code; code_info = Exp kind}; + args = []; + loc = e.exp_loc; + }) | "#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)) + (Lprim + { + primitive = Praw_js_code {code; code_info = Stmt kind}; + args = []; + loc = e.exp_loc; + }) | ("#raw_expr" | "#raw_stmt"), _ -> assert false | _ -> wrap @@ -1179,7 +1227,8 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = | Texp_tuple el -> ( let ll = transl_list el in try Lconst (Const_block (Blk_tuple, List.map extract_constant ll)) - with Not_constant -> Lprim (Pmakeblock Blk_tuple, ll, e.exp_loc)) + with Not_constant -> + Lprim {primitive = Pmakeblock Blk_tuple; args = ll; loc = e.exp_loc}) | Texp_construct ({txt = Lident "false"}, _, []) -> Lconst Const_js_false | Texp_construct ({txt = Lident "true"}, _, []) -> Lconst Const_js_true | Texp_construct (_, cstr, args) -> ( @@ -1223,7 +1272,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = | _ -> Psome in try Lconst (Const_some (extract_constant value)) - with Not_constant -> Lprim (primitive, ll, e.exp_loc) + with Not_constant -> Lprim {primitive; args = ll; loc = e.exp_loc} else let tag_info : Lambda.tag_info = Blk_constructor @@ -1234,12 +1283,15 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = } in try Lconst (Const_block (tag_info, List.map extract_constant ll)) - with Not_constant -> Lprim (Pmakeblock tag_info, ll, e.exp_loc)) + with Not_constant -> + Lprim {primitive = Pmakeblock tag_info; args = ll; loc = e.exp_loc}) | Extension_constructor path -> Lprim - ( Pmakeblock Blk_extension, - transl_extension_path e.exp_env path :: ll, - e.exp_loc )) + { + primitive = Pmakeblock Blk_extension; + args = transl_extension_path e.exp_env path :: ll; + loc = e.exp_loc; + }) | Texp_extension_constructor (_, path) -> transl_extension_path e.exp_env path | Texp_variant (l, arg) -> ( match arg with @@ -1249,7 +1301,12 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = let name = const_polyvar_name l in try Lconst (Const_block (Blk_poly_var, [name; extract_constant lam])) with Not_constant -> - Lprim (Pmakeblock Blk_poly_var, [Lconst name; lam], e.exp_loc))) + Lprim + { + primitive = Pmakeblock Blk_poly_var; + args = [Lconst name; lam]; + loc = 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) -> ( @@ -1257,16 +1314,27 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = match lbl.lbl_repres with | Record_float_unused -> assert false | Record_regular -> - Lprim (Pfield (lbl.lbl_pos, Lambda.fld_record lbl), [targ], e.exp_loc) + Lprim + { + primitive = Pfield (lbl.lbl_pos, Lambda.fld_record lbl); + args = [targ]; + loc = e.exp_loc; + } | Record_inlined _ -> Lprim - (Pfield (lbl.lbl_pos, Lambda.fld_record_inline lbl), [targ], e.exp_loc) + { + primitive = Pfield (lbl.lbl_pos, Lambda.fld_record_inline lbl); + args = [targ]; + loc = e.exp_loc; + } | Record_unboxed _ -> targ | Record_extension -> Lprim - ( Pfield (lbl.lbl_pos + 1, Lambda.fld_record_extension lbl), - [targ], - e.exp_loc )) + { + primitive = Pfield (lbl.lbl_pos + 1, Lambda.fld_record_extension lbl); + args = [targ]; + loc = e.exp_loc; + }) | Texp_setfield (arg, _, lbl, newval) -> let access = match lbl.lbl_repres with @@ -1278,10 +1346,15 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = | Record_extension -> Psetfield (lbl.lbl_pos + 1, Lambda.fld_record_extension_set lbl) in - Lprim (access, [transl_exp arg; transl_exp newval], e.exp_loc) + Lprim + { + primitive = access; + args = [transl_exp arg; transl_exp newval]; + loc = e.exp_loc; + } | Texp_array expr_list -> let ll = transl_list expr_list in - Lprim (Pmakearray, ll, e.exp_loc) + Lprim {primitive = Pmakearray; args = ll; loc = e.exp_loc} | Texp_ifthenelse (cond, ifso, Some ifnot) -> Lifthenelse (transl_exp cond, transl_exp ifso, transl_exp ifnot) | Texp_ifthenelse (cond, ifso, None) -> @@ -1308,13 +1381,25 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = fields in Lprim - ( Pjs_object_create labels, - List.map (fun (_, field) -> transl_exp field) fields, - e.exp_loc ) + { + primitive = Pjs_object_create labels; + args = List.map (fun (_, field) -> transl_exp field) fields; + loc = e.exp_loc; + } | Texp_object_get (expr, nm) -> - Lprim (Pjs_object_get nm.txt, [transl_exp expr], e.exp_loc) + Lprim + { + primitive = Pjs_object_get nm.txt; + args = [transl_exp expr]; + loc = e.exp_loc; + } | Texp_object_set (expr, nm, value) -> - Lprim (Pjs_object_set nm.txt, [transl_exp expr; transl_exp value], e.exp_loc) + Lprim + { + primitive = Pjs_object_set nm.txt; + args = [transl_exp expr; transl_exp value]; + loc = e.exp_loc; + } | Texp_letmodule (id, _loc, modl, body) -> let defining_expr = !transl_module Tcoerce_none None modl in Llet (Strict, id, defining_expr, transl_exp body) @@ -1526,7 +1611,7 @@ and transl_record loc env fields repres opt_init_expr = | Record_extension -> Pfield (i + 1, Lambda.fld_record_extension lbl) in - Lprim (access, [Lvar init_id], loc) + Lprim {primitive = access; args = [Lvar init_id]; loc} | Overridden (_lid, expr) -> transl_exp expr) fields in @@ -1568,7 +1653,12 @@ and transl_record loc env fields repres opt_init_expr = with Not_constant -> ( match repres with | Record_regular -> - Lprim (Pmakeblock (Lambda.blk_record fields mut), ll, loc) + Lprim + { + primitive = Pmakeblock (Lambda.blk_record fields mut); + args = ll; + loc; + } | Record_float_unused -> assert false | Record_inlined {name; representation} -> let runtime = @@ -1581,11 +1671,14 @@ and transl_record loc env fields repres opt_init_expr = (Variant_runtime.get_layout representation.variant) in Lprim - ( Pmakeblock - (Lambda.blk_record_inlined fields name num_nonconsts ~runtime - mut), - ll, - loc ) + { + primitive = + Pmakeblock + (Lambda.blk_record_inlined fields name num_nonconsts + ~runtime mut); + args = ll; + loc; + } | Record_unboxed _ -> ( match ll with | [v] -> v @@ -1599,7 +1692,11 @@ and transl_record loc env fields repres opt_init_expr = in let slot = transl_extension_path env path in Lprim - (Pmakeblock (Lambda.blk_record_ext fields mut), slot :: ll, loc)) + { + primitive = Pmakeblock (Lambda.blk_record_ext fields mut); + args = slot :: ll; + loc; + }) in match opt_init_expr with | None -> lam @@ -1623,7 +1720,10 @@ and transl_record loc env fields repres opt_init_expr = | Record_extension -> Psetfield (lbl.lbl_pos + 1, Lambda.fld_record_extension_set lbl) in - Lsequence (Lprim (upd, [Lvar copy_id; transl_exp expr], loc), cont) + Lsequence + ( Lprim + {primitive = upd; args = [Lvar copy_id; transl_exp expr]; loc}, + cont ) in match opt_init_expr with | None -> assert false @@ -1631,7 +1731,7 @@ and transl_record loc env fields repres opt_init_expr = Llet ( Strict, copy_id, - Lprim (Pduprecord, [transl_exp init_expr], loc), + Lprim {primitive = Pduprecord; args = [transl_exp init_expr]; loc}, Array.fold_left update_field (Lvar copy_id) fields )) and transl_match e arg pat_expr_list exn_pat_expr_list partial = diff --git a/compiler/ml/translmod.ml b/compiler/ml/translmod.ml index 6334c33d12d..9896ddcefc4 100644 --- a/compiler/ml/translmod.ml +++ b/compiler/ml/translmod.ml @@ -76,15 +76,24 @@ let rec apply_coercion loc strict (restr : Typedtree.module_coercion) arg = | Tcoerce_structure (pos_cc_list, id_pos_list, runtime_fields) -> Lambda.name_lambda strict arg (fun id -> let get_field_name name pos = - Lambda.Lprim (Pfield (pos, Fld_module {name}), [Lvar id], loc) + Lambda.Lprim + {primitive = Pfield (pos, Fld_module {name}); args = [Lvar id]; loc} in let lam = Lambda.Lprim - ( Pmakeblock (Blk_module runtime_fields), - Ext_list.map2 pos_cc_list runtime_fields (fun (pos, cc) name -> - apply_coercion loc Alias cc - (Lprim (Pfield (pos, Fld_module {name}), [Lvar id], loc))), - loc ) + { + primitive = Pmakeblock (Blk_module runtime_fields); + args = + Ext_list.map2 pos_cc_list runtime_fields (fun (pos, cc) name -> + apply_coercion loc Alias cc + (Lprim + { + primitive = Pfield (pos, Fld_module {name}); + args = [Lvar id]; + loc; + })); + loc; + } in wrap_id_pos_list loc id_pos_list get_field_name lam) | Tcoerce_functor (cc_arg, cc_res) -> @@ -322,11 +331,14 @@ and transl_structure loc fields cc rootpath final_env = function [] fields in ( Lambda.Lprim - ( Pmakeblock - (if is_top_root_path then Blk_module_export !export_identifiers - else Blk_module (List.rev_map (fun id -> id.Ident.name) fields)), - block_fields, - loc ), + { + primitive = + Pmakeblock + (if is_top_root_path then Blk_module_export !export_identifiers + else Blk_module (List.rev_map (fun id -> id.Ident.name) fields)); + args = block_fields; + loc; + }, List.length fields ) | Tcoerce_structure (pos_cc_list, id_pos_list, runtime_fields) -> (* Do not ignore id_pos_list ! *) @@ -359,11 +371,14 @@ and transl_structure loc fields cc rootpath final_env = function in let lam = Lambda.Lprim - ( Pmakeblock - (if is_top_root_path then Blk_module_export !export_identifiers - else Blk_module runtime_fields), - result, - loc ) + { + primitive = + Pmakeblock + (if is_top_root_path then Blk_module_export !export_identifiers + else Blk_module runtime_fields); + args = result; + loc; + } and id_pos_list = Ext_list.filter id_pos_list (fun (id, _, _) -> not (Lambda.Ident_set.mem id ids)) @@ -455,9 +470,11 @@ and transl_structure loc fields cc rootpath final_env = function ( Alias, id, Lprim - ( Pfield (pos, Fld_module {name = Ident.name id}), - [Lvar mid], - incl.incl_loc ), + { + primitive = Pfield (pos, Fld_module {name = Ident.name id}); + args = [Lvar mid]; + loc = incl.incl_loc; + }, body ), size ) in From 3fe8f588761ae9d06edd20c0b3d465f115de694a Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 1 Sep 2026 15:54:52 +0200 Subject: [PATCH 25/46] Group Lambda's apply location and inline attribute Lam carries an application's location and inline attribute in an `ap_info` record; Lambda had them flat. Give Lambda the same record and make Lam's a manifest alias of it, so the two are the same type rather than the same shape. Conversion stops taking the record apart and rebuilding it. Every constructor of the two expression types now has the same payload. What remains between them is `private` on `t`, `apply` and `prim_info`. Generated JavaScript is unchanged for the runtime, Belt, tests/tests and gentype. Signed-Off-By: Cristiano Calcagno Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/core/lam.ml | 5 ++++- compiler/core/lam.mli | 5 ++++- compiler/core/lam_convert.ml | 11 ++--------- compiler/ml/lambda.ml | 7 ++++--- compiler/ml/lambda.mli | 8 ++++++-- compiler/ml/printlambda.ml | 2 +- compiler/ml/translcore.ml | 9 +++------ compiler/ml/translmod.ml | 6 ++---- 8 files changed, 26 insertions(+), 27 deletions(-) diff --git a/compiler/core/lam.ml b/compiler/core/lam.ml index 8467373ff88..65abfe3fbdd 100644 --- a/compiler/core/lam.ml +++ b/compiler/core/lam.ml @@ -23,7 +23,10 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) type ident = Ident.t -type ap_info = {ap_loc: Location.t; ap_inlined: Lambda.inline_attribute} +type ap_info = Lambda.ap_info = { + ap_loc: Location.t; + ap_inlined: Lambda.inline_attribute; +} module Types = struct type lambda_switch = t Lambda.switch diff --git a/compiler/core/lam.mli b/compiler/core/lam.mli index d649b0749fd..e7ccff0141d 100644 --- a/compiler/core/lam.mli +++ b/compiler/core/lam.mli @@ -22,7 +22,10 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type ap_info = {ap_loc: Location.t; ap_inlined: Lambda.inline_attribute} +type ap_info = Lambda.ap_info = { + ap_loc: Location.t; + ap_inlined: Lambda.inline_attribute; +} type ident = Ident.t diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index 79f2bf7b906..5d42f8769d2 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -178,18 +178,11 @@ let convert (lam : Lambda.lambda) : Lam.t = match lam with | Lvar x -> Lam.var x | Lconst x -> Lam.const x - | Lapply - { - ap_func = fn; - ap_args = args; - ap_loc = loc; - ap_inlined; - ap_transformed_jsx; - } -> + | Lapply {ap_func = fn; ap_args = args; ap_info; ap_transformed_jsx} -> (* we need do this eargly in case [aux fn] add some wrapper *) Lam.apply (convert_aux fn) (Ext_list.map args convert_aux) - {ap_loc = loc; ap_inlined} ~ap_transformed_jsx + ap_info ~ap_transformed_jsx | Lfunction {params; body; attr; loc} -> Lam.function_ ~loc ~attr ~params ~body:(convert_aux body) | Llet (kind, id, e, body) -> diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index 8f2a325a78b..ed0356c35d1 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -403,11 +403,12 @@ and lfunction = { and prim_info = {primitive: primitive; args: lambda list; loc: Location.t} +and ap_info = {ap_loc: Location.t; ap_inlined: inline_attribute} + and lambda_apply = { ap_func: lambda; ap_args: lambda list; - ap_loc: Location.t; - ap_inlined: inline_attribute; + ap_info: ap_info; ap_transformed_jsx: bool; } @@ -571,7 +572,7 @@ let make_key e = ap with ap_func = tr_rec env ap.ap_func; ap_args = tr_recs env ap.ap_args; - ap_loc = Location.none; + ap_info = {ap.ap_info with ap_loc = Location.none}; } | Llet (Alias, x, ex, e) -> (* Ignore aliases -> substitute *) diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index ae1864b397e..b266190375a 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -375,11 +375,15 @@ and lfunction = { and prim_info = {primitive: primitive; args: lambda list; loc: Location.t} +and ap_info = { + ap_loc: Location.t; + ap_inlined: inline_attribute; (* specified with the [@inlined] attribute *) +} + and lambda_apply = { ap_func: lambda; ap_args: lambda list; - ap_loc: Location.t; - ap_inlined: inline_attribute; (* specified with the [@inlined] attribute *) + ap_info: ap_info; ap_transformed_jsx: bool; } diff --git a/compiler/ml/printlambda.ml b/compiler/ml/printlambda.ml index 369c0ccfe45..d4a01c400d1 100644 --- a/compiler/ml/printlambda.ml +++ b/compiler/ml/printlambda.ml @@ -267,7 +267,7 @@ let rec lam ppf = function | Lapply ap -> let lams ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in fprintf ppf "@[<2>(apply@ %a%a%a)@]" lam ap.ap_func lams ap.ap_args - apply_inlined_attribute ap.ap_inlined + apply_inlined_attribute ap.ap_info.ap_inlined | Lfunction {params; body; attr} -> let pr_params ppf params = List.iter (fun param -> fprintf ppf "@ %a" Ident.print param) params diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 316c5202e42..affd7c048c4 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -978,8 +978,7 @@ let wrap_exn loc arg = loc; }; ap_args = [arg]; - ap_loc = loc; - ap_inlined = Default_inline; + ap_info = {ap_loc = loc; ap_inlined = Default_inline}; ap_transformed_jsx = false; } let exception_id_destructed (l : lambda) (fv : Ident.t) : bool = @@ -1435,10 +1434,9 @@ and transl_apply ?(inlined = Default_inline) let lapply ap_func ap_args = Lapply { - ap_loc = loc; ap_func; ap_args; - ap_inlined = inlined; + ap_info = {ap_loc = loc; ap_inlined = inlined}; ap_transformed_jsx = transformed_jsx; } in @@ -1502,8 +1500,7 @@ and transl_apply ?(inlined = Default_inline) { ap_func = lam; ap_args; - ap_inlined = inlined; - ap_loc = loc; + ap_info = {ap_loc = loc; ap_inlined = inlined}; ap_transformed_jsx = transformed_jsx; } in diff --git a/compiler/ml/translmod.ml b/compiler/ml/translmod.ml index 9896ddcefc4..b9d5ed5ee1d 100644 --- a/compiler/ml/translmod.ml +++ b/compiler/ml/translmod.ml @@ -117,10 +117,9 @@ and apply_coercion_result loc strict funct param arg cc_res = apply_coercion loc Strict cc_res (Lapply { - ap_loc = loc; ap_func = Lvar id; ap_args = [arg]; - ap_inlined = Default_inline; + ap_info = {ap_loc = loc; ap_inlined = Default_inline}; ap_transformed_jsx = false; }); }) @@ -302,10 +301,9 @@ and transl_module cc rootpath mexp = apply_coercion loc Strict cc (Lapply { - ap_loc = loc; ap_func = transl_module Tcoerce_none None funct; ap_args = [transl_module ccarg None arg]; - ap_inlined = inlined_attribute; + ap_info = {ap_loc = loc; ap_inlined = inlined_attribute}; ap_transformed_jsx = false; }) | Tmod_constraint (arg, _, _, ccarg) -> From d89e0241628ff942ae21e6f7b236c85223526f81 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 1 Sep 2026 17:08:51 +0200 Subject: [PATCH 26/46] Fold the switcher's range guard into the switch at production The generic switch compiler guards a jump table with a range test, because on a machine target a table plus a range check beats a table carrying a default. A JS switch has a native default clause, so when the table already covers the whole guarded range the guard is pure overhead. Lam.if_ recognized that shape and merged the guard back in as the switch's failaction. Do it in matching's S_arg.make_if instead, where the switcher builds the two branches, and drop the arm and its complete_range helper from Lam.if_. This removes a subtree-traversing peephole from a shared smart constructor: once Lambda and Lam are one type, if_ is what translcore and matching build their conditionals with, and it should not be pattern-matching on shapes a specific producer happens to emit. Generated JavaScript is unchanged across the runtime, Belt and the 620 test modules. Instrumenting the Lam arm before deleting it showed zero firings over the same corpus. Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/core/lam.ml | 33 --------------------------------- compiler/ml/matching.ml | 32 +++++++++++++++++++++++++++++++- 2 files changed, 31 insertions(+), 34 deletions(-) diff --git a/compiler/core/lam.ml b/compiler/core/lam.ml index 65abfe3fbdd..8ebc7b956c7 100644 --- a/compiler/core/lam.ml +++ b/compiler/core/lam.ml @@ -495,18 +495,6 @@ let has_boolean_type (x : t) = Some loc | _ -> None -(** [complete_range sw_consts 0 7] - is complete with [0,1,.. 7] -*) -let rec complete_range (sw_consts : (Lambda.switch_key * _) list) ~(start : int) - ~finish = - match sw_consts with - | [] -> finish < start - | (Switch_int i, _) :: rest -> - start <= finish && i = start - && complete_range rest ~start:(start + 1) ~finish - | (Switch_constructor _, _) :: _ -> false - let rec eval_const_as_bool (v : Lam_constant.t) : bool option = match v with | Const_int x -> Some (x <> 0l) @@ -552,27 +540,6 @@ let if_ (a : t) (b : t) (c : t) : t = | _ -> seq (Lifthenelse (a, b, unit)) c) | _ -> ( match a with - | Lprim - {primitive = Pisout off; args = [Lconst (Const_int range); Lvar xx]} - -> ( - let range = Int32.to_int range in - match c with - | Lswitch - ( (Lvar yy as switch_arg), - ({ - sw_blocks = []; - sw_blocks_full = true; - sw_consts; - sw_consts_full = _; - sw_failaction = None; - } as body) ) - when Ident.same xx yy - && complete_range sw_consts ~start:(-off) ~finish:(range - off) - -> - Lswitch - ( switch_arg, - {body with sw_failaction = Some b; sw_consts_full = false} ) - | _ -> Lifthenelse (a, b, c)) | Lprim {primitive = Pisint; args = [Lvar i]; _} -> ( match b with | Lifthenelse diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index cf966234bdf..70d5e1cffb6 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -1693,7 +1693,37 @@ module S_arg = struct let make_isin h arg ~offset = Lprim {primitive = Pnot; args = [make_isout h arg ~offset]; loc = Location.none} - let make_if cond ifso ifnot = Lifthenelse (cond, ifso, ifnot) + + (* [covers_range cases ~start ~finish] holds when [cases] is exactly the + contiguous integer keys [start .. finish], in order. *) + let rec covers_range (cases : (Lambda.switch_key * act) list) ~start ~finish = + match cases with + | [] -> finish < start + | (Switch_int i, _) :: rest -> + start <= finish && i = start + && covers_range rest ~start:(start + 1) ~finish + | (Switch_constructor _, _) :: _ -> false + + let make_if cond ifso ifnot = + match (cond, ifnot) with + (* The switcher guards a jump table with a range test, because on a machine + target that beats a table carrying a default. A JS [switch] has a native + [default], so when the table already covers the whole guarded range the + guard is pure overhead: drop it and make its action the failaction. *) + | ( Lprim {primitive = Pisout off; args = [Lconst (Const_int range); Lvar x]}, + Lswitch + ( (Lvar y as arg), + ({ + sw_blocks = []; + sw_blocks_full = true; + sw_consts; + sw_failaction = None; + } as sw) ) ) + when Ident.same x y + && covers_range sw_consts ~start:(-off) + ~finish:(Int32.to_int range - off) -> + Lswitch (arg, {sw with sw_failaction = Some ifso; sw_consts_full = false}) + | _ -> Lifthenelse (cond, ifso, ifnot) let make_switch _loc arg cases acts ~offset = let l = ref [] in for i = Array.length cases - 1 downto 0 do From 3eed0fccf12df1875c1bdb3a016a2a16051b42b4 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 1 Sep 2026 17:20:34 +0200 Subject: [PATCH 27/46] Remove the Pisout primitive Pisout was a derived predicate: "arg + offset is outside [0, range]", with both bounds already compile-time constants at the only place that built it. It never became an unsigned comparison in the output either - E.is_out expanded every case into ordinary ===, ||, < and >. Pass the range across the switch functor instead of a lowered test. The Arg signature loses make_isout / make_isin and gains make_if_out / make_if_in, which take the bounds as ints along with both branches, so the producer decides how to test a range. switch.ml's four helpers become two one-line delegations, and matching emits the comparisons directly. The failaction merge now reads the bounds from its arguments rather than recovering them by pattern-matching an Lprim. Removes Pisout from Lambda.primitive, Lam_primitive.t, lam_convert, lam_compile_primitive, lam_analysis, both printers and Lam.has_boolean_type, along with E.is_out and its interface entry. Constant range tests used to be folded by E.int_comp, which reinterprets its left operand as unsigned - an undocumented coupling that is what made is_out's fallback correct despite dropping the lower-bound test. They now fold at the Lam level through the signed Lam_compat.cmp_int32, by the ordinary Pintcomp and Psequor rules. Four snapshots change, one line each: E.is_out had two arms for a two-value range that disagreed on operand order, so a test came out as [x !== 2 && x !== 1] or [x !== 1 && x !== 2] depending on whether the offset landed in an addition or a subtraction. All of them are now ascending. The rest of the runtime, Belt and the 620 test modules are unchanged. Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/core/js_exp_make.ml | 54 -------------------------- compiler/core/js_exp_make.mli | 5 --- compiler/core/lam.ml | 5 +-- compiler/core/lam_analysis.ml | 1 - compiler/core/lam_compile_primitive.ml | 14 ------- compiler/core/lam_convert.ml | 1 - compiler/core/lam_primitive.ml | 5 --- compiler/core/lam_primitive.mli | 1 - compiler/core/lam_print.ml | 1 - compiler/ml/lambda.ml | 1 - compiler/ml/lambda.mli | 1 - compiler/ml/matching.ml | 54 +++++++++++++++++++------- compiler/ml/printlambda.ml | 1 - compiler/ml/switch.ml | 23 ++++++----- compiler/ml/switch.mli | 11 +++++- tests/tests/src/demo_page.mjs | 2 +- tests/tests/src/gpr_3877_test.mjs | 2 +- tests/tests/src/test_demo.mjs | 2 +- tests/tests/src/test_fib.mjs | 2 +- 19 files changed, 66 insertions(+), 120 deletions(-) diff --git a/compiler/core/js_exp_make.ml b/compiler/core/js_exp_make.ml index 8aac48b7de7..6081b289e84 100644 --- a/compiler/core/js_exp_make.ml +++ b/compiler/core/js_exp_make.ml @@ -1545,60 +1545,6 @@ let rec int32_lsr ?comment (e1 : J.expression) (e2 : J.expression) : we can apply a more general optimization here, do some algebraic rewerite rules to rewrite [triple_equal] *) -let rec is_out ?comment (e : t) (range : t) : t = - match (range.expression_desc, e.expression_desc) with - | Number (Int {i = 1l}), Var _ -> - not (or_ (triple_equal e zero_int_literal) (triple_equal e one_int_literal)) - | ( Number (Int {i = 1l}), - ( Bin - ( Plus, - {expression_desc = Number (Int {i; _})}, - ({expression_desc = Var _; _} as x) ) - | Bin - ( Plus, - ({expression_desc = Var _; _} as x), - {expression_desc = Number (Int {i; _})} ) ) ) -> - not - (or_ - (triple_equal x (int (Int32.neg i))) - (triple_equal x (int (Int32.sub Int32.one i)))) - | ( Number (Int {i = 1l}), - Bin - ( Minus, - ({expression_desc = Var _; _} as x), - {expression_desc = Number (Int {i; _})} ) ) -> - not (or_ (triple_equal x (int (Int32.add i 1l))) (triple_equal x (int i))) - (* (x - i >>> 0 ) > k *) - | ( Number (Int {i = k}), - Bin - ( Minus, - ({expression_desc = Var _; _} as x), - {expression_desc = Number (Int {i; _})} ) ) -> - or_ (int_comp Cgt x (int (Int32.add i k))) (int_comp Clt x (int i)) - | Number (Int {i = k}), Var _ -> - (* Note that js support [ 1 < x < 3], - we can optimize it into [ not ( 0<= x <= k)] - *) - or_ (int_comp Cgt e (int k)) (int_comp Clt e zero_int_literal) - | ( _, - Bin - ( Bor, - ({ - expression_desc = - ( Bin - ( (Plus | Minus), - {expression_desc = Number (Int {i = _; _})}, - {expression_desc = Var _; _} ) - | Bin - ( (Plus | Minus), - {expression_desc = Var _; _}, - {expression_desc = Number (Int {i = _; _})} ) ); - } as e), - {expression_desc = Number (Int {i = 0l}); _} ) ) -> - (* TODO: check correctness *) - is_out ?comment e range - | _, _ -> int_comp ?comment Cgt e range - let rec float_add ?comment (e1 : t) (e2 : t) = match (e1.expression_desc, e2.expression_desc) with | Number (Int {i; _}), Number (Int {i = j; _}) -> int ?comment (Int32.add i j) diff --git a/compiler/core/js_exp_make.mli b/compiler/core/js_exp_make.mli index 2ed4db798be..683c49b71b4 100644 --- a/compiler/core/js_exp_make.mli +++ b/compiler/core/js_exp_make.mli @@ -119,11 +119,6 @@ val zero_float_lit : t val zero_bigint_literal : t -val is_out : ?comment:string -> t -> t -> t -(** [is_out e range] is equivalent to [e > range or e <0] - -*) - val dot : ?comment:string -> t -> string -> t val module_access : t -> string -> int32 -> t diff --git a/compiler/core/lam.ml b/compiler/core/lam.ml index 8ebc7b956c7..5a362949ace 100644 --- a/compiler/core/lam.ml +++ b/compiler/core/lam.ml @@ -487,9 +487,8 @@ let has_boolean_type (x : t) = | Lprim { primitive = - ( Pnot | Psequand | Psequor | Pisout _ | Pis_not_none | Pobjcomp _ - | Pboolcomp _ | Pintcomp _ | Pfloatcomp _ | Pbigintcomp _ - | Pstringcomp _ ); + ( Pnot | Psequand | Psequor | Pis_not_none | Pobjcomp _ | Pboolcomp _ + | Pintcomp _ | Pfloatcomp _ | Pbigintcomp _ | Pstringcomp _ ); loc; } -> Some loc diff --git a/compiler/core/lam_analysis.ml b/compiler/core/lam_analysis.ml index 1d81fe88d84..05de1907277 100644 --- a/compiler/core/lam_analysis.ml +++ b/compiler/core/lam_analysis.ml @@ -82,7 +82,6 @@ let rec no_side_effects (lam : Lam.t) : bool = (* Test if the argument is a block or an immediate integer *) | Pisint | Pis_poly_var_block (* Test if the (integer) argument is outside an interval *) - | Pisout _ (* Operations on big arrays: (unsafe, #dimensions, kind, layout) *) (* Compile time constants *) | Pstringadd | Phash | Phash_mixstring | Phash_mixint | Phash_finalmix diff --git a/compiler/core/lam_compile_primitive.ml b/compiler/core/lam_compile_primitive.ml index b3eb3039558..68c96fb5ea6 100644 --- a/compiler/core/lam_compile_primitive.ml +++ b/compiler/core/lam_compile_primitive.ml @@ -373,20 +373,6 @@ let translate output_prefix loc (cxt : Lam_compile_context.t) match args with | [e1; e2] -> E.or_ e1 e2 | _ -> assert false) - | Pisout off -> ( - match args with - (* predicate: [x > range or x < 0 ] - can be simplified if x is positive , x > range - if x is negative, fine, its uint is for sure larger than range, - the output is not readable, we might change it back. - - Note that if range is small like [1], then the negative of - it can be more precise (given integer) - a normal case of the compiler is that it will do a shift - in the first step [ (x - 1) > 1 or ( x - 1 ) < 0 ] - *) - | [range; e] -> E.is_out (E.offset e off) range - | _ -> assert false) | Pstringlength -> E.string_length (Ext_list.singleton_exn args) | Pstringrefs | Pstringrefu -> ( match args with diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index 5d42f8769d2..629d9f8f397 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -93,7 +93,6 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = | Pstringadd -> prim ~primitive:Pstringadd ~args loc | Pstringrefs -> prim ~primitive:Pstringrefs ~args loc | Pisint -> prim ~primitive:Pisint ~args loc - | Pisout i -> prim ~primitive:(Pisout i) ~args loc | Pintoffloat -> prim ~primitive:Pintoffloat ~args loc | Pfloatofint -> prim ~primitive:Pfloatofint ~args loc | Pnegfloat -> prim ~primitive:Pnegfloat ~args loc diff --git a/compiler/core/lam_primitive.ml b/compiler/core/lam_primitive.ml index 762daf64a5c..f585904829d 100644 --- a/compiler/core/lam_primitive.ml +++ b/compiler/core/lam_primitive.ml @@ -138,7 +138,6 @@ type t = | Pawait (* etc or deprecated *) | Pis_poly_var_block - | Pisout of int | Pjscomp of Lam_compat.comparison | Pdebugger | Pjs_object_get of string @@ -228,10 +227,6 @@ let eq_primitive_approx (lhs : t) (rhs : t) = match rhs with | Pcreate_extension b -> a = (b : string) | _ -> false) - | Pisout l -> ( - match rhs with - | Pisout r -> l = r - | _ -> false) (* | Pcaml_obj_set_length -> rhs = Pcaml_obj_set_length *) | Pfield (n0, info0) -> ( match rhs with diff --git a/compiler/core/lam_primitive.mli b/compiler/core/lam_primitive.mli index ffc8664cc3e..5e74215e87e 100644 --- a/compiler/core/lam_primitive.mli +++ b/compiler/core/lam_primitive.mli @@ -132,7 +132,6 @@ type t = | Pawait (* etc or deprecated *) | Pis_poly_var_block - | Pisout of int | Pjscomp of Lam_compat.comparison | Pdebugger | Pjs_object_get of string diff --git a/compiler/core/lam_print.ml b/compiler/core/lam_print.ml index b9c67648323..c1163acc21f 100644 --- a/compiler/core/lam_print.ml +++ b/compiler/core/lam_print.ml @@ -196,7 +196,6 @@ let primitive ppf (prim : Lam_primitive.t) = | Parraysets -> fprintf ppf "array.set" | Pisint -> fprintf ppf "isint" | Pis_poly_var_block -> fprintf ppf "#is_poly_var_block" - | Pisout i -> fprintf ppf "isout %d" i | Pawait -> fprintf ppf "await" | Phash -> fprintf ppf "hash" | Phash_mixint -> fprintf ppf "hash_mix_int" diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index ed0356c35d1..e5145feeeb6 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -296,7 +296,6 @@ type primitive = (* Test if the argument is a block or an immediate integer *) | Pisint (* Test if the (integer) argument is outside an interval *) - | Pisout of int (* Test if the argument is null or undefined *) | Pis_null_undefined (* exn *) diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index b266190375a..ff04ca41a5a 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -256,7 +256,6 @@ type primitive = (* Test if the argument is a block or an immediate integer *) | Pisint (* Test if the (integer) argument is outside an interval *) - | Pisout of int (* Test if the argument is null or undefined *) | Pis_null_undefined (* exn *) diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index 70d5e1cffb6..ebd224bf396 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -1688,11 +1688,7 @@ module S_arg = struct in bind Alias newvar arg (body newarg) let make_const i = Lconst (const_int i) - let make_isout h arg ~offset = - Lprim {primitive = Pisout offset; args = [h; arg]; loc = Location.none} - let make_isin h arg ~offset = - Lprim - {primitive = Pnot; args = [make_isout h arg ~offset]; loc = Location.none} + let make_if cond ifso ifnot = Lifthenelse (cond, ifso, ifnot) (* [covers_range cases ~start ~finish] holds when [cases] is exactly the contiguous integer keys [start .. finish], in order. *) @@ -1704,26 +1700,56 @@ module S_arg = struct && covers_range rest ~start:(start + 1) ~finish | (Switch_constructor _, _) :: _ -> false - let make_if cond ifso ifnot = - match (cond, ifnot) with + (* [arg] is outside [lo .. hi]. A two-value range reads better as a pair of + equality tests than as a pair of comparisons. *) + let out_of_range arg ~lo ~hi = + let loc = Location.none in + let test cmp k = + Lprim {primitive = Pintcomp cmp; args = [arg; Lconst (const_int k)]; loc} + in + if hi = lo + 1 then + Lprim + { + primitive = Pnot; + args = + [ + Lprim {primitive = Psequor; args = [test Ceq lo; test Ceq hi]; loc}; + ]; + loc; + } + else Lprim {primitive = Psequor; args = [test Cgt hi; test Clt lo]; loc} + + let make_if_out ~offset ~range arg ifso ifno = + let lo = -offset and hi = range - offset in + match (arg, ifno) with (* The switcher guards a jump table with a range test, because on a machine target that beats a table carrying a default. A JS [switch] has a native [default], so when the table already covers the whole guarded range the guard is pure overhead: drop it and make its action the failaction. *) - | ( Lprim {primitive = Pisout off; args = [Lconst (Const_int range); Lvar x]}, + | ( Lvar x, Lswitch - ( (Lvar y as arg), + ( (Lvar y as sarg), ({ sw_blocks = []; sw_blocks_full = true; sw_consts; sw_failaction = None; } as sw) ) ) - when Ident.same x y - && covers_range sw_consts ~start:(-off) - ~finish:(Int32.to_int range - off) -> - Lswitch (arg, {sw with sw_failaction = Some ifso; sw_consts_full = false}) - | _ -> Lifthenelse (cond, ifso, ifnot) + when Ident.same x y && covers_range sw_consts ~start:lo ~finish:hi -> + Lswitch (sarg, {sw with sw_failaction = Some ifso; sw_consts_full = false}) + | _ -> Lifthenelse (out_of_range arg ~lo ~hi, ifso, ifno) + + let make_if_in ~offset ~range arg ifso ifno = + let lo = -offset and hi = range - offset in + let cond = + Lprim + { + primitive = Pnot; + args = [out_of_range arg ~lo ~hi]; + loc = Location.none; + } + in + Lifthenelse (cond, ifso, ifno) let make_switch _loc arg cases acts ~offset = let l = ref [] in for i = Array.length cases - 1 downto 0 do diff --git a/compiler/ml/printlambda.ml b/compiler/ml/printlambda.ml index d4a01c400d1..8d10380188c 100644 --- a/compiler/ml/printlambda.ml +++ b/compiler/ml/printlambda.ml @@ -214,7 +214,6 @@ let primitive ppf = function | Pmakedict -> fprintf ppf "makedict" | Pdict_has -> fprintf ppf "dict.has" | Pisint -> fprintf ppf "isint" - | Pisout i -> fprintf ppf "isout %d" i | Pis_null -> fprintf ppf "is_null" | Pis_undefined -> fprintf ppf "is_undefined" | Pis_null_undefined -> fprintf ppf "isnullable" diff --git a/compiler/ml/switch.ml b/compiler/ml/switch.ml index 2ff81e70be1..86c4679acfe 100644 --- a/compiler/ml/switch.ml +++ b/compiler/ml/switch.ml @@ -100,8 +100,15 @@ module type S = sig val bind : act -> (act -> act) -> act val make_const : int -> act val make_prim : primitive -> act list -> act - val make_isout : act -> act -> offset:int -> act - val make_isin : act -> act -> offset:int -> act + + (* [make_if_out ~offset ~range arg ifso ifno] runs [ifso] when [arg] lies + outside [-offset .. range - offset] and [ifno] when it lies inside. The + producer chooses how to test that, because only it knows what the target + can express. *) + val make_if_out : offset:int -> range:int -> act -> act -> act -> act + + (* Dual of [make_if_out]: [ifso] runs when [arg] lies inside the range. *) + val make_if_in : offset:int -> range:int -> act -> act -> act -> act val make_if : act -> act -> act -> act val make_switch : Location.t -> act -> int array -> act array -> offset:int -> act @@ -479,19 +486,11 @@ let rec pkey chan = function and make_if_ne arg i ifso ifnot = make_if_test Arg.neint arg i ifso ifnot - let do_make_if_out h arg ~offset ifso ifno = - Arg.make_if (Arg.make_isout h arg ~offset) ifso ifno - let make_if_out ctx l d mk_ifso mk_ifno = - do_make_if_out (Arg.make_const d) ctx.arg ~offset:(-l) (mk_ifso ctx) - (mk_ifno ctx) - - let do_make_if_in h arg ~offset ifso ifno = - Arg.make_if (Arg.make_isin h arg ~offset) ifso ifno + Arg.make_if_out ~offset:(-l) ~range:d ctx.arg (mk_ifso ctx) (mk_ifno ctx) let make_if_in ctx l d mk_ifso mk_ifno = - do_make_if_in (Arg.make_const d) ctx.arg ~offset:(-l) (mk_ifso ctx) - (mk_ifno ctx) + Arg.make_if_in ~offset:(-l) ~range:d ctx.arg (mk_ifso ctx) (mk_ifno ctx) let rec c_test ctx ({cases; actions} as s) = let lcases = Array.length cases in diff --git a/compiler/ml/switch.mli b/compiler/ml/switch.mli index 6dc605ee48f..195d52144ef 100644 --- a/compiler/ml/switch.mli +++ b/compiler/ml/switch.mli @@ -71,8 +71,15 @@ module type S = sig val bind : act -> (act -> act) -> act val make_const : int -> act val make_prim : primitive -> act list -> act - val make_isout : act -> act -> offset:int -> act - val make_isin : act -> act -> offset:int -> act + + (* [make_if_out ~offset ~range arg ifso ifno] runs [ifso] when [arg] lies + outside [-offset .. range - offset] and [ifno] when it lies inside. The + producer chooses how to test that, because only it knows what the target + can express. *) + val make_if_out : offset:int -> range:int -> act -> act -> act -> act + + (* Dual of [make_if_out]: [ifso] runs when [arg] lies inside the range. *) + val make_if_in : offset:int -> range:int -> act -> act -> act -> act val make_if : act -> act -> act -> act (* construct an actual switch : diff --git a/tests/tests/src/demo_page.mjs b/tests/tests/src/demo_page.mjs index cacf467d0b9..7f49edcbe43 100644 --- a/tests/tests/src/demo_page.mjs +++ b/tests/tests/src/demo_page.mjs @@ -4,7 +4,7 @@ import * as React from "react"; import * as ReactDom from "react-dom"; function fib(x) { - if (x !== 2 && x !== 1) { + if (x !== 1 && x !== 2) { return fib(x - 1 | 0) + fib(x - 2 | 0) | 0; } else { return 1; diff --git a/tests/tests/src/gpr_3877_test.mjs b/tests/tests/src/gpr_3877_test.mjs index 2c16b2d958e..af886e0d791 100644 --- a/tests/tests/src/gpr_3877_test.mjs +++ b/tests/tests/src/gpr_3877_test.mjs @@ -3,7 +3,7 @@ function test(code) { if (code > 599 || code < 500) { - if (code !== 201 && code !== 200) { + if (code !== 200 && code !== 201) { return "the catch all"; } else { return "good response"; diff --git a/tests/tests/src/test_demo.mjs b/tests/tests/src/test_demo.mjs index b622586bcdb..6b82fc3bd55 100644 --- a/tests/tests/src/test_demo.mjs +++ b/tests/tests/src/test_demo.mjs @@ -3,7 +3,7 @@ import * as Stdlib_List from "@rescript/runtime/lib/es6/Stdlib_List.mjs"; function fib(x) { - if (x !== 2 && x !== 1) { + if (x !== 1 && x !== 2) { return fib(x - 1 | 0) + fib(x - 2 | 0) | 0; } else { return 1; diff --git a/tests/tests/src/test_fib.mjs b/tests/tests/src/test_fib.mjs index 4e488a8269b..ff50381b3a5 100644 --- a/tests/tests/src/test_fib.mjs +++ b/tests/tests/src/test_fib.mjs @@ -10,7 +10,7 @@ function fib(x) { } function fib2(x) { - if (x !== 2 && x !== 1) { + if (x !== 1 && x !== 2) { return fib2(x - 1 | 0) + fib2(x - 2 | 0) | 0; } else { return 1; From 61833b1e91f4de23a4f97dcbfba7a5237396db72 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 1 Sep 2026 17:33:18 +0200 Subject: [PATCH 28/46] Remove the Switch functor Switch.Make had a single instantiation. Upstream OCaml has two - matching.ml for Lambda and cmmgen.ml for Cmm - and the functor exists so one copy of Baudinet's algorithm serves both. ReScript dropped native codegen at the fork, so the abstraction has had one client ever since. switch.ml now opens Lambda and defines the operations it needs directly; matching.ml loses S_arg and calls Switch.zyva / Switch.test_sequence. The trivial builders were pure indirection and are inlined: make_const, make_prim, make_if and the six comparison primitives. Only emit_if_out, emit_if_in and emit_switch keep names. Three dead things the functor was hiding: - S.bind was in the signature and implemented, but the algorithm never called it. - zyva's Location.t only fed Arg.make_switch, whose implementation ignored it. Removing it also retires the loc of call_switcher and of call_switcher_variant_constant, which was dead in both matching's and polyvar_pattern_match's implementations. call_switcher_variant_constr keeps its loc - that one reaches a Pfield. - Switch.Not_simple was declared in the .ml and the .mli and never raised or caught. Lambda.Not_simple is a different exception and is still used. 'a t_ctx is now monomorphic. 'a inter stays polymorphic: it is instantiated at both lambda and t_ctx -> lambda, which is now documented rather than rediscovered. make_exit, as_simple_exit and make_catch_delayed move to lambda.ml, the shared dependency, since matching still uses them outside the switcher. The Bernstein/Spuler attribution stays; the line costing an interval test as one addition plus one unsigned test and branch described the backend the algorithm was written for, and now says what this one emits. Generated JavaScript is unchanged. Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/core/polyvar_pattern_match.ml | 6 +- compiler/ml/lambda.ml | 21 + compiler/ml/lambda.mli | 7 + compiler/ml/matching.ml | 153 +--- compiler/ml/matching.mli | 3 +- compiler/ml/switch.ml | 1053 ++++++++++++------------ compiler/ml/switch.mli | 73 +- 7 files changed, 603 insertions(+), 713 deletions(-) diff --git a/compiler/core/polyvar_pattern_match.ml b/compiler/core/polyvar_pattern_match.ml index 4b7b340d4fa..c58ff6b8546 100644 --- a/compiler/core/polyvar_pattern_match.ml +++ b/compiler/core/polyvar_pattern_match.ml @@ -98,8 +98,8 @@ let make_test_sequence_variant_constant (fail : lam option) (arg : lam) Lifthenelse (predicate, act1, acc)) | [], None -> assert false -let call_switcher_variant_constant (_loc : Location.t) (fail : lam option) - (arg : lam) (int_lambda_list : (int * (string * lam)) list) = +let call_switcher_variant_constant (fail : lam option) (arg : lam) + (int_lambda_list : (int * (string * lam)) list) = let int_lambda_list = convert int_lambda_list in match (int_lambda_list, fail) with | (_, act) :: rest, None | rest, Some act -> @@ -115,4 +115,4 @@ let call_switcher_variant_constr (loc : Location.t) (fail : lam option) ( Alias, v, Lprim {primitive = Pfield (0, Fld_poly_var_tag); args = [arg]; loc}, - call_switcher_variant_constant loc fail (Lvar v) int_lambda_list ) + call_switcher_variant_constant fail (Lvar v) int_lambda_list ) diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index e5145feeeb6..f3c4456de2f 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -832,6 +832,27 @@ let subst_lambda s lam = in subst lam +let make_exit i = Lstaticraise (i, []) + +let rec as_simple_exit = function + | Lstaticraise (i, []) -> Some i + | Llet (Alias, _, _, e) -> as_simple_exit e + | _ -> None + +(* Introduce a catch around [handler], if worth it. Returns the exit number to + raise to, and a function wrapping a body in the catch - a body that turns + out to be exactly that raise gets the handler itself instead. *) +let make_catch_delayed handler = + match as_simple_exit handler with + | Some i -> (i, fun act -> act) + | None -> ( + let i = next_raise_count () in + ( i, + fun body -> + match body with + | Lstaticraise (j, _) -> if i = j then handler else body + | _ -> Lstaticcatch (body, (i, []), handler) )) + (* To let-bind expressions to variables *) let bind str var exp body = diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index ff04ca41a5a..3b8f4f795d5 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -459,6 +459,13 @@ val default_function_attribute : function_attribute (* Get a new static failure ident *) val next_raise_count : unit -> int + +val make_exit : int -> lambda + +val as_simple_exit : lambda -> int option + +(* Exit number to raise to, and a wrapper that puts the catch around a body. *) +val make_catch_delayed : lambda -> int * (lambda -> lambda) val next_negative_raise_count : unit -> int (* Negative raise counts are used to compile 'match ... with exception x -> ...'. This disabled some simplifications diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index ebd224bf396..241dcd63aed 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -446,28 +446,6 @@ module Store_exp = Switch.Store (struct let make_key = Lambda.make_key end) -let make_exit i = Lstaticraise (i, []) - -(* Introduce a catch, if worth it, delayed version *) -let rec as_simple_exit = function - | Lstaticraise (i, []) -> Some i - | Llet (Alias, _, _, e) -> as_simple_exit e - | _ -> None - -let make_catch_delayed handler = - match as_simple_exit handler with - | Some i -> (i, fun act -> act) - | None -> ( - let i = next_raise_count () in - (* - Printf.eprintf "SHARE LAMBDA: %i\n%s\n" i (string_of_lam handler); -*) - ( i, - fun body -> - match body with - | Lstaticraise (j, _) -> if i = j then handler else body - | _ -> Lstaticcatch (body, (i, []), handler) )) - let raw_action l = match make_key l with | Some l -> l @@ -1664,111 +1642,6 @@ let make_test_sequence loc fail tst lt_tst arg const_lambda_list = in hs (make_test_sequence const_lambda_list) -module S_arg = struct - type primitive = Lambda.primitive - - let eqint = Pintcomp Ceq - let neint = Pintcomp Cneq - let leint = Pintcomp Cle - let ltint = Pintcomp Clt - let geint = Pintcomp Cge - let gtint = Pintcomp Cgt - - type act = Lambda.lambda - - let make_prim p args = Lprim {primitive = p; args; loc = Location.none} - - let bind arg body = - let newvar, newarg = - match arg with - | Lvar v -> (v, arg) - | _ -> - let newvar = Ident.create "switcher" in - (newvar, Lvar newvar) - in - bind Alias newvar arg (body newarg) - let make_const i = Lconst (const_int i) - let make_if cond ifso ifnot = Lifthenelse (cond, ifso, ifnot) - - (* [covers_range cases ~start ~finish] holds when [cases] is exactly the - contiguous integer keys [start .. finish], in order. *) - let rec covers_range (cases : (Lambda.switch_key * act) list) ~start ~finish = - match cases with - | [] -> finish < start - | (Switch_int i, _) :: rest -> - start <= finish && i = start - && covers_range rest ~start:(start + 1) ~finish - | (Switch_constructor _, _) :: _ -> false - - (* [arg] is outside [lo .. hi]. A two-value range reads better as a pair of - equality tests than as a pair of comparisons. *) - let out_of_range arg ~lo ~hi = - let loc = Location.none in - let test cmp k = - Lprim {primitive = Pintcomp cmp; args = [arg; Lconst (const_int k)]; loc} - in - if hi = lo + 1 then - Lprim - { - primitive = Pnot; - args = - [ - Lprim {primitive = Psequor; args = [test Ceq lo; test Ceq hi]; loc}; - ]; - loc; - } - else Lprim {primitive = Psequor; args = [test Cgt hi; test Clt lo]; loc} - - let make_if_out ~offset ~range arg ifso ifno = - let lo = -offset and hi = range - offset in - match (arg, ifno) with - (* The switcher guards a jump table with a range test, because on a machine - target that beats a table carrying a default. A JS [switch] has a native - [default], so when the table already covers the whole guarded range the - guard is pure overhead: drop it and make its action the failaction. *) - | ( Lvar x, - Lswitch - ( (Lvar y as sarg), - ({ - sw_blocks = []; - sw_blocks_full = true; - sw_consts; - sw_failaction = None; - } as sw) ) ) - when Ident.same x y && covers_range sw_consts ~start:lo ~finish:hi -> - Lswitch (sarg, {sw with sw_failaction = Some ifso; sw_consts_full = false}) - | _ -> Lifthenelse (out_of_range arg ~lo ~hi, ifso, ifno) - - let make_if_in ~offset ~range arg ifso ifno = - let lo = -offset and hi = range - offset in - let cond = - Lprim - { - primitive = Pnot; - args = [out_of_range arg ~lo ~hi]; - loc = Location.none; - } - in - Lifthenelse (cond, ifso, ifno) - let make_switch _loc arg cases acts ~offset = - let l = ref [] in - for i = Array.length cases - 1 downto 0 do - l := (Switch_int (offset + i), acts.(cases.(i))) :: !l - done; - Lswitch - ( arg, - { - sw_consts_full = true; - sw_consts = !l; - sw_blocks_full = true; - sw_blocks = []; - sw_failaction = None; - sw_dispatch = Switch_direct; - } ) - let make_catch = make_catch_delayed - let make_exit = make_exit -end - (* Action sharing for Lswitch argument *) let share_actions_sw sw = (* Attempt sharing on all actions *) @@ -1850,7 +1723,6 @@ let reintroduce_fail sw = else sw | Some _ -> sw -module Switcher = Switch.Make (S_arg) open Switch let rec last def = function @@ -1956,9 +1828,9 @@ let as_interval fail low high l = | None -> as_interval_nofail l | Some act -> as_interval_canfail act low high l ) -let call_switcher loc fail arg low high int_lambda_list = +let call_switcher fail arg low high int_lambda_list = let edges, (cases, actions) = as_interval fail low high int_lambda_list in - Switcher.zyva loc edges arg cases actions + Switch.zyva edges arg cases actions let rec list_as_pat = function | [] -> fatal_error "Matching.list_as_pat" @@ -2050,7 +1922,7 @@ let combine_constant loc arg cst partial ctx def | _ -> assert false) const_lambda_list in - call_switcher loc fail arg min_int max_int int_lambda_list + call_switcher fail arg min_int max_int int_lambda_list | Const_char _ -> let int_lambda_list = List.map @@ -2059,7 +1931,7 @@ let combine_constant loc arg cst partial ctx def | _ -> assert false) const_lambda_list in - call_switcher loc fail arg 0 max_int int_lambda_list + call_switcher fail arg 0 max_int int_lambda_list | Const_string _ -> (* Note as the bytecode compiler may resort to dichotomic search, the clauses of stringswitch are sorted with duplicates removed. @@ -2298,10 +2170,10 @@ let make_test_sequence_variant_constant fail arg int_lambda_list = as_interval fail min_int max_int (List.map (fun (a, (_, c)) -> (a, c)) int_lambda_list) in - Switcher.test_sequence arg cases actions + Switch.test_sequence arg cases actions -let call_switcher_variant_constant loc fail arg int_lambda_list = - call_switcher loc fail arg min_int max_int +let call_switcher_variant_constant fail arg int_lambda_list = + call_switcher fail arg min_int max_int (List.map (fun (a, (_, c)) -> (a, c)) int_lambda_list) let call_switcher_variant_constr loc fail arg int_lambda_list = @@ -2310,12 +2182,11 @@ let call_switcher_variant_constr loc fail arg int_lambda_list = ( Alias, v, Lprim {primitive = Pfield (0, Fld_poly_var_tag); args = [arg]; loc}, - call_switcher loc fail (Lvar v) min_int max_int + call_switcher fail (Lvar v) min_int max_int (List.map (fun (a, (_, c)) -> (a, c)) int_lambda_list) ) let call_switcher_variant_constant : - (Location.t -> - Lambda.lambda option -> + (Lambda.lambda option -> Lambda.lambda -> (int * (string * Lambda.lambda)) list -> Lambda.lambda) @@ -2388,7 +2259,7 @@ let combine_variant loc row arg partial ctx def (tag_lambda_list, total1, _pats) | None -> lam | Some fail -> test_int_or_block arg fail lam) | _, _ -> - let lam_const = !call_switcher_variant_constant loc fail arg consts + let lam_const = !call_switcher_variant_constant fail arg consts and lam_nonconst = !call_switcher_variant_constr loc fail arg nonconsts in @@ -2400,9 +2271,7 @@ let combine_array loc arg partial ctx def (len_lambda_list, total1, _pats) = let fail, local_jumps = mk_failaction_neg partial ctx def in let lambda1 = let newvar = Ident.create "len" in - let switch = - call_switcher loc fail (Lvar newvar) 0 max_int len_lambda_list - in + let switch = call_switcher fail (Lvar newvar) 0 max_int len_lambda_list in bind Alias newvar (Lprim {primitive = Parraylength; args = [arg]; loc}) switch diff --git a/compiler/ml/matching.mli b/compiler/ml/matching.mli index 041eac3b9d1..3bfe53d7e39 100644 --- a/compiler/ml/matching.mli +++ b/compiler/ml/matching.mli @@ -19,8 +19,7 @@ open Typedtree open Lambda val call_switcher_variant_constant : - (Location.t -> - Lambda.lambda option -> + (Lambda.lambda option -> Lambda.lambda -> (int * (string * Lambda.lambda)) list -> Lambda.lambda) diff --git a/compiler/ml/switch.ml b/compiler/ml/switch.ml index 86c4679acfe..eb890e11d9b 100644 --- a/compiler/ml/switch.ml +++ b/compiler/ml/switch.ml @@ -13,6 +13,8 @@ (* *) (**************************************************************************) +open Lambda + type 'a shared = Shared of 'a | Single of 'a type 'a t_store = { @@ -21,8 +23,6 @@ type 'a t_store = { act_store_shared: 'a -> int; } -exception Not_simple - module type Stored = sig type t type key @@ -87,34 +87,75 @@ module Store (A : Stored) = struct } end -module type S = sig - type primitive - val eqint : primitive - val neint : primitive - val leint : primitive - val ltint : primitive - val geint : primitive - val gtint : primitive - type act - - val bind : act -> (act -> act) -> act - val make_const : int -> act - val make_prim : primitive -> act list -> act - - (* [make_if_out ~offset ~range arg ifso ifno] runs [ifso] when [arg] lies - outside [-offset .. range - offset] and [ifno] when it lies inside. The - producer chooses how to test that, because only it knows what the target - can express. *) - val make_if_out : offset:int -> range:int -> act -> act -> act -> act - - (* Dual of [make_if_out]: [ifso] runs when [arg] lies inside the range. *) - val make_if_in : offset:int -> range:int -> act -> act -> act -> act - val make_if : act -> act -> act -> act - val make_switch : - Location.t -> act -> int array -> act array -> offset:int -> act - val make_catch : act -> int * (act -> act) - val make_exit : int -> act -end +(* The algorithm below builds a decision structure over Lambda. It used to be a + functor so that upstream OCaml could share it between the bytecode and the + native backends; ReScript has only the one, so the operations it needs are + defined here directly. *) + +let eqint = Pintcomp Ceq +let neint = Pintcomp Cneq +let leint = Pintcomp Cle +let ltint = Pintcomp Clt +let geint = Pintcomp Cge +let gtint = Pintcomp Cgt + +let prim p args : lambda = Lprim {primitive = p; args; loc = Location.none} + +(* [covers_range cases ~start ~finish] holds when [cases] is exactly the + contiguous integer keys [start .. finish], in order. *) +let rec covers_range (cases : (switch_key * lambda) list) ~start ~finish = + match cases with + | [] -> finish < start + | (Switch_int i, _) :: rest -> + start <= finish && i = start && covers_range rest ~start:(start + 1) ~finish + | (Switch_constructor _, _) :: _ -> false + +(* [arg] is outside [lo .. hi]. A two-value range reads better as a pair of + equality tests than as a pair of comparisons. *) +let out_of_range arg ~lo ~hi = + let test cmp k = prim (Pintcomp cmp) [arg; Lconst (const_int k)] in + if hi = lo + 1 then prim Pnot [prim Psequor [test Ceq lo; test Ceq hi]] + else prim Psequor [test Cgt hi; test Clt lo] + +let emit_if_out ~offset ~range arg ifso ifno = + let lo = -offset and hi = range - offset in + match (arg, ifno) with + (* The switcher guards a jump table with a range test, because on a machine + target that beats a table carrying a default. A JS [switch] has a native + [default], so when the table already covers the whole guarded range the + guard is pure overhead: drop it and make its action the failaction. *) + | ( Lvar x, + Lswitch + ( (Lvar y as sarg), + ({ + sw_blocks = []; + sw_blocks_full = true; + sw_consts; + sw_failaction = None; + } as sw) ) ) + when Ident.same x y && covers_range sw_consts ~start:lo ~finish:hi -> + Lswitch (sarg, {sw with sw_failaction = Some ifso; sw_consts_full = false}) + | _ -> Lifthenelse (out_of_range arg ~lo ~hi, ifso, ifno) + +let emit_if_in ~offset ~range arg ifso ifno = + let lo = -offset and hi = range - offset in + Lifthenelse (prim Pnot [out_of_range arg ~lo ~hi], ifso, ifno) + +let emit_switch arg cases acts ~offset : lambda = + let l = ref [] in + for i = Array.length cases - 1 downto 0 do + l := (Switch_int (offset + i), acts.(cases.(i))) :: !l + done; + Lswitch + ( arg, + { + sw_consts_full = true; + sw_consts = !l; + sw_blocks_full = true; + sw_blocks = []; + sw_failaction = None; + sw_dispatch = Switch_direct; + } ) (* The module will ``produce good code for the case statement'' *) (* @@ -131,21 +172,24 @@ end Technical Reports, James Cook University *) (* - Main adaptation is considering interval tests - (implemented as one addition + one unsigned test and branch) - which leads to exhaustive search for finding the optimal - test sequence in small cases and heuristics otherwise. + Main adaptation is considering interval tests, which leads to exhaustive + search for finding the optimal test sequence in small cases and heuristics + otherwise. Upstream costs an interval test as one addition plus one unsigned + test and branch; here it is a pair of comparisons, or a pair of equality + tests for a two-value range - see [out_of_range]. *) -module Make (Arg : S) = struct - type 'a inter = {cases: (int * int * int) array; actions: 'a array} - type 'a t_ctx = {off: int; arg: 'a} +(* [actions] is instantiated both at [lambda] (the original actions) and at + [t_ctx -> lambda] (cluster actions, which still need a context). *) +type 'a inter = {cases: (int * int * int) array; actions: 'a array} - let cut = ref 8 +type t_ctx = {off: int; arg: lambda} - and more_cut = ref 16 +let cut = ref 8 - (* +and more_cut = ref 16 + +(* let pint chan i = if i = min_int then Printf.fprintf chan "-oo" else if i=max_int then Printf.fprintf chan "oo" @@ -164,19 +208,19 @@ let prerr_inter i = Printf.fprintf stderr "cases=%a" pcases i.cases *) - let get_act cases i = - let _, _, r = cases.(i) in - r +let get_act cases i = + let _, _, r = cases.(i) in + r - and get_low cases i = - let r, _, _ = cases.(i) in - r +and get_low cases i = + let r, _, _ = cases.(i) in + r - type ctests = {mutable n: int; mutable ni: int} +type ctests = {mutable n: int; mutable ni: int} - let too_much = {n = max_int; ni = max_int} +let too_much = {n = max_int; ni = max_int} - (* +(* let ptests chan {n=n ; ni=ni} = Printf.fprintf chan "{n=%d ; ni=%d}" n ni @@ -186,96 +230,96 @@ let pta chan t = done *) - let less_tests c1 c2 = - if c1.n < c2.n then true - else if c1.n = c2.n then if c1.ni < c2.ni then true else false - else false +let less_tests c1 c2 = + if c1.n < c2.n then true + else if c1.n = c2.n then if c1.ni < c2.ni then true else false + else false - and eq_tests c1 c2 = c1.n = c2.n && c1.ni = c2.ni +and eq_tests c1 c2 = c1.n = c2.n && c1.ni = c2.ni - let less2tests (c1, d1) (c2, d2) = - if eq_tests c1 c2 then less_tests d1 d2 else less_tests c1 c2 +let less2tests (c1, d1) (c2, d2) = + if eq_tests c1 c2 then less_tests d1 d2 else less_tests c1 c2 - let add_test t1 t2 = - t1.n <- t1.n + t2.n; - t1.ni <- t1.ni + t2.ni +let add_test t1 t2 = + t1.n <- t1.n + t2.n; + t1.ni <- t1.ni + t2.ni - type t_ret = Inter of int * int | Sep of int | No +type t_ret = Inter of int * int | Sep of int | No - (* +(* let pret chan = function | Inter (i,j)-> Printf.fprintf chan "Inter %d %d" i j | Sep i -> Printf.fprintf chan "Sep %d" i | No -> Printf.fprintf chan "No" *) - let coupe cases i = - let l, _, _ = cases.(i) in - (l, Array.sub cases 0 i, Array.sub cases i (Array.length cases - i)) - - let case_append c1 c2 = - let len1 = Array.length c1 and len2 = Array.length c2 in - match (len1, len2) with - | 0, _ -> c2 - | _, 0 -> c1 - | _, _ -> - let l1, h1, act1 = c1.(Array.length c1 - 1) and l2, h2, act2 = c2.(0) in - if act1 = act2 then ( - let r = Array.make (len1 + len2 - 1) c1.(0) in - for i = 0 to len1 - 2 do - r.(i) <- c1.(i) - done; - - let l = - if len1 - 2 >= 0 then - let _, h, _ = r.(len1 - 2) in - if h + 1 < l1 then h + 1 else l1 - else l1 - and h = - if 1 < len2 - 1 then - let l, _, _ = c2.(1) in - if h2 + 1 < l then l - 1 else h2 - else h2 - in - r.(len1 - 1) <- (l, h, act1); - for i = 1 to len2 - 1 do - r.(len1 - 1 + i) <- c2.(i) - done; - r) - else if h1 > l1 then ( - let r = Array.make (len1 + len2) c1.(0) in - for i = 0 to len1 - 2 do - r.(i) <- c1.(i) - done; - r.(len1 - 1) <- (l1, l2 - 1, act1); - for i = 0 to len2 - 1 do - r.(len1 + i) <- c2.(i) - done; - r) - else if h2 > l2 then ( - let r = Array.make (len1 + len2) c1.(0) in - for i = 0 to len1 - 1 do - r.(i) <- c1.(i) - done; - r.(len1) <- (h1 + 1, h2, act2); - for i = 1 to len2 - 1 do - r.(len1 + i) <- c2.(i) - done; - r) - else Array.append c1 c2 - - let coupe_inter i j cases = - let lcases = Array.length cases in - let low, _, _ = cases.(i) and _, high, _ = cases.(j) in - ( low, - high, - Array.sub cases i (j - i + 1), - case_append (Array.sub cases 0 i) - (Array.sub cases (j + 1) (lcases - (j + 1))) ) - - type kind = Kvalue of int | Kinter of int | Kempty +let coupe cases i = + let l, _, _ = cases.(i) in + (l, Array.sub cases 0 i, Array.sub cases i (Array.length cases - i)) + +let case_append c1 c2 = + let len1 = Array.length c1 and len2 = Array.length c2 in + match (len1, len2) with + | 0, _ -> c2 + | _, 0 -> c1 + | _, _ -> + let l1, h1, act1 = c1.(Array.length c1 - 1) and l2, h2, act2 = c2.(0) in + if act1 = act2 then ( + let r = Array.make (len1 + len2 - 1) c1.(0) in + for i = 0 to len1 - 2 do + r.(i) <- c1.(i) + done; - (* + let l = + if len1 - 2 >= 0 then + let _, h, _ = r.(len1 - 2) in + if h + 1 < l1 then h + 1 else l1 + else l1 + and h = + if 1 < len2 - 1 then + let l, _, _ = c2.(1) in + if h2 + 1 < l then l - 1 else h2 + else h2 + in + r.(len1 - 1) <- (l, h, act1); + for i = 1 to len2 - 1 do + r.(len1 - 1 + i) <- c2.(i) + done; + r) + else if h1 > l1 then ( + let r = Array.make (len1 + len2) c1.(0) in + for i = 0 to len1 - 2 do + r.(i) <- c1.(i) + done; + r.(len1 - 1) <- (l1, l2 - 1, act1); + for i = 0 to len2 - 1 do + r.(len1 + i) <- c2.(i) + done; + r) + else if h2 > l2 then ( + let r = Array.make (len1 + len2) c1.(0) in + for i = 0 to len1 - 1 do + r.(i) <- c1.(i) + done; + r.(len1) <- (h1 + 1, h2, act2); + for i = 1 to len2 - 1 do + r.(len1 + i) <- c2.(i) + done; + r) + else Array.append c1 c2 + +let coupe_inter i j cases = + let lcases = Array.length cases in + let low, _, _ = cases.(i) and _, high, _ = cases.(j) in + ( low, + high, + Array.sub cases i (j - i + 1), + case_append (Array.sub cases 0 i) + (Array.sub cases (j + 1) (lcases - (j + 1))) ) + +type kind = Kvalue of int | Kinter of int | Kempty + +(* let pkind chan = function | Kvalue i ->Printf.fprintf chan "V%d" i | Kinter i -> Printf.fprintf chan "I%d" i @@ -288,46 +332,46 @@ let rec pkey chan = function Printf.fprintf chan "%a %a" pkey rem pkind k *) - let t = Hashtbl.create 17 - - let make_key cases = - let seen = ref [] and count = ref 0 in - let rec got_it act = function - | [] -> - seen := (act, !count) :: !seen; - let r = !count in - incr count; - r - | (act0, index) :: rem -> if act0 = act then index else got_it act rem - in - - let make_one (l : int) h act = - if l = h then Kvalue (got_it act !seen) else Kinter (got_it act !seen) - in +let t = Hashtbl.create 17 - let rec make_rec i pl = - if i < 0 then [] - else - let l, h, act = cases.(i) in - if pl = h + 1 then make_one l h act :: make_rec (i - 1) l - else Kempty :: make_one l h act :: make_rec (i - 1) l - in +let make_key cases = + let seen = ref [] and count = ref 0 in + let rec got_it act = function + | [] -> + seen := (act, !count) :: !seen; + let r = !count in + incr count; + r + | (act0, index) :: rem -> if act0 = act then index else got_it act rem + in - let l, h, act = cases.(Array.length cases - 1) in - make_one l h act :: make_rec (Array.length cases - 2) l + let make_one (l : int) h act = + if l = h then Kvalue (got_it act !seen) else Kinter (got_it act !seen) + in - let same_act t = - let len = Array.length t in - let a = get_act t (len - 1) in - let rec do_rec i = - if i < 0 then true - else - let b = get_act t i in - b = a && do_rec (i - 1) - in - do_rec (len - 2) + let rec make_rec i pl = + if i < 0 then [] + else + let l, h, act = cases.(i) in + if pl = h + 1 then make_one l h act :: make_rec (i - 1) l + else Kempty :: make_one l h act :: make_rec (i - 1) l + in + + let l, h, act = cases.(Array.length cases - 1) in + make_one l h act :: make_rec (Array.length cases - 2) l + +let same_act t = + let len = Array.length t in + let a = get_act t (len - 1) in + let rec do_rec i = + if i < 0 then true + else + let b = get_act t i in + b = a && do_rec (i - 1) + in + do_rec (len - 2) - (* +(* Interval test x in [l,h] works by checking x-l in [0,h-l] * This may be false for arithmetic modulo 2^31 * Subtracting l may change the relative ordering of values @@ -341,49 +385,113 @@ let rec pkey chan = function This condition is checked by zyva *) - let inter_limit = 1 lsl 16 - - let ok_inter = ref false - - let rec opt_count top cases = - let key = make_key cases in - try Hashtbl.find t key - with Not_found -> - let r = - let lcases = Array.length cases in - match lcases with - | 0 -> assert false - | _ when same_act cases -> (No, ({n = 0; ni = 0}, {n = 0; ni = 0})) - | _ -> - if lcases < !cut then enum top cases - else if lcases < !more_cut then heuristic cases - else divide cases - in - Hashtbl.add t key r; - r +let inter_limit = 1 lsl 16 + +let ok_inter = ref false + +let rec opt_count top cases = + let key = make_key cases in + try Hashtbl.find t key + with Not_found -> + let r = + let lcases = Array.length cases in + match lcases with + | 0 -> assert false + | _ when same_act cases -> (No, ({n = 0; ni = 0}, {n = 0; ni = 0})) + | _ -> + if lcases < !cut then enum top cases + else if lcases < !more_cut then heuristic cases + else divide cases + in + Hashtbl.add t key r; + r - and divide cases = - let lcases = Array.length cases in - let m = lcases / 2 in - let _, left, right = coupe cases m in - let ci = {n = 1; ni = 0} - and cm = {n = 1; ni = 0} - and _, (cml, cleft) = opt_count false left - and _, (cmr, cright) = opt_count false right in - add_test ci cleft; - add_test ci cright; - if less_tests cml cmr then add_test cm cmr else add_test cm cml; - (Sep m, (cm, ci)) - - and heuristic cases = - let lcases = Array.length cases in - - let sep, csep = divide cases - and inter, cinter = - if !ok_inter then - let _, _, act0 = cases.(0) and _, _, act1 = cases.(lcases - 1) in - if act0 = act1 then ( - let low, high, inside, outside = coupe_inter 1 (lcases - 2) cases in +and divide cases = + let lcases = Array.length cases in + let m = lcases / 2 in + let _, left, right = coupe cases m in + let ci = {n = 1; ni = 0} + and cm = {n = 1; ni = 0} + and _, (cml, cleft) = opt_count false left + and _, (cmr, cright) = opt_count false right in + add_test ci cleft; + add_test ci cright; + if less_tests cml cmr then add_test cm cmr else add_test cm cml; + (Sep m, (cm, ci)) + +and heuristic cases = + let lcases = Array.length cases in + + let sep, csep = divide cases + and inter, cinter = + if !ok_inter then + let _, _, act0 = cases.(0) and _, _, act1 = cases.(lcases - 1) in + if act0 = act1 then ( + let low, high, inside, outside = coupe_inter 1 (lcases - 2) cases in + let _, (cmi, cinside) = opt_count false inside + and _, (cmo, coutside) = opt_count false outside + and cmij = {n = 1; ni = (if low = high then 0 else 1)} + and cij = {n = 1; ni = (if low = high then 0 else 1)} in + add_test cij cinside; + add_test cij coutside; + if less_tests cmi cmo then add_test cmij cmo else add_test cmij cmi; + (Inter (1, lcases - 2), (cmij, cij))) + else (Inter (-1, -1), (too_much, too_much)) + else (Inter (-1, -1), (too_much, too_much)) + in + if less2tests csep cinter then (sep, csep) else (inter, cinter) + +and enum top cases = + let lcases = Array.length cases in + let lim, with_sep = + let best = ref (-1) and best_cost = ref (too_much, too_much) in + + for i = 1 to lcases - 1 do + let _, left, right = coupe cases i in + let ci = {n = 1; ni = 0} + and cm = {n = 1; ni = 0} + and _, (cml, cleft) = opt_count false left + and _, (cmr, cright) = opt_count false right in + add_test ci cleft; + add_test ci cright; + if less_tests cml cmr then add_test cm cmr else add_test cm cml; + + if less2tests (cm, ci) !best_cost then ( + if top then Printf.fprintf stderr "Get it: %d\n" i; + best := i; + best_cost := (cm, ci)) + done; + (!best, !best_cost) + in + + let ilow, ihigh, with_inter = + if not !ok_inter then ( + let rlow = ref (-1) + and rhigh = ref (-1) + and best_cost = ref (too_much, too_much) in + for i = 1 to lcases - 2 do + let low, high, inside, outside = coupe_inter i i cases in + if low = high then ( + let _, (cmi, cinside) = opt_count false inside + and _, (cmo, coutside) = opt_count false outside + and cmij = {n = 1; ni = 0} + and cij = {n = 1; ni = 0} in + add_test cij cinside; + add_test cij coutside; + if less_tests cmi cmo then add_test cmij cmo else add_test cmij cmi; + if less2tests (cmij, cij) !best_cost then ( + rlow := i; + rhigh := i; + best_cost := (cmij, cij))) + done; + (!rlow, !rhigh, !best_cost)) + else + let rlow = ref (-1) + and rhigh = ref (-1) + and best_cost = ref (too_much, too_much) in + for i = 1 to lcases - 2 do + for j = i to lcases - 2 do + let low, high, inside, outside = coupe_inter i j cases in let _, (cmi, cinside) = opt_count false inside and _, (cmo, coutside) = opt_count false outside and cmij = {n = 1; ni = (if low = high then 0 else 1)} @@ -391,332 +499,265 @@ let rec pkey chan = function add_test cij cinside; add_test cij coutside; if less_tests cmi cmo then add_test cmij cmo else add_test cmij cmi; - (Inter (1, lcases - 2), (cmij, cij))) - else (Inter (-1, -1), (too_much, too_much)) - else (Inter (-1, -1), (too_much, too_much)) - in - if less2tests csep cinter then (sep, csep) else (inter, cinter) - - and enum top cases = - let lcases = Array.length cases in - let lim, with_sep = - let best = ref (-1) and best_cost = ref (too_much, too_much) in - - for i = 1 to lcases - 1 do - let _, left, right = coupe cases i in - let ci = {n = 1; ni = 0} - and cm = {n = 1; ni = 0} - and _, (cml, cleft) = opt_count false left - and _, (cmr, cright) = opt_count false right in - add_test ci cleft; - add_test ci cright; - if less_tests cml cmr then add_test cm cmr else add_test cm cml; - - if less2tests (cm, ci) !best_cost then ( - if top then Printf.fprintf stderr "Get it: %d\n" i; - best := i; - best_cost := (cm, ci)) + if less2tests (cmij, cij) !best_cost then ( + rlow := i; + rhigh := j; + best_cost := (cmij, cij)) + done done; - (!best, !best_cost) - in - - let ilow, ihigh, with_inter = - if not !ok_inter then ( - let rlow = ref (-1) - and rhigh = ref (-1) - and best_cost = ref (too_much, too_much) in - for i = 1 to lcases - 2 do - let low, high, inside, outside = coupe_inter i i cases in - if low = high then ( - let _, (cmi, cinside) = opt_count false inside - and _, (cmo, coutside) = opt_count false outside - and cmij = {n = 1; ni = 0} - and cij = {n = 1; ni = 0} in - add_test cij cinside; - add_test cij coutside; - if less_tests cmi cmo then add_test cmij cmo else add_test cmij cmi; - if less2tests (cmij, cij) !best_cost then ( - rlow := i; - rhigh := i; - best_cost := (cmij, cij))) - done; - (!rlow, !rhigh, !best_cost)) - else - let rlow = ref (-1) - and rhigh = ref (-1) - and best_cost = ref (too_much, too_much) in - for i = 1 to lcases - 2 do - for j = i to lcases - 2 do - let low, high, inside, outside = coupe_inter i j cases in - let _, (cmi, cinside) = opt_count false inside - and _, (cmo, coutside) = opt_count false outside - and cmij = {n = 1; ni = (if low = high then 0 else 1)} - and cij = {n = 1; ni = (if low = high then 0 else 1)} in - add_test cij cinside; - add_test cij coutside; - if less_tests cmi cmo then add_test cmij cmo else add_test cmij cmi; - if less2tests (cmij, cij) !best_cost then ( - rlow := i; - rhigh := j; - best_cost := (cmij, cij)) - done - done; - (!rlow, !rhigh, !best_cost) - in - let r = ref (Inter (ilow, ihigh)) and rc = ref with_inter in - if less2tests with_sep !rc then ( - r := Sep lim; - rc := with_sep); - (!r, !rc) - - let make_if_test test arg i ifso ifnot = - Arg.make_if (Arg.make_prim test [arg; Arg.make_const i]) ifso ifnot - - let make_if_lt arg i ifso ifnot = - match i with - | 1 -> make_if_test Arg.leint arg 0 ifso ifnot - | _ -> make_if_test Arg.ltint arg i ifso ifnot - - and make_if_ge arg i ifso ifnot = - match i with - | 1 -> make_if_test Arg.gtint arg 0 ifso ifnot - | _ -> make_if_test Arg.geint arg i ifso ifnot - - and make_if_eq arg i ifso ifnot = make_if_test Arg.eqint arg i ifso ifnot - - and make_if_ne arg i ifso ifnot = make_if_test Arg.neint arg i ifso ifnot - - let make_if_out ctx l d mk_ifso mk_ifno = - Arg.make_if_out ~offset:(-l) ~range:d ctx.arg (mk_ifso ctx) (mk_ifno ctx) - - let make_if_in ctx l d mk_ifso mk_ifno = - Arg.make_if_in ~offset:(-l) ~range:d ctx.arg (mk_ifso ctx) (mk_ifno ctx) - - let rec c_test ctx ({cases; actions} as s) = - let lcases = Array.length cases in - assert (lcases > 0); - if lcases = 1 then actions.(get_act cases 0) ctx - else - let w, _c = opt_count false cases in - (* + (!rlow, !rhigh, !best_cost) + in + let r = ref (Inter (ilow, ihigh)) and rc = ref with_inter in + if less2tests with_sep !rc then ( + r := Sep lim; + rc := with_sep); + (!r, !rc) + +let make_if_test test arg i ifso ifnot = + Lifthenelse (prim test [arg; Lconst (const_int i)], ifso, ifnot) + +let make_if_lt arg i ifso ifnot = + match i with + | 1 -> make_if_test leint arg 0 ifso ifnot + | _ -> make_if_test ltint arg i ifso ifnot + +and make_if_ge arg i ifso ifnot = + match i with + | 1 -> make_if_test gtint arg 0 ifso ifnot + | _ -> make_if_test geint arg i ifso ifnot + +and make_if_eq arg i ifso ifnot = make_if_test eqint arg i ifso ifnot + +and make_if_ne arg i ifso ifnot = make_if_test neint arg i ifso ifnot + +let make_if_out ctx l d mk_ifso mk_ifno = + emit_if_out ~offset:(-l) ~range:d ctx.arg (mk_ifso ctx) (mk_ifno ctx) + +let make_if_in ctx l d mk_ifso mk_ifno = + emit_if_in ~offset:(-l) ~range:d ctx.arg (mk_ifso ctx) (mk_ifno ctx) + +let rec c_test ctx ({cases; actions} as s) = + let lcases = Array.length cases in + assert (lcases > 0); + if lcases = 1 then actions.(get_act cases 0) ctx + else + let w, _c = opt_count false cases in + (* Printf.fprintf stderr "off=%d tactic=%a for %a\n" ctx.off pret w pcases cases ; *) - match w with - | No -> actions.(get_act cases 0) ctx - | Inter (i, j) -> - let low, high, inside, outside = coupe_inter i j cases in - let _, (cinside, _) = opt_count false inside - and _, (coutside, _) = opt_count false outside in - (* Costs are retrieved to put the code with more remaining tests + match w with + | No -> actions.(get_act cases 0) ctx + | Inter (i, j) -> + let low, high, inside, outside = coupe_inter i j cases in + let _, (cinside, _) = opt_count false inside + and _, (coutside, _) = opt_count false outside in + (* Costs are retrieved to put the code with more remaining tests in the privileged (positive) branch of ``if'' *) - if low = high then - if less_tests coutside cinside then - make_if_eq ctx.arg (low + ctx.off) - (c_test ctx {s with cases = inside}) - (c_test ctx {s with cases = outside}) - else - make_if_ne ctx.arg (low + ctx.off) - (c_test ctx {s with cases = outside}) - (c_test ctx {s with cases = inside}) - else if less_tests coutside cinside then - make_if_in ctx (low + ctx.off) (high - low) - (fun ctx -> c_test ctx {s with cases = inside}) - (fun ctx -> c_test ctx {s with cases = outside}) - else - make_if_out ctx (low + ctx.off) (high - low) - (fun ctx -> c_test ctx {s with cases = outside}) - (fun ctx -> c_test ctx {s with cases = inside}) - | Sep i -> - let lim, left, right = coupe cases i in - let _, (cleft, _) = opt_count false left - and _, (cright, _) = opt_count false right in - let left = {s with cases = left} and right = {s with cases = right} in - - if i = 1 && lim + ctx.off = 1 && get_low cases 0 + ctx.off = 0 then - make_if_ne ctx.arg 0 (c_test ctx right) (c_test ctx left) - else if less_tests cright cleft then - make_if_lt ctx.arg (lim + ctx.off) (c_test ctx left) - (c_test ctx right) + if low = high then + if less_tests coutside cinside then + make_if_eq ctx.arg (low + ctx.off) + (c_test ctx {s with cases = inside}) + (c_test ctx {s with cases = outside}) else - make_if_ge ctx.arg (lim + ctx.off) (c_test ctx right) - (c_test ctx left) - - (* Minimal density of switches *) - let theta = ref 0.33333 - - (* Minimal number of tests to make a switch *) - let switch_min = ref 3 - - (* Particular case 0, 1, 2 *) - let particular_case cases i j = - j - i = 2 - && - let l1, _h1, act1 = cases.(i) - and l2, _h2, _act2 = cases.(i + 1) - and l3, h3, act3 = cases.(i + 2) in - l1 + 1 = l2 && l2 + 1 = l3 && l3 = h3 && act1 <> act3 - - let approx_count cases i j = - let l = j - i + 1 in - if l < !cut then - let _, (_, {n = ntests}) = opt_count false (Array.sub cases i l) in - ntests - else l - 1 - - (* Sends back a boolean that says whether is switch is worth or not *) - - let dense {cases} i j = - if i = j then true - else - let l, _, _ = cases.(i) and _, h, _ = cases.(j) in - let ntests = approx_count cases i j in - (* + make_if_ne ctx.arg (low + ctx.off) + (c_test ctx {s with cases = outside}) + (c_test ctx {s with cases = inside}) + else if less_tests coutside cinside then + make_if_in ctx (low + ctx.off) (high - low) + (fun ctx -> c_test ctx {s with cases = inside}) + (fun ctx -> c_test ctx {s with cases = outside}) + else + make_if_out ctx (low + ctx.off) (high - low) + (fun ctx -> c_test ctx {s with cases = outside}) + (fun ctx -> c_test ctx {s with cases = inside}) + | Sep i -> + let lim, left, right = coupe cases i in + let _, (cleft, _) = opt_count false left + and _, (cright, _) = opt_count false right in + let left = {s with cases = left} and right = {s with cases = right} in + + if i = 1 && lim + ctx.off = 1 && get_low cases 0 + ctx.off = 0 then + make_if_ne ctx.arg 0 (c_test ctx right) (c_test ctx left) + else if less_tests cright cleft then + make_if_lt ctx.arg (lim + ctx.off) (c_test ctx left) (c_test ctx right) + else + make_if_ge ctx.arg (lim + ctx.off) (c_test ctx right) (c_test ctx left) + +(* Minimal density of switches *) +let theta = ref 0.33333 + +(* Minimal number of tests to make a switch *) +let switch_min = ref 3 + +(* Particular case 0, 1, 2 *) +let particular_case cases i j = + j - i = 2 + && + let l1, _h1, act1 = cases.(i) + and l2, _h2, _act2 = cases.(i + 1) + and l3, h3, act3 = cases.(i + 2) in + l1 + 1 = l2 && l2 + 1 = l3 && l3 = h3 && act1 <> act3 + +let approx_count cases i j = + let l = j - i + 1 in + if l < !cut then + let _, (_, {n = ntests}) = opt_count false (Array.sub cases i l) in + ntests + else l - 1 + +(* Sends back a boolean that says whether is switch is worth or not *) + +let dense {cases} i j = + if i = j then true + else + let l, _, _ = cases.(i) and _, h, _ = cases.(j) in + let ntests = approx_count cases i j in + (* (ntests+1) >= theta * (h-l+1) *) - particular_case cases i j - || ntests >= !switch_min - && float_of_int ntests +. 1.0 - >= !theta *. (float_of_int h -. float_of_int l +. 1.0) + particular_case cases i j + || ntests >= !switch_min + && float_of_int ntests +. 1.0 + >= !theta *. (float_of_int h -. float_of_int l +. 1.0) - (* Compute clusters by dynamic programming +(* Compute clusters by dynamic programming Adaptation of the correction to Bernstein ``Correction to `Producing Good Code for the Case Statement' '' S.K. Kannan and T.A. Proebsting Software Practice and Experience Vol. 24(2) 233 (Feb 1994) *) - let comp_clusters s = - let len = Array.length s.cases in - let min_clusters = Array.make len max_int and k = Array.make len 0 in - let get_min i = if i < 0 then 0 else min_clusters.(i) in - - for i = 0 to len - 1 do - for j = 0 to i do - if dense s j i && get_min (j - 1) + 1 < min_clusters.(i) then ( - k.(i) <- j; - min_clusters.(i) <- get_min (j - 1) + 1) - done - done; - (min_clusters.(len - 1), k) - - (* Assume j > i *) - let make_switch loc {cases; actions} i j = - let ll, _, _ = cases.(i) and _, hh, _ = cases.(j) in - let tbl = Array.make (hh - ll + 1) 0 - and t = Hashtbl.create 17 - and index = ref 0 in - let get_index act = - try Hashtbl.find t act - with Not_found -> - let i = !index in - incr index; - Hashtbl.add t act i; - i - in - - for k = i to j do - let l, h, act = cases.(k) in - let index = get_index act in - for kk = l - ll to h - ll do - tbl.(kk) <- index - done - done; - let acts = Array.make !index actions.(0) in - Hashtbl.iter (fun act i -> acts.(i) <- actions.(act)) t; - fun ctx -> Arg.make_switch ~offset:(ll + ctx.off) loc ctx.arg tbl acts - - let make_clusters loc ({cases; actions} as s) n_clusters k = - let len = Array.length cases in - let r = Array.make n_clusters (0, 0, 0) - and t = Hashtbl.create 17 - and index = ref 0 - and bidon = ref (Array.length actions) in - let get_index act = - try - let i, _ = Hashtbl.find t act in - i - with Not_found -> - let i = !index in - incr index; - Hashtbl.add t act (i, fun _ -> actions.(act)); - i - and add_index act = +let comp_clusters s = + let len = Array.length s.cases in + let min_clusters = Array.make len max_int and k = Array.make len 0 in + let get_min i = if i < 0 then 0 else min_clusters.(i) in + + for i = 0 to len - 1 do + for j = 0 to i do + if dense s j i && get_min (j - 1) + 1 < min_clusters.(i) then ( + k.(i) <- j; + min_clusters.(i) <- get_min (j - 1) + 1) + done + done; + (min_clusters.(len - 1), k) + +(* Assume j > i *) +let make_switch {cases; actions} i j = + let ll, _, _ = cases.(i) and _, hh, _ = cases.(j) in + let tbl = Array.make (hh - ll + 1) 0 + and t = Hashtbl.create 17 + and index = ref 0 in + let get_index act = + try Hashtbl.find t act + with Not_found -> let i = !index in incr index; - incr bidon; - Hashtbl.add t !bidon (i, act); + Hashtbl.add t act i; i - in - - let rec zyva j ir = - let i = k.(j) in - (if i = j then - let l, h, act = cases.(i) in - r.(ir) <- (l, h, get_index act) - else - (* assert i < j *) - let l, _, _ = cases.(i) and _, h, _ = cases.(j) in - r.(ir) <- (l, h, add_index (make_switch loc s i j))); - if i > 0 then zyva (i - 1) (ir - 1) - in - - zyva (len - 1) (n_clusters - 1); - let acts = Array.make !index (fun _ -> assert false) in - Hashtbl.iter (fun _ (i, act) -> acts.(i) <- act) t; - {cases = r; actions = acts} - - let do_zyva loc (low, high) arg cases actions = - let old_ok = !ok_inter in - ok_inter := abs low <= inter_limit && abs high <= inter_limit; - if !ok_inter <> old_ok then Hashtbl.clear t; - - let s = {cases; actions} in + in + + for k = i to j do + let l, h, act = cases.(k) in + let index = get_index act in + for kk = l - ll to h - ll do + tbl.(kk) <- index + done + done; + let acts = Array.make !index actions.(0) in + Hashtbl.iter (fun act i -> acts.(i) <- actions.(act)) t; + fun ctx -> emit_switch ~offset:(ll + ctx.off) ctx.arg tbl acts + +let make_clusters ({cases; actions} as s) n_clusters k = + let len = Array.length cases in + let r = Array.make n_clusters (0, 0, 0) + and t = Hashtbl.create 17 + and index = ref 0 + and bidon = ref (Array.length actions) in + let get_index act = + try + let i, _ = Hashtbl.find t act in + i + with Not_found -> + let i = !index in + incr index; + Hashtbl.add t act (i, fun _ -> actions.(act)); + i + and add_index act = + let i = !index in + incr index; + incr bidon; + Hashtbl.add t !bidon (i, act); + i + in + + let rec zyva j ir = + let i = k.(j) in + (if i = j then + let l, h, act = cases.(i) in + r.(ir) <- (l, h, get_index act) + else + (* assert i < j *) + let l, _, _ = cases.(i) and _, h, _ = cases.(j) in + r.(ir) <- (l, h, add_index (make_switch s i j))); + if i > 0 then zyva (i - 1) (ir - 1) + in + + zyva (len - 1) (n_clusters - 1); + let acts = Array.make !index (fun _ -> assert false) in + Hashtbl.iter (fun _ (i, act) -> acts.(i) <- act) t; + {cases = r; actions = acts} + +let do_zyva (low, high) arg cases actions = + let old_ok = !ok_inter in + ok_inter := abs low <= inter_limit && abs high <= inter_limit; + if !ok_inter <> old_ok then Hashtbl.clear t; + + let s = {cases; actions} in - (* + (* Printf.eprintf "ZYVA: %B [low=%i,high=%i]\n" !ok_inter low high ; pcases stderr cases ; prerr_endline "" ; *) - let n_clusters, k = comp_clusters s in - let clusters = make_clusters loc s n_clusters k in - c_test {arg; off = 0} clusters - - let abstract_shared actions = - let handlers = ref (fun x -> x) in - let actions = - Array.map - (fun act -> - match act with - | Single act -> act - | Shared act -> - let i, h = Arg.make_catch act in - let oh = !handlers in - (handlers := fun act -> h (oh act)); - Arg.make_exit i) - actions - in - (!handlers, actions) - - let zyva loc lh arg cases actions = - assert (Array.length cases > 0); - let actions = actions.act_get_shared () in - let hs, actions = abstract_shared actions in - hs (do_zyva loc lh arg cases actions) - - and test_sequence arg cases actions = - assert (Array.length cases > 0); - let actions = actions.act_get_shared () in - let hs, actions = abstract_shared actions in - let old_ok = !ok_inter in - ok_inter := false; - if !ok_inter <> old_ok then Hashtbl.clear t; - let s = {cases; actions = Array.map (fun act _ -> act) actions} in - (* + let n_clusters, k = comp_clusters s in + let clusters = make_clusters s n_clusters k in + c_test {arg; off = 0} clusters + +let abstract_shared actions = + let handlers = ref (fun x -> x) in + let actions = + Array.map + (fun act -> + match act with + | Single act -> act + | Shared act -> + let i, h = make_catch_delayed act in + let oh = !handlers in + (handlers := fun act -> h (oh act)); + make_exit i) + actions + in + (!handlers, actions) + +let zyva lh arg cases actions = + assert (Array.length cases > 0); + let actions = actions.act_get_shared () in + let hs, actions = abstract_shared actions in + hs (do_zyva lh arg cases actions) + +and test_sequence arg cases actions = + assert (Array.length cases > 0); + let actions = actions.act_get_shared () in + let hs, actions = abstract_shared actions in + let old_ok = !ok_inter in + ok_inter := false; + if !ok_inter <> old_ok then Hashtbl.clear t; + let s = {cases; actions = Array.map (fun act _ -> act) actions} in + (* Printf.eprintf "SEQUENCE: %B\n" !ok_inter ; pcases stderr cases ; prerr_endline "" ; *) - hs (c_test {arg; off = 0} s) -end + hs (c_test {arg; off = 0} s) diff --git a/compiler/ml/switch.mli b/compiler/ml/switch.mli index 195d52144ef..1bf69e9fe39 100644 --- a/compiler/ml/switch.mli +++ b/compiler/ml/switch.mli @@ -37,8 +37,6 @@ type 'a t_store = { act_store_shared: 'a -> int; } -exception Not_simple - module type Stored = sig type t type key @@ -50,51 +48,8 @@ module Store (A : Stored) : sig val mk_store : unit -> A.t t_store end -(* Arguments to the Make functor *) -module type S = sig - (* type of basic tests *) - type primitive - - (* basic tests themselves *) - val eqint : primitive - val neint : primitive - val leint : primitive - val ltint : primitive - val geint : primitive - val gtint : primitive - - (* type of actions *) - type act - - (* Various constructors, for making a binder, - adding one integer, etc. *) - val bind : act -> (act -> act) -> act - val make_const : int -> act - val make_prim : primitive -> act list -> act - - (* [make_if_out ~offset ~range arg ifso ifno] runs [ifso] when [arg] lies - outside [-offset .. range - offset] and [ifno] when it lies inside. The - producer chooses how to test that, because only it knows what the target - can express. *) - val make_if_out : offset:int -> range:int -> act -> act -> act -> act - - (* Dual of [make_if_out]: [ifso] runs when [arg] lies inside the range. *) - val make_if_in : offset:int -> range:int -> act -> act -> act -> act - val make_if : act -> act -> act -> act - - (* construct an actual switch : - make_switch arg cases acts - NB: cases is in the value form *) - val make_switch : - Location.t -> act -> int array -> act array -> offset:int -> act - - (* Build last minute sharing of action stuff *) - val make_catch : act -> int * (act -> act) - val make_exit : int -> act -end - (* - Make.zyva arg low high cases actions where + zyva (low, high) arg cases actions where - arg is the argument of the switch. - low, high are the interval limits. - cases is a list of sub-interval and action indices @@ -103,17 +58,15 @@ end All these arguments specify a switch construct and zyva returns an action that performs the switch. *) -module Make : functor (Arg : S) -> sig - (* Standard entry point, sharing is tracked *) - val zyva : - Location.t -> - int * int -> - Arg.act -> - (int * int * int) array -> - Arg.act t_store -> - Arg.act - - (* Output test sequence, sharing tracked *) - val test_sequence : - Arg.act -> (int * int * int) array -> Arg.act t_store -> Arg.act -end +val zyva : + int * int -> + Lambda.lambda -> + (int * int * int) array -> + Lambda.lambda t_store -> + Lambda.lambda + +val test_sequence : + Lambda.lambda -> + (int * int * int) array -> + Lambda.lambda t_store -> + Lambda.lambda From d765b50b289b423d44966900260535fb6fc3aae7 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 1 Sep 2026 18:13:38 +0200 Subject: [PATCH 29/46] Make Lam_primitive.t a re-export of Lambda.primitive The two declarations had the same 115 constructors with the same payloads - Lam_compat.comparison, Lam_tag_info.t and Lambda.import_source are all already aliases of the Lambda types - and differed only in declaration order. Keeping them apart meant every new primitive had to be added twice and stay in sync by hand. Lam_primitive now re-exports the type manifestly, as Lam_constant already does for constants, and keeps its operations. Lam_convert's lam_prim was 116 lines mapping each constructor to itself; it is gone, and Lprim conversion is a direct Lam.prim call. lam_convert.ml goes from 230 lines to 95. Generated JavaScript is unchanged. Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/core/lam_convert.ml | 145 ++------------------------------ compiler/core/lam_primitive.ml | 83 +++++++++--------- compiler/core/lam_primitive.mli | 75 ++++++++++------- 3 files changed, 91 insertions(+), 212 deletions(-) diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index 629d9f8f397..8cc02c9da77 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -22,144 +22,9 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -let prim = Lam.prim - -(* type required_modules = Lam_module_ident.Hash_set.t *) - -(** drop Lseq (List! ) etc - see #3852, we drop all these required global modules - but added it back based on our own module analysis -*) -let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = - match p with - | Pcreate_extension s -> prim ~primitive:(Pcreate_extension s) ~args loc - | Pmakeblock info -> prim ~primitive:(Pmakeblock info) ~args loc - | Pdebugger -> prim ~primitive:Pdebugger ~args loc - | Psome -> prim ~primitive:Psome ~args loc - | Psome_not_nest -> prim ~primitive:Psome_not_nest ~args loc - | Ptypeof -> prim ~primitive:Ptypeof ~args loc - | Pis_null_undefined -> prim ~primitive:Pis_null_undefined ~args loc - | Pnull_to_opt -> prim ~primitive:Pnull_to_opt ~args loc - | Pis_null -> prim ~primitive:Pis_null ~args loc - | Pis_undefined -> prim ~primitive:Pis_undefined ~args loc - | Pnull_undefined_to_opt -> prim ~primitive:Pnull_undefined_to_opt ~args loc - | Pis_not_none -> prim ~primitive:Pis_not_none ~args loc - | Pval_from_option -> prim ~primitive:Pval_from_option ~args loc - | Pval_from_option_not_nest -> - prim ~primitive:Pval_from_option_not_nest ~args loc - | Pjscomp x -> prim ~primitive:(Pjscomp x) ~args loc - | Pfield (id, info) -> prim ~primitive:(Pfield (id, info)) ~args loc - | Psetfield (id, info) -> prim ~primitive:(Psetfield (id, info)) ~args loc - | 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 - | Pobjcomp x -> prim ~primitive:(Pobjcomp x) ~args loc - | Pobjorder -> prim ~primitive:Pobjorder ~args loc - | Pobjmin -> prim ~primitive:Pobjmin ~args loc - | Pobjmax -> prim ~primitive:Pobjmax ~args loc - | Pobjtag -> prim ~primitive:Pobjtag ~args loc - | Pobjsize -> prim ~primitive:Pobjsize ~args loc - | Psequand -> prim ~primitive:Psequand ~args loc - | Psequor -> prim ~primitive:Psequor ~args loc - | Pnot -> prim ~primitive:Pnot ~args loc - | Pboolcomp x -> prim ~primitive:(Pboolcomp x) ~args loc - | Pboolorder -> prim ~primitive:Pboolorder ~args loc - | Pboolmin -> prim ~primitive:Pboolmin ~args loc - | Pboolmax -> prim ~primitive:Pboolmax ~args loc - | Pnegint -> prim ~primitive:Pnegint ~args loc - | Paddint -> prim ~primitive:Paddint ~args loc - | Psubint -> prim ~primitive:Psubint ~args loc - | Pmulint -> prim ~primitive:Pmulint ~args loc - | Pdivint -> prim ~primitive:Pdivint ~args loc - | Pmodint -> prim ~primitive:Pmodint ~args loc - | Ppowint -> prim ~primitive:Ppowint ~args loc - | Pandint -> prim ~primitive:Pandint ~args loc - | Porint -> prim ~primitive:Porint ~args loc - | Pxorint -> prim ~primitive:Pxorint ~args loc - | Pnotint -> prim ~primitive:Pnotint ~args loc - | Plslint -> prim ~primitive:Plslint ~args loc - | Plsrint -> prim ~primitive:Plsrint ~args loc - | Pasrint -> prim ~primitive:Pasrint ~args loc - | Pintorder -> prim ~primitive:Pintorder ~args loc - | Pintmin -> prim ~primitive:Pintmin ~args loc - | Pintmax -> prim ~primitive:Pintmax ~args loc - | Pstringlength -> prim ~primitive:Pstringlength ~args loc - | Pstringrefu -> prim ~primitive:Pstringrefu ~args loc - | Pstringcomp x -> prim ~primitive:(Pstringcomp x) ~args loc - | Pstringorder -> prim ~primitive:Pstringorder ~args loc - | Pstringmin -> prim ~primitive:Pstringmin ~args loc - | Pstringmax -> prim ~primitive:Pstringmax ~args loc - | Pstringadd -> prim ~primitive:Pstringadd ~args loc - | Pstringrefs -> prim ~primitive:Pstringrefs ~args loc - | Pisint -> prim ~primitive:Pisint ~args loc - | Pintoffloat -> prim ~primitive:Pintoffloat ~args loc - | Pfloatofint -> prim ~primitive:Pfloatofint ~args loc - | Pnegfloat -> prim ~primitive:Pnegfloat ~args loc - | Paddfloat -> prim ~primitive:Paddfloat ~args loc - | Psubfloat -> prim ~primitive:Psubfloat ~args loc - | Pmulfloat -> prim ~primitive:Pmulfloat ~args loc - | Pdivfloat -> prim ~primitive:Pdivfloat ~args loc - | Pmodfloat -> prim ~primitive:Pmodfloat ~args loc - | Ppowfloat -> prim ~primitive:Ppowfloat ~args loc - | Pfloatorder -> prim ~primitive:Pfloatorder ~args loc - | Pfloatmin -> prim ~primitive:Pfloatmin ~args loc - | Pfloatmax -> prim ~primitive:Pfloatmax ~args loc - | Pnegbigint -> prim ~primitive:Pnegbigint ~args loc - | Paddbigint -> prim ~primitive:Paddbigint ~args loc - | Psubbigint -> prim ~primitive:Psubbigint ~args loc - | Pmulbigint -> prim ~primitive:Pmulbigint ~args loc - | Pdivbigint -> prim ~primitive:Pdivbigint ~args loc - | Pmodbigint -> prim ~primitive:Pmodbigint ~args loc - | Ppowbigint -> prim ~primitive:Ppowbigint ~args loc - | Pandbigint -> prim ~primitive:Pandbigint ~args loc - | Porbigint -> prim ~primitive:Porbigint ~args loc - | Pxorbigint -> prim ~primitive:Pxorbigint ~args loc - | Pnotbigint -> prim ~primitive:Pnotbigint ~args loc - | Plslbigint -> prim ~primitive:Plslbigint ~args loc - | Pasrbigint -> prim ~primitive:Pasrbigint ~args loc - | Pbigintcomp x -> prim ~primitive:(Pbigintcomp x) ~args loc - | Pbigintorder -> prim ~primitive:Pbigintorder ~args loc - | Pbigintmin -> prim ~primitive:Pbigintmin ~args loc - | Pbigintmax -> prim ~primitive:Pbigintmax ~args loc - | Pintcomp x -> prim ~primitive:(Pintcomp x) ~args loc - | Pfloatcomp x -> prim ~primitive:(Pfloatcomp x) ~args loc - | Pmakearray -> prim ~primitive:Pmakearray ~args loc - | Parraylength -> prim ~primitive:Parraylength ~args loc - | Parrayrefu -> prim ~primitive:Parrayrefu ~args loc - | Parraysetu -> prim ~primitive:Parraysetu ~args loc - | Parrayrefs -> prim ~primitive:Parrayrefs ~args loc - | Parraysets -> prim ~primitive:Parraysets ~args loc - | Pmakelist -> prim ~primitive:Pmakelist ~args loc - | Pmakedict -> prim ~primitive:Pmakedict ~args loc - | Pdict_has -> prim ~primitive:Pdict_has ~args loc - | Pawait -> prim ~primitive:Pawait ~args loc - | Pimport src -> prim ~primitive:(Pimport src) ~args loc - | Pinit_mod -> prim ~primitive:Pinit_mod ~args loc - | Pupdate_mod -> prim ~primitive:Pupdate_mod ~args loc - | Phash -> prim ~primitive:Phash ~args loc - | Phash_mixint -> prim ~primitive:Phash_mixint ~args loc - | Phash_mixstring -> prim ~primitive:Phash_mixstring ~args loc - | Phash_finalmix -> prim ~primitive:Phash_finalmix ~args loc - | Pis_poly_var_block -> prim ~primitive:Pis_poly_var_block ~args loc - | Pjs_call {prim_name; arg_types; ffi; transformed_jsx} -> - prim - ~primitive:(Pjs_call {prim_name; arg_types; ffi; transformed_jsx}) - ~args loc - | Pjs_object_create labels -> - prim ~primitive:(Pjs_object_create labels) ~args loc - | Pjs_object_get name -> prim ~primitive:(Pjs_object_get name) ~args loc - | Pjs_object_set name -> prim ~primitive:(Pjs_object_set name) ~args loc - | Praw_js_code info -> prim ~primitive:(Praw_js_code info) ~args loc - | Pjs_fn_method -> prim ~primitive:Pjs_fn_method ~args loc - -(* Does not exist since we compile array in js backend unlike native backend *) - -(* Which other compilation units this one refers to. A reference that later - passes delete still has to be imported when the module it names is impure, - so the answer is taken from the term as written (see #3852). Read off the - Lambda term rather than accumulated while translating it, so that - translation stays a function of its input. *) +(** Global modules a unit depends on. Convert used to drop [Lglobal_module] + references and have them added back by module analysis (see #3852); they + are collected here instead, from the Lambda term directly. *) let required_modules (lam : Lambda.lambda) : Lam_module_ident.Hash_set.t = let required = Lam_module_ident.Hash_set.create 0 in let rec collect (lam : Lambda.lambda) = @@ -190,8 +55,8 @@ let convert (lam : Lambda.lambda) : Lam.t = Lam.letrec (Ext_list.map_snd bindings convert_aux) (convert_aux body) | Lglobal_module id -> Lam.global_module id | Lprim {primitive; args; loc} -> - let args = Ext_list.map args convert_aux in - lam_prim ~primitive ~args loc + (* [Lam_primitive.t] is [Lambda.primitive]: nothing to translate. *) + Lam.prim ~primitive ~args:(Ext_list.map args convert_aux) loc | Lswitch (e, s) -> convert_switch e s | Lstringswitch (e, cases, default) -> Lam.stringswitch (convert_aux e) diff --git a/compiler/core/lam_primitive.ml b/compiler/core/lam_primitive.ml index f585904829d..ed3747c2bf4 100644 --- a/compiler/core/lam_primitive.ml +++ b/compiler/core/lam_primitive.ml @@ -26,17 +26,20 @@ type ident = Ident.t -type t = +type t = Lambda.primitive = + | Pdebugger + | Ptypeof + | Psome + | Psome_not_nest + (** [Some x] where [x] cannot itself be [undefined], so no wrapping is + needed. *) (* Operations on heap blocks *) | Pmakeblock of Lam_tag_info.t - | Pfield of int * Lam_compat.field_dbg_info - | Psetfield of int * Lam_compat.set_field_dbg_info - (* could have field info at least for record *) + | Pfield of int * Lambda.field_dbg_info + | Psetfield of int * Lambda.set_field_dbg_info | Pduprecord - (* Tagged template literal: [tag; strings_array; values_array] *) - | Ptagged_template - | Precord_rest of string list - (* External call *) + | Precord_rest of string list (* excluded runtime field names *) + (* JS FFI calls, expanded from the external's spec at translation *) | Pjs_call of { prim_name: string; arg_types: External_arg_spec.params; @@ -44,6 +47,8 @@ type t = transformed_jsx: bool; } | Pjs_object_create of External_arg_spec.obj_params + | Pjs_object_get of string + | Pjs_object_set of string (* Exceptions *) | Praise (* object primitives *) @@ -53,7 +58,7 @@ type t = | Pobjmax | Pobjtag | Pobjsize - (* Boolean primitives *) + (* Boolean operations *) | Psequand | Psequor | Pnot @@ -61,8 +66,7 @@ type t = | Pboolorder | Pboolmin | Pboolmax - (* Integer primitives *) - | Pisint + (* Integer operations *) | Pnegint | Paddint | Psubint @@ -81,15 +85,15 @@ type t = | Pintorder | Pintmin | Pintmax - (* Float primitives *) + (* Float operations *) | Pintoffloat | Pfloatofint | Pnegfloat + | Pmodfloat | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat - | Pmodfloat | Ppowfloat | Pfloatcomp of Lam_compat.comparison | Pfloatorder @@ -99,10 +103,10 @@ type t = | Pnegbigint | Paddbigint | Psubbigint + | Ppowbigint | Pmulbigint | Pdivbigint | Pmodbigint - | Ppowbigint | Pandbigint | Porbigint | Pxorbigint @@ -113,16 +117,16 @@ type t = | Pbigintorder | Pbigintmin | Pbigintmax - (* String primitives *) + (* String operations *) | Pstringlength | Pstringrefu | Pstringrefs - | Pstringadd | Pstringcomp of Lam_compat.comparison | Pstringorder | Pstringmin | Pstringmax - (* Array primitives *) + | Pstringadd + (* Array operations *) | Pmakearray | Parraylength | Parrayrefu @@ -136,37 +140,36 @@ type t = | Pdict_has (* promise *) | Pawait - (* etc or deprecated *) - | Pis_poly_var_block - | Pjscomp of Lam_compat.comparison - | Pdebugger - | Pjs_object_get of string - | Pjs_object_set of string + (* modules *) + | Pimport of Lambda.import_source | Pinit_mod | Pupdate_mod - | Praw_js_code of Js_raw_info.t - (* we wrap it when do the conversion to prevent - accendential optimization - play safe first - *) - | Pjs_fn_method + (* hash *) + | Phash + | Phash_mixint + | Phash_mixstring + | Phash_finalmix + (* Test if the argument is a block or an immediate integer *) + | Pisint + (* Test if the (integer) argument is outside an interval *) + (* Test if the argument is null or undefined *) + | Pis_null_undefined + (* exn *) + | Pcreate_extension of string + (* js *) + | Pjscomp of Lam_compat.comparison | Pnull_to_opt | Pnull_undefined_to_opt + (* Produced by Lam_pass_remove_alias, not by translation *) | Pis_null | Pis_undefined - | Pis_null_undefined - | Pimport of Lambda.import_source - | Ptypeof - | Pcreate_extension of string - | Pis_not_none (* no info about its type *) + | Pis_not_none | Pval_from_option | Pval_from_option_not_nest - | Psome - | Psome_not_nest - | Phash - | Phash_mixstring - | Phash_mixint - | Phash_finalmix + | Pis_poly_var_block + | Praw_js_code of Js_raw_info.t + | Pjs_fn_method + | Ptagged_template let eq_field_dbg_info (x : Lam_compat.field_dbg_info) (y : Lam_compat.field_dbg_info) = diff --git a/compiler/core/lam_primitive.mli b/compiler/core/lam_primitive.mli index 5e74215e87e..47da2a27e87 100644 --- a/compiler/core/lam_primitive.mli +++ b/compiler/core/lam_primitive.mli @@ -24,21 +24,30 @@ type ident = Ident.t -type t = +type t = Lambda.primitive = + | Pdebugger + | Ptypeof + | Psome + | Psome_not_nest + (** [Some x] where [x] cannot itself be [undefined], so no wrapping is + needed. *) + (* Operations on heap blocks *) | Pmakeblock of Lam_tag_info.t | Pfield of int * Lambda.field_dbg_info | Psetfield of int * Lambda.set_field_dbg_info | Pduprecord - | Ptagged_template - | Precord_rest of string list + | Precord_rest of string list (* excluded runtime field names *) + (* JS FFI calls, expanded from the external's spec at translation *) | Pjs_call of { - (* Location.t * [loc] is passed down *) prim_name: string; arg_types: External_arg_spec.params; ffi: External_ffi_types.external_decl; transformed_jsx: bool; } | Pjs_object_create of External_arg_spec.obj_params + | Pjs_object_get of string + | Pjs_object_set of string + (* Exceptions *) | Praise (* object primitives *) | Pobjcomp of Lam_compat.comparison @@ -47,7 +56,7 @@ type t = | Pobjmax | Pobjtag | Pobjsize - (* bool primitives *) + (* Boolean operations *) | Psequand | Psequor | Pnot @@ -55,8 +64,7 @@ type t = | Pboolorder | Pboolmin | Pboolmax - (* int primitives *) - | Pisint + (* Integer operations *) | Pnegint | Paddint | Psubint @@ -75,28 +83,28 @@ type t = | Pintorder | Pintmin | Pintmax - (* float primitives *) + (* Float operations *) | Pintoffloat | Pfloatofint | Pnegfloat + | Pmodfloat | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat - | Pmodfloat | Ppowfloat | Pfloatcomp of Lam_compat.comparison | Pfloatorder | Pfloatmin | Pfloatmax - (* bigint primitives *) + (* BigInt operations *) | Pnegbigint | Paddbigint | Psubbigint + | Ppowbigint | Pmulbigint | Pdivbigint | Pmodbigint - | Ppowbigint | Pandbigint | Porbigint | Pxorbigint @@ -107,16 +115,16 @@ type t = | Pbigintorder | Pbigintmin | Pbigintmax - (* string primitives *) + (* String operations *) | Pstringlength | Pstringrefu | Pstringrefs - | Pstringadd | Pstringcomp of Lam_compat.comparison | Pstringorder | Pstringmin | Pstringmax - (* Array primitives *) + | Pstringadd + (* Array operations *) | Pmakearray | Parraylength | Parrayrefu @@ -130,33 +138,36 @@ type t = | Pdict_has (* promise *) | Pawait - (* etc or deprecated *) - | Pis_poly_var_block - | Pjscomp of Lam_compat.comparison - | Pdebugger - | Pjs_object_get of string - | Pjs_object_set of string + (* modules *) + | Pimport of Lambda.import_source | Pinit_mod | Pupdate_mod - | Praw_js_code of Js_raw_info.t - | Pjs_fn_method + (* hash *) + | Phash + | Phash_mixint + | Phash_mixstring + | Phash_finalmix + (* Test if the argument is a block or an immediate integer *) + | Pisint + (* Test if the (integer) argument is outside an interval *) + (* Test if the argument is null or undefined *) + | Pis_null_undefined + (* exn *) + | Pcreate_extension of string + (* js *) + | Pjscomp of Lam_compat.comparison | Pnull_to_opt | Pnull_undefined_to_opt + (* Produced by Lam_pass_remove_alias, not by translation *) | Pis_null | Pis_undefined - | Pis_null_undefined - | Pimport of Lambda.import_source - | Ptypeof - | Pcreate_extension of string | Pis_not_none | Pval_from_option | Pval_from_option_not_nest - | Psome - | Psome_not_nest - | Phash - | Phash_mixstring - | Phash_mixint - | Phash_finalmix + | Pis_poly_var_block + | Praw_js_code of Js_raw_info.t + | Pjs_fn_method + | Ptagged_template val is_immutable_block : Lam_tag_info.t -> bool From eadd03d9c406f20ac132b9e3cdf00ea22a49eb20 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 1 Sep 2026 18:30:23 +0200 Subject: [PATCH 30/46] Make Lambda private, with a constructor per variant Lam.t is private so that every term the optimizer builds goes through the normalizing constructors. That guarantee cannot survive sharing the type with a public Lambda: once the two are equal, Lambda's constructors build values of Lam.t directly. Privacy has to hold on both sides or on neither. So Lambda gains the same discipline first. lambda, prim_info and lambda_apply are private - matching Lam's t, prim_info and apply - and the interface documents a constructor per variant, with signatures mirroring Lam's so the later alias is a rename. 238 construction sites move over, across translcore, matching, translmod, transl_recmodule, lambda_scc, switch, translattribute and polyvar_pattern_match. The constructors are plain wrappers for now. The folds stay in Lam until the two types become one, so there is never a second copy of the fold logic in flight; when Lam.t becomes a private re-export, lam.ml loses the ability to construct and its folds move up into these constructors. Generated JavaScript is unchanged, which is expected rather than lucky: at this stage the constructors build exactly what the call sites built. Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/core/polyvar_pattern_match.ml | 45 +- compiler/ml/lambda.ml | 37 ++ compiler/ml/lambda.mli | 63 ++- compiler/ml/lambda_scc.ml | 12 +- compiler/ml/matching.ml | 259 +++++------- compiler/ml/switch.ml | 31 +- compiler/ml/transl_recmodule.ml | 24 +- compiler/ml/translattribute.ml | 2 +- compiler/ml/translcore.ml | 565 ++++++++++--------------- compiler/ml/translmod.ml | 172 ++++---- 10 files changed, 528 insertions(+), 682 deletions(-) diff --git a/compiler/core/polyvar_pattern_match.ml b/compiler/core/polyvar_pattern_match.ml index c58ff6b8546..0e41f32eccc 100644 --- a/compiler/core/polyvar_pattern_match.ml +++ b/compiler/core/polyvar_pattern_match.ml @@ -61,29 +61,20 @@ let or_list (arg : lam) (hash_names : (int * string) list) = match hash_names with | (hash, name) :: rest -> let init : lam = - Lprim - { - primitive = Pintcomp Ceq; - args = [arg; Lconst (Lambda.const_polyvar name)]; - loc = Location.none; - } + Lambda.prim ~primitive:(Pintcomp Ceq) + ~args:[arg; Lambda.const (Lambda.const_polyvar name)] + Location.none in Ext_list.fold_left rest init (fun acc (hash, name) -> - Lambda.Lprim - { - primitive = Psequor; - args = - [ - acc; - Lprim - { - primitive = Pintcomp Ceq; - args = [arg; Lconst (Lambda.const_polyvar name)]; - loc = Location.none; - }; - ]; - loc = Location.none; - }) + Lambda.prim ~primitive:Psequor + ~args: + [ + acc; + Lambda.prim ~primitive:(Pintcomp Ceq) + ~args:[arg; Lambda.const (Lambda.const_polyvar name)] + Location.none; + ] + Location.none) | _ -> assert false let make_test_sequence_variant_constant (fail : lam option) (arg : lam) @@ -95,7 +86,7 @@ let make_test_sequence_variant_constant (fail : lam option) (arg : lam) | (_, act) :: rest, None | rest, Some act -> Ext_list.fold_right rest act (fun (hash_names, act1) acc -> let predicate : lam = or_list arg hash_names in - Lifthenelse (predicate, act1, acc)) + Lambda.if_ predicate act1 acc) | [], None -> assert false let call_switcher_variant_constant (fail : lam option) (arg : lam) @@ -105,14 +96,12 @@ let call_switcher_variant_constant (fail : lam option) (arg : lam) | (_, act) :: rest, None | rest, Some act -> Ext_list.fold_right rest act (fun (hash_names, act1) acc -> let predicate = or_list arg hash_names in - Lifthenelse (predicate, act1, acc)) + Lambda.if_ predicate act1 acc) | [], None -> assert false let call_switcher_variant_constr (loc : Location.t) (fail : lam option) (arg : lam) int_lambda_list : lam = let v = Ident.create "variant" in - Llet - ( Alias, - v, - Lprim {primitive = Pfield (0, Fld_poly_var_tag); args = [arg]; loc}, - call_switcher_variant_constant fail (Lvar v) int_lambda_list ) + Lambda.let_ Alias v + (Lambda.prim ~primitive:(Pfield (0, Fld_poly_var_tag)) ~args:[arg] loc) + (call_switcher_variant_constant fail (Lambda.var v) int_lambda_list) diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index f3c4456de2f..8331a75487d 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -514,6 +514,43 @@ let offset_ref ~delta r loc = let id = Ident.create "ref" in Llet (Strict, id, r, assign (Lvar id)) +(* Constructors. The type is private outside this module, so every term is + built through one of these. They are plain for now; the normalizations that + Lam.prim / Lam.if_ / Lam.switch perform will move here when the two layers + become one type. *) + +let var id : lambda = Lvar id +let global_module id : lambda = Lglobal_module id +let const ct : lambda = Lconst ct + +let apply ?(ap_transformed_jsx = false) ap_func ap_args ap_info : lambda = + Lapply {ap_func; ap_args; ap_info; ap_transformed_jsx} + +let function_ ~loc ~attr ~params ~body : lambda = + Lfunction {params; body; attr; loc} + +let let_ kind id e body : lambda = Llet (kind, id, e, body) +let letrec bindings body : lambda = Lletrec (bindings, body) +let prim ~primitive ~args loc : lambda = Lprim {primitive; args; loc} +let switch lam sw : lambda = Lswitch (lam, sw) + +let stringswitch lam cases default : lambda = Lstringswitch (lam, cases, default) + +let staticraise i args : lambda = Lstaticraise (i, args) +let staticcatch body catch handler : lambda = Lstaticcatch (body, catch, handler) +let try_ body id handler : lambda = Ltrywith (body, id, handler) +let if_ a b c : lambda = Lifthenelse (a, b, c) +let seq a b : lambda = Lsequence (a, b) +let break : lambda = Lbreak +let continue : lambda = Lcontinue +let while_ cond body : lambda = Lwhile (cond, body) +let for_ id from_ to_ dir body : lambda = Lfor (id, from_, to_, dir, body) +let for_of id iterable body : lambda = Lfor_of (id, iterable, body) + +let for_await_of id iterable body : lambda = Lfor_await_of (id, iterable, body) + +let assign id body : lambda = Lassign (id, body) + let mk_builtin b args loc = match b with | Primitive p -> Lprim {primitive = p; args; loc} diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index 3b8f4f795d5..9d4f6b5c738 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -337,7 +337,7 @@ type function_attribute = { one_unit_arg: bool; } -type lambda = +type lambda = private | Lvar of Ident.t | Lglobal_module of Ident.t (** A reference to another compilation unit: a name the module system @@ -372,14 +372,18 @@ and lfunction = { loc: Location.t; } -and prim_info = {primitive: primitive; args: lambda list; loc: Location.t} +and prim_info = private { + primitive: primitive; + args: lambda list; + loc: Location.t; +} and ap_info = { ap_loc: Location.t; ap_inlined: inline_attribute; (* specified with the [@inlined] attribute *) } -and lambda_apply = { +and lambda_apply = private { ap_func: lambda; ap_args: lambda list; ap_info: ap_info; @@ -432,6 +436,59 @@ val const_module_alias : structured_constant val lambda_assert_false : lambda val lambda_unit : lambda +(* Constructors. [lambda] is private, so every term outside this module is + built through one of these. *) + +val var : Ident.t -> lambda + +val global_module : Ident.t -> lambda + +val const : structured_constant -> lambda + +val apply : + ?ap_transformed_jsx:bool -> lambda -> lambda list -> ap_info -> lambda + +val function_ : + loc:Location.t -> + attr:function_attribute -> + params:Ident.t list -> + body:lambda -> + lambda + +val let_ : let_kind -> Ident.t -> lambda -> lambda -> lambda + +val letrec : (Ident.t * lambda) list -> lambda -> lambda + +val prim : primitive:primitive -> args:lambda list -> Location.t -> lambda + +val switch : lambda -> lambda_switch -> lambda + +val stringswitch : lambda -> (string * lambda) list -> lambda option -> lambda + +val staticraise : int -> lambda list -> lambda + +val staticcatch : lambda -> int * Ident.t list -> lambda -> lambda + +val try_ : lambda -> Ident.t -> lambda -> lambda + +val if_ : lambda -> lambda -> lambda -> lambda + +val seq : lambda -> lambda -> lambda + +val break : lambda + +val continue : lambda + +val while_ : lambda -> lambda -> lambda + +val for_ : Ident.t -> lambda -> lambda -> direction_flag -> lambda -> lambda + +val for_of : Ident.t -> lambda -> lambda -> lambda + +val for_await_of : Ident.t -> lambda -> lambda -> lambda + +val assign : Ident.t -> lambda -> lambda + val mk_builtin : builtin -> lambda list -> Location.t -> lambda (** Expands the non-[Primitive] builtins, which have no IR form. *) diff --git a/compiler/ml/lambda_scc.ml b/compiler/ml/lambda_scc.ml index e3683b9fa8a..2c91bf3e840 100644 --- a/compiler/ml/lambda_scc.ml +++ b/compiler/ml/lambda_scc.ml @@ -88,12 +88,12 @@ let preprocess_deps (groups : bindings) : _ * Ident.t array * Vec_int.t array = 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, id, bind, body) + if exists_var (Ident.same id) bind then letrec groups body + else 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 Lletrec (groups, body) + if Int_vec_vec.length clusters <= 1 then letrec groups body else Int_vec_vec.fold_right (fun (v : Vec_int.t) acc -> @@ -109,7 +109,7 @@ let bind_rec (groups : bindings) (body : lambda) : lambda = | [(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, id, lam, acc) - | _ -> Lletrec (bindings, acc)) + letrec bindings acc + else let_ Strict id lam acc + | _ -> letrec bindings acc) clusters body diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index 241dcd63aed..9ba2a73c1d7 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -514,16 +514,9 @@ let simplify_or p = try simpl_rec p with Var p -> p let bind_record_rest loc arg rest action = - Llet - ( Strict, - rest.rest_ident, - Lprim - { - primitive = Precord_rest rest.excluded_runtime_labels; - args = [arg]; - loc; - }, - action ) + let_ Strict rest.rest_ident + (prim ~primitive:(Precord_rest rest.excluded_runtime_labels) ~args:[arg] loc) + action let simplify_cases args cls = match args with @@ -1053,7 +1046,7 @@ and precompile_or argo cls ors args def k = let new_patl = Parmatch.omega_list patl in let mk_new_action vs = - Lstaticraise (or_num, List.map (fun v -> Lvar v) vs) + staticraise or_num (List.map (fun v -> var v) vs) in let body, handlers = do_cases rem in @@ -1179,8 +1172,7 @@ let make_field_args ~fld_info loc binding_kind arg first_pos last_pos argl = let rec make_args pos = if pos > last_pos then argl else - ( Lprim {primitive = Pfield (pos, fld_info); args = [arg]; loc}, - binding_kind ) + (prim ~primitive:(Pfield (pos, fld_info)) ~args:[arg] loc, binding_kind) :: make_args (pos + 1) in make_args first_pos @@ -1266,8 +1258,7 @@ let make_constr_matching p def ctx = function Pval_from_option_not_nest | _ -> Pval_from_option in - (Lprim {primitive = from_option; args = [arg]; loc = p.pat_loc}, Alias) - :: argl + (prim ~primitive:from_option ~args:[arg] p.pat_loc, Alias) :: argl | Ordinary_constructor _ -> make_field_args p.pat_loc Alias arg 0 (cstr.cstr_arity - 1) argl ~fld_info:(if cstr.cstr_name = "::" then Fld_cons else Fld_variant) @@ -1325,12 +1316,9 @@ let make_variant_matching_nonconst p lab def ctx = function { cases = []; args = - ( Lprim - { - primitive = Pfield (1, Fld_poly_var_content); - args = [arg]; - loc = p.pat_loc; - }, + ( prim + ~primitive:(Pfield (1, Fld_poly_var_content)) + ~args:[arg] p.pat_loc, Alias ) :: argl; default = def; @@ -1404,7 +1392,7 @@ let make_tuple_matching loc arity def = function let rec make_args pos = if pos >= arity then argl else - (Lprim {primitive = Pfield (pos, Fld_tuple); args = [arg]; loc}, Alias) + (prim ~primitive:(Pfield (pos, Fld_tuple)) ~args:[arg] loc, Alias) :: make_args (pos + 1) in { @@ -1453,28 +1441,19 @@ let make_record_matching loc all_labels def = function match lbl.lbl_repres with | Record_float_unused -> assert false | Record_regular -> - Lprim - { - primitive = Pfield (lbl.lbl_pos, Lambda.fld_record lbl); - args = [arg]; - loc; - } + prim + ~primitive:(Pfield (lbl.lbl_pos, Lambda.fld_record lbl)) + ~args:[arg] loc | Record_inlined _ -> - Lprim - { - primitive = Pfield (lbl.lbl_pos, Lambda.fld_record_inline lbl); - args = [arg]; - loc; - } + prim + ~primitive:(Pfield (lbl.lbl_pos, Lambda.fld_record_inline lbl)) + ~args:[arg] loc | Record_unboxed _ -> arg | Record_extension -> - Lprim - { - primitive = - Pfield (lbl.lbl_pos + 1, Lambda.fld_record_extension lbl); - args = [arg]; - loc; - } + prim + ~primitive: + (Pfield (lbl.lbl_pos + 1, Lambda.fld_record_extension lbl)) + ~args:[arg] loc in let str = match lbl.lbl_mut with @@ -1518,12 +1497,7 @@ let make_array_matching p def ctx = function let rec make_args pos = if pos >= len then argl else - ( Lprim - { - primitive = Parrayrefu; - args = [arg; Lconst (const_int pos)]; - loc = p.pat_loc; - }, + ( prim ~primitive:Parrayrefu ~args:[arg; const (const_int pos)] p.pat_loc, StrictOpt ) :: make_args (pos + 1) in @@ -1602,19 +1576,19 @@ let rec cut n l = let rec do_tests_fail loc fail tst arg = function | [] -> fail | (c, act) :: rem -> - Lifthenelse - ( Lprim {primitive = tst; args = [arg; Lconst (const_of_typed c)]; loc}, - do_tests_fail loc fail tst arg rem, - act ) + if_ + (prim ~primitive:tst ~args:[arg; const (const_of_typed c)] loc) + (do_tests_fail loc fail tst arg rem) + act let rec do_tests_nofail loc tst arg = function | [] -> fatal_error "Matching.do_tests_nofail" | [(_, act)] -> act | (c, act) :: rem -> - Lifthenelse - ( Lprim {primitive = tst; args = [arg; Lconst (const_of_typed c)]; loc}, - do_tests_nofail loc tst arg rem, - act ) + if_ + (prim ~primitive:tst ~args:[arg; const (const_of_typed c)] loc) + (do_tests_nofail loc tst arg rem) + act let make_test_sequence loc fail tst lt_tst arg const_lambda_list = let const_lambda_list = sort_lambda_list const_lambda_list in @@ -1630,15 +1604,11 @@ let make_test_sequence loc fail tst lt_tst arg const_lambda_list = let list1, list2 = cut (List.length const_lambda_list / 2) const_lambda_list in - Lifthenelse - ( Lprim - { - primitive = lt_tst; - args = [arg; Lconst (const_of_typed (fst (List.hd list2)))]; - loc; - }, - make_test_sequence list1, - make_test_sequence list2 ) + if_ + (prim ~primitive:lt_tst + ~args:[arg; const (const_of_typed (fst (List.hd list2)))] + loc) + (make_test_sequence list1) (make_test_sequence list2) in hs (make_test_sequence const_lambda_list) @@ -1852,8 +1822,7 @@ let mk_failaction_neg partial ctx def = match partial with | Partial -> ( match def with - | (_, idef) :: _ -> - (Some (Lstaticraise (idef, [])), jumps_singleton idef ctx) + | (_, idef) :: _ -> (Some (staticraise idef []), jumps_singleton idef ctx) | [] -> (* Act as Total, this means If no appropriate default matrix exists, @@ -1872,7 +1841,7 @@ let mk_failaction_pos partial seen ctx defs = | [], _ | _, [] -> List.fold_left (fun (klist, jumps) (pats, i) -> - let action = Lstaticraise (i, []) in + let action = staticraise i [] in let klist = List.fold_right (fun pat r -> (get_key_constr pat, action) :: r) @@ -1947,7 +1916,7 @@ let combine_constant loc arg cst partial ctx def const_lambda_list in let hs, sw, fail = share_actions_tree sw fail in - hs (Lstringswitch (arg, sw, fail)) + hs (stringswitch arg sw fail) | Const_float _ -> make_test_sequence loc fail (Pfloatcomp Cneq) (Pfloatcomp Clt) arg const_lambda_list @@ -2031,18 +2000,16 @@ let lower_constructor_matching_plan ~loc ~arg = function | Test_payload_presence {test; absent; present} -> let condition = match test with - | Is_present_option -> Lprim {primitive = Pis_not_none; args = [arg]; loc} + | Is_present_option -> prim ~primitive:Pis_not_none ~args:[arg] loc | Is_nonempty_list -> - Lprim - {primitive = Pjscomp Cneq; args = [arg; Lconst (const_int 0)]; loc} + prim ~primitive:(Pjscomp Cneq) ~args:[arg; const (const_int 0)] loc in - Lifthenelse (condition, present, absent) - | Test_boolean_value {if_false; if_true} -> - Lifthenelse (arg, if_true, if_false) + if_ condition present absent + | Test_boolean_value {if_false; if_true} -> if_ arg if_true if_false | Switch_on_constructors sw -> let hs, sw = share_actions_sw sw in let sw = reintroduce_fail sw in - hs (Lswitch (arg, sw)) + hs (switch arg sw) let make_constructor_matching_plan ~cstr ~(layout : Variant_runtime.layout) ~fail_opt ~num_consts ~num_nonconsts ~tag_lambda_list ~consts ~nonconsts = @@ -2117,29 +2084,22 @@ let combine_constructor loc arg ex_pat cstr partial ctx def List.fold_right (fun (path, act) rem -> let ext = transl_extension_path ex_pat.pat_env path in - Lifthenelse - ( Lprim - { - primitive = Pstringcomp Ceq; - args = - [ - Lprim - { - primitive = - Pfield - (0, Fld_record {name = Literals.exception_id}); - args = [Lvar tag]; - loc; - }; - ext; - ]; - loc; - }, - act, - rem )) + if_ + (prim ~primitive:(Pstringcomp Ceq) + ~args: + [ + prim + ~primitive: + (Pfield (0, Fld_record {name = Literals.exception_id})) + ~args:[var tag] + loc; + ext; + ] + loc) + act rem) extension_cases default in - Llet (Alias, tag, arg, tests) + let_ Alias tag arg tests in (lambda1, jumps_union local_jumps total1) else @@ -2178,12 +2138,10 @@ let call_switcher_variant_constant fail arg int_lambda_list = let call_switcher_variant_constr loc fail arg int_lambda_list = let v = Ident.create "variant" in - Llet - ( Alias, - v, - Lprim {primitive = Pfield (0, Fld_poly_var_tag); args = [arg]; loc}, - call_switcher fail (Lvar v) min_int max_int - (List.map (fun (a, (_, c)) -> (a, c)) int_lambda_list) ) + let_ Alias v + (prim ~primitive:(Pfield (0, Fld_poly_var_tag)) ~args:[arg] loc) + (call_switcher fail (var v) min_int max_int + (List.map (fun (a, (_, c)) -> (a, c)) int_lambda_list)) let call_switcher_variant_constant : (Lambda.lambda option -> @@ -2223,10 +2181,7 @@ let combine_variant loc row arg partial ctx def (tag_lambda_list, total1, _pats) row.row_fields else num_constr := max_int; let test_int_or_block arg if_int if_block = - Lifthenelse - ( Lprim {primitive = Pis_poly_var_block; args = [arg]; loc}, - if_block, - if_int ) + if_ (prim ~primitive:Pis_poly_var_block ~args:[arg] loc) if_block if_int in let sig_complete = List.length tag_lambda_list = !num_constr and one_action = same_actions tag_lambda_list in @@ -2271,10 +2226,8 @@ let combine_array loc arg partial ctx def (len_lambda_list, total1, _pats) = let fail, local_jumps = mk_failaction_neg partial ctx def in let lambda1 = let newvar = Ident.create "len" in - let switch = call_switcher fail (Lvar newvar) 0 max_int len_lambda_list in - bind Alias newvar - (Lprim {primitive = Parraylength; args = [arg]; loc}) - switch + let switch = call_switcher fail (var newvar) 0 max_int len_lambda_list in + bind Alias newvar (prim ~primitive:Parraylength ~args:[arg] loc) switch in (lambda1, jumps_union local_jumps total1) @@ -2330,12 +2283,11 @@ let compile_orhandlers compile_fun lambda1 total1 ctx to_catch = else do_rec r total_r rem | _ -> do_rec - (Lstaticcatch (r, (i, vars), handler_i)) + (staticcatch r (i, vars) handler_i) (jumps_union (jumps_remove i total_r) (jumps_map (ctx_rshift_num (ncols mat)) total_i)) rem - with Unused -> - do_rec (Lstaticcatch (r, (i, vars), lambda_unit)) total_r rem) + with Unused -> do_rec (staticcatch r (i, vars) lambda_unit) total_r rem) in do_rec lambda1 total1 to_catch @@ -2369,18 +2321,18 @@ let rec lower_bind v arg lam = and pnot = approx_present v ifnot in match (pcond, pso, pnot) with | false, false, false -> lam - | false, true, false -> Lifthenelse (cond, lower_bind v arg ifso, ifnot) - | false, false, true -> Lifthenelse (cond, ifso, lower_bind v arg ifnot) + | false, true, false -> if_ cond (lower_bind v arg ifso) ifnot + | false, false, true -> if_ cond ifso (lower_bind v arg ifnot) | _, _, _ -> bind Alias v arg lam) | Lswitch (ls, ({sw_consts = [(i, act)]; sw_blocks = []} as sw)) when not (approx_present v ls) -> - Lswitch (ls, {sw with sw_consts = [(i, lower_bind v arg act)]}) + switch ls {sw with sw_consts = [(i, lower_bind v arg act)]} | Lswitch (ls, ({sw_consts = []; sw_blocks = [(i, act)]} as sw)) when not (approx_present v ls) -> - Lswitch (ls, {sw with sw_blocks = [(i, lower_bind v arg act)]}) + switch ls {sw with sw_blocks = [(i, lower_bind v arg act)]} | Llet (Alias, vv, lv, l) -> if approx_present v lv then bind Alias v arg lam - else Llet (Alias, vv, lv, lower_bind v arg l) + else let_ Alias vv lv (lower_bind v arg l) | Lvar u when Ident.same u v -> (* eliminate [let v = arg in v]; [lower_bind] is only used for alias bindings, so [arg] is pure *) @@ -2395,7 +2347,7 @@ let bind_check str v arg lam = let comp_exit ctx m = match m.default with - | (_, i) :: _ -> (Lstaticraise (i, []), jumps_singleton i ctx) + | (_, i) :: _ -> (staticraise i [], jumps_singleton i ctx) | _ -> fatal_error "Matching.comp_exit" let rec comp_match_handlers comp_fun partial ctx arg first_match next_matchs = @@ -2420,11 +2372,11 @@ let rec comp_match_handlers comp_fun partial ctx arg first_match next_matchs = ctx_i arg pm in c_rec - (Lstaticcatch (body, (i, []), li)) + (staticcatch body (i, []) li) (jumps_union total_i total_rem) rem with Unused -> - c_rec (Lstaticcatch (body, (i, []), lambda_unit)) total_rem rem)) + c_rec (staticcatch body (i, []) lambda_unit) total_rem rem)) in try let first_lam, total = comp_fun Partial ctx arg first_match in @@ -2448,7 +2400,7 @@ let arg_to_var arg cls = | Lvar v -> (v, arg) | _ -> let v = name_pattern "match" cls in - (v, Lvar v) + (v, var v) (* The main compilation function. @@ -2629,7 +2581,7 @@ let start_ctx n = [{left = []; right = omegas n}] let check_total total lambda i handler_fun = if jumps_is_empty total then lambda - else Lstaticcatch (lambda, (i, []), handler_fun ()) + else staticcatch lambda (i, []) (handler_fun ()) let compile_matching repr handler_fun arg pat_act_list partial = let partial = check_partial pat_act_list partial in @@ -2663,31 +2615,22 @@ let partial_function loc () = (* [Location.get_pos_info] is too expensive *) let fname, line, char = Location.get_pos_info loc.Location.loc_start in let fname = Filename.basename fname in - Lprim - { - primitive = Praise; - args = - [ - Lprim - { - primitive = Pmakeblock Blk_extension; - args = - [ - transl_normal_path Predef.path_match_failure; - Lconst - (Const_block - ( Blk_tuple, - [ - const_string fname None; - const_int line; - const_int char; - ] )); - ]; - loc; - }; - ]; - loc; - } + prim ~primitive:Praise + ~args: + [ + prim ~primitive:(Pmakeblock Blk_extension) + ~args: + [ + transl_normal_path Predef.path_match_failure; + const + (Const_block + ( Blk_tuple, + [const_string fname None; const_int line; const_int char] + )); + ] + loc; + ] + loc let for_function loc repr param pat_act_list partial = compile_matching repr (partial_function loc) param pat_act_list partial @@ -2695,7 +2638,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 {primitive = Praise; args = [param]; loc = Location.none}) + (fun () -> prim ~primitive:Praise ~args:[param] Location.none) param pat_act_list Partial let simple_for_let loc param pat body = @@ -2754,10 +2697,10 @@ let for_let loc param pat body = | Tpat_any -> (* This eliminates a useless variable (and stack slot in bytecode) for "let _ = ...". See #6865. *) - Lsequence (param, body) + seq param body | Tpat_var (id, _) -> (* fast path, and keep track of simple bindings to unboxable numbers *) - Llet (Strict, id, param, body) + let_ Strict id param body | _ -> simple_for_let loc param pat body (* Handling of tupled functions and matchings *) @@ -2845,10 +2788,7 @@ let do_for_multiple_match loc paraml pat_act_list partial = { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; args = - [ - ( Lprim {primitive = Pmakeblock Blk_tuple; args = paraml; loc}, - Strict ); - ]; + [(prim ~primitive:(Pmakeblock Blk_tuple) ~args:paraml loc, Strict)]; default = [([[omega]], raise_num)]; } ) | _ -> @@ -2856,10 +2796,7 @@ let do_for_multiple_match loc paraml pat_act_list partial = { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; args = - [ - ( Lprim {primitive = Pmakeblock Blk_tuple; args = paraml; loc}, - Strict ); - ]; + [(prim ~primitive:(Pmakeblock Blk_tuple) ~args:paraml loc, Strict)]; default = []; } ) in @@ -2871,7 +2808,7 @@ let do_for_multiple_match loc paraml pat_act_list partial = let size = List.length paraml and idl = List.map (fun _ -> Ident.create "match") paraml in - let args = List.map (fun id -> (Lvar id, Alias)) idl in + let args = List.map (fun id -> (var id, Alias)) idl in let flat_next = flatten_precompiled size args next and flat_nexts = @@ -2912,6 +2849,6 @@ let bind_opt (v, eo) k = let for_multiple_match loc paraml pat_act_list partial = let v_paraml = List.map param_to_var paraml in - let paraml = List.map (fun (v, _) -> Lvar v) v_paraml in + let paraml = List.map (fun (v, _) -> var v) v_paraml in List.fold_right bind_opt v_paraml (do_for_multiple_match loc paraml pat_act_list partial) diff --git a/compiler/ml/switch.ml b/compiler/ml/switch.ml index eb890e11d9b..839a061c361 100644 --- a/compiler/ml/switch.ml +++ b/compiler/ml/switch.ml @@ -99,7 +99,7 @@ let ltint = Pintcomp Clt let geint = Pintcomp Cge let gtint = Pintcomp Cgt -let prim p args : lambda = Lprim {primitive = p; args; loc = Location.none} +let prim p args : lambda = prim ~primitive:p ~args Location.none (* [covers_range cases ~start ~finish] holds when [cases] is exactly the contiguous integer keys [start .. finish], in order. *) @@ -113,7 +113,7 @@ let rec covers_range (cases : (switch_key * lambda) list) ~start ~finish = (* [arg] is outside [lo .. hi]. A two-value range reads better as a pair of equality tests than as a pair of comparisons. *) let out_of_range arg ~lo ~hi = - let test cmp k = prim (Pintcomp cmp) [arg; Lconst (const_int k)] in + let test cmp k = prim (Pintcomp cmp) [arg; const (const_int k)] in if hi = lo + 1 then prim Pnot [prim Psequor [test Ceq lo; test Ceq hi]] else prim Psequor [test Cgt hi; test Clt lo] @@ -134,28 +134,27 @@ let emit_if_out ~offset ~range arg ifso ifno = sw_failaction = None; } as sw) ) ) when Ident.same x y && covers_range sw_consts ~start:lo ~finish:hi -> - Lswitch (sarg, {sw with sw_failaction = Some ifso; sw_consts_full = false}) - | _ -> Lifthenelse (out_of_range arg ~lo ~hi, ifso, ifno) + switch sarg {sw with sw_failaction = Some ifso; sw_consts_full = false} + | _ -> if_ (out_of_range arg ~lo ~hi) ifso ifno let emit_if_in ~offset ~range arg ifso ifno = let lo = -offset and hi = range - offset in - Lifthenelse (prim Pnot [out_of_range arg ~lo ~hi], ifso, ifno) + if_ (prim Pnot [out_of_range arg ~lo ~hi]) ifso ifno let emit_switch arg cases acts ~offset : lambda = let l = ref [] in for i = Array.length cases - 1 downto 0 do l := (Switch_int (offset + i), acts.(cases.(i))) :: !l done; - Lswitch - ( arg, - { - sw_consts_full = true; - sw_consts = !l; - sw_blocks_full = true; - sw_blocks = []; - sw_failaction = None; - sw_dispatch = Switch_direct; - } ) + switch arg + { + sw_consts_full = true; + sw_consts = !l; + sw_blocks_full = true; + sw_blocks = []; + sw_failaction = None; + sw_dispatch = Switch_direct; + } (* The module will ``produce good code for the case statement'' *) (* @@ -514,7 +513,7 @@ and enum top cases = (!r, !rc) let make_if_test test arg i ifso ifnot = - Lifthenelse (prim test [arg; Lconst (const_int i)], ifso, ifnot) + if_ (prim test [arg; const (const_int i)]) ifso ifnot let make_if_lt arg i ifso ifnot = match i with diff --git a/compiler/ml/transl_recmodule.ml b/compiler/ml/transl_recmodule.ml index d89857b73d6..f75b7a925d8 100644 --- a/compiler/ml/transl_recmodule.ml +++ b/compiler/ml/transl_recmodule.ml @@ -12,7 +12,7 @@ exception Error of Location.t * error let undefined_location loc = let fname, line, char = Location.get_pos_info loc.Location.loc_start in let fname = Filename.basename fname in - Lconst + const (Const_block ( Lambda.Blk_tuple, [const_string fname None; const_int line; const_int char] )) @@ -78,7 +78,7 @@ let init_shape modl = try Some ( undefined_location modl.mod_loc, - Lconst (init_shape_mod modl.mod_env modl.mod_type) ) + const (init_shape_mod modl.mod_env modl.mod_type) ) with Not_found -> None type binding_status = Undefined | Inprogress | Defined @@ -139,17 +139,14 @@ let eval_rec_bindings_aux (bindings : binding list) (cont : t) : t = | (id, Some (loc, shape), _rhs) :: rem -> let init = if shape_is_empty shape then Lambda.lambda_unit - else - Lambda.Lprim - {primitive = Pinit_mod; args = [loc; shape]; loc = Location.none} + else Lambda.prim ~primitive:Pinit_mod ~args:[loc; shape] Location.none in - Lambda.Llet (Strict, id, init, bind_inits rem acc) + Lambda.let_ Strict id init (bind_inits rem acc) in let rec bind_strict args acc = match args with | [] -> acc - | (id, None, rhs) :: rem -> - Lambda.Llet (Strict, id, rhs, bind_strict rem acc) + | (id, None, rhs) :: rem -> Lambda.let_ Strict id rhs (bind_strict rem acc) | (_id, Some _, _rhs) :: rem -> bind_strict rem acc in let rec patch_forwards args = @@ -160,14 +157,11 @@ let eval_rec_bindings_aux (bindings : binding list) (cont : t) : t = let patch = if shape_is_empty shape then rhs else - Lambda.Lprim - { - primitive = Pupdate_mod; - args = [shape; Lvar id; rhs]; - loc = Location.none; - } + Lambda.prim ~primitive:Pupdate_mod + ~args:[shape; var id; rhs] + Location.none in - Lsequence (patch, patch_forwards rem) + seq patch (patch_forwards rem) in bind_inits bindings (bind_strict bindings (patch_forwards bindings)) diff --git a/compiler/ml/translattribute.ml b/compiler/ml/translattribute.ml index 91314cfdcf3..b750b7f2767 100644 --- a/compiler/ml/translattribute.ml +++ b/compiler/ml/translattribute.ml @@ -90,7 +90,7 @@ let add_inline_attribute (expr : Lambda.lambda) loc attributes = | Always_inline | Never_inline -> Location.prerr_warning loc (Warnings.Duplicated_attribute "inline")); let attr = {attr with inline} in - Lfunction {funct with attr} + Lambda.function_ ~loc:funct.loc ~attr ~params:funct.params ~body:funct.body | expr, Always_inline -> Location.prerr_warning loc (Warnings.Misplaced_attribute "inline"); expr diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index affd7c048c4..9029131edae 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -49,7 +49,7 @@ let transl_extension_constructor env path ext = in let loc = ext.ext_loc in match ext.ext_kind with - | Text_decl _ -> Lprim {primitive = Pcreate_extension name; args = []; loc} + | Text_decl _ -> prim ~primitive:(Pcreate_extension name) ~args:[] loc | Text_rebind (path, _lid) -> transl_extension_path ~loc env path (* Translation of primitives *) @@ -556,10 +556,10 @@ let external_returns_unit env (p : Primitive.description) (val_type : type_expr) let external_result_wrap loc (result_type : External_ffi_types.return_wrapper) ~returns_unit result = match result_type with - | Return_unset when returns_unit -> Lsequence (result, Lconst const_unit) - | Return_null_to_opt -> Lprim {primitive = Pnull_to_opt; args = [result]; loc} + | Return_unset when returns_unit -> seq result (const const_unit) + | Return_null_to_opt -> prim ~primitive:Pnull_to_opt ~args:[result] loc | Return_null_undefined_to_opt -> - Lprim {primitive = Pnull_undefined_to_opt; args = [result]; loc} + prim ~primitive:Pnull_undefined_to_opt ~args:[result] loc | Return_unset | Return_identity -> result (* Does importing this external as a value require the FFI adaptation a @@ -598,87 +598,69 @@ let transl_adapted_external_import loc env (p : Primitive.description) (val_type : type_expr) : Lambda.lambda = let returns_unit = external_returns_unit env p val_type in let send_call receiver args (kind : External_ffi_types.decl_kind) = - Lprim - { - primitive = - Pjs_call - { - prim_name = name; - arg_types = External_arg_spec.dummy :: arg_types; - ffi = - { - kind; - module_ = None; - scopes; - variadic; - effective_arity = List.length arg_types + 1; - }; - transformed_jsx = false; - }; - args = receiver :: args; - loc; - } + prim + ~primitive: + (Pjs_call + { + prim_name = name; + arg_types = External_arg_spec.dummy :: arg_types; + ffi = + { + kind; + module_ = None; + scopes; + variadic; + effective_arity = List.length arg_types + 1; + }; + transformed_jsx = false; + }) + ~args:(receiver :: args) loc in let m = Ident.create "m" in let adapted_value = if p.prim_arity = 0 then external_result_wrap loc return_wrapper ~returns_unit - (send_call (Lvar m) [] (Decl_get {name})) + (send_call (var m) [] (Decl_get {name})) else let params = List.init p.prim_arity (fun i -> Ident.create ("prim" ^ string_of_int i)) in - Lfunction - { - params; - attr = default_function_attribute; - loc; - body = - external_result_wrap loc return_wrapper ~returns_unit - (send_call (Lvar m) - (List.map (fun i -> Lvar i) params) - (Decl_send {name})); - } + function_ ~loc ~attr:default_function_attribute ~params + ~body: + (external_result_wrap loc return_wrapper ~returns_unit + (send_call (var m) + (List.map (fun i -> var i) params) + (Decl_send {name}))) in let callback = - Lfunction - { - params = [m]; - attr = default_function_attribute; - loc; - body = adapted_value; - } + function_ ~loc ~attr:default_function_attribute ~params:[m] + ~body:adapted_value in - Lprim - { - primitive = - Pjs_call - { - prim_name = "then"; - arg_types = [External_arg_spec.dummy; External_arg_spec.dummy]; - ffi = - { - kind = Decl_send {name = "then"}; - module_ = None; - scopes = []; - variadic = false; - effective_arity = 2; - }; - transformed_jsx = false; - }; - args = - [ - Lprim - { - primitive = Pimport (Import_external {module_ = emn; path = []}); - args = []; - loc; - }; - callback; - ]; - loc; - } + prim + ~primitive: + (Pjs_call + { + prim_name = "then"; + arg_types = [External_arg_spec.dummy; External_arg_spec.dummy]; + ffi = + { + kind = Decl_send {name = "then"}; + module_ = None; + scopes = []; + variadic = false; + effective_arity = 2; + }; + transformed_jsx = false; + }) + ~args: + [ + prim + ~primitive:(Pimport (Import_external {module_ = emn; path = []})) + ~args:[] loc; + callback; + ] + loc let transl_dynamic_import loc (arg : Typedtree.expression) : Lambda.lambda = match arg.exp_desc with @@ -707,25 +689,22 @@ let transl_dynamic_import loc (arg : Typedtree.expression) : Lambda.lambda = when external_import_needs_adaptation arg_types decl return_wrapper -> transl_adapted_external_import loc arg.exp_env ~emn ~name ~scopes ~variadic ~arg_types ~return_wrapper p val_type - | _ -> Lprim {primitive = Pimport (import_source_of_arg arg); args = []; loc} + | _ -> prim ~primitive:(Pimport (import_source_of_arg arg)) ~args:[] loc let transl_external_application loc env (p : Primitive.description) ~(val_type : type_expr) argl ~transformed_jsx : Lambda.lambda = match p.prim_kind with - | Kind_inline_const c -> Lconst (lambda_of_inline_const c) + | Kind_inline_const c -> const (lambda_of_inline_const c) | Kind_external (Ffi_obj_create labels) -> - Lprim {primitive = Pjs_object_create labels; args = argl; loc} + prim ~primitive:(Pjs_object_create labels) ~args:argl loc | Kind_external (Ffi_bs (arg_types, result_type, decl)) -> external_result_wrap loc result_type ~returns_unit:(external_returns_unit env p val_type) - (Lprim - { - primitive = - Pjs_call - {prim_name = p.prim_name; arg_types; ffi = decl; transformed_jsx}; - args = argl; - loc; - }) + (prim + ~primitive: + (Pjs_call + {prim_name = p.prim_name; arg_types; ffi = decl; transformed_jsx}) + ~args:argl loc) | Kind_intrinsic -> Location.raise_errorf ~loc "@{Error:@} internal error, using unrecognized primitive %s" @@ -752,7 +731,7 @@ let lam_of_loc kind loc = in match kind with | Loc_POS -> - Lconst + const (Const_block ( Blk_tuple, [ @@ -761,18 +740,18 @@ let lam_of_loc kind loc = const_int cnum; const_int enum; ] )) - | Loc_FILE -> Lconst (const_string file None) + | Loc_FILE -> const (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) + const (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) - | Loc_LINE -> Lconst (const_int lnum) + const (const_string loc None) + | Loc_LINE -> const (const_int lnum) (* Eta-expand a primitive *) @@ -785,15 +764,9 @@ let transl_primitive loc p env ty ~val_type = | 0 -> lam | 1 -> let param = Ident.create "prim" in - Lfunction - { - params = [param]; - attr = default_function_attribute; - loc; - body = - Lprim - {primitive = Pmakeblock Blk_tuple; args = [lam; Lvar param]; loc}; - } + function_ ~loc ~attr:default_function_attribute ~params:[param] + ~body: + (prim ~primitive:(Pmakeblock Blk_tuple) ~args:[lam; var param] loc) | _ -> assert false) | None -> ( let prim = @@ -816,16 +789,11 @@ let transl_primitive loc p env ty ~val_type = List.init p.prim_arity (fun i -> Ident.create ("prim" ^ string_of_int i)) in - Lfunction - { - params; - attr = default_function_attribute; - loc; - body = - transl_external_application loc env p ~val_type - (List.map (fun id -> Lvar id) params) - ~transformed_jsx:false; - } + function_ ~loc ~attr:default_function_attribute ~params + ~body: + (transl_external_application loc env p ~val_type + (List.map (fun id -> var id) params) + ~transformed_jsx:false) | Some builtin -> warn_polymorphic_comparison loc builtin []; let rec make_params n total = @@ -842,13 +810,8 @@ let transl_primitive loc p env ty ~val_type = if prim_arity = 1 then [Ident.create "prim"] else make_params prim_arity prim_arity in - Lfunction - { - params; - attr = default_function_attribute; - loc; - body = mk_builtin builtin (List.map (fun id -> Lvar id) params) loc; - }) + function_ ~loc ~attr:default_function_attribute ~params + ~body:(mk_builtin builtin (List.map (fun id -> var id) params) loc)) (* [None] means the primitive is an external whose application must be expanded from its FFI spec *) @@ -922,31 +885,22 @@ let assert_failed exp = Location.get_pos_info exp.exp_loc.Location.loc_start in let fname = Filename.basename fname in - Lprim - { - primitive = Praise; - args = - [ - Lprim - { - primitive = Pmakeblock Blk_extension; - args = - [ - transl_normal_path Predef.path_assert_failure; - Lconst - (Const_block - ( Blk_tuple, - [ - const_string fname None; - const_int line; - const_int char; - ] )); - ]; - loc = exp.exp_loc; - }; - ]; - loc = exp.exp_loc; - } + prim ~primitive:Praise + ~args: + [ + prim ~primitive:(Pmakeblock Blk_extension) + ~args: + [ + transl_normal_path Predef.path_assert_failure; + const + (Const_block + ( Blk_tuple, + [const_string fname None; const_int line; const_int char] + )); + ] + exp.exp_loc; + ] + exp.exp_loc let rec cut n l = if n = 0 then ([], l) @@ -964,23 +918,14 @@ let rec cut n l = 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 - { - primitive = Pfield (0, Fld_module {name = "internalToException"}); - args = - [ - Lglobal_module - (Ident.create_persistent Primitive_modules.exceptions); - ]; - loc; - }; - ap_args = [arg]; - ap_info = {ap_loc = loc; ap_inlined = Default_inline}; - ap_transformed_jsx = false; - } + apply ~ap_transformed_jsx:false + (prim + ~primitive:(Pfield (0, Fld_module {name = "internalToException"})) + ~args: + [global_module (Ident.create_persistent Primitive_modules.exceptions)] + loc) + [arg] + {ap_loc = loc; ap_inlined = Default_inline} let exception_id_destructed (l : lambda) (fv : Ident.t) : bool = let rec hit_opt = function | None -> false @@ -1019,7 +964,7 @@ let exception_id_destructed (l : lambda) (fv : Ident.t) : bool = 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, id, wrap_exn Location.none (Lvar raw_id), handler)) + (raw_id, let_ StrictOpt id (wrap_exn Location.none (var raw_id)) handler) else (id, handler) let extract_directive_for_fn exp = @@ -1066,7 +1011,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_of_typed cst) + | Texp_constant cst -> const (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} -> @@ -1096,7 +1041,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = } in let loc = e.exp_loc in - Lfunction {params; body = lbody; attr; loc} + function_ ~loc ~attr ~params ~body:lbody | Texp_apply {funct; args = oargs} when List.exists (fun (attr, _) -> attr.txt = "res.taggedTemplate") @@ -1111,12 +1056,9 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = | [(_, Some strings); (_, Some values)] -> (strings, values) | _ -> assert false in - Lprim - { - primitive = Ptagged_template; - args = [transl_exp funct; transl_exp strings; transl_exp values]; - loc = e.exp_loc; - } + prim ~primitive:Ptagged_template + ~args:[transl_exp funct; transl_exp strings; transl_exp values] + e.exp_loc | Texp_apply { funct = @@ -1157,12 +1099,8 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = | [arg1] -> let lam = lam_of_loc kind arg1.exp_loc in wrap - (Lprim - { - primitive = Pmakeblock Blk_tuple; - args = lam :: argl; - loc = e.exp_loc; - }) + (prim ~primitive:(Pmakeblock Blk_tuple) ~args:(lam :: argl) + e.exp_loc) | _ -> assert false) | None -> ( match @@ -1175,21 +1113,15 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = | "#raw_expr", [Lconst (Const_string {s = code})] -> let kind = Classify_function.classify code in wrap - (Lprim - { - primitive = Praw_js_code {code; code_info = Exp kind}; - args = []; - loc = e.exp_loc; - }) + (prim + ~primitive:(Praw_js_code {code; code_info = Exp kind}) + ~args:[] e.exp_loc) | "#raw_stmt", [Lconst (Const_string {s = code})] -> let kind = Classify_function.classify_stmt code in wrap - (Lprim - { - primitive = Praw_js_code {code; code_info = Stmt kind}; - args = []; - loc = e.exp_loc; - }) + (prim + ~primitive:(Praw_js_code {code; code_info = Stmt kind}) + ~args:[] e.exp_loc) | ("#raw_expr" | "#raw_stmt"), _ -> assert false | _ -> wrap @@ -1220,16 +1152,16 @@ 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 - let handler = Matching.for_trywith (Lvar id) (transl_cases pat_expr_list) in + let handler = Matching.for_trywith (var id) (transl_cases pat_expr_list) in let id, handler = pack_trywith_exn id handler in - Ltrywith (transl_exp body, id, handler) + try_ (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)) + try const (Const_block (Blk_tuple, List.map extract_constant ll)) with Not_constant -> - Lprim {primitive = Pmakeblock Blk_tuple; args = ll; loc = e.exp_loc}) - | Texp_construct ({txt = Lident "false"}, _, []) -> Lconst Const_js_false - | Texp_construct ({txt = Lident "true"}, _, []) -> Lconst Const_js_true + prim ~primitive:(Pmakeblock Blk_tuple) ~args:ll e.exp_loc) + | Texp_construct ({txt = Lident "false"}, _, []) -> const Const_js_false + | Texp_construct ({txt = Lident "true"}, _, []) -> const Const_js_true | Texp_construct (_, cstr, args) -> ( let ll = transl_list args in if cstr.cstr_inlined <> None then @@ -1239,7 +1171,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = else match cstr.cstr_kind with | Ordinary_constructor _ when cstr.cstr_args = [] -> - Lconst + const (if Datarepr.constructor_has_optional_shape cstr then const_shape_none else const_constructor @@ -1270,8 +1202,8 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = Psome_not_nest | _ -> Psome in - try Lconst (Const_some (extract_constant value)) - with Not_constant -> Lprim {primitive; args = ll; loc = e.exp_loc} + try const (Const_some (extract_constant value)) + with Not_constant -> prim ~primitive ~args:ll e.exp_loc else let tag_info : Lambda.tag_info = Blk_constructor @@ -1281,31 +1213,25 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = runtime; } in - try Lconst (Const_block (tag_info, List.map extract_constant ll)) + try const (Const_block (tag_info, List.map extract_constant ll)) with Not_constant -> - Lprim {primitive = Pmakeblock tag_info; args = ll; loc = e.exp_loc}) + prim ~primitive:(Pmakeblock tag_info) ~args:ll e.exp_loc) | Extension_constructor path -> - Lprim - { - primitive = Pmakeblock Blk_extension; - args = transl_extension_path e.exp_env path :: ll; - loc = e.exp_loc; - }) + prim ~primitive:(Pmakeblock Blk_extension) + ~args:(transl_extension_path e.exp_env path :: ll) + e.exp_loc) | Texp_extension_constructor (_, path) -> transl_extension_path e.exp_env path | Texp_variant (l, arg) -> ( match arg with - | None -> Lconst (const_polyvar l) + | None -> const (const_polyvar l) | Some arg -> ( let lam = transl_exp arg in let name = const_polyvar_name l in - try Lconst (Const_block (Blk_poly_var, [name; extract_constant lam])) + try const (Const_block (Blk_poly_var, [name; extract_constant lam])) with Not_constant -> - Lprim - { - primitive = Pmakeblock Blk_poly_var; - args = [Lconst name; lam]; - loc = e.exp_loc; - })) + prim ~primitive:(Pmakeblock Blk_poly_var) + ~args:[const name; 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) -> ( @@ -1313,27 +1239,18 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = match lbl.lbl_repres with | Record_float_unused -> assert false | Record_regular -> - Lprim - { - primitive = Pfield (lbl.lbl_pos, Lambda.fld_record lbl); - args = [targ]; - loc = e.exp_loc; - } + prim + ~primitive:(Pfield (lbl.lbl_pos, Lambda.fld_record lbl)) + ~args:[targ] e.exp_loc | Record_inlined _ -> - Lprim - { - primitive = Pfield (lbl.lbl_pos, Lambda.fld_record_inline lbl); - args = [targ]; - loc = e.exp_loc; - } + prim + ~primitive:(Pfield (lbl.lbl_pos, Lambda.fld_record_inline lbl)) + ~args:[targ] e.exp_loc | Record_unboxed _ -> targ | Record_extension -> - Lprim - { - primitive = Pfield (lbl.lbl_pos + 1, Lambda.fld_record_extension lbl); - args = [targ]; - loc = e.exp_loc; - }) + prim + ~primitive:(Pfield (lbl.lbl_pos + 1, Lambda.fld_record_extension lbl)) + ~args:[targ] e.exp_loc) | Texp_setfield (arg, _, lbl, newval) -> let access = match lbl.lbl_repres with @@ -1345,30 +1262,24 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = | Record_extension -> Psetfield (lbl.lbl_pos + 1, Lambda.fld_record_extension_set lbl) in - Lprim - { - primitive = access; - args = [transl_exp arg; transl_exp newval]; - loc = e.exp_loc; - } + prim ~primitive:access ~args:[transl_exp arg; transl_exp newval] e.exp_loc | Texp_array expr_list -> let ll = transl_list expr_list in - Lprim {primitive = Pmakearray; args = ll; loc = e.exp_loc} + prim ~primitive:Pmakearray ~args:ll e.exp_loc | Texp_ifthenelse (cond, ifso, Some ifnot) -> - Lifthenelse (transl_exp cond, transl_exp ifso, transl_exp ifnot) + if_ (transl_exp cond) (transl_exp ifso) (transl_exp ifnot) | Texp_ifthenelse (cond, ifso, None) -> - Lifthenelse (transl_exp cond, transl_exp ifso, lambda_unit) - | Texp_sequence (expr1, expr2) -> - Lsequence (transl_exp expr1, transl_exp expr2) - | Texp_break -> Lbreak - | Texp_continue -> Lcontinue - | Texp_while (cond, body) -> Lwhile (transl_exp cond, transl_exp body) + if_ (transl_exp cond) (transl_exp ifso) lambda_unit + | Texp_sequence (expr1, expr2) -> seq (transl_exp expr1) (transl_exp expr2) + | Texp_break -> break + | Texp_continue -> continue + | Texp_while (cond, body) -> while_ (transl_exp cond) (transl_exp body) | Texp_for (param, _, low, high, dir, body) -> - Lfor (param, transl_exp low, transl_exp high, dir, transl_exp body) + for_ param (transl_exp low) (transl_exp high) dir (transl_exp body) | Texp_for_of (param, _, iterable, body) -> - Lfor_of (param, transl_exp iterable, transl_exp body) + for_of param (transl_exp iterable) (transl_exp body) | Texp_for_await_of (param, _, iterable, body) -> - Lfor_await_of (param, transl_exp iterable, transl_exp body) + for_await_of param (transl_exp iterable) (transl_exp body) | Texp_object_literal fields -> let labels = List.map @@ -1379,42 +1290,29 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = }) fields in - Lprim - { - primitive = Pjs_object_create labels; - args = List.map (fun (_, field) -> transl_exp field) fields; - loc = e.exp_loc; - } + prim ~primitive:(Pjs_object_create labels) + ~args:(List.map (fun (_, field) -> transl_exp field) fields) + e.exp_loc | Texp_object_get (expr, nm) -> - Lprim - { - primitive = Pjs_object_get nm.txt; - args = [transl_exp expr]; - loc = e.exp_loc; - } + prim ~primitive:(Pjs_object_get nm.txt) ~args:[transl_exp expr] e.exp_loc | Texp_object_set (expr, nm, value) -> - Lprim - { - primitive = Pjs_object_set nm.txt; - args = [transl_exp expr; transl_exp value]; - loc = e.exp_loc; - } + prim ~primitive:(Pjs_object_set nm.txt) + ~args:[transl_exp expr; transl_exp value] + e.exp_loc | Texp_letmodule (id, _loc, modl, body) -> let defining_expr = !transl_module Tcoerce_none None modl in - Llet (Strict, id, defining_expr, transl_exp body) + let_ Strict id defining_expr (transl_exp body) | Texp_letexception (cd, body) -> - Llet - ( Strict, - cd.ext_id, - transl_extension_constructor e.exp_env None cd, - transl_exp body ) + let_ Strict cd.ext_id + (transl_extension_constructor e.exp_env None cd) + (transl_exp body) | Texp_pack modl -> !transl_module Tcoerce_none None modl | Texp_assert {exp_desc = Texp_construct (_, {cstr_name = "false"}, _)} -> if !Clflags.no_assert_false then Lambda.lambda_assert_false else assert_failed e | Texp_assert cond -> if !Clflags.noassert then lambda_unit - else Lifthenelse (transl_exp cond, lambda_unit, assert_failed e) + else if_ (transl_exp cond) lambda_unit (assert_failed e) and transl_list expr_list = List.map transl_exp expr_list @@ -1422,7 +1320,7 @@ and transl_guard guard rhs = let expr = transl_exp rhs in match guard with | None -> expr - | Some cond -> Lifthenelse (transl_exp cond, expr, staticfail) + | Some cond -> if_ (transl_exp cond) expr staticfail and transl_case {c_lhs; c_guard; c_rhs} = (c_lhs, transl_guard c_guard c_rhs) @@ -1432,13 +1330,8 @@ and transl_apply ?(inlined = Default_inline) ?(uncurried_partial_application = None) ?(transformed_jsx = false) lam sargs loc = let lapply ap_func ap_args = - Lapply - { - ap_func; - ap_args; - ap_info = {ap_loc = loc; ap_inlined = inlined}; - ap_transformed_jsx = transformed_jsx; - } + apply ~ap_transformed_jsx:transformed_jsx ap_func ap_args + {ap_loc = loc; ap_inlined = inlined} in let rec build_apply lam args = function | (None, optional) :: l -> @@ -1449,7 +1342,7 @@ and transl_apply ?(inlined = Default_inline) | _ -> let id = Ident.create name in defs := (id, lam) :: !defs; - Lvar id + var id in let args, args' = if List.for_all (fun (_, opt) -> opt) args then ([], args) @@ -1460,21 +1353,14 @@ and transl_apply ?(inlined = Default_inline) and l = List.map (fun (arg, opt) -> (may_map (protect "arg") arg, opt)) l and id_arg = Ident.create "param" in let body = - match build_apply handle ((Lvar id_arg, optional) :: args') l with + match build_apply handle ((var id_arg, optional) :: args') l with | Lfunction {params = ids; body = lam; attr; loc} -> - Lfunction {params = id_arg :: ids; body = lam; attr; loc} + function_ ~loc ~attr ~params:(id_arg :: ids) ~body:lam | lam -> - Lfunction - { - params = [id_arg]; - body = lam; - attr = default_function_attribute; - loc; - } + function_ ~loc ~attr:default_function_attribute ~params:[id_arg] + ~body:lam in - List.fold_left - (fun body (id, lam) -> Llet (Strict, id, lam, body)) - body !defs + List.fold_left (fun body (id, lam) -> let_ Strict id lam body) body !defs | (Some arg, optional) :: l -> build_apply lam ((arg, optional) :: args) l | [] -> lapply lam (List.rev_map fst args) in @@ -1488,29 +1374,20 @@ and transl_apply ?(inlined = Default_inline) | _, None -> let id_arg = Ident.create "none" in none_ids := id_arg :: !none_ids; - Some (Lvar id_arg)) + Some (var id_arg)) in let extra_ids = Array.init extra_arity (fun _ -> Ident.create "extra") |> Array.to_list in - let extra_args = Ext_list.map extra_ids (fun id -> Lvar id) in + let extra_args = Ext_list.map extra_ids (fun id -> var id) in let ap_args = args @ extra_args in let l0 = - Lapply - { - ap_func = lam; - ap_args; - ap_info = {ap_loc = loc; ap_inlined = inlined}; - ap_transformed_jsx = transformed_jsx; - } + apply ~ap_transformed_jsx:transformed_jsx lam ap_args + {ap_loc = loc; ap_inlined = inlined} in - Lfunction - { - params = List.rev_append !none_ids extra_ids; - body = l0; - attr = default_function_attribute; - loc; - } + function_ ~loc ~attr:default_function_attribute + ~params:(List.rev_append !none_ids extra_ids) + ~body:l0 | _ -> (build_apply lam [] (List.map @@ -1523,16 +1400,14 @@ and transl_function loc (params : function_param list) body = | [] -> assert false | [{fp_param; fp_pat; fp_partial}] -> ( [fp_param], - Matching.for_function loc None (Lvar fp_param) + Matching.for_function loc None (var fp_param) [(fp_pat, transl_exp body)] fp_partial, is_base_type body.exp_env body.exp_type Predef.path_unit ) | {fp_param; fp_pat; fp_partial} :: rest -> let lparams, lbody, return_unit = transl_function loc rest body in ( fp_param :: lparams, - Matching.for_function loc None (Lvar fp_param) - [(fp_pat, lbody)] - fp_partial, + Matching.for_function loc None (var fp_param) [(fp_pat, lbody)] fp_partial, return_unit ) and transl_let ~js_hoist rec_flag pat_expr_list body = @@ -1608,7 +1483,7 @@ and transl_record loc env fields repres opt_init_expr = | Record_extension -> Pfield (i + 1, Lambda.fld_record_extension lbl) in - Lprim {primitive = access; args = [Lvar init_id]; loc} + prim ~primitive:access ~args:[var init_id] loc | Overridden (_lid, expr) -> transl_exp expr) fields in @@ -1625,7 +1500,7 @@ and transl_record loc env fields repres opt_init_expr = match repres with | Record_float_unused -> assert false | Record_regular -> - Lconst (Const_block (Lambda.blk_record fields mut, cl)) + const (Const_block (Lambda.blk_record fields mut, cl)) | Record_inlined {name; representation} -> let runtime = match Variant_runtime.representation representation with @@ -1636,13 +1511,13 @@ and transl_record loc env fields repres opt_init_expr = Variant_runtime.num_blocks (Variant_runtime.get_layout representation.variant) in - Lconst + const (Const_block ( Lambda.blk_record_inlined fields name num_nonconsts ~runtime mut, cl )) | Record_unboxed _ -> - Lconst + const (match cl with | [v] -> v | _ -> assert false) @@ -1650,12 +1525,9 @@ and transl_record loc env fields repres opt_init_expr = with Not_constant -> ( match repres with | Record_regular -> - Lprim - { - primitive = Pmakeblock (Lambda.blk_record fields mut); - args = ll; - loc; - } + prim + ~primitive:(Pmakeblock (Lambda.blk_record fields mut)) + ~args:ll loc | Record_float_unused -> assert false | Record_inlined {name; representation} -> let runtime = @@ -1667,15 +1539,12 @@ and transl_record loc env fields repres opt_init_expr = Variant_runtime.num_blocks (Variant_runtime.get_layout representation.variant) in - Lprim - { - primitive = - Pmakeblock - (Lambda.blk_record_inlined fields name num_nonconsts - ~runtime mut); - args = ll; - loc; - } + prim + ~primitive: + (Pmakeblock + (Lambda.blk_record_inlined fields name num_nonconsts ~runtime + mut)) + ~args:ll loc | Record_unboxed _ -> ( match ll with | [v] -> v @@ -1688,16 +1557,13 @@ and transl_record loc env fields repres opt_init_expr = | _ -> assert false in let slot = transl_extension_path env path in - Lprim - { - primitive = Pmakeblock (Lambda.blk_record_ext fields mut); - args = slot :: ll; - loc; - }) + prim + ~primitive:(Pmakeblock (Lambda.blk_record_ext fields mut)) + ~args:(slot :: ll) loc) in match opt_init_expr with | None -> lam - | Some init_expr -> Llet (Strict, init_id, transl_exp init_expr, lam) + | Some init_expr -> let_ Strict init_id (transl_exp init_expr) lam else (* Take a shallow copy of the init record, then mutate the fields of the copy *) @@ -1717,19 +1583,16 @@ and transl_record loc env fields repres opt_init_expr = | Record_extension -> Psetfield (lbl.lbl_pos + 1, Lambda.fld_record_extension_set lbl) in - Lsequence - ( Lprim - {primitive = upd; args = [Lvar copy_id; transl_exp expr]; loc}, - cont ) + seq + (prim ~primitive:upd ~args:[var copy_id; transl_exp expr] loc) + cont in match opt_init_expr with | None -> assert false | Some init_expr -> - Llet - ( Strict, - copy_id, - Lprim {primitive = Pduprecord; args = [transl_exp init_expr]; loc}, - Array.fold_left update_field (Lvar copy_id) fields )) + let_ Strict copy_id + (prim ~primitive:Pduprecord ~args:[transl_exp init_expr] loc) + (Array.fold_left update_field (var copy_id) fields)) and transl_match e arg pat_expr_list exn_pat_expr_list partial = let id = Typecore.name_pattern "exn" exn_pat_expr_list @@ -1737,19 +1600,19 @@ and transl_match e arg pat_expr_list exn_pat_expr_list partial = 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 exn_handler = Matching.for_trywith (var id) exn_cases in let id, exn_handler = pack_trywith_exn id exn_handler in - Lstaticcatch - ( Ltrywith (Lstaticraise (static_exception_id, body), id, exn_handler), - (static_exception_id, val_ids), - handler ) + staticcatch + (try_ (staticraise static_exception_id body) id exn_handler) + (static_exception_id, val_ids) + handler in match (arg, exn_cases) with | {exp_desc = Texp_tuple argl}, [] -> Matching.for_multiple_match e.exp_loc (transl_list argl) cases partial | {exp_desc = Texp_tuple argl}, _ :: _ -> let val_ids = List.map (fun _ -> Typecore.name_pattern "val" []) argl in - let lvars = List.map (fun id -> Lvar id) val_ids in + let lvars = List.map (fun id -> var id) val_ids in static_catch (transl_list argl) val_ids (Matching.for_multiple_match e.exp_loc lvars cases partial) | arg, [] -> @@ -1759,7 +1622,7 @@ and transl_match e arg pat_expr_list exn_pat_expr_list partial = static_catch [transl_exp arg] [val_id] - (Matching.for_function e.exp_loc None (Lvar val_id) cases partial) + (Matching.for_function e.exp_loc None (var val_id) cases partial) open Format diff --git a/compiler/ml/translmod.ml b/compiler/ml/translmod.ml index b9d5ed5ee1d..ee70442c48d 100644 --- a/compiler/ml/translmod.ml +++ b/compiler/ml/translmod.ml @@ -65,7 +65,7 @@ let transl_type_extension env rootpath (tyext : Typedtree.type_extension) body : (field_path rootpath ext.ext_id) ext in - Lambda.Llet (Strict, ext.ext_id, lam, body)) + Lambda.let_ Strict ext.ext_id lam body) tyext.tyext_constructors body (* Compile a coercion *) @@ -76,29 +76,26 @@ let rec apply_coercion loc strict (restr : Typedtree.module_coercion) arg = | Tcoerce_structure (pos_cc_list, id_pos_list, runtime_fields) -> Lambda.name_lambda strict arg (fun id -> let get_field_name name pos = - Lambda.Lprim - {primitive = Pfield (pos, Fld_module {name}); args = [Lvar id]; loc} + Lambda.prim + ~primitive:(Pfield (pos, Fld_module {name})) + ~args:[Lambda.var id] + loc in let lam = - Lambda.Lprim - { - primitive = Pmakeblock (Blk_module runtime_fields); - args = - Ext_list.map2 pos_cc_list runtime_fields (fun (pos, cc) name -> - apply_coercion loc Alias cc - (Lprim - { - primitive = Pfield (pos, Fld_module {name}); - args = [Lvar id]; - loc; - })); - loc; - } + Lambda.prim ~primitive:(Pmakeblock (Blk_module runtime_fields)) + ~args: + (Ext_list.map2 pos_cc_list runtime_fields (fun (pos, cc) name -> + apply_coercion loc Alias cc + (Lambda.prim + ~primitive:(Pfield (pos, Fld_module {name})) + ~args:[Lambda.var id] + loc))) + loc in wrap_id_pos_list loc id_pos_list get_field_name lam) | Tcoerce_functor (cc_arg, cc_res) -> let param = Ident.create "funarg" in - let carg = apply_coercion loc Alias cc_arg (Lvar param) in + let carg = apply_coercion loc Alias cc_arg (Lambda.var param) in apply_coercion_result loc strict arg param carg cc_res | Tcoerce_primitive {pc_loc; pc_desc; pc_env; pc_type} -> Translcore.transl_primitive pc_loc pc_desc pc_env pc_type ~val_type:pc_type @@ -108,21 +105,13 @@ let rec apply_coercion loc strict (restr : Typedtree.module_coercion) arg = and apply_coercion_result loc strict funct param arg cc_res = Lambda.name_lambda strict funct (fun id -> - Lfunction - { - params = [param]; - attr = {Lambda.default_function_attribute with is_a_functor = true}; - loc; - body = - apply_coercion loc Strict cc_res - (Lapply - { - ap_func = Lvar id; - ap_args = [arg]; - ap_info = {ap_loc = loc; ap_inlined = Default_inline}; - ap_transformed_jsx = false; - }); - }) + Lambda.function_ ~loc + ~attr:{Lambda.default_function_attribute with is_a_functor = true} + ~params:[param] + ~body: + (apply_coercion loc Strict cc_res + (Lambda.apply ~ap_transformed_jsx:false (Lambda.var id) [arg] + {ap_loc = loc; ap_inlined = Default_inline}))) and wrap_id_pos_list loc id_pos_list get_field lam = let fv = Lambda.free_variables lam in @@ -134,12 +123,10 @@ and wrap_id_pos_list loc id_pos_list get_field lam = (fun (lam, s) (id', pos, c) -> if Lambda.Ident_set.mem id' fv then let id'' = Ident.create (Ident.name id') in - ( Lambda.Llet - ( Alias, - id'', - apply_coercion loc Alias c (get_field (Ident.name id') pos), - lam ), - Ident.add id' (Lambda.Lvar id'') s ) + ( Lambda.let_ Alias id'' + (apply_coercion loc Alias c (get_field (Ident.name id') pos)) + lam, + Ident.add id' (Lambda.var id'') s ) else (lam, s)) (lam, Ident.empty) id_pos_list in @@ -260,25 +247,21 @@ let rec compile_functor mexp coercion root_path loc = (* cf. [transl_module] *) let param, loc_, arg_coercion = functor_param in let param' = Ident.rename param in - let arg = apply_coercion loc_ Alias arg_coercion (Lvar param') in + let arg = apply_coercion loc_ Alias arg_coercion (Lambda.var param') in let body = - Lambda.Llet (Alias, param, arg, transl_module res_coercion body_path body) + Lambda.let_ Alias param arg (transl_module res_coercion body_path body) in - Lambda.Lfunction - { - params = [param']; - attr = - { - inline = inline_attribute; - is_a_functor = true; - return_unit = false; - async = false; - one_unit_arg = false; - directive = None; - }; - loc; - body; - } + Lambda.function_ ~loc + ~attr: + { + inline = inline_attribute; + is_a_functor = true; + return_unit = false; + async = false; + one_unit_arg = false; + directive = None; + } + ~params:[param'] ~body (* Compile a module expression *) and transl_module cc rootpath mexp = @@ -299,13 +282,10 @@ and transl_module cc rootpath mexp = Translattribute.get_and_remove_inlined_attribute_on_module funct in apply_coercion loc Strict cc - (Lapply - { - ap_func = transl_module Tcoerce_none None funct; - ap_args = [transl_module ccarg None arg]; - ap_info = {ap_loc = loc; ap_inlined = inlined_attribute}; - ap_transformed_jsx = false; - }) + (Lambda.apply ~ap_transformed_jsx:false + (transl_module Tcoerce_none None funct) + [transl_module ccarg None arg] + {ap_loc = loc; ap_inlined = inlined_attribute}) | Tmod_constraint (arg, _, _, ccarg) -> transl_module (compose_coercions cc ccarg) rootpath arg | Tmod_unpack (arg, _) -> @@ -325,18 +305,15 @@ and transl_structure loc fields cc rootpath final_env = function (fun acc id -> if is_top_root_path then export_identifiers := id :: !export_identifiers; - Lambda.Lvar id :: acc) + Lambda.var id :: acc) [] fields in - ( Lambda.Lprim - { - primitive = - Pmakeblock - (if is_top_root_path then Blk_module_export !export_identifiers - else Blk_module (List.rev_map (fun id -> id.Ident.name) fields)); - args = block_fields; - loc; - }, + ( Lambda.prim + ~primitive: + (Pmakeblock + (if is_top_root_path then Blk_module_export !export_identifiers + else Blk_module (List.rev_map (fun id -> id.Ident.name) fields))) + ~args:block_fields loc, List.length fields ) | Tcoerce_structure (pos_cc_list, id_pos_list, runtime_fields) -> (* Do not ignore id_pos_list ! *) @@ -346,7 +323,7 @@ and transl_structure loc fields cc rootpath final_env = function Format.eprintf "@]@.";*) assert (List.length runtime_fields = List.length pos_cc_list); let v = Ext_array.reverse_of_list fields in - let get_field pos = Lambda.Lvar v.(pos) + let get_field pos = Lambda.var v.(pos) and ids = List.fold_right Lambda.Ident_set.add fields Lambda.Ident_set.empty in @@ -368,15 +345,12 @@ and transl_structure loc fields cc rootpath final_env = function pos_cc_list [] in let lam = - Lambda.Lprim - { - primitive = - Pmakeblock - (if is_top_root_path then Blk_module_export !export_identifiers - else Blk_module runtime_fields); - args = result; - loc; - } + Lambda.prim + ~primitive: + (Pmakeblock + (if is_top_root_path then Blk_module_export !export_identifiers + else Blk_module runtime_fields)) + ~args:result loc and id_pos_list = Ext_list.filter id_pos_list (fun (id, _, _) -> not (Lambda.Ident_set.mem id ids)) @@ -388,7 +362,7 @@ and transl_structure loc fields cc rootpath final_env = function match item.str_desc with | Tstr_eval (expr, _) -> let body, size = transl_structure loc fields cc rootpath final_env rem in - (Lsequence (Translcore.transl_exp expr, body), size) + (Lambda.seq (Translcore.transl_exp expr) body, size) | Tstr_value (rec_flag, pat_expr_list) -> let ext_fields = rev_let_bound_idents pat_expr_list @ fields in let body, size = @@ -420,11 +394,9 @@ and transl_structure loc fields cc rootpath final_env = function let body, size = transl_structure loc (id :: fields) cc rootpath final_env rem in - ( Llet - ( Strict, - id, - Translcore.transl_extension_constructor item.str_env path ext, - body ), + ( Lambda.let_ Strict id + (Translcore.transl_extension_constructor item.str_env path ext) + body, size ) | Tstr_module mb as s -> let id = mb.mb_id in @@ -441,7 +413,7 @@ and transl_structure loc fields cc rootpath final_env = function Translattribute.add_inline_attribute module_body mb.mb_loc mb.mb_attributes in - (Llet (pure_module mb.mb_expr, id, module_body, body), size) + (Lambda.let_ (pure_module mb.mb_expr) id module_body body, size) | Tstr_recmodule bindings -> let ext_fields = List.rev_append (List.map (fun mb -> mb.mb_id) bindings) fields @@ -464,20 +436,18 @@ and transl_structure loc fields cc rootpath final_env = function | [] -> transl_structure loc newfields cc rootpath final_env rem | id :: ids -> let body, size = rebind_idents (pos + 1) (id :: newfields) ids in - ( Llet - ( Alias, - id, - Lprim - { - primitive = Pfield (pos, Fld_module {name = Ident.name id}); - args = [Lvar mid]; - loc = incl.incl_loc; - }, - body ), + ( Lambda.let_ Alias id + (Lambda.prim + ~primitive:(Pfield (pos, Fld_module {name = Ident.name id})) + ~args:[Lambda.var mid] + incl.incl_loc) + body, size ) in let body, size = rebind_idents 0 fields ids in - ( Llet (pure_module modl, mid, transl_module Tcoerce_none None modl, body), + ( Lambda.let_ (pure_module modl) mid + (transl_module Tcoerce_none None modl) + body, size ) | Tstr_primitive _ | Tstr_type _ | Tstr_modtype _ | Tstr_open _ | Tstr_attribute _ -> From 9aefec85a49ce163579ecd85cc3d2e84d5239883 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 1 Sep 2026 19:23:27 +0200 Subject: [PATCH 31/46] Add sharing variants of the list and option maps [map_sharing] returns the original list when every element maps to a physically equal value, so a traversal that rewrites nothing allocates nothing. Same for [map_snd_sharing] and the option map. Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/ext/ext_list.ml | 16 ++++++++++++++++ compiler/ext/ext_list.mli | 7 +++++++ compiler/ext/ext_option.ml | 7 +++++++ compiler/ext/ext_option.mli | 4 ++++ 4 files changed, 34 insertions(+) diff --git a/compiler/ext/ext_list.ml b/compiler/ext/ext_list.ml index 05d9826ab22..0217ed5c522 100644 --- a/compiler/ext/ext_list.ml +++ b/compiler/ext/ext_list.ml @@ -136,6 +136,22 @@ let rec map_snd l f = let y5 = f x5 in (v1, y1) :: (v2, y2) :: (v3, y3) :: (v4, y4) :: (v5, y5) :: map_snd tail f +let rec map_sharing l f = + match l with + | [] -> l + | x :: xs -> + let x' = f x in + let xs' = map_sharing xs f in + if x' == x && xs' == xs then l else x' :: xs' + +let rec map_snd_sharing l f = + match l with + | [] -> l + | (k, x) :: xs -> + let x' = f x in + let xs' = map_snd_sharing xs f in + if x' == x && xs' == xs then l else (k, x') :: xs' + let rec map_last l f = match l with | [] -> [] diff --git a/compiler/ext/ext_list.mli b/compiler/ext/ext_list.mli index add2b277351..0fe22de37a6 100644 --- a/compiler/ext/ext_list.mli +++ b/compiler/ext/ext_list.mli @@ -39,6 +39,13 @@ val mapi_append : 'a list -> (int -> 'a -> 'b) -> 'b list -> 'b list val map_snd : ('a * 'b) list -> ('b -> 'c) -> ('a * 'c) list +val map_sharing : 'a list -> ('a -> 'a) -> 'a list +(** [map_sharing l f] is [map l f], but returns [l] itself when every element + maps to a physically equal value, so an unchanged list allocates nothing. *) + +val map_snd_sharing : ('a * 'b) list -> ('b -> 'b) -> ('a * 'b) list +(** [map_snd] with the sharing of {!map_sharing}. *) + val map_last : 'a list -> (bool -> 'a -> 'b) -> 'b list (** [map_last f xs ] will pass [true] to [f] for the last element, diff --git a/compiler/ext/ext_option.ml b/compiler/ext/ext_option.ml index 92a2439a972..7e7e133a5ac 100644 --- a/compiler/ext/ext_option.ml +++ b/compiler/ext/ext_option.ml @@ -27,6 +27,13 @@ let map v f = | None -> None | Some x -> Some (f x) +let map_sharing v f = + match v with + | None -> v + | Some x -> + let x' = f x in + if x' == x then v else Some x' + let iter v f = match v with | None -> () diff --git a/compiler/ext/ext_option.mli b/compiler/ext/ext_option.mli index 41e0bb042df..d9860f97c64 100644 --- a/compiler/ext/ext_option.mli +++ b/compiler/ext/ext_option.mli @@ -26,6 +26,10 @@ val map : 'a option -> ('a -> 'b) -> 'b option +val map_sharing : 'a option -> ('a -> 'a) -> 'a option +(** [map] that returns the option itself when the value is physically + unchanged, so it allocates nothing. *) + val iter : 'a option -> ('a -> unit) -> unit val exists : 'a option -> ('a -> bool) -> bool From 1a5c53faa35b001438082aa51d903210bde783d1 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 1 Sep 2026 19:23:39 +0200 Subject: [PATCH 32/46] Give Lambda's constructors the folds Lam's have Lambda's constructors were plain wrappers; Lam's normalize as they build. Since the two types are converging, Lambda gets the same treatment, and the interface documents which six normalize and what each does - so the rule is readable rather than folklore. The folds need three operation sets that lived on the Lam side, and compiler/core cannot be a dependency of compiler/ml, so they move down and are delegated from their old homes: cmp_int32 / cmp_float from Lam_compat, eq_approx from Lam_constant (as const_eq_approx), and eq_primitive_approx from Lam_primitive. One fold does not come along. [if a then raise e else c] becoming [(if a then raise e else ()); c] is code motion, not normalization: matching inspects the terms it has built after the fact, and rewriting them as they are constructed leaves static raises without their catch - the runtime build fails outright with Not_found from compile_staticraise. It stays in Lam.if_ for now and moves to a scheduled pass next. The interface states the rule this taught us: a constructor may replace a node with an equivalent one, but may not move code between branches. Generated JavaScript is unchanged. That is expected rather than lucky: at production the operands are still in source shape, so the folds almost never fire there - measured at zero firings for prim. Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/core/lam_compat.ml | 19 +- compiler/core/lam_primitive.ml | 111 +----- compiler/frontend/lam_constant.ml | 46 +-- compiler/ml/lambda.ml | 633 +++++++++++++++++++++++++++++- compiler/ml/lambda.mli | 43 +- 5 files changed, 670 insertions(+), 182 deletions(-) diff --git a/compiler/core/lam_compat.ml b/compiler/core/lam_compat.ml index 7df7e27eed7..744021bda27 100644 --- a/compiler/core/lam_compat.ml +++ b/compiler/core/lam_compat.ml @@ -33,23 +33,8 @@ let eq_comparison (p : comparison) (p1 : comparison) = | Ceq -> p1 = Ceq | Cneq -> p1 = Cneq -let cmp_int32 (cmp : comparison) (a : int32) b : bool = - match cmp with - | Ceq -> a = b - | Cneq -> a <> b - | Cgt -> a > b - | Cle -> a <= b - | Clt -> a < b - | Cge -> a >= b - -let cmp_float (cmp : comparison) (a : float) b : bool = - match cmp with - | Ceq -> a = b - | Cneq -> a <> b - | Cgt -> a > b - | Cle -> a <= b - | Clt -> a < b - | Cge -> a >= b +let cmp_int32 = Lambda.cmp_int32 +let cmp_float = Lambda.cmp_float type let_kind = Lambda.let_kind = Strict | Alias | StrictOpt | Variable diff --git a/compiler/core/lam_primitive.ml b/compiler/core/lam_primitive.ml index ed3747c2bf4..ca322f5b64b 100644 --- a/compiler/core/lam_primitive.ml +++ b/compiler/core/lam_primitive.ml @@ -171,118 +171,9 @@ type t = Lambda.primitive = | Pjs_fn_method | Ptagged_template -let eq_field_dbg_info (x : Lam_compat.field_dbg_info) - (y : Lam_compat.field_dbg_info) = - x = y -(* save it to avoid conditional compilation, fix it later *) - -let eq_set_field_dbg_info (x : Lam_compat.set_field_dbg_info) - (y : Lam_compat.set_field_dbg_info) = - x = y -(* save it to avoid conditional compilation, fix it later *) - -let eq_tag_info (x : Lam_tag_info.t) y = x = y - (* The mutability of a block is a property of its shape, so it is derived rather than stored alongside it. *) let is_immutable_block (info : Lam_tag_info.t) = Lambda.mutable_flag_of_tag_info info = Immutable -let eq_primitive_approx (lhs : t) (rhs : t) = - match lhs with - | Praise - (* generic comparison *) - | Pobjorder | Pobjmin | Pobjmax | Pobjtag | Pobjsize - (* bool primitives *) - | Psequand | Psequor | Pnot | Pboolcomp _ | Pboolorder | Pboolmin | Pboolmax - (* int primitives *) - | Pisint | Pnegint | Paddint | Psubint | Pmulint | Pdivint | Pmodint | Ppowint - | Pnotint | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint - | Pintorder | Pintmin | Pintmax - (* float primitives *) - | Pintoffloat | Pfloatofint | Pnegfloat | Paddfloat | Psubfloat | Pmulfloat - | Pdivfloat | Pmodfloat | Ppowfloat | Pfloatorder | Pfloatmin | Pfloatmax - (* bigint primitives *) - | Pnegbigint | Paddbigint | Psubbigint | Pmulbigint | Pdivbigint | Pmodbigint - | Ppowbigint | Pnotbigint | Pandbigint | Porbigint | Pxorbigint | Plslbigint - | Pasrbigint | Pbigintorder | Pbigintmin | Pbigintmax - (* string primitives *) - | Pstringlength | Pstringrefu | Pstringrefs | Pstringadd | Pstringcomp _ - | Pstringorder | Pstringmin | Pstringmax - (* List primitives *) - | Pmakelist - (* dict primitives *) - | Pmakedict | Pdict_has - (* promise *) - | Pawait - (* etc *) - | 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 | Pis_poly_var_block - | Pdebugger | Pinit_mod | Pupdate_mod | Pduprecord | Pmakearray | Parraylength - | Parrayrefu | Parraysetu | Parrayrefs | Parraysets | Pjs_fn_method | Phash - | Phash_mixstring | Phash_mixint | Phash_finalmix | Precord_rest _ -> - rhs = lhs - (* Reachable only via the optimizer's term-equality comparison, which the - test suite doesn't exercise for tagged templates. *) - | Ptagged_template -> ( ((rhs = lhs) [@coverage off])) - | Pcreate_extension a -> ( - match rhs with - | Pcreate_extension b -> a = (b : string) - | _ -> false) - (* | Pcaml_obj_set_length -> rhs = Pcaml_obj_set_length *) - | Pfield (n0, info0) -> ( - match rhs with - | Pfield (n1, info1) -> n0 = n1 && eq_field_dbg_info info0 info1 - | _ -> false) - | Psetfield (i0, info0) -> ( - match rhs with - | Psetfield (i1, info1) -> i0 = i1 && eq_set_field_dbg_info info0 info1 - | _ -> false) - | Pmakeblock info0 -> ( - match rhs with - | Pmakeblock info1 -> eq_tag_info info0 info1 - | _ -> false) - | Pjs_call {prim_name; arg_types; ffi; _} -> ( - match rhs with - | Pjs_call rhs -> - prim_name = rhs.prim_name && arg_types = rhs.arg_types && ffi = rhs.ffi - | _ -> false) - | Pimport src -> ( - match rhs with - | Pimport src2 -> src = src2 - | _ -> false) - | Pjs_object_create obj_create -> ( - match rhs with - | Pjs_object_create obj_create1 -> obj_create = obj_create1 - | _ -> false) - | Pobjcomp comparison -> ( - match rhs with - | Pobjcomp comparison1 -> Lam_compat.eq_comparison comparison comparison1 - | _ -> false) - | Pintcomp comparison -> ( - match rhs with - | Pintcomp comparison1 -> Lam_compat.eq_comparison comparison comparison1 - | _ -> false) - | Pfloatcomp comparison -> ( - match rhs with - | Pfloatcomp comparison1 -> Lam_compat.eq_comparison comparison comparison1 - | _ -> false) - | Pbigintcomp comparison -> ( - match rhs with - | Pbigintcomp comparison1 -> Lam_compat.eq_comparison comparison comparison1 - | _ -> false) - | Pjscomp comparison -> ( - match rhs with - | Pjscomp comparison1 -> Lam_compat.eq_comparison comparison comparison1 - | _ -> false) - | Pjs_object_get name -> ( - match rhs with - | Pjs_object_get rhs_name -> name = rhs_name - | _ -> false) - | Pjs_object_set name -> ( - match rhs with - | Pjs_object_set rhs_name -> name = rhs_name - | _ -> false) - | Praw_js_code _ -> false -(* TOO lazy, here comparison is only approximation*) +let eq_primitive_approx = Lambda.eq_primitive_approx diff --git a/compiler/frontend/lam_constant.ml b/compiler/frontend/lam_constant.ml index aa34e1cc4b5..8e0ad1ef52c 100644 --- a/compiler/frontend/lam_constant.ml +++ b/compiler/frontend/lam_constant.ml @@ -44,51 +44,7 @@ type t = Lambda.structured_constant = | Const_some of t | Const_js_undefined of {is_unit: bool} -let rec eq_approx (x : t) (y : t) = - match x with - | Const_module_alias -> y = Const_module_alias - | Const_js_null -> y = Const_js_null - | Const_js_undefined b -> y = Const_js_undefined b - | Const_js_true -> y = Const_js_true - | Const_js_false -> y = Const_js_false - | Const_int ix -> ( - match y with - | Const_int iy -> ix = iy - | _ -> false) - | Const_assertfalse -> y = Const_assertfalse - | Const_constructor ix -> ( - match y with - | Const_constructor iy -> ix = iy - | _ -> false) - | Const_char ix -> ( - match y with - | Const_char iy -> ix = iy - | _ -> false) - | Const_string {s = sx; delim = ux} -> ( - match y with - | Const_string {s = sy; delim = uy} -> sx = sy && ux = uy - | _ -> false) - | Const_float ix -> ( - match y with - | Const_float iy -> ix = iy - | _ -> false) - | Const_bigint (sx, ix) -> ( - match y with - | Const_bigint (sy, iy) -> sx = sy && ix = iy - | _ -> false) - | Const_polyvar ix -> ( - match y with - | Const_polyvar iy -> ix = iy - | _ -> false) - | Const_block (ix, ixs) -> ( - match y with - | Const_block (iy, iys) -> - ix = iy && Ext_list.for_all2_no_exn ixs iys eq_approx - | _ -> false) - | Const_some ix -> ( - match y with - | Const_some iy -> eq_approx ix iy - | _ -> false) +let eq_approx = Lambda.const_eq_approx let rec is_allocating (c : t) : bool = match c with diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index 8331a75487d..89dccf6a73d 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -482,6 +482,8 @@ let lambda_assert_false = Lconst Const_assertfalse let lambda_module_alias = Lconst const_module_alias let lambda_unit = Lconst const_unit +let lambda_true = Lconst Const_js_true +let lambda_false = Lconst Const_js_false (* [r := r.contents + delta]. The reference is mentioned twice, so bind it unless it is already a variable. *) @@ -514,6 +516,177 @@ let offset_ref ~delta r loc = let id = Ident.create "ref" in Llet (Strict, id, r, assign (Lvar id)) +let eq_comparison (p : comparison) (p1 : comparison) = p = p1 + +let eq_field_dbg_info (x : field_dbg_info) (y : field_dbg_info) = x = y +let eq_set_field_dbg_info (x : set_field_dbg_info) (y : set_field_dbg_info) = + x = y + +let eq_tag_info (x : tag_info) y = x = y + +let eq_primitive_approx (lhs : primitive) (rhs : primitive) = + match lhs with + | Praise + (* generic comparison *) + | Pobjorder | Pobjmin | Pobjmax | Pobjtag | Pobjsize + (* bool primitives *) + | Psequand | Psequor | Pnot | Pboolcomp _ | Pboolorder | Pboolmin | Pboolmax + (* int primitives *) + | Pisint | Pnegint | Paddint | Psubint | Pmulint | Pdivint | Pmodint | Ppowint + | Pnotint | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint + | Pintorder | Pintmin | Pintmax + (* float primitives *) + | Pintoffloat | Pfloatofint | Pnegfloat | Paddfloat | Psubfloat | Pmulfloat + | Pdivfloat | Pmodfloat | Ppowfloat | Pfloatorder | Pfloatmin | Pfloatmax + (* bigint primitives *) + | Pnegbigint | Paddbigint | Psubbigint | Pmulbigint | Pdivbigint | Pmodbigint + | Ppowbigint | Pnotbigint | Pandbigint | Porbigint | Pxorbigint | Plslbigint + | Pasrbigint | Pbigintorder | Pbigintmin | Pbigintmax + (* string primitives *) + | Pstringlength | Pstringrefu | Pstringrefs | Pstringadd | Pstringcomp _ + | Pstringorder | Pstringmin | Pstringmax + (* List primitives *) + | Pmakelist + (* dict primitives *) + | Pmakedict | Pdict_has + (* promise *) + | Pawait + (* etc *) + | 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 | Pis_poly_var_block + | Pdebugger | Pinit_mod | Pupdate_mod | Pduprecord | Pmakearray | Parraylength + | Parrayrefu | Parraysetu | Parrayrefs | Parraysets | Pjs_fn_method | Phash + | Phash_mixstring | Phash_mixint | Phash_finalmix | Precord_rest _ -> + rhs = lhs + (* Reachable only via the optimizer's term-equality comparison, which the + test suite doesn't exercise for tagged templates. *) + | Ptagged_template -> ( ((rhs = lhs) [@coverage off])) + | Pcreate_extension a -> ( + match rhs with + | Pcreate_extension b -> a = (b : string) + | _ -> false) + (* | Pcaml_obj_set_length -> rhs = Pcaml_obj_set_length *) + | Pfield (n0, info0) -> ( + match rhs with + | Pfield (n1, info1) -> n0 = n1 && eq_field_dbg_info info0 info1 + | _ -> false) + | Psetfield (i0, info0) -> ( + match rhs with + | Psetfield (i1, info1) -> i0 = i1 && eq_set_field_dbg_info info0 info1 + | _ -> false) + | Pmakeblock info0 -> ( + match rhs with + | Pmakeblock info1 -> eq_tag_info info0 info1 + | _ -> false) + | Pjs_call {prim_name; arg_types; ffi; _} -> ( + match rhs with + | Pjs_call rhs -> + prim_name = rhs.prim_name && arg_types = rhs.arg_types && ffi = rhs.ffi + | _ -> false) + | Pimport src -> ( + match rhs with + | Pimport src2 -> src = src2 + | _ -> false) + | Pjs_object_create obj_create -> ( + match rhs with + | Pjs_object_create obj_create1 -> obj_create = obj_create1 + | _ -> false) + | Pobjcomp comparison -> ( + match rhs with + | Pobjcomp comparison1 -> eq_comparison comparison comparison1 + | _ -> false) + | Pintcomp comparison -> ( + match rhs with + | Pintcomp comparison1 -> eq_comparison comparison comparison1 + | _ -> false) + | Pfloatcomp comparison -> ( + match rhs with + | Pfloatcomp comparison1 -> eq_comparison comparison comparison1 + | _ -> false) + | Pbigintcomp comparison -> ( + match rhs with + | Pbigintcomp comparison1 -> eq_comparison comparison comparison1 + | _ -> false) + | Pjscomp comparison -> ( + match rhs with + | Pjscomp comparison1 -> eq_comparison comparison comparison1 + | _ -> false) + | Pjs_object_get name -> ( + match rhs with + | Pjs_object_get rhs_name -> name = rhs_name + | _ -> false) + | Pjs_object_set name -> ( + match rhs with + | Pjs_object_set rhs_name -> name = rhs_name + | _ -> false) + | Praw_js_code _ -> false +(* TOO lazy, here comparison is only approximation*) + +let rec const_eq_approx (x : structured_constant) (y : structured_constant) = + match x with + | Const_module_alias -> y = Const_module_alias + | Const_js_null -> y = Const_js_null + | Const_js_undefined b -> y = Const_js_undefined b + | Const_js_true -> y = Const_js_true + | Const_js_false -> y = Const_js_false + | Const_int ix -> ( + match y with + | Const_int iy -> ix = iy + | _ -> false) + | Const_assertfalse -> y = Const_assertfalse + | Const_constructor ix -> ( + match y with + | Const_constructor iy -> ix = iy + | _ -> false) + | Const_char ix -> ( + match y with + | Const_char iy -> ix = iy + | _ -> false) + | Const_string {s = sx; delim = ux} -> ( + match y with + | Const_string {s = sy; delim = uy} -> sx = sy && ux = uy + | _ -> false) + | Const_float ix -> ( + match y with + | Const_float iy -> ix = iy + | _ -> false) + | Const_bigint (sx, ix) -> ( + match y with + | Const_bigint (sy, iy) -> sx = sy && ix = iy + | _ -> false) + | Const_polyvar ix -> ( + match y with + | Const_polyvar iy -> ix = iy + | _ -> false) + | Const_block (ix, ixs) -> ( + match y with + | Const_block (iy, iys) -> + ix = iy && Ext_list.for_all2_no_exn ixs iys const_eq_approx + | _ -> false) + | Const_some ix -> ( + match y with + | Const_some iy -> const_eq_approx ix iy + | _ -> false) + +let cmp_int32 (cmp : comparison) (a : int32) b : bool = + match cmp with + | Ceq -> a = b + | Cneq -> a <> b + | Cgt -> a > b + | Cle -> a <= b + | Clt -> a < b + | Cge -> a >= b + +let cmp_float (cmp : comparison) (a : float) b : bool = + match cmp with + | Ceq -> a = b + | Cneq -> a <> b + | Cgt -> a > b + | Cle -> a <= b + | Clt -> a < b + | Cge -> a >= b + (* Constructors. The type is private outside this module, so every term is built through one of these. They are plain for now; the normalizations that Lam.prim / Lam.if_ / Lam.switch perform will move here when the two layers @@ -523,24 +696,15 @@ let var id : lambda = Lvar id let global_module id : lambda = Lglobal_module id let const ct : lambda = Lconst ct -let apply ?(ap_transformed_jsx = false) ap_func ap_args ap_info : lambda = - Lapply {ap_func; ap_args; ap_info; ap_transformed_jsx} - let function_ ~loc ~attr ~params ~body : lambda = Lfunction {params; body; attr; loc} let let_ kind id e body : lambda = Llet (kind, id, e, body) let letrec bindings body : lambda = Lletrec (bindings, body) -let prim ~primitive ~args loc : lambda = Lprim {primitive; args; loc} -let switch lam sw : lambda = Lswitch (lam, sw) - -let stringswitch lam cases default : lambda = Lstringswitch (lam, cases, default) let staticraise i args : lambda = Lstaticraise (i, args) let staticcatch body catch handler : lambda = Lstaticcatch (body, catch, handler) let try_ body id handler : lambda = Ltrywith (body, id, handler) -let if_ a b c : lambda = Lifthenelse (a, b, c) -let seq a b : lambda = Lsequence (a, b) let break : lambda = Lbreak let continue : lambda = Lcontinue let while_ cond body : lambda = Lwhile (cond, body) @@ -551,6 +715,457 @@ let for_await_of id iterable body : lambda = Lfor_await_of (id, iterable, body) let assign id body : lambda = Lassign (id, body) +exception Not_simple_form + +(** + + + [is_eta_conversion_exn params inner_args outer_args] + case 1: + {{ + (fun params -> wrap (primitive (inner_args)) args + }} + when [inner_args] are the same as [params], it can be simplified as + [wrap (primitive args)] + + where [wrap] used to be simple instructions + Note that [external] functions are forced to do eta-conversion + when combined with [|>] operator, we need to make sure beta-reduction + is applied though since `[@variadic]` needs such guarantee. + Since `[@variadic] is the tail position +*) +let rec is_eta_conversion_exn params inner_args outer_args : lambda list = + match (params, inner_args, outer_args) with + | x :: xs, Lvar y :: ys, r :: rest when Ident.same x y -> + r :: is_eta_conversion_exn xs ys rest + | [], [], [] -> [] + | _, _, _ -> raise_notrace Not_simple_form + +let rec apply ?(ap_transformed_jsx = false) fn args (ap_info : ap_info) : lambda + = + match fn with + | Lfunction + { + params; + body = + Lprim + { + primitive = + ( Pnull_to_opt | Pnull_undefined_to_opt | Pis_null + | Pis_null_undefined | Ptypeof ) as wrap; + args = + [Lprim ({primitive = _; args = inner_args} as primitive_call)]; + }; + } -> ( + match is_eta_conversion_exn params inner_args args with + | args -> + let loc = ap_info.ap_loc in + Lprim + {primitive = wrap; args = [Lprim {primitive_call with args; loc}]; loc} + | exception Not_simple_form -> + Lapply {ap_func = fn; ap_args = args; ap_info; ap_transformed_jsx}) + | Lfunction + { + params; + body = Lprim ({primitive = _; args = inner_args} as primitive_call); + } -> ( + match is_eta_conversion_exn params inner_args args with + | args -> Lprim {primitive_call with args; loc = ap_info.ap_loc} + | exception _ -> + Lapply {ap_func = fn; ap_args = args; ap_info; ap_transformed_jsx}) + | Lfunction + { + params; + body = + Lsequence + ( Lprim ({primitive = _; args = inner_args} as primitive_call), + (Lconst _ as const) ); + } -> ( + match is_eta_conversion_exn params inner_args args with + | args -> + Lsequence (Lprim {primitive_call with args; loc = ap_info.ap_loc}, const) + | exception _ -> + Lapply {ap_func = fn; ap_args = args; ap_info; ap_transformed_jsx} + (* | Lfunction {params;body} when Ext_list.same_length params args -> + Ext_list.fold_right2 (fun p arg acc -> + Llet(Strict,p,arg,acc) + ) params args body *) + (* TODO: more rigirous analysis on [let_kind] *)) + | Llet (kind, id, e, (Lfunction _ as fn)) -> + Llet (kind, id, e, apply fn args ap_info ~ap_transformed_jsx) + (* | Llet (kind0, id0, e0, Llet (kind,id, e, (Lfunction _ as fn))) -> + Llet(kind0,id0,e0,Llet (kind, id, e, apply fn args loc status)) *) + | _ -> Lapply {ap_func = fn; ap_args = args; ap_info; ap_transformed_jsx} + +let rec eq_approx (l1 : lambda) (l2 : lambda) = + match l1 with + | Lglobal_module i1 -> ( + match l2 with + | Lglobal_module i2 -> Ident.same i1 i2 + | _ -> false) + | Lvar i1 -> ( + match l2 with + | Lvar i2 -> Ident.same i1 i2 + | _ -> false) + | Lconst c1 -> ( + match l2 with + | Lconst c2 -> const_eq_approx c1 c2 + | _ -> false) + | Lapply app1 -> ( + match l2 with + | Lapply app2 -> + eq_approx app1.ap_func app2.ap_func + && eq_approx_list app1.ap_args app2.ap_args + | _ -> false) + | Lifthenelse (a, b, c) -> ( + match l2 with + | Lifthenelse (a0, b0, c0) -> + eq_approx a a0 && eq_approx b b0 && eq_approx c c0 + | _ -> false) + | Lsequence (a, b) -> ( + match l2 with + | Lsequence (a0, b0) -> eq_approx a a0 && eq_approx b b0 + | _ -> false) + | Lbreak -> l2 = Lbreak + | Lcontinue -> l2 = Lcontinue + | Lwhile (p, b) -> ( + match l2 with + | Lwhile (p0, b0) -> eq_approx p p0 && eq_approx b b0 + | _ -> false) + | Lassign (v0, l0) -> ( + match l2 with + | Lassign (v1, l1) -> Ident.same v0 v1 && eq_approx l0 l1 + | _ -> false) + | Lstaticraise (id, ls) -> ( + match l2 with + | Lstaticraise (id1, ls1) -> id = id1 && eq_approx_list ls ls1 + | _ -> false) + | Lprim info1 -> ( + match l2 with + | Lprim info2 -> + eq_primitive_approx info1.primitive info2.primitive + && eq_approx_list info1.args info2.args + | _ -> false) + | Lstringswitch (arg, patterns, default) -> ( + match l2 with + | Lstringswitch (arg2, patterns2, default2) -> + eq_approx arg arg2 && eq_option default default2 + && Ext_list.for_all2_no_exn patterns patterns2 + (fun ((k : string), v) (k2, v2) -> k = k2 && eq_approx v v2) + | _ -> false) + | Lfunction _ + | Llet (_, _, _, _) + | Lletrec _ | Lswitch _ | Lstaticcatch _ | Ltrywith _ + | Lfor (_, _, _, _, _) + | Lfor_of (_, _, _) + | Lfor_await_of (_, _, _) -> + false + +and eq_option l1 l2 = + match l1 with + | None -> l2 = None + | Some l1 -> ( + match l2 with + | Some l2 -> eq_approx l1 l2 + | None -> false) + +and eq_approx_list ls ls1 = Ext_list.for_all2_no_exn ls ls1 eq_approx + +let switch lam (lam_switch : lambda_switch) : lambda = + let action_or_switch = function + | Some action -> action + | None -> ( + match lam_switch.sw_failaction with + | Some action -> action + | None -> Lswitch (lam, lam_switch)) + in + match lam with + | Lconst (Const_constructor cstr_name) -> + let action = + Ext_list.find_opt lam_switch.sw_consts (fun (key, action) -> + match key with + | Switch_constructor (Constant tag) when cstr_name = tag -> + Some action + | Switch_int _ | Switch_constructor _ -> None) + in + action_or_switch action + | 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 + let action = + Ext_list.find_opt lam_switch.sw_consts (fun (key, action) -> + match key with + | Switch_int ordinal when ordinal = i -> Some action + | Switch_constructor + (Constant {tag_type = Some (Variant_runtime.Int value)}) + when value = i -> + Some action + | Switch_int _ | Switch_constructor _ -> None) + in + action_or_switch action + | Lconst (Const_block (tag_info, _)) -> + let runtime = + match tag_info with + | Blk_constructor {runtime} | Blk_record_inlined {runtime} -> Some runtime + | Blk_tuple | Blk_poly_var | Blk_record _ | Blk_record_ext _ + | Blk_module _ | Blk_module_export _ | Blk_extension -> + None + in + let action = + Ext_list.find_opt lam_switch.sw_blocks (fun (key, action) -> + match key with + | Switch_constructor (Block {runtime = case_runtime}) + when runtime = Some case_runtime -> + Some action + | Switch_int _ | Switch_constructor _ -> None) + in + action_or_switch action + | _ -> Lswitch (lam, lam_switch) + +let stringswitch (lam : lambda) cases default : lambda = + match lam with + | Lconst (Const_string {s; delim = None | Some DNoQuotes}) -> + Ext_list.assoc_by_string cases s default + | _ -> Lstringswitch (lam, cases, default) + +let rec seq (a : lambda) b : lambda = + match a with + | Lprim {primitive = Pmakeblock _; args = x :: xs} -> + seq (Ext_list.fold_left xs x seq) b + | Lprim {primitive = Pnull_to_opt | Pnull_undefined_to_opt; args = [a]} -> + seq a b + | _ -> Lsequence (a, b) + +module Lift = struct + let int i : lambda = Lconst (Const_int i) + + let bool b = if b then lambda_true else lambda_false + + let string s : lambda = Lconst (Const_string {s; delim = None}) + + let char b : lambda = Lconst (Const_char b) +end + +let prim ~primitive:(prim : primitive) ~args loc : lambda = + let default () : lambda = Lprim {primitive = prim; args; loc} in + match args with + | [Lconst a] -> ( + match (prim, a) with + | Pnegint, Const_int i -> Lift.int (Int32.neg i) + (* | Pfloatofint, ( (Const_int a)) *) + (* -> Lift.float (float_of_int a) *) + | Pintoffloat, Const_float a -> + Lift.int (Int32.of_float (float_of_string a)) + (* | Pnegfloat -> Lift.float (-. a) *) + | Pstringlength, Const_string {s; delim = None} -> + Lift.int (Int32.of_int (String.length s)) + (* | Pnegbint Pnativeint, ( (Const_nativeint i)) *) + (* -> *) + (* Lift.nativeint (Nativeint.neg i) *) + | Pnot, Const_js_true -> lambda_false + | Pnot, Const_js_false -> lambda_true + | _ -> default ()) + | [Lconst a; Lconst b] -> ( + match (prim, a, b) with + | Pintcomp cmp, Const_int a, Const_int b -> Lift.bool (cmp_int32 cmp a b) + | Pfloatcomp cmp, Const_float a, Const_float b -> + (* FIXME: could raise? *) + Lift.bool (cmp_float cmp (float_of_string a) (float_of_string b)) + | Pbigintcomp _, Const_bigint _, Const_bigint _ -> default () + | Pintcomp ((Ceq | Cneq) as op), Const_polyvar a, Const_polyvar b -> + Lift.bool + (match op with + | Ceq -> a = (b : string) + | Cneq -> a <> b + | _ -> assert false) + | ( Pintcomp ((Ceq | Cneq) as op), + Const_constructor {name = a; tag_type = None}, + Const_constructor {name = b; tag_type = None} ) -> + (* Both runtime representations are the constructor names *) + Lift.bool + (match op with + | Ceq -> a = b + | Cneq -> a <> b + | _ -> assert false) + | ( ( Paddint | Psubint | Pmulint | Pdivint | Pmodint | Pandint | Porint + | Pxorint | Plslint | Plsrint | Pasrint ), + Const_int aa, + Const_int bb ) -> ( + (* WE SHOULD keep it as [int], to preserve types *) + let int_ = Lift.int in + match prim with + | Paddint -> int_ (Int32.add aa bb) + | Psubint -> int_ (Int32.sub aa bb) + | Pmulint -> int_ (Int32.mul aa bb) + | Pdivint -> if bb = 0l then default () else int_ (Int32.div aa bb) + | Pmodint -> if bb = 0l then default () else int_ (Int32.rem aa bb) + | Pandint -> int_ (Int32.logand aa bb) + | Porint -> int_ (Int32.logor aa bb) + | Pxorint -> int_ (Int32.logxor aa bb) + | Plslint -> int_ (Int32.shift_left aa (Int32.to_int bb)) + | Plsrint -> int_ (Int32.shift_right_logical aa (Int32.to_int bb)) + | Pasrint -> int_ (Int32.shift_right aa (Int32.to_int bb)) + | _ -> default ()) + | Psequand, Const_js_false, (Const_js_true | Const_js_false) -> lambda_false + | Psequand, Const_js_true, Const_js_true -> lambda_true + | Psequand, Const_js_true, Const_js_false -> lambda_false + | Psequor, Const_js_true, (Const_js_true | Const_js_false) -> lambda_true + | Psequor, Const_js_false, Const_js_true -> lambda_true + | Psequor, Const_js_false, Const_js_false -> lambda_false + | ( Pstringadd, + Const_string {s = a; delim = None}, + Const_string {s = b; delim = None} ) -> + Lift.string (a ^ b) + | ( (Pstringrefs | Pstringrefu), + Const_string {s = a; delim = None}, + Const_int b ) -> ( + try Lift.char (Char.code (String.get a (Int32.to_int b))) + with _ -> default ()) + | _ -> default ()) + | _ -> ( + match prim with + | Pmakeblock (Blk_module fields) -> ( + let rec aux fields args (var : Ident.t) i = + match (fields, args) with + | [], [] -> true + | ( f :: fields, + Lprim + { + primitive = Pfield (pos, Fld_module {name = f1}); + args = [(Lglobal_module v1 | Lvar v1)]; + } + :: args ) -> + pos = i && f = f1 && Ident.same var v1 && aux fields args var (i + 1) + | _, _ -> false + in + match (fields, args) with + | ( field1 :: rest, + Lprim + { + primitive = Pfield (pos, Fld_module {name = f1}); + args = [((Lglobal_module v1 | Lvar v1) as lam)]; + } + :: args1 ) -> + if pos = 0 && field1 = f1 && aux rest args1 v1 1 then lam + else default () + | _ -> default ()) + (* In this level, include is already expanded, so that + {[ + { x0 : y0 ; x1 : y1 } + ]} + such module x can indeed be replaced by module y + *) + | _ -> default ()) + +let not_ loc x : lambda = + match x with + | Lprim ({primitive = Pintcomp Cneq} as prim) -> + Lprim {prim with primitive = Pintcomp Ceq} + | _ -> prim ~primitive:Pnot ~args:[x] loc + +let has_boolean_type (x : lambda) = + match x with + | Lprim + { + primitive = + ( Pnot | Psequand | Psequor | Pis_not_none | Pobjcomp _ | Pboolcomp _ + | Pintcomp _ | Pfloatcomp _ | Pbigintcomp _ | Pstringcomp _ ); + loc; + } -> + Some loc + | _ -> None + +let rec eval_const_as_bool (v : structured_constant) : bool option = + match v with + | 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 _ + -> + Some false + | Const_js_true | Const_string _ | Const_polyvar _ | Const_float _ + | Const_bigint _ | Const_block _ -> + Some true + | Const_some b -> eval_const_as_bool b + | Const_constructor {name; tag_type} -> ( + (* Truthiness of the canonical runtime representation *) + match tag_type with + | None -> Some (name <> "[]") (* the name string; [] is the number 0 *) + | Some (String s) -> Some (s <> "") + | Some (Int i) -> Some (i <> 0) + | Some (Bool b) -> Some b + | Some Null | Some Undefined -> Some false + | Some (Float _ | BigInt _ | Untagged _) -> None) + +let if_ (a : lambda) (b : lambda) (c : lambda) : lambda = + match a with + | Lconst v -> ( + match eval_const_as_bool v with + | Some v -> if v then b else c + | None -> Lifthenelse (a, b, c)) + | _ -> ( + match (b, c) with + | _, Lconst Const_assertfalse -> + seq a b (* TODO: we could customize more cases *) + | 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 -> ( + match has_boolean_type a with + | Some loc -> not_ loc a + | None -> Lifthenelse (a, b, c)) + (* [if a then raise e else c] could become [(if a then raise e else ()); c], + but that is code motion, not normalization: it changes the shape that + matching's own exit bookkeeping inspects after the term is assembled, + and doing it here leaves static raises without their catch. It stays a + Lam-side rewrite until it can be expressed as a pass. *) + | _ -> ( + match a with + | Lprim {primitive = Pisint; args = [Lvar i]; _} -> ( + match b with + | Lifthenelse + (Lprim {primitive = Pintcomp Ceq; args = [Lvar j; Lconst _]}, _, b_f) + when Ident.same i j && eq_approx b_f c -> + b + | Lprim {primitive = Pintcomp Ceq; args = [Lvar j; Lconst _]} + when Ident.same i j && eq_approx lambda_false c -> + b + | Lifthenelse + ( Lprim + ({primitive = Pintcomp Cneq; args = [Lvar j; Lconst _]} as + b_pred), + b_t, + b_f ) + when Ident.same i j && eq_approx b_t c -> + Lifthenelse (Lprim {b_pred with primitive = Pintcomp Ceq}, b_f, b_t) + | Lprim + {primitive = Pintcomp Cneq; args = [Lvar j; Lconst _] as args; loc} + | Lprim + { + primitive = Pnot; + args = + [ + Lprim + { + primitive = Pintcomp Ceq; + args = [Lvar j; Lconst _] as args; + loc; + }; + ]; + } + when Ident.same i j && eq_approx lambda_true c -> + Lprim {primitive = Pintcomp Cneq; args; loc} + | _ -> Lifthenelse (a, b, c)) + | _ -> Lifthenelse (a, b, c))) + +let sequor l r = if_ l lambda_true r + +(** [l && r] *) +let sequand l r = if_ l r lambda_false + +(** [l && r ] *) + let mk_builtin b args loc = match b with | Primitive p -> Lprim {primitive = p; args; loc} diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index 9d4f6b5c738..096939f9fc4 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -436,8 +436,37 @@ val const_module_alias : structured_constant val lambda_assert_false : lambda val lambda_unit : lambda +val eq_primitive_approx : primitive -> primitive -> bool + +val const_eq_approx : structured_constant -> structured_constant -> bool + +val cmp_int32 : comparison -> int32 -> int32 -> bool + +val cmp_float : comparison -> float -> float -> bool + (* Constructors. [lambda] is private, so every term outside this module is - built through one of these. *) + built through one of these. + + Most are plain wrappers. Six normalize as they build, and are the only + place that normalization happens - a pass cannot bypass it by writing a + constructor directly: + + - [prim] folds an operation whose arguments are already constants, and + collapses a module record rebuilt field-by-field from another module + back to that module. + - [if_] resolves a constant condition, collapses a branch that asserts + false, turns boolean branches into the condition or its negation, and + recognizes a few [Pisint] shapes. + - [switch] and [stringswitch] pick the matching case when the scrutinee + is constant. + - [not_] rewrites a negated inequality into an equality. + - [seq] drops a first operand that only allocates. + - [apply] eta-reduces a function whose body is a single primitive call on + its own parameters. + + These fire when a term is rebuilt with new children, which in practice + means during the optimizer's passes rather than at production: the + frontend has no constants in operand position yet. *) val var : Ident.t -> lambda @@ -489,6 +518,18 @@ val for_await_of : Ident.t -> lambda -> lambda -> lambda val assign : Ident.t -> lambda -> lambda +val not_ : Location.t -> lambda -> lambda + +val sequor : lambda -> lambda -> lambda + +val sequand : lambda -> lambda -> lambda + +val lambda_true : lambda + +val lambda_false : lambda + +val eq_approx : lambda -> lambda -> bool + val mk_builtin : builtin -> lambda list -> Location.t -> lambda (** Expands the non-[Primitive] builtins, which have no IR form. *) From 0ef1dcfcc269d4b1c5dea19496dda3257d8cc4de Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 1 Sep 2026 19:23:52 +0200 Subject: [PATCH 33/46] Move the raise-guard rewrite out of Lam.if_ into a pass [if a then raise e else c] reads better as [(if a then raise e else ()); c]: the continuation stops being nested inside a branch, which is the guard clause idiom in the emitted JavaScript. It is worth keeping - dropping it changes 20 files, adding an indentation level to bodies as large as Stdlib_List.getOrThrow. But it is code motion, not normalization, and it cannot run from a constructor: matching inspects the terms it has built after the fact, so rewriting them during construction leaves static raises without their catch. As a scheduled traversal it is fine. It has to run last: instrumenting the firing site shows the opportunities come from conversion (18) and from four different passes - exits, remove_alias, lets_dce and deep_flatten (5) - so a pass placed after all of them catches every case without having to know which one produced it. Applying it only at the end of translation recovers 18 of the 20 files; the two it misses need inlining first, where invalid_arg and assert(false) become raises. Lam gains shallow_map_sharing, which maps a node's immediate children and rebuilds through the smart constructors, so a rewritten child is still normalized while an unchanged node is returned as-is. The pass is then only its own logic, and the traversal is available to other passes. The pass allocates nothing when it has nothing to do: over the corpus, 742 of 760 modules come back physically identical having allocated zero minor words; the 18 that are rewritten allocate 63 words each, the spine down to each rewritten node. Generated JavaScript is unchanged. Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/core/lam.ml | 77 +++++++++++++++++++++++-- compiler/core/lam.mli | 5 ++ compiler/core/lam_compile_main.ml | 2 +- compiler/core/lam_pass_guard_raises.ml | 8 +++ compiler/core/lam_pass_guard_raises.mli | 14 +++++ 5 files changed, 101 insertions(+), 5 deletions(-) create mode 100644 compiler/core/lam_pass_guard_raises.ml create mode 100644 compiler/core/lam_pass_guard_raises.mli diff --git a/compiler/core/lam.ml b/compiler/core/lam.ml index 5a362949ace..f5f8a613d63 100644 --- a/compiler/core/lam.ml +++ b/compiler/core/lam.ml @@ -533,10 +533,6 @@ let if_ (a : t) (b : t) (c : t) : t = match has_boolean_type a with | Some loc -> not_ loc a | None -> Lifthenelse (a, b, c)) - | Lprim {primitive = Praise}, _ -> ( - match c with - | Lconst _ -> Lifthenelse (a, b, c) - | _ -> seq (Lifthenelse (a, b, unit)) c) | _ -> ( match a with | Lprim {primitive = Pisint; args = [Lvar i]; _} -> ( @@ -582,3 +578,76 @@ let sequor l r = if_ l true_ r (** [l && r ] *) let sequand l r = if_ l r false_ + +(** [shallow_map_sharing f lam] rewrites [lam]'s immediate children with [f] + and rebuilds the node through its smart constructor, so the result is + normalized. A node whose children all come back physically unchanged is + returned as-is, so a traversal that rewrites nothing allocates nothing. *) +let shallow_map_sharing (f : t -> t) (lam : t) : t = + match lam with + | Lvar _ | Lglobal_module _ | Lconst _ | Lbreak | Lcontinue -> lam + | Lapply ap -> + let fn = f ap.ap_func in + let args = Ext_list.map_sharing ap.ap_args f in + if fn == ap.ap_func && args == ap.ap_args then lam + else apply fn args ap.ap_info ~ap_transformed_jsx:ap.ap_transformed_jsx + | Lfunction {params; body; attr; loc} -> + let body' = f body in + if body' == body then lam else function_ ~loc ~attr ~params ~body:body' + | Llet (k, id, e, b) -> + let e' = f e and b' = f b in + if e' == e && b' == b then lam else let_ k id e' b' + | Lletrec (bs, b) -> + let bs' = Ext_list.map_snd_sharing bs f and b' = f b in + if bs' == bs && b' == b then lam else letrec bs' b' + | Lprim {primitive; args; loc} -> + let args' = Ext_list.map_sharing args f in + if args' == args then lam else prim ~primitive ~args:args' loc + | Lswitch (e, sw) -> + let e' = f e in + let consts = Ext_list.map_snd_sharing sw.sw_consts f in + let blocks = Ext_list.map_snd_sharing sw.sw_blocks f in + let fail = Ext_option.map_sharing sw.sw_failaction f in + if + e' == e && consts == sw.sw_consts && blocks == sw.sw_blocks + && fail == sw.sw_failaction + then lam + else + switch e' + {sw with sw_consts = consts; sw_blocks = blocks; sw_failaction = fail} + | Lstringswitch (e, cases, d) -> + let e' = f e in + let cases' = Ext_list.map_snd_sharing cases f in + let d' = Ext_option.map_sharing d f in + if e' == e && cases' == cases && d' == d then lam + else stringswitch e' cases' d' + | Lstaticraise (i, args) -> + let args' = Ext_list.map_sharing args f in + if args' == args then lam else staticraise i args' + | Lstaticcatch (b, h, hd) -> + let b' = f b and hd' = f hd in + if b' == b && hd' == hd then lam else staticcatch b' h hd' + | Ltrywith (b, id, h) -> + let b' = f b and h' = f h in + if b' == b && h' == h then lam else try_ b' id h' + | Lifthenelse (a, b, c) -> + let a' = f a and b' = f b and c' = f c in + if a' == a && b' == b && c' == c then lam else if_ a' b' c' + | Lsequence (a, b) -> + let a' = f a and b' = f b in + if a' == a && b' == b then lam else seq a' b' + | Lwhile (a, b) -> + let a' = f a and b' = f b in + if a' == a && b' == b then lam else while_ a' b' + | Lfor (id, a, b, d, c) -> + let a' = f a and b' = f b and c' = f c in + if a' == a && b' == b && c' == c then lam else for_ id a' b' d c' + | Lfor_of (id, a, b) -> + let a' = f a and b' = f b in + if a' == a && b' == b then lam else for_of id a' b' + | Lfor_await_of (id, a, b) -> + let a' = f a and b' = f b in + if a' == a && b' == b then lam else for_await_of id a' b' + | Lassign (id, b) -> + let b' = f b in + if b' == b then lam else assign id b' diff --git a/compiler/core/lam.mli b/compiler/core/lam.mli index e7ccff0141d..d1caf80bda9 100644 --- a/compiler/core/lam.mli +++ b/compiler/core/lam.mli @@ -154,4 +154,9 @@ val for_await_of : ident -> t -> t -> t (**************************************************************) +val shallow_map_sharing : (t -> t) -> t -> t +(** Rewrite a node's immediate children, rebuilding through the smart + constructors. A node whose children are all physically unchanged is + returned as-is, so a traversal that rewrites nothing allocates nothing. *) + val eq_approx : t -> t -> bool diff --git a/compiler/core/lam_compile_main.ml b/compiler/core/lam_compile_main.ml index 14b73c88a3f..740b58d1404 100644 --- a/compiler/core/lam_compile_main.ml +++ b/compiler/core/lam_compile_main.ml @@ -316,7 +316,7 @@ let compile (output_prefix : string) export_idents hoisted (lam : Lambda.lambda) (* |> Lam_group_pass.scc_pass |> d "scc" *) |> Lam_pass_exits.simplify_exits - |> d "simplify_lets" + |> Lam_pass_guard_raises.guard_raises |> d "simplify_lets" |> fun lam -> if debug_ir then Ext_log.dwarn ~__POS__ "Before coercion: %a@." Lam_stats.print meta; diff --git a/compiler/core/lam_pass_guard_raises.ml b/compiler/core/lam_pass_guard_raises.ml new file mode 100644 index 00000000000..af7704fb518 --- /dev/null +++ b/compiler/core/lam_pass_guard_raises.ml @@ -0,0 +1,8 @@ +let rec guard_raises (lam : Lam.t) : Lam.t = + match lam with + | Lifthenelse (a, (Lprim {primitive = Praise} as b), c) -> ( + match c with + (* A constant alternative is already as flat as it gets. *) + | Lconst _ -> Lam.shallow_map_sharing guard_raises lam + | _ -> Lam.seq (Lam.if_ (guard_raises a) b Lam.unit) (guard_raises c)) + | _ -> Lam.shallow_map_sharing guard_raises lam diff --git a/compiler/core/lam_pass_guard_raises.mli b/compiler/core/lam_pass_guard_raises.mli new file mode 100644 index 00000000000..2818f7b2b1e --- /dev/null +++ b/compiler/core/lam_pass_guard_raises.mli @@ -0,0 +1,14 @@ +val guard_raises : Lam.t -> Lam.t +(** Rewrite [if a then raise e else c] into [(if a then raise e else ()); c], + so the continuation stops being nested inside a branch - the guard clause + idiom in the emitted JavaScript. + + This is code motion rather than normalization: it changes the shape that + surrounding code matches on, so it cannot live in [Lam.if_]. Matching + inspects the terms it has built after the fact, and rewriting them as they + are constructed leaves static raises without their catch. + + Run it late. The opportunities come from conversion and from four + different passes ([exits], [remove_alias], [lets_dce], [deep_flatten]), so + a traversal scheduled after all of them catches every case without having + to know which pass produced it. *) From fb89d6c98acaedd53cd0fb26955322000af3563c Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 1 Sep 2026 20:00:03 +0200 Subject: [PATCH 34/46] Make Lam.t an alias of Lambda.lambda and drop the conversion The two types had the same constructors in the same order with every payload already aliased, so Lam.t becomes a plain alias. Not a re-export: the passes never open Lam, they reach the constructors by type-directed disambiguation from the (lam : Lam.t) annotation, and that resolves them from Lambda just as well - warnings 40 and 41 are already off in this tree. lam.ml goes from 653 lines to 69: the type block is aliases and everything else delegates. shallow_map_sharing moves to Lambda, since with the type shared and private there, lam.ml can no longer construct - which is the invariant we wanted. Lam_convert.convert was the identity, so it goes and lam_compile_main feeds the Lambda term straight into the pipeline. required_modules stays. Three files reached constructors through the module path rather than by disambiguation - Lam.Lvar and friends - and now say Lambda. Generated JavaScript is unchanged. Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/core/lam.ml | 664 ++------------------------ compiler/core/lam.mli | 68 +-- compiler/core/lam_analysis.ml | 2 +- compiler/core/lam_compile.ml | 4 +- compiler/core/lam_compile_main.ml | 20 +- compiler/core/lam_convert.ml | 57 --- compiler/core/lam_convert.mli | 5 - compiler/jsoo/jsoo_playground_main.ml | 3 +- compiler/ml/lambda.ml | 73 +++ compiler/ml/lambda.mli | 6 + 10 files changed, 141 insertions(+), 761 deletions(-) diff --git a/compiler/core/lam.ml b/compiler/core/lam.ml index f5f8a613d63..a126b624dbf 100644 --- a/compiler/core/lam.ml +++ b/compiler/core/lam.ml @@ -22,632 +22,48 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type ident = Ident.t type ap_info = Lambda.ap_info = { ap_loc: Location.t; ap_inlined: Lambda.inline_attribute; } -module Types = struct - type lambda_switch = t Lambda.switch - - and lfunction = { - params: ident list; - body: t; - attr: Lambda.function_attribute; - loc: Location.t; - } - - (* - Invariant: - length (sw_consts) <= sw_consts_full - when length (sw_consts) >= sw_consts_full -> true - Note that failaction would appear in both - {[ - match x with - | .. - | .. - | _ -> 2 - ]} - since compiler would first test [x] is a const pointer - or not then the [default] applies to each branch. - - In most cases: {[ - let sw = - {sw_consts_full = List.length consts >= num_consts; - sw_consts = consts; - sw_blocks_full = List.length nonconsts >= num_nonconsts; - sw_blocks = nonconsts; - sw_failaction = None} in - ]} - where the counts come from the variant layout. - - but there are some edge cases (see https://caml.inria.fr/mantis/view.php?id=6033) - one predicate used is - {[ - (sw.sw_consts_full - List.length sw.sw_consts) + - (sw.sw_blocks_full - List.length sw.sw_blocks) > 1 - ]} - if [= 1] with [some fail] -- called once - if [= 0] could not have [some fail] - *) - and prim_info = {primitive: Lam_primitive.t; args: t list; loc: Location.t} - - and apply = { - ap_func: t; - ap_args: t list; - ap_info: ap_info; - ap_transformed_jsx: bool; - } - - and t = - | Lvar of ident - | Lglobal_module of ident - | Lconst of Lam_constant.t - | Lapply of apply - | Lfunction of lfunction - | Llet of Lam_compat.let_kind * ident * t * t - | Lletrec of (ident * t) list * t - | Lprim of prim_info - | Lswitch of t * lambda_switch - | Lstringswitch of t * (string * t) list * t option - | Lstaticraise of int * t list - | Lstaticcatch of t * (int * ident list) * t - | Ltrywith of t * ident * t - | Lifthenelse of t * t * t - | Lsequence of t * t - | Lbreak - | Lcontinue - | Lwhile of t * t - | Lfor of ident * t * t * Asttypes.direction_flag * t - | Lfor_of of ident * t * t - | Lfor_await_of of ident * t * t - | Lassign of ident * t -end - -include Types - -exception Not_simple_form - -(** - - - [is_eta_conversion_exn params inner_args outer_args] - case 1: - {{ - (fun params -> wrap (primitive (inner_args)) args - }} - when [inner_args] are the same as [params], it can be simplified as - [wrap (primitive args)] - - where [wrap] used to be simple instructions - Note that [external] functions are forced to do eta-conversion - when combined with [|>] operator, we need to make sure beta-reduction - is applied though since `[@variadic]` needs such guarantee. - Since `[@variadic] is the tail position -*) -let rec is_eta_conversion_exn params inner_args outer_args : t list = - match (params, inner_args, outer_args) with - | x :: xs, Lvar y :: ys, r :: rest when Ident.same x y -> - r :: is_eta_conversion_exn xs ys rest - | [], [], [] -> [] - | _, _, _ -> raise_notrace Not_simple_form - -(** FIXME: more robust inlining check later, we should inline it before we add stub code*) -let rec apply ?(ap_transformed_jsx = false) fn args (ap_info : ap_info) : t = - match fn with - | Lfunction - { - params; - body = - Lprim - { - primitive = - ( Pnull_to_opt | Pnull_undefined_to_opt | Pis_null - | Pis_null_undefined | Ptypeof ) as wrap; - args = - [Lprim ({primitive = _; args = inner_args} as primitive_call)]; - }; - } -> ( - match is_eta_conversion_exn params inner_args args with - | args -> - let loc = ap_info.ap_loc in - Lprim - {primitive = wrap; args = [Lprim {primitive_call with args; loc}]; loc} - | exception Not_simple_form -> - Lapply {ap_func = fn; ap_args = args; ap_info; ap_transformed_jsx}) - | Lfunction - { - params; - body = Lprim ({primitive = _; args = inner_args} as primitive_call); - } -> ( - match is_eta_conversion_exn params inner_args args with - | args -> Lprim {primitive_call with args; loc = ap_info.ap_loc} - | exception _ -> - Lapply {ap_func = fn; ap_args = args; ap_info; ap_transformed_jsx}) - | Lfunction - { - params; - body = - Lsequence - ( Lprim ({primitive = _; args = inner_args} as primitive_call), - (Lconst _ as const) ); - } -> ( - match is_eta_conversion_exn params inner_args args with - | args -> - Lsequence (Lprim {primitive_call with args; loc = ap_info.ap_loc}, const) - | exception _ -> - Lapply {ap_func = fn; ap_args = args; ap_info; ap_transformed_jsx} - (* | Lfunction {params;body} when Ext_list.same_length params args -> - Ext_list.fold_right2 (fun p arg acc -> - Llet(Strict,p,arg,acc) - ) params args body *) - (* TODO: more rigirous analysis on [let_kind] *)) - | Llet (kind, id, e, (Lfunction _ as fn)) -> - Llet (kind, id, e, apply fn args ap_info ~ap_transformed_jsx) - (* | Llet (kind0, id0, e0, Llet (kind,id, e, (Lfunction _ as fn))) -> - Llet(kind0,id0,e0,Llet (kind, id, e, apply fn args loc status)) *) - | _ -> Lapply {ap_func = fn; ap_args = args; ap_info; ap_transformed_jsx} - -let rec eq_approx (l1 : t) (l2 : t) = - match l1 with - | Lglobal_module i1 -> ( - match l2 with - | Lglobal_module i2 -> Ident.same i1 i2 - | _ -> false) - | Lvar i1 -> ( - match l2 with - | Lvar i2 -> Ident.same i1 i2 - | _ -> false) - | Lconst c1 -> ( - match l2 with - | Lconst c2 -> Lam_constant.eq_approx c1 c2 - | _ -> false) - | Lapply app1 -> ( - match l2 with - | Lapply app2 -> - eq_approx app1.ap_func app2.ap_func - && eq_approx_list app1.ap_args app2.ap_args - | _ -> false) - | Lifthenelse (a, b, c) -> ( - match l2 with - | Lifthenelse (a0, b0, c0) -> - eq_approx a a0 && eq_approx b b0 && eq_approx c c0 - | _ -> false) - | Lsequence (a, b) -> ( - match l2 with - | Lsequence (a0, b0) -> eq_approx a a0 && eq_approx b b0 - | _ -> false) - | Lbreak -> l2 = Lbreak - | Lcontinue -> l2 = Lcontinue - | Lwhile (p, b) -> ( - match l2 with - | Lwhile (p0, b0) -> eq_approx p p0 && eq_approx b b0 - | _ -> false) - | Lassign (v0, l0) -> ( - match l2 with - | Lassign (v1, l1) -> Ident.same v0 v1 && eq_approx l0 l1 - | _ -> false) - | Lstaticraise (id, ls) -> ( - match l2 with - | Lstaticraise (id1, ls1) -> id = id1 && eq_approx_list ls ls1 - | _ -> false) - | Lprim info1 -> ( - match l2 with - | Lprim info2 -> - Lam_primitive.eq_primitive_approx info1.primitive info2.primitive - && eq_approx_list info1.args info2.args - | _ -> false) - | Lstringswitch (arg, patterns, default) -> ( - match l2 with - | Lstringswitch (arg2, patterns2, default2) -> - eq_approx arg arg2 && eq_option default default2 - && Ext_list.for_all2_no_exn patterns patterns2 - (fun ((k : string), v) (k2, v2) -> k = k2 && eq_approx v v2) - | _ -> false) - | Lfunction _ - | Llet (_, _, _, _) - | Lletrec _ | Lswitch _ | Lstaticcatch _ | Ltrywith _ - | Lfor (_, _, _, _, _) - | Lfor_of (_, _, _) - | Lfor_await_of (_, _, _) -> - false - -and eq_option l1 l2 = - match l1 with - | None -> l2 = None - | Some l1 -> ( - match l2 with - | Some l2 -> eq_approx l1 l2 - | None -> false) - -and eq_approx_list ls ls1 = Ext_list.for_all2_no_exn ls ls1 eq_approx - -let switch lam (lam_switch : lambda_switch) : t = - let action_or_switch = function - | Some action -> action - | None -> ( - match lam_switch.sw_failaction with - | Some action -> action - | None -> Lswitch (lam, lam_switch)) - in - match lam with - | Lconst (Const_constructor cstr_name) -> - let action = - Ext_list.find_opt lam_switch.sw_consts (fun (key, action) -> - match key with - | Lambda.Switch_constructor (Constant tag) when cstr_name = tag -> - Some action - | Switch_int _ | Switch_constructor _ -> None) - in - action_or_switch action - | 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 - let action = - Ext_list.find_opt lam_switch.sw_consts (fun (key, action) -> - match key with - | Lambda.Switch_int ordinal when ordinal = i -> Some action - | Switch_constructor - (Constant {tag_type = Some (Variant_runtime.Int value)}) - when value = i -> - Some action - | Switch_int _ | Switch_constructor _ -> None) - in - action_or_switch action - | Lconst (Const_block (tag_info, _)) -> - let runtime = - match tag_info with - | Lambda.Blk_constructor {runtime} | Blk_record_inlined {runtime} -> - Some runtime - | Blk_tuple | Blk_poly_var | Blk_record _ | Blk_record_ext _ - | Blk_module _ | Blk_module_export _ | Blk_extension -> - None - in - let action = - Ext_list.find_opt lam_switch.sw_blocks (fun (key, action) -> - match key with - | Switch_constructor (Block {runtime = case_runtime}) - when runtime = Some case_runtime -> - Some action - | Lambda.Switch_int _ | Switch_constructor _ -> None) - in - action_or_switch action - | _ -> Lswitch (lam, lam_switch) - -let stringswitch (lam : t) cases default : t = - match lam with - | Lconst (Const_string {s; delim = None | Some DNoQuotes}) -> - Ext_list.assoc_by_string cases s default - | _ -> Lstringswitch (lam, cases, default) - -let true_ : t = Lconst Const_js_true -let false_ : t = Lconst Const_js_false -let unit : t = Lconst (Const_js_undefined {is_unit = true}) -let break : t = Lbreak -let continue : t = Lcontinue - -let rec seq (a : t) b : t = - match a with - | Lprim {primitive = Pmakeblock _; args = x :: xs} -> - seq (Ext_list.fold_left xs x seq) b - | Lprim {primitive = Pnull_to_opt | Pnull_undefined_to_opt; args = [a]} -> - seq a b - | _ -> Lsequence (a, b) - -let var id : t = Lvar id -let global_module id = Lglobal_module id -let const ct : t = Lconst ct - -let function_ ~loc ~attr ~params ~body : t = Lfunction {params; body; attr; loc} - -let let_ kind id e body : t = Llet (kind, id, e, body) -let letrec bindings body : t = Lletrec (bindings, body) -let while_ a b : t = Lwhile (a, b) -let try_ body id handler : t = Ltrywith (body, id, handler) -let for_ v e1 e2 dir e3 : t = Lfor (v, e1, e2, dir, e3) -let for_of v e1 e2 : t = Lfor_of (v, e1, e2) -let for_await_of v e1 e2 : t = Lfor_await_of (v, e1, e2) -let assign v l : t = Lassign (v, l) -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) - - let bool b = if b then true_ else false_ - - let string s : t = Lconst (Const_string {s; delim = None}) - - let char b : t = Lconst (Const_char b) -end - -let prim ~primitive:(prim : Lam_primitive.t) ~args loc : t = - let default () : t = Lprim {primitive = prim; args; loc} in - match args with - | [Lconst a] -> ( - match (prim, a) with - | Pnegint, Const_int i -> Lift.int (Int32.neg i) - (* | Pfloatofint, ( (Const_int a)) *) - (* -> Lift.float (float_of_int a) *) - | Pintoffloat, Const_float a -> - Lift.int (Int32.of_float (float_of_string a)) - (* | Pnegfloat -> Lift.float (-. a) *) - | Pstringlength, Const_string {s; delim = None} -> - Lift.int (Int32.of_int (String.length s)) - (* | Pnegbint Pnativeint, ( (Const_nativeint i)) *) - (* -> *) - (* Lift.nativeint (Nativeint.neg i) *) - | Pnot, Const_js_true -> false_ - | Pnot, Const_js_false -> true_ - | _ -> default ()) - | [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 b) - | Pfloatcomp cmp, Const_float a, Const_float b -> - (* FIXME: could raise? *) - Lift.bool - (Lam_compat.cmp_float cmp (float_of_string a) (float_of_string b)) - | Pbigintcomp cmp, Const_bigint _, Const_bigint _ -> default () - | Pintcomp ((Ceq | Cneq) as op), Const_polyvar a, Const_polyvar b -> - Lift.bool - (match op with - | Ceq -> a = (b : string) - | Cneq -> a <> b - | _ -> assert false) - | ( Pintcomp ((Ceq | Cneq) as op), - Const_constructor {name = a; tag_type = None}, - Const_constructor {name = b; tag_type = None} ) -> - (* Both runtime representations are the constructor names *) - Lift.bool - (match op with - | Ceq -> a = b - | Cneq -> a <> b - | _ -> assert false) - | ( ( Paddint | Psubint | Pmulint | Pdivint | Pmodint | Pandint | Porint - | Pxorint | Plslint | Plsrint | Pasrint ), - Const_int aa, - Const_int bb ) -> ( - (* WE SHOULD keep it as [int], to preserve types *) - let int_ = Lift.int in - match prim with - | Paddint -> int_ (Int32.add aa bb) - | Psubint -> int_ (Int32.sub aa bb) - | Pmulint -> int_ (Int32.mul aa bb) - | Pdivint -> if bb = 0l then default () else int_ (Int32.div aa bb) - | Pmodint -> if bb = 0l then default () else int_ (Int32.rem aa bb) - | Pandint -> int_ (Int32.logand aa bb) - | Porint -> int_ (Int32.logor aa bb) - | Pxorint -> int_ (Int32.logxor aa bb) - | Plslint -> int_ (Int32.shift_left aa (Int32.to_int bb)) - | Plsrint -> int_ (Int32.shift_right_logical aa (Int32.to_int bb)) - | Pasrint -> int_ (Int32.shift_right aa (Int32.to_int bb)) - | _ -> default ()) - | Psequand, Const_js_false, (Const_js_true | Const_js_false) -> false_ - | Psequand, Const_js_true, Const_js_true -> true_ - | Psequand, Const_js_true, Const_js_false -> false_ - | Psequor, Const_js_true, (Const_js_true | Const_js_false) -> true_ - | Psequor, Const_js_false, Const_js_true -> true_ - | Psequor, Const_js_false, Const_js_false -> false_ - | ( Pstringadd, - Const_string {s = a; delim = None}, - Const_string {s = b; delim = None} ) -> - Lift.string (a ^ b) - | ( (Pstringrefs | Pstringrefu), - Const_string {s = a; delim = None}, - Const_int b ) -> ( - try Lift.char (Char.code (String.get a (Int32.to_int b))) - with _ -> default ()) - | _ -> default ()) - | _ -> ( - match prim with - | Pmakeblock (Blk_module fields) -> ( - let rec aux fields args (var : Ident.t) i = - match (fields, args) with - | [], [] -> true - | ( f :: fields, - Lprim - { - primitive = Pfield (pos, Fld_module {name = f1}); - args = [(Lglobal_module v1 | Lvar v1)]; - } - :: args ) -> - pos = i && f = f1 && Ident.same var v1 && aux fields args var (i + 1) - | _, _ -> false - in - match (fields, args) with - | ( field1 :: rest, - Lprim - { - primitive = Pfield (pos, Fld_module {name = f1}); - args = [((Lglobal_module v1 | Lvar v1) as lam)]; - } - :: args1 ) -> - if pos = 0 && field1 = f1 && aux rest args1 v1 1 then lam - else default () - | _ -> default ()) - (* In this level, include is already expanded, so that - {[ - { x0 : y0 ; x1 : y1 } - ]} - such module x can indeed be replaced by module y - *) - | _ -> default ()) - -let not_ loc x : t = - match x with - | Lprim ({primitive = Pintcomp Cneq} as prim) -> - Lprim {prim with primitive = Pintcomp Ceq} - | _ -> prim ~primitive:Pnot ~args:[x] loc - -let has_boolean_type (x : t) = - match x with - | Lprim - { - primitive = - ( Pnot | Psequand | Psequor | Pis_not_none | Pobjcomp _ | Pboolcomp _ - | Pintcomp _ | Pfloatcomp _ | Pbigintcomp _ | Pstringcomp _ ); - loc; - } -> - Some loc - | _ -> None - -let rec eval_const_as_bool (v : Lam_constant.t) : bool option = - match v with - | 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 _ - -> - Some false - | Const_js_true | Const_string _ | Const_polyvar _ | Const_float _ - | Const_bigint _ | Const_block _ -> - Some true - | Const_some b -> eval_const_as_bool b - | Const_constructor {name; tag_type} -> ( - (* Truthiness of the canonical runtime representation *) - match tag_type with - | None -> Some (name <> "[]") (* the name string; [] is the number 0 *) - | Some (String s) -> Some (s <> "") - | Some (Int i) -> Some (i <> 0) - | Some (Bool b) -> Some b - | Some Null | Some Undefined -> Some false - | Some (Float _ | BigInt _ | Untagged _) -> None) - -let if_ (a : t) (b : t) (c : t) : t = - match a with - | Lconst v -> ( - match eval_const_as_bool v with - | Some v -> if v then b else c - | None -> Lifthenelse (a, b, c)) - | _ -> ( - match (b, c) with - | _, Lconst Const_assertfalse -> - seq a b (* TODO: we could customize more cases *) - | 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 -> ( - match has_boolean_type a with - | Some loc -> not_ loc a - | None -> Lifthenelse (a, b, c)) - | _ -> ( - match a with - | Lprim {primitive = Pisint; args = [Lvar i]; _} -> ( - match b with - | Lifthenelse - (Lprim {primitive = Pintcomp Ceq; args = [Lvar j; Lconst _]}, _, b_f) - when Ident.same i j && eq_approx b_f c -> - b - | Lprim {primitive = Pintcomp Ceq; args = [Lvar j; Lconst _]} - when Ident.same i j && eq_approx false_ c -> - b - | Lifthenelse - ( Lprim - ({primitive = Pintcomp Cneq; args = [Lvar j; Lconst _]} as - b_pred), - b_t, - b_f ) - when Ident.same i j && eq_approx b_t c -> - Lifthenelse (Lprim {b_pred with primitive = Pintcomp Ceq}, b_f, b_t) - | Lprim - {primitive = Pintcomp Cneq; args = [Lvar j; Lconst _] as args; loc} - | Lprim - { - primitive = Pnot; - args = - [ - Lprim - { - primitive = Pintcomp Ceq; - args = [Lvar j; Lconst _] as args; - loc; - }; - ]; - } - when Ident.same i j && eq_approx true_ c -> - Lprim {primitive = Pintcomp Cneq; args; loc} - | _ -> Lifthenelse (a, b, c)) - | _ -> Lifthenelse (a, b, c))) - -(* TODO: the smart constructor is not exploited yet*) -(* [l || r ] *) -let sequor l r = if_ l true_ r - -(** [l && r ] *) -let sequand l r = if_ l r false_ - -(** [shallow_map_sharing f lam] rewrites [lam]'s immediate children with [f] - and rebuilds the node through its smart constructor, so the result is - normalized. A node whose children all come back physically unchanged is - returned as-is, so a traversal that rewrites nothing allocates nothing. *) -let shallow_map_sharing (f : t -> t) (lam : t) : t = - match lam with - | Lvar _ | Lglobal_module _ | Lconst _ | Lbreak | Lcontinue -> lam - | Lapply ap -> - let fn = f ap.ap_func in - let args = Ext_list.map_sharing ap.ap_args f in - if fn == ap.ap_func && args == ap.ap_args then lam - else apply fn args ap.ap_info ~ap_transformed_jsx:ap.ap_transformed_jsx - | Lfunction {params; body; attr; loc} -> - let body' = f body in - if body' == body then lam else function_ ~loc ~attr ~params ~body:body' - | Llet (k, id, e, b) -> - let e' = f e and b' = f b in - if e' == e && b' == b then lam else let_ k id e' b' - | Lletrec (bs, b) -> - let bs' = Ext_list.map_snd_sharing bs f and b' = f b in - if bs' == bs && b' == b then lam else letrec bs' b' - | Lprim {primitive; args; loc} -> - let args' = Ext_list.map_sharing args f in - if args' == args then lam else prim ~primitive ~args:args' loc - | Lswitch (e, sw) -> - let e' = f e in - let consts = Ext_list.map_snd_sharing sw.sw_consts f in - let blocks = Ext_list.map_snd_sharing sw.sw_blocks f in - let fail = Ext_option.map_sharing sw.sw_failaction f in - if - e' == e && consts == sw.sw_consts && blocks == sw.sw_blocks - && fail == sw.sw_failaction - then lam - else - switch e' - {sw with sw_consts = consts; sw_blocks = blocks; sw_failaction = fail} - | Lstringswitch (e, cases, d) -> - let e' = f e in - let cases' = Ext_list.map_snd_sharing cases f in - let d' = Ext_option.map_sharing d f in - if e' == e && cases' == cases && d' == d then lam - else stringswitch e' cases' d' - | Lstaticraise (i, args) -> - let args' = Ext_list.map_sharing args f in - if args' == args then lam else staticraise i args' - | Lstaticcatch (b, h, hd) -> - let b' = f b and hd' = f hd in - if b' == b && hd' == hd then lam else staticcatch b' h hd' - | Ltrywith (b, id, h) -> - let b' = f b and h' = f h in - if b' == b && h' == h then lam else try_ b' id h' - | Lifthenelse (a, b, c) -> - let a' = f a and b' = f b and c' = f c in - if a' == a && b' == b && c' == c then lam else if_ a' b' c' - | Lsequence (a, b) -> - let a' = f a and b' = f b in - if a' == a && b' == b then lam else seq a' b' - | Lwhile (a, b) -> - let a' = f a and b' = f b in - if a' == a && b' == b then lam else while_ a' b' - | Lfor (id, a, b, d, c) -> - let a' = f a and b' = f b and c' = f c in - if a' == a && b' == b && c' == c then lam else for_ id a' b' d c' - | Lfor_of (id, a, b) -> - let a' = f a and b' = f b in - if a' == a && b' == b then lam else for_of id a' b' - | Lfor_await_of (id, a, b) -> - let a' = f a and b' = f b in - if a' == a && b' == b then lam else for_await_of id a' b' - | Lassign (id, b) -> - let b' = f b in - if b' == b then lam else assign id b' +type ident = Ident.t +type lambda_switch = Lambda.lambda_switch +type apply = Lambda.lambda_apply +type lfunction = Lambda.lfunction +type prim_info = Lambda.prim_info +type t = Lambda.lambda + +(* Lam and Lambda are one type. What is left here is the naming the optimizer + uses; the constructors, their normalizations and the traversals all live in + Lambda. *) + +let var = Lambda.var +let global_module = Lambda.global_module +let const = Lambda.const +let apply = Lambda.apply +let function_ = Lambda.function_ +let let_ = Lambda.let_ +let letrec = Lambda.letrec +let prim = Lambda.prim +let switch = Lambda.switch +let stringswitch = Lambda.stringswitch +let staticraise = Lambda.staticraise +let staticcatch = Lambda.staticcatch +let try_ = Lambda.try_ +let if_ = Lambda.if_ +let seq = Lambda.seq +let break = Lambda.break +let continue = Lambda.continue +let while_ = Lambda.while_ +let for_ = Lambda.for_ +let for_of = Lambda.for_of +let for_await_of = Lambda.for_await_of +let assign = Lambda.assign +let not_ = Lambda.not_ +let sequor = Lambda.sequor +let sequand = Lambda.sequand +let false_ = Lambda.lambda_false +let unit = Lambda.lambda_unit +let shallow_map_sharing = Lambda.shallow_map_sharing +let eq_approx = Lambda.eq_approx diff --git a/compiler/core/lam.mli b/compiler/core/lam.mli index d1caf80bda9..9620140360f 100644 --- a/compiler/core/lam.mli +++ b/compiler/core/lam.mli @@ -29,61 +29,22 @@ type ap_info = Lambda.ap_info = { type ident = Ident.t -type lambda_switch = t Lambda.switch +type lambda_switch = Lambda.lambda_switch -and apply = private { - ap_func: t; - ap_args: t list; - ap_info: ap_info; - ap_transformed_jsx: bool; -} +type apply = Lambda.lambda_apply -and lfunction = { - params: ident list; - body: t; - attr: Lambda.function_attribute; - loc: Location.t; -} +type lfunction = Lambda.lfunction -and prim_info = private { - primitive: Lam_primitive.t; - args: t list; - loc: Location.t; -} +type prim_info = Lambda.prim_info -and t = private - | Lvar of ident - | Lglobal_module of ident - | Lconst of Lam_constant.t - | Lapply of apply - | Lfunction of lfunction - | Llet of Lam_compat.let_kind * ident * t * t - | Lletrec of (ident * t) list * t - | Lprim of prim_info - | Lswitch of t * lambda_switch - | Lstringswitch of t * (string * t) list * t option - | Lstaticraise of int * t list - | Lstaticcatch of t * (int * ident list) * t - | Ltrywith of t * ident * t - | Lifthenelse of t * t * t - | Lsequence of t * t - | Lbreak - | Lcontinue - | Lwhile of t * t - | Lfor of ident * t * t * Asttypes.direction_flag * t - | Lfor_of of ident * t * t - | Lfor_await_of of ident * t * t - | Lassign of ident * t - -(* | Levent of t * Lambda.lambda_event - [Levent] in the branch hurt pattern match, - we should use record for trivial debugger info -*) +type t = Lambda.lambda +(** The optimizer's name for {!Lambda.lambda}. It is the same type: the + constructors, their normalizations and the traversals live in Lambda, and + the type is private there, so a term can only be built through them. *) (**************************************************************) val var : ident -> t -(** Smart constructors *) val global_module : ident -> t @@ -103,30 +64,22 @@ val let_ : Lam_compat.let_kind -> ident -> t -> t -> t val letrec : (ident * t) list -> t -> t val if_ : t -> t -> t -> t -(** constant folding *) val switch : t -> lambda_switch -> t -(** constant folding*) val stringswitch : t -> (string * t) list -> t option -> t -(** constant folding*) -(* val true_ : t *) val false_ : t val unit : t val sequor : t -> t -> t -(** convert [l || r] to [if l then true else r]*) val sequand : t -> t -> t -(** convert [l && r] to [if l then r else false *) val not_ : Location.t -> t -> t -(** constant folding *) val seq : t -> t -> t -(** drop unused block *) val break : t @@ -134,13 +87,11 @@ val continue : t val while_ : t -> t -> t -(* val event : t -> Lambda.lambda_event -> t *) val try_ : t -> ident -> t -> t val assign : ident -> t -> t val prim : primitive:Lam_primitive.t -> args:t list -> Location.t -> t -(** constant folding *) val staticcatch : t -> int * ident list -> t -> t @@ -155,8 +106,5 @@ val for_await_of : ident -> t -> t -> t (**************************************************************) val shallow_map_sharing : (t -> t) -> t -> t -(** Rewrite a node's immediate children, rebuilding through the smart - constructors. A node whose children are all physically unchanged is - returned as-is, so a traversal that rewrites nothing allocates nothing. *) val eq_approx : t -> t -> bool diff --git a/compiler/core/lam_analysis.ml b/compiler/core/lam_analysis.ml index 05de1907277..a0c494e1278 100644 --- a/compiler/core/lam_analysis.ml +++ b/compiler/core/lam_analysis.ml @@ -230,7 +230,7 @@ let destruct_pattern (body : Lam.t) params args = match body with | Lswitch (Lvar v, switch) -> ( match aux v params args with - | Some (Lam.Lconst _ as lam) -> + | Some (Lambda.Lconst _ as lam) -> size (Lam.switch lam switch) < small_inline_size | Some _ | None -> false) | Lifthenelse (Lvar v, then_, else_) -> ( diff --git a/compiler/core/lam_compile.ml b/compiler/core/lam_compile.ml index 428f55bf1bd..efbea71c607 100644 --- a/compiler/core/lam_compile.ml +++ b/compiler/core/lam_compile.ml @@ -275,9 +275,9 @@ let compile output_prefix = let rec extract_field_path segments primitive args = match (primitive, args) with | ( Lam_primitive.Pfield (_, Fld_module {name}), - [Lam.Lprim {primitive; args; _}] ) -> + [Lambda.Lprim {primitive; args; _}] ) -> extract_field_path (name :: segments) primitive args - | Lam_primitive.Pfield (_, Fld_module {name}), [Lam.Lglobal_module id] -> + | Lam_primitive.Pfield (_, Fld_module {name}), [Lambda.Lglobal_module id] -> Some (id, name :: segments) | _ -> None in diff --git a/compiler/core/lam_compile_main.ml b/compiler/core/lam_compile_main.ml index 740b58d1404..1039be99208 100644 --- a/compiler/core/lam_compile_main.ml +++ b/compiler/core/lam_compile_main.ml @@ -135,21 +135,22 @@ let js_hoisted_aliases (export_ids : Ident.t list) fields in let rec resolve_binding seen = function - | Lam.Lvar id as lam -> ( + | Lambda.Lvar id as lam -> ( if Set_ident.mem seen id then (lam, Some id) else match Map_ident.find_opt group_map id with | Some - ((Lam.Lvar _ | Lam.Lprim {primitive = Lam_primitive.Pfield _; _}) - as alias) -> + (( Lambda.Lvar _ + | Lambda.Lprim {primitive = Lam_primitive.Pfield _; _} ) as alias) + -> resolve_binding (Set_ident.add seen id) alias | Some resolved -> (resolved, Some id) | None -> (lam, Some id)) - | Lam.Lprim {primitive = Lam_primitive.Pfield (pos, _); args = [base]} as - lam -> ( + | Lambda.Lprim {primitive = Lam_primitive.Pfield (pos, _); args = [base]} + as lam -> ( match fst (resolve_binding seen base) with - | Lam.Lprim {primitive = Lam_primitive.Pmakeblock (Blk_module _); args} - -> ( + | Lambda.Lprim + {primitive = Lam_primitive.Pmakeblock (Blk_module _); args} -> ( match List.nth_opt args pos with | Some field -> resolve_binding seen field | None -> (lam, None)) @@ -171,7 +172,7 @@ let js_hoisted_aliases (export_ids : Ident.t list) Some (List.rev positions, binding_id, target) | field :: fields -> ( match resolve Set_ident.empty lam with - | Lam.Lprim + | Lambda.Lprim {primitive = Lam_primitive.Pmakeblock (Blk_module names); args} -> ( match find_field field 0 names args with | Some (pos, arg) -> find_path arg fields ((pos, field) :: positions) @@ -219,7 +220,7 @@ let js_hoisted_aliases (export_ids : Ident.t list) if Set_string.mem occupied_names js_name then let error_loc = match target with - | Lam.Lfunction {loc} -> loc + | Lambda.Lfunction {loc} -> loc | _ -> loc in Location.raise_errorf ~loc:error_loc @@ -275,7 +276,6 @@ let compile (output_prefix : string) export_idents hoisted (lam : Lambda.lambda) Lam_compile_env.reset () in let may_required_modules = Lam_convert.required_modules lam in - let lam = 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 8cc02c9da77..2adc5b2198d 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -36,60 +36,3 @@ let required_modules (lam : Lambda.lambda) : Lam_module_ident.Hash_set.t = in collect lam; required - -let convert (lam : Lambda.lambda) : Lam.t = - let rec convert_aux (lam : Lambda.lambda) : Lam.t = - match lam with - | Lvar x -> Lam.var x - | Lconst x -> Lam.const x - | Lapply {ap_func = fn; ap_args = args; ap_info; ap_transformed_jsx} -> - (* we need do this eargly in case [aux fn] add some wrapper *) - Lam.apply (convert_aux fn) - (Ext_list.map args convert_aux) - ap_info ~ap_transformed_jsx - | Lfunction {params; body; attr; loc} -> - Lam.function_ ~loc ~attr ~params ~body:(convert_aux body) - | Llet (kind, 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) - | Lglobal_module id -> Lam.global_module id - | Lprim {primitive; args; loc} -> - (* [Lam_primitive.t] is [Lambda.primitive]: nothing to translate. *) - Lam.prim ~primitive ~args:(Ext_list.map args convert_aux) loc - | Lswitch (e, s) -> convert_switch e s - | Lstringswitch (e, cases, default) -> - Lam.stringswitch (convert_aux e) - (Ext_list.map_snd cases convert_aux) - (Ext_option.map default convert_aux) - | Lstaticraise (id, args) -> - Lam.staticraise id (Ext_list.map args convert_aux) - | Lstaticcatch (b, (i, ids), handler) -> - Lam.staticcatch (convert_aux b) (i, ids) (convert_aux handler) - | Ltrywith (b, 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) - | Lbreak -> Lam.break - | Lcontinue -> Lam.continue - | Lwhile (b, body) -> Lam.while_ (convert_aux b) (convert_aux body) - | Lfor (id, from_, to_, dir, loop) -> - Lam.for_ id (convert_aux from_) (convert_aux to_) dir (convert_aux loop) - | Lfor_of (id, iterable, body) -> - Lam.for_of id (convert_aux iterable) (convert_aux body) - | 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_switch (e : Lambda.lambda) (s : Lambda.lambda_switch) = - 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 diff --git a/compiler/core/lam_convert.mli b/compiler/core/lam_convert.mli index badee14d1cb..443c6880d70 100644 --- a/compiler/core/lam_convert.mli +++ b/compiler/core/lam_convert.mli @@ -26,8 +26,3 @@ val required_modules : Lambda.lambda -> Lam_module_ident.Hash_set.t (** The other compilation units this one refers to, read off the Lambda term. A reference the optimizer deletes still has to be imported when the module it names is impure. *) - -val convert : Lambda.lambda -> Lam.t -(** [convert lam] translates Lambda to Lam. [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 275ac919033..51661236a9a 100644 --- a/compiler/jsoo/jsoo_playground_main.ml +++ b/compiler/jsoo/jsoo_playground_main.ml @@ -547,8 +547,7 @@ module Compile = struct 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 lambda in - let lam = Lam_print.lambda_to_string lam in + let lam = Lam_print.lambda_to_string lambda in let debug_attrs = Js.Unsafe. [| diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index 89dccf6a73d..7fa7197e7c7 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -1159,6 +1159,79 @@ let if_ (a : lambda) (b : lambda) (c : lambda) : lambda = | _ -> Lifthenelse (a, b, c)) | _ -> Lifthenelse (a, b, c))) +(** [shallow_map_sharing f lam] rewrites [lam]'s immediate children with [f] + and rebuilds the node through its smart constructor, so the result is + normalized. A node whose children all come back physically unchanged is + returned as-is, so a traversal that rewrites nothing allocates nothing. *) +let shallow_map_sharing (f : lambda -> lambda) (lam : lambda) : lambda = + match lam with + | Lvar _ | Lglobal_module _ | Lconst _ | Lbreak | Lcontinue -> lam + | Lapply ap -> + let fn = f ap.ap_func in + let args = Ext_list.map_sharing ap.ap_args f in + if fn == ap.ap_func && args == ap.ap_args then lam + else apply fn args ap.ap_info ~ap_transformed_jsx:ap.ap_transformed_jsx + | Lfunction {params; body; attr; loc} -> + let body' = f body in + if body' == body then lam else function_ ~loc ~attr ~params ~body:body' + | Llet (k, id, e, b) -> + let e' = f e and b' = f b in + if e' == e && b' == b then lam else let_ k id e' b' + | Lletrec (bs, b) -> + let bs' = Ext_list.map_snd_sharing bs f and b' = f b in + if bs' == bs && b' == b then lam else letrec bs' b' + | Lprim {primitive; args; loc} -> + let args' = Ext_list.map_sharing args f in + if args' == args then lam else prim ~primitive ~args:args' loc + | Lswitch (e, sw) -> + let e' = f e in + let consts = Ext_list.map_snd_sharing sw.sw_consts f in + let blocks = Ext_list.map_snd_sharing sw.sw_blocks f in + let fail = Ext_option.map_sharing sw.sw_failaction f in + if + e' == e && consts == sw.sw_consts && blocks == sw.sw_blocks + && fail == sw.sw_failaction + then lam + else + switch e' + {sw with sw_consts = consts; sw_blocks = blocks; sw_failaction = fail} + | Lstringswitch (e, cases, d) -> + let e' = f e in + let cases' = Ext_list.map_snd_sharing cases f in + let d' = Ext_option.map_sharing d f in + if e' == e && cases' == cases && d' == d then lam + else stringswitch e' cases' d' + | Lstaticraise (i, args) -> + let args' = Ext_list.map_sharing args f in + if args' == args then lam else staticraise i args' + | Lstaticcatch (b, h, hd) -> + let b' = f b and hd' = f hd in + if b' == b && hd' == hd then lam else staticcatch b' h hd' + | Ltrywith (b, id, h) -> + let b' = f b and h' = f h in + if b' == b && h' == h then lam else try_ b' id h' + | Lifthenelse (a, b, c) -> + let a' = f a and b' = f b and c' = f c in + if a' == a && b' == b && c' == c then lam else if_ a' b' c' + | Lsequence (a, b) -> + let a' = f a and b' = f b in + if a' == a && b' == b then lam else seq a' b' + | Lwhile (a, b) -> + let a' = f a and b' = f b in + if a' == a && b' == b then lam else while_ a' b' + | Lfor (id, a, b, d, c) -> + let a' = f a and b' = f b and c' = f c in + if a' == a && b' == b && c' == c then lam else for_ id a' b' d c' + | Lfor_of (id, a, b) -> + let a' = f a and b' = f b in + if a' == a && b' == b then lam else for_of id a' b' + | Lfor_await_of (id, a, b) -> + let a' = f a and b' = f b in + if a' == a && b' == b then lam else for_await_of id a' b' + | Lassign (id, b) -> + let b' = f b in + if b' == b then lam else assign id b' + let sequor l r = if_ l lambda_true r (** [l && r] *) diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index 096939f9fc4..13dea6e7b04 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -528,6 +528,12 @@ val lambda_true : lambda val lambda_false : lambda +val shallow_map_sharing : (lambda -> lambda) -> lambda -> lambda +(** Rewrite a node's immediate children, rebuilding through the constructors + so the result is normalized. A node whose children are all physically + unchanged is returned as-is, so a traversal that rewrites nothing + allocates nothing. *) + val eq_approx : lambda -> lambda -> bool val mk_builtin : builtin -> lambda list -> Location.t -> lambda From 87ecd27165c7bcbfaa120b7a2b280090fdb0c92e Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 1 Sep 2026 20:07:48 +0200 Subject: [PATCH 35/46] Delete the Lam re-export shells Lam_tag_info, Lam_constant, Lam_primitive and Lam_compat had become re-exports standing between the core and types it already shared with Lambda: a manifest alias, a delegation or two, and one or two real functions each. The real functions move down - const_is_allocating, is_immutable_block, str_of_field_info - and the four modules go. Every reference names Lambda now, including the constructors the shells re-exported: Lam_compat.Strict, Lam_compat.Fld_module, Lam_primitive.Pfield and the rest. Seven files deleted, 44 touched. Generated JavaScript is unchanged. Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/core/js_exp_make.ml | 12 +- compiler/core/js_exp_make.mli | 12 +- compiler/core/js_of_lam_block.ml | 8 +- compiler/core/js_of_lam_block.mli | 6 +- compiler/core/js_op.ml | 4 +- compiler/core/js_stmt_make.mli | 10 +- compiler/core/lam.mli | 6 +- compiler/core/lam_analysis.ml | 2 +- compiler/core/lam_beta_reduce.ml | 4 +- compiler/core/lam_coercion.ml | 2 +- compiler/core/lam_compat.ml | 67 ------- compiler/core/lam_compat.mli | 52 ------ compiler/core/lam_compile.ml | 16 +- compiler/core/lam_compile_const.ml | 6 +- compiler/core/lam_compile_const.mli | 2 +- compiler/core/lam_compile_context.ml | 2 +- compiler/core/lam_compile_context.mli | 2 +- compiler/core/lam_compile_main.ml | 19 +- compiler/core/lam_compile_primitive.ml | 2 +- compiler/core/lam_compile_primitive.mli | 2 +- compiler/core/lam_compile_util.ml | 4 +- compiler/core/lam_compile_util.mli | 4 +- compiler/core/lam_group.ml | 6 +- compiler/core/lam_group.mli | 4 +- compiler/core/lam_id_kind.ml | 2 +- compiler/core/lam_id_kind.mli | 2 +- compiler/core/lam_iter.ml | 5 +- compiler/core/lam_pass_collect.ml | 2 +- compiler/core/lam_pass_deep_flatten.ml | 4 +- compiler/core/lam_pass_lets_dce.ml | 4 +- compiler/core/lam_pass_remove_alias.ml | 2 +- compiler/core/lam_primitive.ml | 179 ------------------- compiler/core/lam_primitive.mli | 174 ------------------ compiler/core/lam_print.ml | 8 +- compiler/core/lam_print.mli | 2 +- compiler/core/lam_stats_export.ml | 2 +- compiler/core/lam_tag_info.ml | 30 ---- compiler/core/lam_util.ml | 8 +- compiler/core/lam_util.mli | 2 +- compiler/frontend/lam_constant.ml | 57 ------ compiler/frontend/lam_constant.mli | 49 ----- compiler/ml/lambda.ml | 26 +++ compiler/ml/lambda.mli | 8 + tests/ounit_tests/ounit_js_analyzer_tests.ml | 6 +- 44 files changed, 126 insertions(+), 700 deletions(-) delete mode 100644 compiler/core/lam_compat.ml delete mode 100644 compiler/core/lam_compat.mli delete mode 100644 compiler/core/lam_primitive.ml delete mode 100644 compiler/core/lam_primitive.mli delete mode 100644 compiler/core/lam_tag_info.ml delete mode 100644 compiler/frontend/lam_constant.ml delete mode 100644 compiler/frontend/lam_constant.mli diff --git a/compiler/core/js_exp_make.ml b/compiler/core/js_exp_make.ml index 6081b289e84..5e8d25b979c 100644 --- a/compiler/core/js_exp_make.ml +++ b/compiler/core/js_exp_make.ml @@ -308,7 +308,7 @@ let method_ ?comment ?immutable_mask ~async ~return_unit params body : t = } (** ATTENTION: This is coupuled with {!Caml_obj.caml_update_dummy} *) -let dummy_obj ?comment (info : Lam_tag_info.t) : t = +let dummy_obj ?comment (info : Lambda.tag_info) : t = (* TODO: for record it is [{}] for other it is [[]] @@ -1443,7 +1443,7 @@ let to_int32 ?comment (e : J.expression) : J.expression = int32_bor ?comment e zero_int_literal (* TODO: if we already know the input is int32, [x|0] can be reduced into [x] *) -let string_comp (cmp : Lam_compat.comparison) ?comment (e0 : t) (e1 : t) = +let string_comp (cmp : Lambda.comparison) ?comment (e0 : t) (e1 : t) = match (e0.expression_desc, e1.expression_desc) with | Str {txt = a0; delim = d0}, Str {txt = a1; delim = d1} -> ( match (cmp, str_equal a0 d0 a1 d1) with @@ -1462,7 +1462,7 @@ let is_type_object (e : t) : t = string_equal (typeof e) (str "object") let obj_length ?comment e : t = to_int32 {expression_desc = Length e; comment; source_loc = None} -let compare_int_aux (cmp : Lam_compat.comparison) (l : int) r = +let compare_int_aux (cmp : Lambda.comparison) (l : int) r = match cmp with | Ceq -> l = r | Cneq -> l <> r @@ -1471,7 +1471,7 @@ let compare_int_aux (cmp : Lam_compat.comparison) (l : int) r = | Cle -> l <= r | Cge -> l >= r -let rec int_comp (cmp : Lam_compat.comparison) ?comment (e0 : t) (e1 : t) = +let rec int_comp (cmp : Lambda.comparison) ?comment (e0 : t) (e1 : t) = match (cmp, e0.expression_desc, e1.expression_desc) with | _, Number (Int {i = l}), Number (Int {i = r}) -> let l = Ext_int.int32_unsigned_to_int l in @@ -1499,7 +1499,7 @@ let rec int_comp (cmp : Lam_compat.comparison) ?comment (e0 : t) (e1 : t) = true_ | _ -> bin ?comment (Lam_compile_util.jsop_of_comp cmp) e0 e1 -let bool_comp (cmp : Lam_compat.comparison) ?comment (e0 : t) (e1 : t) = +let bool_comp (cmp : Lambda.comparison) ?comment (e0 : t) (e1 : t) = match (e0, e1) with | {expression_desc = Bool l}, {expression_desc = Bool r} -> bool @@ -1669,7 +1669,7 @@ let rec int32_band ?comment (e1 : J.expression) (e2 : J.expression) : let bigint_op ?comment op (e1 : t) (e2 : t) = bin ?comment op e1 e2 -let bigint_comp (cmp : Lam_compat.comparison) ?comment (e0 : t) (e1 : t) = +let bigint_comp (cmp : Lambda.comparison) ?comment (e0 : t) (e1 : t) = let normalize s = let len = String.length s in let buf = Buffer.create len in diff --git a/compiler/core/js_exp_make.mli b/compiler/core/js_exp_make.mli index 683c49b71b4..459884cd1eb 100644 --- a/compiler/core/js_exp_make.mli +++ b/compiler/core/js_exp_make.mli @@ -230,21 +230,21 @@ val float_mod : ?comment:string -> t -> t -> t val float_pow : ?comment:string -> t -> t -> t -val int_comp : Lam_compat.comparison -> ?comment:string -> t -> t -> t +val int_comp : Lambda.comparison -> ?comment:string -> t -> t -> t -val bool_comp : Lam_compat.comparison -> ?comment:string -> t -> t -> t +val bool_comp : Lambda.comparison -> ?comment:string -> t -> t -> t -val string_comp : Lam_compat.comparison -> ?comment:string -> t -> t -> t +val string_comp : Lambda.comparison -> ?comment:string -> t -> t -> t val bigint_op : ?comment:string -> Js_op.binop -> t -> t -> t -val bigint_comp : Lam_compat.comparison -> ?comment:string -> t -> t -> t +val bigint_comp : Lambda.comparison -> ?comment:string -> t -> t -> t val bigint_div : checked:bool -> ?comment:string -> t -> t -> t val bigint_mod : checked:bool -> ?comment:string -> t -> t -> t -val js_comp : Lam_compat.comparison -> ?comment:string -> t -> t -> t +val js_comp : Lambda.comparison -> ?comment:string -> t -> t -> t val not : t -> t @@ -302,7 +302,7 @@ val in_ : t -> t -> t (** we don't expose a general interface, since a general interface is generally not safe *) -val dummy_obj : ?comment:string -> Lam_tag_info.t -> t +val dummy_obj : ?comment:string -> Lambda.tag_info -> t (** used combined with [caml_update_dummy]*) val of_block : ?comment:string -> ?e:J.expression -> J.statement list -> t diff --git a/compiler/core/js_of_lam_block.ml b/compiler/core/js_of_lam_block.ml index 82a4609a6f7..27c00d38ea4 100644 --- a/compiler/core/js_of_lam_block.ml +++ b/compiler/core/js_of_lam_block.ml @@ -24,13 +24,13 @@ module E = Js_exp_make -let make_block mutable_flag (tag_info : Lam_tag_info.t) args = +let make_block mutable_flag (tag_info : Lambda.tag_info) args = E.make_block tag_info args mutable_flag -let field (field_info : Lam_compat.field_dbg_info) e (i : int32) = +let field (field_info : Lambda.field_dbg_info) e (i : int32) = match field_info with | Fld_tuple -> - E.array_index_by_int ?comment:(Lam_compat.str_of_field_info field_info) e i + E.array_index_by_int ?comment:(Lambda.str_of_field_info field_info) e i | Fld_poly_var_content -> E.poly_var_value_access e | Fld_poly_var_tag -> E.poly_var_tag_access e | Fld_record_extension {name} -> E.extension_access e (Some name) i @@ -41,7 +41,7 @@ let field (field_info : Lam_compat.field_dbg_info) e (i : int32) = | Fld_record {name} -> E.record_access e name i | Fld_module {name} -> E.module_access e name i -let set_field (field_info : Lam_compat.set_field_dbg_info) e i e0 = +let set_field (field_info : Lambda.set_field_dbg_info) e i e0 = match field_info with | Fld_record_extension_set name -> E.extension_assign e i name e0 | Fld_record_inline_set name | Fld_record_set name -> diff --git a/compiler/core/js_of_lam_block.mli b/compiler/core/js_of_lam_block.mli index 4e1f0a86df1..c43336ed54d 100644 --- a/compiler/core/js_of_lam_block.mli +++ b/compiler/core/js_of_lam_block.mli @@ -25,12 +25,12 @@ (** Utilities for creating block of lambda expression in JS IR *) val make_block : - Js_op.mutable_flag -> Lam_tag_info.t -> J.expression list -> J.expression + Js_op.mutable_flag -> Lambda.tag_info -> J.expression list -> J.expression -val field : Lam_compat.field_dbg_info -> J.expression -> int32 -> J.expression +val field : Lambda.field_dbg_info -> J.expression -> int32 -> J.expression val set_field : - Lam_compat.set_field_dbg_info -> + Lambda.set_field_dbg_info -> J.expression -> int32 -> J.expression -> diff --git a/compiler/core/js_op.ml b/compiler/core/js_op.ml index 3b187075463..c610fc7d78d 100644 --- a/compiler/core/js_op.ml +++ b/compiler/core/js_op.ml @@ -61,7 +61,7 @@ type kind = import_attributes: External_ffi_types.import_attributes option; } -type property = Lam_compat.let_kind = Strict | Alias | StrictOpt | Variable +type property = Lambda.let_kind = Strict | Alias | StrictOpt | Variable type property_name = Lit of string | Symbol_name @@ -113,4 +113,4 @@ type ident_info = {mutable used_stats: used_stats} type exports = Ident.t list -type tag_info = Lam_tag_info.t +type tag_info = Lambda.tag_info diff --git a/compiler/core/js_stmt_make.mli b/compiler/core/js_stmt_make.mli index 98759f2caf2..b3dbcd9b008 100644 --- a/compiler/core/js_stmt_make.mli +++ b/compiler/core/js_stmt_make.mli @@ -30,7 +30,7 @@ val throw_stmt : ?comment:string -> J.expression -> t val if_ : ?comment:string -> - ?declaration:Lam_compat.let_kind * Ident.t -> + ?declaration:Lambda.let_kind * Ident.t -> (* when it's not None, we also need make a variable declaration in the begininnig, however, we can optmize such case *) @@ -47,7 +47,7 @@ val block : ?comment:string -> J.block -> t val int_switch : ?comment:string -> - ?declaration:Lam_compat.let_kind * Ident.t -> + ?declaration:Lambda.let_kind * Ident.t -> ?default:J.block -> J.expression -> (int * J.case_clause) list -> @@ -70,7 +70,7 @@ val int_switch : val string_switch : ?comment:string -> - ?declaration:Lam_compat.let_kind * Ident.t -> + ?declaration:Lambda.let_kind * Ident.t -> ?default:J.block -> J.expression -> (Variant_runtime.tag_type * J.case_clause) list -> @@ -79,7 +79,7 @@ val string_switch : val declare_variable : ?comment:string -> ?ident_info:J.ident_info -> - kind:Lam_compat.let_kind -> + kind:Lambda.let_kind -> Ident.t -> t (** Just declaration without initialization *) @@ -88,7 +88,7 @@ val declare_variable : val define_variable : ?comment:string -> ?ident_info:J.ident_info -> - kind:Lam_compat.let_kind -> + kind:Lambda.let_kind -> Ident.t -> J.expression -> t diff --git a/compiler/core/lam.mli b/compiler/core/lam.mli index 9620140360f..56285b8fe59 100644 --- a/compiler/core/lam.mli +++ b/compiler/core/lam.mli @@ -48,7 +48,7 @@ val var : ident -> t val global_module : ident -> t -val const : Lam_constant.t -> t +val const : Lambda.structured_constant -> t val apply : ?ap_transformed_jsx:bool -> t -> t list -> ap_info -> t @@ -59,7 +59,7 @@ val function_ : body:t -> t -val let_ : Lam_compat.let_kind -> ident -> t -> t -> t +val let_ : Lambda.let_kind -> ident -> t -> t -> t val letrec : (ident * t) list -> t -> t @@ -91,7 +91,7 @@ val try_ : t -> ident -> t -> t val assign : ident -> t -> t -val prim : primitive:Lam_primitive.t -> args:t list -> Location.t -> t +val prim : primitive:Lambda.primitive -> args:t list -> Location.t -> t val staticcatch : t -> int * ident list -> t -> t diff --git a/compiler/core/lam_analysis.ml b/compiler/core/lam_analysis.ml index a0c494e1278..aae2ac3aad6 100644 --- a/compiler/core/lam_analysis.ml +++ b/compiler/core/lam_analysis.ml @@ -23,7 +23,7 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) (**used in effect analysis, it is sound but not-complete *) -let not_zero_constant (x : Lam_constant.t) = +let not_zero_constant (x : Lambda.structured_constant) = match x with | Const_int i -> i <> 0l | Const_assertfalse -> false diff --git a/compiler/core/lam_beta_reduce.ml b/compiler/core/lam_beta_reduce.ml index 0cf3d2531c9..ae6bdd42270 100644 --- a/compiler/core/lam_beta_reduce.ml +++ b/compiler/core/lam_beta_reduce.ml @@ -69,7 +69,7 @@ let propagate_beta_reduce (meta : Lam_stats.t) (params : Ident.t list) Ext_list.fold_left rest_bindings new_body (fun l (param, arg) -> (match arg with | Lprim {primitive = Pmakeblock info; args; _} - when Lam_primitive.is_immutable_block info -> + when Lambda.is_immutable_block info -> Hash_ident.replace meta.ident_tbl param (Lam_util.kind_of_lambda_block args) | Lprim {primitive = Psome | Psome_not_nest; args = [v]; _} -> @@ -112,7 +112,7 @@ let propagate_beta_reduce_with_map (meta : Lam_stats.t) Ext_list.fold_left rest_bindings new_body (fun l (param, (arg : Lam.t)) -> (match arg with | Lprim {primitive = Pmakeblock info; args} - when Lam_primitive.is_immutable_block info -> + when Lambda.is_immutable_block info -> Hash_ident.replace meta.ident_tbl param (Lam_util.kind_of_lambda_block args) | Lprim {primitive = Psome | Psome_not_nest; args = [v]} -> diff --git a/compiler/core/lam_coercion.ml b/compiler/core/lam_coercion.ml index 2ddddc7cfd0..e4f441c4001 100644 --- a/compiler/core/lam_coercion.ml +++ b/compiler/core/lam_coercion.ml @@ -111,7 +111,7 @@ let handle_exports (meta : Lam_stats.t) (lambda_exports : Lam.t list) } else let newid = Ident.rename original_export_id in - let kind : Lam_compat.let_kind = Alias in + let kind : Lambda.let_kind = Alias in Lam_util.alias_ident_or_global meta newid id NA; { acc with diff --git a/compiler/core/lam_compat.ml b/compiler/core/lam_compat.ml deleted file mode 100644 index 744021bda27..00000000000 --- a/compiler/core/lam_compat.ml +++ /dev/null @@ -1,67 +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. *) - -type comparison = Lambda.comparison = Ceq | Cneq | Clt | Cgt | Cle | Cge - -let eq_comparison (p : comparison) (p1 : comparison) = - match p with - | Cge -> p1 = Cge - | Cgt -> p1 = Cgt - | Cle -> p1 = Cle - | Clt -> p1 = Clt - | Ceq -> p1 = Ceq - | Cneq -> p1 = Cneq - -let cmp_int32 = Lambda.cmp_int32 -let cmp_float = Lambda.cmp_float - -type let_kind = Lambda.let_kind = Strict | Alias | StrictOpt | Variable - -type field_dbg_info = Lambda.field_dbg_info = - | Fld_record of {name: string} - | Fld_module of {name: string} - | Fld_record_inline of {name: string} - | Fld_record_extension of {name: string} - | Fld_tuple - | Fld_poly_var_tag - | Fld_poly_var_content - | Fld_extension - | Fld_variant - | Fld_cons - -let str_of_field_info (x : field_dbg_info) : string option = - match x with - | Fld_extension | Fld_variant | Fld_cons | Fld_poly_var_tag - | Fld_poly_var_content | Fld_tuple -> - None - | Fld_record {name; _} - | Fld_module {name; _} - | Fld_record_inline {name} - | Fld_record_extension {name} -> - Some name - -type set_field_dbg_info = Lambda.set_field_dbg_info = - | Fld_record_set of string - | Fld_record_inline_set of string - | Fld_record_extension_set of string diff --git a/compiler/core/lam_compat.mli b/compiler/core/lam_compat.mli deleted file mode 100644 index 00f15725e63..00000000000 --- a/compiler/core/lam_compat.mli +++ /dev/null @@ -1,52 +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. *) - -type comparison = Lambda.comparison = Ceq | Cneq | Clt | Cgt | Cle | Cge - -type let_kind = Lambda.let_kind = Strict | Alias | StrictOpt | Variable - -type field_dbg_info = Lambda.field_dbg_info = - | Fld_record of {name: string} - | Fld_module of {name: string} - | Fld_record_inline of {name: string} - | Fld_record_extension of {name: string} - | Fld_tuple - | Fld_poly_var_tag - | Fld_poly_var_content - | Fld_extension - | Fld_variant - | Fld_cons - -val str_of_field_info : field_dbg_info -> string option - -type set_field_dbg_info = Lambda.set_field_dbg_info = - | Fld_record_set of string - | Fld_record_inline_set of string - | Fld_record_extension_set of string - -val cmp_int32 : comparison -> int32 -> int32 -> bool - -val cmp_float : comparison -> float -> float -> bool - -val eq_comparison : comparison -> comparison -> bool diff --git a/compiler/core/lam_compile.ml b/compiler/core/lam_compile.ml index efbea71c607..5f8ca3bd5ca 100644 --- a/compiler/core/lam_compile.ml +++ b/compiler/core/lam_compile.ml @@ -274,10 +274,10 @@ let compile output_prefix = table. *) let rec extract_field_path segments primitive args = match (primitive, args) with - | ( Lam_primitive.Pfield (_, Fld_module {name}), - [Lambda.Lprim {primitive; args; _}] ) -> + | Lambda.Pfield (_, Fld_module {name}), [Lambda.Lprim {primitive; args; _}] + -> extract_field_path (name :: segments) primitive args - | Lam_primitive.Pfield (_, Fld_module {name}), [Lambda.Lglobal_module id] -> + | Lambda.Pfield (_, Fld_module {name}), [Lambda.Lglobal_module id] -> Some (id, name :: segments) | _ -> None in @@ -563,7 +563,7 @@ let compile output_prefix = cxt:Lam_compile_context.t -> switch: (?default:J.block -> - ?declaration:Lam_compat.let_kind * Ident.t -> + ?declaration:Lambda.let_kind * Ident.t -> _ -> ('a * J.case_clause) list -> J.statement) -> @@ -578,7 +578,7 @@ let compile output_prefix = ~(cxt : Lam_compile_context.t) ~(switch : ?default:J.block -> - ?declaration:Lam_compat.let_kind * Ident.t -> + ?declaration:Lambda.let_kind * Ident.t -> _ -> (a * J.case_clause) list -> J.statement) ~(switch_exp : J.expression) ~(default : default_case) @@ -1762,8 +1762,8 @@ let compile output_prefix = exp | {primitive; args; loc} -> compile_primitive_default primitive args loc and collect_dup_overrides (copy_id : Ident.t) (lam : Lam.t) - (acc : (Lam_compat.set_field_dbg_info * Lam.t) list) : - (Lam_compat.set_field_dbg_info * Lam.t) list option = + (acc : (Lambda.set_field_dbg_info * Lam.t) list) : + (Lambda.set_field_dbg_info * Lam.t) list option = match lam with | Lsequence ( Lprim @@ -1792,7 +1792,7 @@ let compile output_prefix = let blocks, props = List.fold_left (fun (blocks, props) - ((fld_info : Lam_compat.set_field_dbg_info), value_lam) -> + ((fld_info : Lambda.set_field_dbg_info), value_lam) -> let val_output = compile_lambda need_value_cxt value_lam in let val_val = match val_output.value with diff --git a/compiler/core/lam_compile_const.ml b/compiler/core/lam_compile_const.ml index 83dd8bcb520..4cef7f14659 100644 --- a/compiler/core/lam_compile_const.ml +++ b/compiler/core/lam_compile_const.ml @@ -25,7 +25,7 @@ module E = Js_exp_make (** return [val < 0] if not nested [Some (Some (Some None))]*) -let rec is_some_none_aux (x : Lam_constant.t) acc = +let rec is_some_none_aux (x : Lambda.structured_constant) acc = match x with | Const_some v -> is_some_none_aux v (acc + 1) | Const_module_alias | Const_js_undefined _ -> acc @@ -34,14 +34,14 @@ let rec is_some_none_aux (x : Lam_constant.t) acc = let rec nested_some_none n none = if n = 0 then none else nested_some_none (n - 1) (E.optional_block none) -let rec translate_some (x : Lam_constant.t) : J.expression = +let rec translate_some (x : Lambda.structured_constant) : J.expression = let depth = is_some_none_aux x 0 in if depth < 0 then E.optional_not_nest_block (translate x) else nested_some_none depth (E.optional_block (translate (Const_js_undefined {is_unit = false}))) -and translate (x : Lam_constant.t) : J.expression = +and translate (x : Lambda.structured_constant) : J.expression = match x with | Const_module_alias -> E.undefined (* TODO *) | Const_some s -> translate_some s diff --git a/compiler/core/lam_compile_const.mli b/compiler/core/lam_compile_const.mli index 2a97874bee3..30c22414ba5 100644 --- a/compiler/core/lam_compile_const.mli +++ b/compiler/core/lam_compile_const.mli @@ -24,6 +24,6 @@ (** Compile lambda constant to JS *) -val translate : Lam_constant.t -> J.expression +val translate : Lambda.structured_constant -> J.expression val translate_arg_cst : External_arg_spec.cst -> J.expression diff --git a/compiler/core/lam_compile_context.ml b/compiler/core/lam_compile_context.ml index 636f0a254bf..d917b2d77e7 100644 --- a/compiler/core/lam_compile_context.ml +++ b/compiler/core/lam_compile_context.ml @@ -54,7 +54,7 @@ type tail_type = Not_tail | Maybe_tail_is_return of maybe_tail (* have a mutable field to notifiy it's actually triggered *) (* anonoymous function does not have identifier *) -type let_kind = Lam_compat.let_kind +type let_kind = Lambda.let_kind type loop_frame = {mutable label: J.label option} type continuation = diff --git a/compiler/core/lam_compile_context.mli b/compiler/core/lam_compile_context.mli index 6f4b4010cab..9fe27c9888a 100644 --- a/compiler/core/lam_compile_context.mli +++ b/compiler/core/lam_compile_context.mli @@ -41,7 +41,7 @@ type return_label = { type value = {exit_id: Ident.t; bindings: Ident.t list; order_id: int} -type let_kind = Lam_compat.let_kind +type let_kind = Lambda.let_kind type loop_frame = {mutable label: J.label option} type tail = {label: return_label option; in_staticcatch: bool} diff --git a/compiler/core/lam_compile_main.ml b/compiler/core/lam_compile_main.ml index 1039be99208..0aba4dff8ae 100644 --- a/compiler/core/lam_compile_main.ml +++ b/compiler/core/lam_compile_main.ml @@ -129,8 +129,7 @@ let js_hoisted_aliases (export_ids : Ident.t list) | (pos, name) :: fields -> access loc (Lam.prim - ~primitive: - (Lam_primitive.Pfield (pos, Lam_compat.Fld_module {name})) + ~primitive:(Lambda.Pfield (pos, Lambda.Fld_module {name})) ~args:[base] loc) fields in @@ -140,17 +139,15 @@ let js_hoisted_aliases (export_ids : Ident.t list) else match Map_ident.find_opt group_map id with | Some - (( Lambda.Lvar _ - | Lambda.Lprim {primitive = Lam_primitive.Pfield _; _} ) as alias) - -> + ((Lambda.Lvar _ | Lambda.Lprim {primitive = Lambda.Pfield _; _}) + as alias) -> resolve_binding (Set_ident.add seen id) alias | Some resolved -> (resolved, Some id) | None -> (lam, Some id)) - | Lambda.Lprim {primitive = Lam_primitive.Pfield (pos, _); args = [base]} - as lam -> ( + | Lambda.Lprim {primitive = Lambda.Pfield (pos, _); args = [base]} as lam + -> ( match fst (resolve_binding seen base) with - | Lambda.Lprim - {primitive = Lam_primitive.Pmakeblock (Blk_module _); args} -> ( + | Lambda.Lprim {primitive = Lambda.Pmakeblock (Blk_module _); args} -> ( match List.nth_opt args pos with | Some field -> resolve_binding seen field | None -> (lam, None)) @@ -172,8 +169,8 @@ let js_hoisted_aliases (export_ids : Ident.t list) Some (List.rev positions, binding_id, target) | field :: fields -> ( match resolve Set_ident.empty lam with - | Lambda.Lprim - {primitive = Lam_primitive.Pmakeblock (Blk_module names); args} -> ( + | Lambda.Lprim {primitive = Lambda.Pmakeblock (Blk_module names); args} + -> ( match find_field field 0 names args with | Some (pos, arg) -> find_path arg fields ((pos, field) :: positions) | None -> None) diff --git a/compiler/core/lam_compile_primitive.ml b/compiler/core/lam_compile_primitive.ml index 68c96fb5ea6..67fa13cefc3 100644 --- a/compiler/core/lam_compile_primitive.ml +++ b/compiler/core/lam_compile_primitive.ml @@ -71,7 +71,7 @@ let wrap_then_path import (path : string list) = 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 = + (prim : Lambda.primitive) (args : J.expression list) : J.expression = 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 diff --git a/compiler/core/lam_compile_primitive.mli b/compiler/core/lam_compile_primitive.mli index b507f63b1cf..279a47242e6 100644 --- a/compiler/core/lam_compile_primitive.mli +++ b/compiler/core/lam_compile_primitive.mli @@ -32,6 +32,6 @@ val translate : string -> Location.t -> Lam_compile_context.t -> - Lam_primitive.t -> + Lambda.primitive -> J.expression list -> J.expression diff --git a/compiler/core/lam_compile_util.ml b/compiler/core/lam_compile_util.ml index a2c3a48437e..4b23e7715e2 100644 --- a/compiler/core/lam_compile_util.ml +++ b/compiler/core/lam_compile_util.ml @@ -22,7 +22,7 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -let jsop_of_comp (cmp : Lam_compat.comparison) : Js_op.binop = +let jsop_of_comp (cmp : Lambda.comparison) : Js_op.binop = match cmp with | Ceq -> EqEqEq (* comparison*) | Cneq -> NotEqEq @@ -31,7 +31,7 @@ let jsop_of_comp (cmp : Lam_compat.comparison) : Js_op.binop = | Cle -> Le | Cge -> Ge -let runtime_of_comp (cmp : Lam_compat.comparison) : string = +let runtime_of_comp (cmp : Lambda.comparison) : string = match cmp with | Ceq -> "equal" | Cneq -> "notequal" diff --git a/compiler/core/lam_compile_util.mli b/compiler/core/lam_compile_util.mli index 3b12a28ac9f..031bcbd748c 100644 --- a/compiler/core/lam_compile_util.mli +++ b/compiler/core/lam_compile_util.mli @@ -24,6 +24,6 @@ (** Some utilities for lambda compilation*) -val jsop_of_comp : Lam_compat.comparison -> Js_op.binop +val jsop_of_comp : Lambda.comparison -> Js_op.binop -val runtime_of_comp : Lam_compat.comparison -> string +val runtime_of_comp : Lambda.comparison -> string diff --git a/compiler/core/lam_group.ml b/compiler/core/lam_group.ml index 357222cd641..3a913f197c1 100644 --- a/compiler/core/lam_group.ml +++ b/compiler/core/lam_group.ml @@ -24,11 +24,11 @@ (** This is not a recursive type definition *) type t = - | Single of Lam_compat.let_kind * Ident.t * Lam.t + | Single of Lambda.let_kind * Ident.t * Lam.t | Recursive of (Ident.t * Lam.t) list | Nop of Lam.t -let single (kind : Lam_compat.let_kind) id (body : Lam.t) = +let single (kind : Lambda.let_kind) id (body : Lam.t) = match (kind, body) with | (Strict | StrictOpt), (Lvar _ | Lconst _) -> Single (Alias, id, body) | _ -> Single (kind, id, body) @@ -40,7 +40,7 @@ let nop_cons (x : Lam.t) acc = (* let pp = Format.fprintf *) -let str_of_kind (kind : Lam_compat.let_kind) = +let str_of_kind (kind : Lambda.let_kind) = match kind with | Alias -> "a" | Strict -> "" diff --git a/compiler/core/lam_group.mli b/compiler/core/lam_group.mli index c6325acc923..1e1f620a0ae 100644 --- a/compiler/core/lam_group.mli +++ b/compiler/core/lam_group.mli @@ -23,7 +23,7 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) type t = - | Single of Lam_compat.let_kind * Ident.t * Lam.t + | Single of Lambda.let_kind * Ident.t * Lam.t | Recursive of (Ident.t * Lam.t) list | Nop of Lam.t @@ -31,6 +31,6 @@ type t = val pp_group : Format.formatter -> t -> unit -val single : Lam_compat.let_kind -> Ident.t -> Lam.t -> t +val single : Lambda.let_kind -> Ident.t -> Lam.t -> t val nop_cons : Lam.t -> t list -> t list diff --git a/compiler/core/lam_id_kind.ml b/compiler/core/lam_id_kind.ml index b7967fb15ff..09809a4b5a3 100644 --- a/compiler/core/lam_id_kind.ml +++ b/compiler/core/lam_id_kind.ml @@ -40,7 +40,7 @@ type t = | OptionalBlock of Lam.t * boxed_nullable | ImmutableBlock of element array | MutableBlock of element array - | Constant of Lam_constant.t + | Constant of Lambda.structured_constant | Module of Ident.t (** TODO: static module vs first class module *) | FunctionId of { mutable arity: Lam_arity.t; diff --git a/compiler/core/lam_id_kind.mli b/compiler/core/lam_id_kind.mli index 040a63a417e..d68422b34f5 100644 --- a/compiler/core/lam_id_kind.mli +++ b/compiler/core/lam_id_kind.mli @@ -52,7 +52,7 @@ type t = | OptionalBlock of Lam.t * boxed_nullable | ImmutableBlock of element array | MutableBlock of element array - | Constant of Lam_constant.t + | Constant of Lambda.structured_constant | Module of Ident.t (** TODO: static module vs first class module *) | FunctionId of { mutable arity: Lam_arity.t; diff --git a/compiler/core/lam_iter.ml b/compiler/core/lam_iter.ml index 157fd291812..472d377d93d 100644 --- a/compiler/core/lam_iter.ml +++ b/compiler/core/lam_iter.ml @@ -28,7 +28,10 @@ type ident = Ident.t let inner_exists (l : t) (f : t -> bool) : bool = match l with - | Lvar (_ : ident) | Lglobal_module _ | Lconst (_ : Lam_constant.t) -> false + | Lvar (_ : ident) + | Lglobal_module _ + | Lconst (_ : Lambda.structured_constant) -> + false | Lapply {ap_func; ap_args; ap_info = _} -> f ap_func || Ext_list.exists ap_args f | Lfunction {body; params = _} -> f body diff --git a/compiler/core/lam_pass_collect.ml b/compiler/core/lam_pass_collect.ml index 158ae02fcab..fe2ed29bd06 100644 --- a/compiler/core/lam_pass_collect.ml +++ b/compiler/core/lam_pass_collect.ml @@ -47,7 +47,7 @@ let collect_info (meta : Lam_stats.t) (lam : Lam.t) = match lam with | Lconst v -> Hash_ident.replace meta.ident_tbl ident (Constant v) | Lprim {primitive = Pmakeblock info; args = ls} - when Lam_primitive.is_immutable_block info -> + when Lambda.is_immutable_block info -> Hash_ident.replace meta.ident_tbl ident (Lam_util.kind_of_lambda_block ls); List.iter collect ls | Lprim {primitive = Psome | Psome_not_nest; args = [v]} -> diff --git a/compiler/core/lam_pass_deep_flatten.ml b/compiler/core/lam_pass_deep_flatten.ml index 576dce3673a..f0fa4cc419a 100644 --- a/compiler/core/lam_pass_deep_flatten.ml +++ b/compiler/core/lam_pass_deep_flatten.ml @@ -121,7 +121,7 @@ let rec rhs_is_beta_residue (lam : Lam.t) = _, Lprim {primitive = Pmakeblock info}, rest ) - when Lam_primitive.is_immutable_block info -> + when Lambda.is_immutable_block info -> rhs_is_beta_residue rest | Llet ((Alias | Strict | StrictOpt), _, Lvar _, rest) -> rhs_is_beta_residue rest @@ -179,7 +179,7 @@ let deep_flatten (lam : Lam.t) : Lam.t = | ( ("match" | "include" | "param"), (Alias | Strict | StrictOpt), Lprim {primitive = Pmakeblock info; args} ) - when Lam_primitive.is_immutable_block info -> ( + when Lambda.is_immutable_block info -> ( match eliminate_tuple id body Map_int.empty with | Some (tuple_mapping, body) -> flatten diff --git a/compiler/core/lam_pass_lets_dce.ml b/compiler/core/lam_pass_lets_dce.ml index 6adae73cf92..b8d31040ad2 100644 --- a/compiler/core/lam_pass_lets_dce.ml +++ b/compiler/core/lam_pass_lets_dce.ml @@ -26,7 +26,7 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = v, Lprim {primitive = Pmakeblock info as primitive; args = [linit]; loc}, lbody ) - when not (Lam_primitive.is_immutable_block info) -> ( + when not (Lambda.is_immutable_block info) -> ( let slinit = simplif linit in let slbody = simplif lbody in try @@ -90,7 +90,7 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = else match l1 with | Lprim {primitive = Pmakeblock info as primitive; args = [linit]; loc} - when not (Lam_primitive.is_immutable_block info) -> ( + when not (Lambda.is_immutable_block info) -> ( let slinit = simplif linit in let slbody = simplif lbody in try diff --git a/compiler/core/lam_pass_remove_alias.ml b/compiler/core/lam_pass_remove_alias.ml index b3ac7cee2c5..795cad8062f 100644 --- a/compiler/core/lam_pass_remove_alias.ml +++ b/compiler/core/lam_pass_remove_alias.ml @@ -41,7 +41,7 @@ let id_is_for_sure_true_in_boolean (tbl : Lam_stats.ident_tbl) id = | None -> Eval_unknown -let is_const_some (cst : Lam_constant.t) : bool = +let is_const_some (cst : Lambda.structured_constant) : bool = match cst with | Const_some _ -> true | _ -> false diff --git a/compiler/core/lam_primitive.ml b/compiler/core/lam_primitive.ml deleted file mode 100644 index ca322f5b64b..00000000000 --- a/compiler/core/lam_primitive.ml +++ /dev/null @@ -1,179 +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. *) - -[@@@warning "+9"] - -type ident = Ident.t - -type t = Lambda.primitive = - | Pdebugger - | Ptypeof - | Psome - | Psome_not_nest - (** [Some x] where [x] cannot itself be [undefined], so no wrapping is - needed. *) - (* Operations on heap blocks *) - | Pmakeblock of Lam_tag_info.t - | Pfield of int * Lambda.field_dbg_info - | Psetfield of int * Lambda.set_field_dbg_info - | Pduprecord - | Precord_rest of string list (* excluded runtime field names *) - (* JS FFI calls, expanded from the external's spec at translation *) - | Pjs_call of { - prim_name: string; - arg_types: External_arg_spec.params; - ffi: External_ffi_types.external_decl; - transformed_jsx: bool; - } - | Pjs_object_create of External_arg_spec.obj_params - | Pjs_object_get of string - | Pjs_object_set of string - (* Exceptions *) - | Praise - (* object primitives *) - | Pobjcomp of Lam_compat.comparison - | Pobjorder - | Pobjmin - | Pobjmax - | Pobjtag - | Pobjsize - (* Boolean operations *) - | Psequand - | Psequor - | Pnot - | Pboolcomp of Lam_compat.comparison - | Pboolorder - | Pboolmin - | Pboolmax - (* Integer operations *) - | Pnegint - | Paddint - | Psubint - | Pmulint - | Pdivint - | Pmodint - | Ppowint - | Pandint - | Porint - | Pxorint - | Pnotint - | Plslint - | Plsrint - | Pasrint - | Pintcomp of Lam_compat.comparison - | Pintorder - | Pintmin - | Pintmax - (* Float operations *) - | Pintoffloat - | Pfloatofint - | Pnegfloat - | Pmodfloat - | Paddfloat - | Psubfloat - | Pmulfloat - | Pdivfloat - | Ppowfloat - | Pfloatcomp of Lam_compat.comparison - | Pfloatorder - | Pfloatmin - | Pfloatmax - (* BigInt operations *) - | Pnegbigint - | Paddbigint - | Psubbigint - | Ppowbigint - | Pmulbigint - | Pdivbigint - | Pmodbigint - | Pandbigint - | Porbigint - | Pxorbigint - | Pnotbigint - | Plslbigint - | Pasrbigint - | Pbigintcomp of Lam_compat.comparison - | Pbigintorder - | Pbigintmin - | Pbigintmax - (* String operations *) - | Pstringlength - | Pstringrefu - | Pstringrefs - | Pstringcomp of Lam_compat.comparison - | Pstringorder - | Pstringmin - | Pstringmax - | Pstringadd - (* Array operations *) - | Pmakearray - | Parraylength - | Parrayrefu - | Parraysetu - | Parrayrefs - | Parraysets - (* List primitives *) - | Pmakelist - (* dict primitives *) - | Pmakedict - | Pdict_has - (* promise *) - | Pawait - (* modules *) - | Pimport of Lambda.import_source - | Pinit_mod - | Pupdate_mod - (* hash *) - | Phash - | Phash_mixint - | Phash_mixstring - | Phash_finalmix - (* Test if the argument is a block or an immediate integer *) - | Pisint - (* Test if the (integer) argument is outside an interval *) - (* Test if the argument is null or undefined *) - | Pis_null_undefined - (* exn *) - | Pcreate_extension of string - (* js *) - | Pjscomp of Lam_compat.comparison - | Pnull_to_opt - | Pnull_undefined_to_opt - (* Produced by Lam_pass_remove_alias, not by translation *) - | Pis_null - | Pis_undefined - | Pis_not_none - | Pval_from_option - | Pval_from_option_not_nest - | Pis_poly_var_block - | Praw_js_code of Js_raw_info.t - | Pjs_fn_method - | Ptagged_template - -(* The mutability of a block is a property of its shape, so it is derived - rather than stored alongside it. *) -let is_immutable_block (info : Lam_tag_info.t) = - Lambda.mutable_flag_of_tag_info info = Immutable - -let eq_primitive_approx = Lambda.eq_primitive_approx diff --git a/compiler/core/lam_primitive.mli b/compiler/core/lam_primitive.mli deleted file mode 100644 index 47da2a27e87..00000000000 --- a/compiler/core/lam_primitive.mli +++ /dev/null @@ -1,174 +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. *) - -type ident = Ident.t - -type t = Lambda.primitive = - | Pdebugger - | Ptypeof - | Psome - | Psome_not_nest - (** [Some x] where [x] cannot itself be [undefined], so no wrapping is - needed. *) - (* Operations on heap blocks *) - | Pmakeblock of Lam_tag_info.t - | Pfield of int * Lambda.field_dbg_info - | Psetfield of int * Lambda.set_field_dbg_info - | Pduprecord - | Precord_rest of string list (* excluded runtime field names *) - (* JS FFI calls, expanded from the external's spec at translation *) - | Pjs_call of { - prim_name: string; - arg_types: External_arg_spec.params; - ffi: External_ffi_types.external_decl; - transformed_jsx: bool; - } - | Pjs_object_create of External_arg_spec.obj_params - | Pjs_object_get of string - | Pjs_object_set of string - (* Exceptions *) - | Praise - (* object primitives *) - | Pobjcomp of Lam_compat.comparison - | Pobjorder - | Pobjmin - | Pobjmax - | Pobjtag - | Pobjsize - (* Boolean operations *) - | Psequand - | Psequor - | Pnot - | Pboolcomp of Lam_compat.comparison - | Pboolorder - | Pboolmin - | Pboolmax - (* Integer operations *) - | Pnegint - | Paddint - | Psubint - | Pmulint - | Pdivint - | Pmodint - | Ppowint - | Pandint - | Porint - | Pxorint - | Pnotint - | Plslint - | Plsrint - | Pasrint - | Pintcomp of Lam_compat.comparison - | Pintorder - | Pintmin - | Pintmax - (* Float operations *) - | Pintoffloat - | Pfloatofint - | Pnegfloat - | Pmodfloat - | Paddfloat - | Psubfloat - | Pmulfloat - | Pdivfloat - | Ppowfloat - | Pfloatcomp of Lam_compat.comparison - | Pfloatorder - | Pfloatmin - | Pfloatmax - (* BigInt operations *) - | Pnegbigint - | Paddbigint - | Psubbigint - | Ppowbigint - | Pmulbigint - | Pdivbigint - | Pmodbigint - | Pandbigint - | Porbigint - | Pxorbigint - | Pnotbigint - | Plslbigint - | Pasrbigint - | Pbigintcomp of Lam_compat.comparison - | Pbigintorder - | Pbigintmin - | Pbigintmax - (* String operations *) - | Pstringlength - | Pstringrefu - | Pstringrefs - | Pstringcomp of Lam_compat.comparison - | Pstringorder - | Pstringmin - | Pstringmax - | Pstringadd - (* Array operations *) - | Pmakearray - | Parraylength - | Parrayrefu - | Parraysetu - | Parrayrefs - | Parraysets - (* List primitives *) - | Pmakelist - (* dict primitives *) - | Pmakedict - | Pdict_has - (* promise *) - | Pawait - (* modules *) - | Pimport of Lambda.import_source - | Pinit_mod - | Pupdate_mod - (* hash *) - | Phash - | Phash_mixint - | Phash_mixstring - | Phash_finalmix - (* Test if the argument is a block or an immediate integer *) - | Pisint - (* Test if the (integer) argument is outside an interval *) - (* Test if the argument is null or undefined *) - | Pis_null_undefined - (* exn *) - | Pcreate_extension of string - (* js *) - | Pjscomp of Lam_compat.comparison - | Pnull_to_opt - | Pnull_undefined_to_opt - (* Produced by Lam_pass_remove_alias, not by translation *) - | Pis_null - | Pis_undefined - | Pis_not_none - | Pval_from_option - | Pval_from_option_not_nest - | Pis_poly_var_block - | Praw_js_code of Js_raw_info.t - | Pjs_fn_method - | Ptagged_template - -val is_immutable_block : Lam_tag_info.t -> bool - -val eq_primitive_approx : t -> t -> bool diff --git a/compiler/core/lam_print.ml b/compiler/core/lam_print.ml index c1163acc21f..08d8429c5a9 100644 --- a/compiler/core/lam_print.ml +++ b/compiler/core/lam_print.ml @@ -13,7 +13,7 @@ open Format open Asttypes -let rec struct_const ppf (cst : Lam_constant.t) = +let rec struct_const ppf (cst : Lambda.structured_constant) = match cst with | Const_js_true -> fprintf ppf "#true" | Const_js_false -> fprintf ppf "#false" @@ -38,7 +38,7 @@ let rec struct_const ppf (cst : Lam_constant.t) = (Lambda.tag_label_of_tag_info i) struct_const sc1 sconsts scl -let primitive ppf (prim : Lam_primitive.t) = +let primitive ppf (prim : Lambda.primitive) = match prim with (* | Pcreate_exception s -> fprintf ppf "[exn-create]%S" s *) | Pcreate_extension s -> fprintf ppf "[ext-create]%S" s @@ -68,7 +68,7 @@ let primitive ppf (prim : Lam_primitive.t) = | Pmakeblock i -> fprintf ppf "makemutable %s" (Lambda.tag_label_of_tag_info i) | Pfield (n, field_info) -> ( - match Lam_compat.str_of_field_info field_info with + match Lambda.str_of_field_info field_info with | None -> fprintf ppf "field %i" n | Some s -> fprintf ppf "field %s/%i" s n) | Psetfield (n, _) -> @@ -211,7 +211,7 @@ let kind = function | Variable -> "v" | Recursive -> "r" -let to_print_kind (k : Lam_compat.let_kind) : print_kind = +let to_print_kind (k : Lambda.let_kind) : print_kind = match k with | Alias -> Alias | Strict -> Strict diff --git a/compiler/core/lam_print.mli b/compiler/core/lam_print.mli index f8b6fda4975..235386710a7 100644 --- a/compiler/core/lam_print.mli +++ b/compiler/core/lam_print.mli @@ -24,7 +24,7 @@ val lambda : Format.formatter -> Lam.t -> unit -val primitive : Format.formatter -> Lam_primitive.t -> unit +val primitive : Format.formatter -> Lambda.primitive -> unit val serialize : string -> Lam.t -> unit diff --git a/compiler/core/lam_stats_export.ml b/compiler/core/lam_stats_export.ml index 3bbe21a7a35..4b72fa98d40 100644 --- a/compiler/core/lam_stats_export.ml +++ b/compiler/core/lam_stats_export.ml @@ -42,7 +42,7 @@ let values_of_export (meta : Lam_stats.t) (export_map : Lam.t Map_ident.t) : | Some _ | None -> ( match Map_ident.find_opt export_map x with | Some (Lprim {primitive = Pmakeblock info; args}) - when Lam_primitive.is_immutable_block info -> + when Lambda.is_immutable_block info -> Submodule (Ext_array.of_list_map args (fun lam -> Lam_arity_analysis.get_arity meta lam)) diff --git a/compiler/core/lam_tag_info.ml b/compiler/core/lam_tag_info.ml deleted file mode 100644 index dddd3d98503..00000000000 --- a/compiler/core/lam_tag_info.ml +++ /dev/null @@ -1,30 +0,0 @@ -(* Copyright (C) 2018-Present 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. *) - -(* Similiar to {!Lambda.tag_info} - In particular, - it reduces some branches e.g, - [Blk_some], [Blk_some_not_nested] -*) -type t = Lambda.tag_info diff --git a/compiler/core/lam_util.ml b/compiler/core/lam_util.ml index 7c4663ced2a..6139fea17cd 100644 --- a/compiler/core/lam_util.ml +++ b/compiler/core/lam_util.ml @@ -57,7 +57,7 @@ let add_required_modules ( x : Ident.t list) (meta : Lam_stats.t) = syntactic and narrow. *) let refine_let ~kind param (arg : Lam.t) (l : Lam.t) : Lam.t = let is_block_constructor = function - | Lam_primitive.Pmakeblock _ -> true + | Lambda.Pmakeblock _ -> true | _ -> false in (* SafeAlias is the predicate that justifies the (Alias) rewrite @@ -91,7 +91,7 @@ let refine_let ~kind param (arg : Lam.t) (l : Lam.t) : Lam.t = is_safe_to_alias inner | _ -> false in - match ((kind : Lam_compat.let_kind), arg, l) with + match ((kind : Lambda.let_kind), arg, l) with | _, _, Lvar w when Ident.same w param -> (* If the body immediately returns the binding (e.g. `{ let x = value; x }`), we skip creating `x` and keep `value`. There is no `rec`, so `value` @@ -209,13 +209,13 @@ let field_flatten_get lam v i info (tbl : Lam_id_kind.t Hash_ident.t) : Lam.t = if fst fields.(i) = name then found := Ext_list.nth_opt ls i done; match !found with - | Some c when not (Lam_constant.is_allocating c) -> Lam.const c + | Some c when not (Lambda.const_is_allocating c) -> Lam.const c | _ -> lam ()) | _ -> lam ()) | Some (Constant (Const_block (_, ls))) -> ( match Ext_list.nth_opt ls i with | None -> lam () - | Some x when not (Lam_constant.is_allocating x) -> Lam.const x + | Some x when not (Lambda.const_is_allocating x) -> Lam.const x | Some _ -> lam ()) | Some _ | None -> lam () diff --git a/compiler/core/lam_util.mli b/compiler/core/lam_util.mli index f9b845da901..f1bc595c20f 100644 --- a/compiler/core/lam_util.mli +++ b/compiler/core/lam_util.mli @@ -52,7 +52,7 @@ val field_flatten_get : val alias_ident_or_global : Lam_stats.t -> Ident.t -> Ident.t -> Lam_id_kind.t -> unit -val refine_let : kind:Lam_compat.let_kind -> Ident.t -> Lam.t -> Lam.t -> Lam.t +val refine_let : kind:Lambda.let_kind -> Ident.t -> Lam.t -> Lam.t -> Lam.t val not_function : Lam.t -> bool diff --git a/compiler/frontend/lam_constant.ml b/compiler/frontend/lam_constant.ml deleted file mode 100644 index 8e0ad1ef52c..00000000000 --- a/compiler/frontend/lam_constant.ml +++ /dev/null @@ -1,57 +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. *) - -(* The constant representation is owned by [Lambda]; this module is the - operations on it. *) -type t = Lambda.structured_constant = - | Const_int of int32 - | Const_char of int - | Const_string of {s: string; delim: External_arg_spec.delim option} - | Const_float of string - | Const_bigint of bool * string - | Const_block of Lambda.tag_info * t list - | Const_constructor of Variant_runtime.tag - (** Constant constructor of a nominal variant, from its canonical - runtime descriptor. Integer-represented ones are [Const_int]. *) - | Const_polyvar of string - (** Tagless polymorphic variant; numeric-looking names are [Const_int]. *) - | Const_assertfalse - | Const_module_alias - | Const_js_false - | Const_js_true - | Const_js_null - | Const_some of t - | Const_js_undefined of {is_unit: bool} - -let eq_approx = Lambda.const_eq_approx - -let rec is_allocating (c : t) : bool = - match c with - | Const_some t -> is_allocating t - | Const_block _ -> true - | Const_js_null | Const_js_undefined _ | Const_js_true | Const_js_false - | Const_int _ | Const_assertfalse | Const_constructor _ | Const_char _ - | Const_string _ | Const_float _ | Const_bigint _ | Const_polyvar _ - | Const_module_alias -> - false diff --git a/compiler/frontend/lam_constant.mli b/compiler/frontend/lam_constant.mli deleted file mode 100644 index ff01439dab6..00000000000 --- a/compiler/frontend/lam_constant.mli +++ /dev/null @@ -1,49 +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. *) - -(* The constant representation is owned by [Lambda]; this module is the - operations on it. *) -type t = Lambda.structured_constant = - | Const_int of int32 - | Const_char of int - | Const_string of {s: string; delim: External_arg_spec.delim option} - | Const_float of string - | Const_bigint of bool * string - | Const_block of Lambda.tag_info * t list - | Const_constructor of Variant_runtime.tag - (** Constant constructor of a nominal variant, from its canonical - runtime descriptor. Integer-represented ones are [Const_int]. *) - | Const_polyvar of string - (** Tagless polymorphic variant; numeric-looking names are [Const_int]. *) - | Const_assertfalse - | Const_module_alias - | Const_js_false - | Const_js_true - | Const_js_null - | Const_some of t - | Const_js_undefined of {is_unit: bool} - -val eq_approx : t -> t -> bool - -val is_allocating : t -> bool diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index 7fa7197e7c7..007befa38f6 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -623,6 +623,32 @@ let eq_primitive_approx (lhs : primitive) (rhs : primitive) = | Praw_js_code _ -> false (* TOO lazy, here comparison is only approximation*) +(* The source-level name a field access carries, when it has one. *) +let str_of_field_info (x : field_dbg_info) : string option = + match x with + | Fld_extension | Fld_variant | Fld_cons | Fld_poly_var_tag + | Fld_poly_var_content | Fld_tuple -> + None + | Fld_record {name} + | Fld_module {name} + | Fld_record_inline {name} + | Fld_record_extension {name} -> + Some name + +let is_immutable_block (info : tag_info) = + mutable_flag_of_tag_info info = Immutable + +(* A constant that has to be built at run time rather than shared. *) +let rec const_is_allocating (c : structured_constant) : bool = + match c with + | Const_some t -> const_is_allocating t + | Const_block _ -> true + | Const_js_null | Const_js_undefined _ | Const_js_true | Const_js_false + | Const_int _ | Const_assertfalse | Const_constructor _ | Const_char _ + | Const_string _ | Const_float _ | Const_bigint _ | Const_polyvar _ + | Const_module_alias -> + false + let rec const_eq_approx (x : structured_constant) (y : structured_constant) = match x with | Const_module_alias -> y = Const_module_alias diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index 13dea6e7b04..17776dc90e0 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -438,6 +438,14 @@ val lambda_unit : lambda val eq_primitive_approx : primitive -> primitive -> bool +val str_of_field_info : field_dbg_info -> string option + +val eq_comparison : comparison -> comparison -> bool + +val is_immutable_block : tag_info -> bool + +val const_is_allocating : structured_constant -> bool + val const_eq_approx : structured_constant -> structured_constant -> bool val cmp_int32 : comparison -> int32 -> int32 -> bool diff --git a/tests/ounit_tests/ounit_js_analyzer_tests.ml b/tests/ounit_tests/ounit_js_analyzer_tests.ml index c28e17eb6c4..47e885e23fa 100644 --- a/tests/ounit_tests/ounit_js_analyzer_tests.ml +++ b/tests/ounit_tests/ounit_js_analyzer_tests.ml @@ -30,7 +30,7 @@ let for_await_of_statement = } let record_rest_statement ~source ~field ~rest = - Js_stmt_make.define_variable ~kind:Lam_compat.Strict rest + Js_stmt_make.define_variable ~kind:Lambda.Strict rest (record_rest_expression source field) let function_expression param body = @@ -56,7 +56,7 @@ let transform_expression expression = Js_pass_record_rest.program { J.block = - [Js_stmt_make.define_variable ~kind:Lam_compat.Strict fn expression]; + [Js_stmt_make.define_variable ~kind:Lambda.Strict fn expression]; exports = []; export_set = Set_ident.empty; } @@ -169,7 +169,7 @@ let suites = { J.block = [ - Js_stmt_make.define_variable ~kind:Lam_compat.Strict rest + Js_stmt_make.define_variable ~kind:Lambda.Strict rest (Js_exp_make.record_rest [ { From 72b340c87930e07216df4020d42a1edea06c07fd Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 1 Sep 2026 20:14:21 +0200 Subject: [PATCH 36/46] Retire Lam_free_variables in favour of Lambda's The two were the same computation - one written through iter and a get callback, the other hand-recursed - differing only in the set type. Lambda's wins, because Ident_set is load-bearing beyond free variables: matching uses it for pattern variable sets and unions those with free_variables results, so moving the other way would have cascaded through matching. Converting the five core call sites was the cheap direction. Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/core/lam_compile.ml | 4 +- compiler/core/lam_dce.ml | 16 ++-- compiler/core/lam_free_variables.ml | 111 --------------------------- compiler/core/lam_free_variables.mli | 25 ------ 4 files changed, 10 insertions(+), 146 deletions(-) delete mode 100644 compiler/core/lam_free_variables.ml delete mode 100644 compiler/core/lam_free_variables.mli diff --git a/compiler/core/lam_compile.ml b/compiler/core/lam_compile.ml index 5f8ca3bd5ca..810ba7319ec 100644 --- a/compiler/core/lam_compile.ml +++ b/compiler/core/lam_compile.ml @@ -1279,7 +1279,7 @@ let compile output_prefix = (lambda_cxt : Lam_compile_context.t) = let new_cxt = {lambda_cxt with continuation = NeedValue Not_tail} in let emitted_id = - if Set_ident.mem (Lam_free_variables.pass_free_variables body) id then id + if Lambda.Ident_set.mem id (Lambda.free_variables body) then id else Ext_ident.create_tmp ~name:"_for_of" () in let block = @@ -1302,7 +1302,7 @@ let compile output_prefix = (lambda_cxt : Lam_compile_context.t) = let new_cxt = {lambda_cxt with continuation = NeedValue Not_tail} in let emitted_id = - if Set_ident.mem (Lam_free_variables.pass_free_variables body) id then id + if Lambda.Ident_set.mem id (Lambda.free_variables body) then id else Ext_ident.create_tmp ~name:"_for_await_of" () in let block = diff --git a/compiler/core/lam_dce.ml b/compiler/core/lam_dce.ml index ee476b3da81..951dadd0ef9 100644 --- a/compiler/core/lam_dce.ml +++ b/compiler/core/lam_dce.ml @@ -23,7 +23,7 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) let transitive_closure (initial_idents : Ident.t list) - (ident_freevars : Set_ident.t Hash_ident.t) = + (ident_freevars : Lambda.Ident_set.t Hash_ident.t) = let visited = Hash_set_ident.create 31 in let rec dfs (id : Ident.t) : unit = if not (Hash_set_ident.mem visited id || Ext_ident.is_js_or_global id) then ( @@ -32,7 +32,7 @@ let transitive_closure (initial_idents : Ident.t list) | None -> Ext_fmt.failwithf ~loc:__LOC__ "%s/%d not found" (Ident.name id) id.stamp - | Some e -> Set_ident.iter e dfs) + | Some e -> Lambda.Ident_set.iter dfs e) in Ext_list.iter initial_idents dfs; visited @@ -46,15 +46,13 @@ let remove export_idents (rest : Lam_group.t list) : Lam_group.t list = Ext_list.fold_left rest export_idents (fun acc x -> match x with | Single (kind, id, lam) -> ( - Hash_ident.add ident_free_vars id - (Lam_free_variables.pass_free_variables lam); + Hash_ident.add ident_free_vars id (Lambda.free_variables lam); match kind with | Alias | StrictOpt -> acc | Strict | Variable -> id :: acc) | Recursive bindings -> Ext_list.fold_left bindings acc (fun acc (id, lam) -> - Hash_ident.add ident_free_vars id - (Lam_free_variables.pass_free_variables lam); + Hash_ident.add ident_free_vars id (Lambda.free_variables lam); match lam with | Lfunction _ -> acc | _ -> id :: acc) @@ -62,8 +60,10 @@ let remove export_idents (rest : Lam_group.t list) : Lam_group.t list = if Lam_analysis.no_side_effects lam then acc else (* its free varaibles here will be defined above *) - Set_ident.fold (Lam_free_variables.pass_free_variables lam) acc - (fun x acc -> x :: acc)) + Lambda.Ident_set.fold + (fun x acc -> x :: acc) + (Lambda.free_variables lam) + acc) in let visited = transitive_closure initial_idents ident_free_vars in Ext_list.fold_left rest [] (fun acc x -> diff --git a/compiler/core/lam_free_variables.ml b/compiler/core/lam_free_variables.ml deleted file mode 100644 index d269c78c7cb..00000000000 --- a/compiler/core/lam_free_variables.ml +++ /dev/null @@ -1,111 +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. *) - -let pass_free_variables (l : Lam.t) : Set_ident.t = - let fv = ref Set_ident.empty in - let rec free_list xs = List.iter free xs - and free_list_snd : 'a. ('a * Lam.t) list -> unit = - fun xs -> Ext_list.iter_snd xs free - and free (l : Lam.t) = - match l with - | Lvar id -> fv := Set_ident.add !fv id - | Lassign (id, e) -> - free e; - fv := Set_ident.add !fv id - | Lstaticcatch (e1, (_, vars), e2) -> - free e1; - free e2; - Ext_list.iter vars (fun id -> fv := Set_ident.remove !fv id) - | Ltrywith (e1, exn, e2) -> - free e1; - free e2; - fv := Set_ident.remove !fv exn - | Lfunction {body; params} -> - free body; - Ext_list.iter params (fun param -> fv := Set_ident.remove !fv param) - | Llet (_str, id, arg, body) -> - free arg; - free body; - fv := Set_ident.remove !fv id - | Lletrec (decl, body) -> - free body; - free_list_snd decl; - Ext_list.iter decl (fun (id, _exp) -> fv := Set_ident.remove !fv id) - | Lfor (v, e1, e2, _dir, e3) -> - free e1; - free e2; - free e3; - fv := Set_ident.remove !fv v - | Lfor_of (v, e1, e2) -> - free e1; - free e2; - fv := Set_ident.remove !fv v - | Lfor_await_of (v, e1, e2) -> - free e1; - free e2; - fv := Set_ident.remove !fv v - | Lconst _ -> () - | Lapply {ap_func; ap_args; _} -> - free ap_func; - free_list ap_args - | Lglobal_module _ -> () - (* according to the existing semantics: - [primitive] is not counted - *) - | Lprim {args; _} -> free_list args - | Lswitch (arg, sw) -> - free arg; - free_list_snd sw.sw_consts; - free_list_snd sw.sw_blocks; - Ext_option.iter sw.sw_failaction free - | Lstringswitch (arg, cases, default) -> - free arg; - free_list_snd cases; - Ext_option.iter default free - | Lstaticraise (_, args) -> free_list args - | Lifthenelse (e1, e2, e3) -> - free e1; - free e2; - free e3 - | Lsequence (e1, e2) -> - free e1; - free e2 - | Lbreak | Lcontinue -> () - | Lwhile (e1, e2) -> - free e1; - free e2 - in - free l; - !fv - -(** - [hit_any_variables fv l] - check the lambda expression [l] if has some free - variables captured by [fv]. - Note it does not do any checking like below - [Llet(str,id,arg,body)] - it only check [arg] or [body] is hit or not, there - is a case that [id] is hit in [arg] but also exists - in [fv], this is ignored. -*) diff --git a/compiler/core/lam_free_variables.mli b/compiler/core/lam_free_variables.mli deleted file mode 100644 index 4126b4b857a..00000000000 --- a/compiler/core/lam_free_variables.mli +++ /dev/null @@ -1,25 +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. *) - -val pass_free_variables : Lam.t -> Set_ident.t From 03f074f1107ecb5395575b60de8ebcc394dbb7d8 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 1 Sep 2026 20:17:42 +0200 Subject: [PATCH 37/46] Express subst_lambda through shallow_map_sharing and retire Lam_subst subst_lambda was 49 lines of hand-written shallow rebuild, and the only place left that constructed a term without going through the constructors - it could, being inside the module that owns the type. shallow_map_sharing already does that walk, so substitution is the Lvar case and a recursion: eight lines, normalizing as it rebuilds, and returning a subterm that contains no substituted variable physically unchanged. Lam_subst was the same function over Map_ident instead of Ident.tbl, kept apart only because it rebuilt through the smart constructors while subst_lambda did not. With that difference gone it is redundant, and its one caller in lam_pass_exits switches map type. Generated JavaScript is unchanged, at both steps. Normalizing during substitution turns out to be a no-op for the same reason it is at production: translmod substitutes module identifiers, so the folds have nothing to act on. Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/core/lam_pass_exits.ml | 8 ++-- compiler/core/lam_subst.ml | 82 --------------------------------- compiler/core/lam_subst.mli | 31 ------------- compiler/ml/lambda.ml | 52 +++------------------ 4 files changed, 10 insertions(+), 163 deletions(-) delete mode 100644 compiler/core/lam_subst.ml delete mode 100644 compiler/core/lam_subst.mli diff --git a/compiler/core/lam_pass_exits.ml b/compiler/core/lam_pass_exits.ml index 40127068e24..b4b9428455c 100644 --- a/compiler/core/lam_pass_exits.ml +++ b/compiler/core/lam_pass_exits.ml @@ -194,11 +194,11 @@ let subst_helper (subst : subst_tbl) (query : int -> int) (lam : Lam.t) : Lam.t let handler = to_lam handler in let ys = Ext_list.map xs Ident.rename in let env = - Ext_list.fold_right2 xs ys Map_ident.empty (fun x y t -> - Map_ident.add t x (Lam.var y)) + Ext_list.fold_right2 xs ys Ident.empty (fun x y t -> + Ident.add x (Lam.var y) t) in - Ext_list.fold_right2 ys ls (Lam_subst.subst env handler) (fun y l r -> - Lam.let_ Strict y l r) + Ext_list.fold_right2 ys ls (Lambda.subst_lambda env handler) + (fun y l r -> Lam.let_ Strict y l r) | None -> Lam.staticraise i ls) | Lvar _ | Lconst _ -> lam | Lapply {ap_func; ap_args; ap_info; ap_transformed_jsx} -> diff --git a/compiler/core/lam_subst.ml b/compiler/core/lam_subst.ml deleted file mode 100644 index 7778f78c7fb..00000000000 --- a/compiler/core/lam_subst.ml +++ /dev/null @@ -1,82 +0,0 @@ -(* Copyright (C) 2017 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. *) - -(* Apply a substitution to a lambda-term. - Assumes that the bound variables of the lambda-term do not - belong to the domain of the substitution. - Assumes that the image of the substitution is out of reach - of the bound variables of the lambda-term (no capture). *) - -let subst (s : Lam.t Map_ident.t) lam = - let rec subst_aux (x : Lam.t) : Lam.t = - match x with - | Lvar id -> Map_ident.find_default s id x - | Lconst _ -> x - | Lapply {ap_func; ap_args; ap_info} -> - Lam.apply (subst_aux ap_func) (Ext_list.map ap_args subst_aux) ap_info - | Lfunction {params; body; attr; loc} -> - Lam.function_ ~loc ~params ~body:(subst_aux body) ~attr - | Llet (str, id, arg, body) -> - Lam.let_ str id (subst_aux arg) (subst_aux body) - | Lletrec (decl, body) -> - Lam.letrec (Ext_list.map decl subst_decl) (subst_aux body) - | Lprim {primitive; args; loc} -> - Lam.prim ~primitive ~args:(Ext_list.map args subst_aux) loc - | Lglobal_module _ -> x - | Lswitch (arg, sw) -> - Lam.switch (subst_aux arg) - { - sw with - sw_consts = Ext_list.map sw.sw_consts subst_case; - sw_blocks = Ext_list.map sw.sw_blocks subst_case; - sw_failaction = subst_opt sw.sw_failaction; - } - | Lstringswitch (arg, cases, default) -> - Lam.stringswitch (subst_aux arg) - (Ext_list.map cases subst_strcase) - (subst_opt default) - | Lstaticraise (i, args) -> Lam.staticraise i (Ext_list.map args subst_aux) - | Lstaticcatch (e1, io, e2) -> - Lam.staticcatch (subst_aux e1) io (subst_aux e2) - | Ltrywith (e1, exn, e2) -> Lam.try_ (subst_aux e1) exn (subst_aux e2) - | Lifthenelse (e1, e2, e3) -> - Lam.if_ (subst_aux e1) (subst_aux e2) (subst_aux e3) - | Lsequence (e1, e2) -> Lam.seq (subst_aux e1) (subst_aux e2) - | Lbreak -> Lam.break - | Lcontinue -> Lam.continue - | Lwhile (e1, e2) -> Lam.while_ (subst_aux e1) (subst_aux e2) - | Lfor (v, e1, e2, dir, e3) -> - Lam.for_ v (subst_aux e1) (subst_aux e2) dir (subst_aux e3) - | Lfor_of (v, e1, e2) -> Lam.for_of v (subst_aux e1) (subst_aux e2) - | Lfor_await_of (v, e1, e2) -> - Lam.for_await_of v (subst_aux e1) (subst_aux e2) - | Lassign (id, e) -> Lam.assign id (subst_aux e) - and subst_decl (id, exp) = (id, subst_aux exp) - and subst_case (key, case) = (key, subst_aux case) - and subst_strcase (key, case) = (key, subst_aux case) - and subst_opt = function - | None -> None - | Some e -> Some (subst_aux e) - in - subst_aux lam diff --git a/compiler/core/lam_subst.mli b/compiler/core/lam_subst.mli deleted file mode 100644 index 00836dc8205..00000000000 --- a/compiler/core/lam_subst.mli +++ /dev/null @@ -1,31 +0,0 @@ -(* Copyright (C) 2017 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. *) - -(* Apply a substitution to a lambda-term. - Assumes that the bound variables of the lambda-term do not - belong to the domain of the substitution. - Assumes that the image of the substitution is out of reach - of the bound variables of the lambda-term (no capture). *) - -val subst : Lam.t Map_ident.t -> Lam.t -> Lam.t diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index 007befa38f6..ea695655586 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -1533,53 +1533,13 @@ let transl_extension_path = transl_value_path Assumes that the image of the substitution is out of reach of the bound variables of the lambda-term (no capture). *) +(* Substitution rebuilds through [shallow_map_sharing], so the result is + normalized and an untouched subterm is returned physically unchanged. *) let subst_lambda s lam = - let rec subst = function - | Lvar id as l -> ( try Ident.find_same id s with Not_found -> l) - | Lglobal_module _ as l -> l - | Lconst _ as l -> l - | Lapply ap -> - Lapply - { - ap with - ap_func = subst ap.ap_func; - ap_args = List.map subst ap.ap_args; - } - | Lfunction {params; body; attr; loc} -> - Lfunction {params; body = subst body; attr; loc} - | Llet (str, id, arg, body) -> Llet (str, id, subst arg, subst body) - | Lletrec (decl, body) -> Lletrec (List.map subst_decl decl, subst body) - | Lprim {primitive = p; args; loc} -> - Lprim {primitive = p; args = List.map subst args; loc} - | Lswitch (arg, sw) -> - Lswitch - ( subst arg, - { - sw with - sw_consts = List.map subst_case sw.sw_consts; - sw_blocks = List.map subst_case sw.sw_blocks; - sw_failaction = subst_opt sw.sw_failaction; - } ) - | Lstringswitch (arg, cases, default) -> - Lstringswitch (subst arg, List.map subst_strcase cases, subst_opt default) - | Lstaticraise (i, args) -> Lstaticraise (i, List.map subst args) - | Lstaticcatch (e1, io, e2) -> Lstaticcatch (subst e1, io, subst e2) - | Ltrywith (e1, exn, e2) -> Ltrywith (subst e1, exn, subst e2) - | Lifthenelse (e1, e2, e3) -> Lifthenelse (subst e1, subst e2, subst e3) - | Lsequence (e1, e2) -> Lsequence (subst e1, subst e2) - | Lbreak -> Lbreak - | Lcontinue -> Lcontinue - | Lwhile (e1, e2) -> Lwhile (subst e1, subst e2) - | Lfor (v, e1, e2, dir, e3) -> Lfor (v, subst e1, subst e2, dir, subst e3) - | Lfor_of (v, e1, e2) -> Lfor_of (v, subst e1, subst e2) - | Lfor_await_of (v, e1, e2) -> Lfor_await_of (v, subst e1, subst e2) - | Lassign (id, e) -> Lassign (id, subst e) - and subst_decl (id, exp) = (id, subst exp) - and subst_case (key, case) = (key, subst case) - and subst_strcase (key, case) = (key, subst case) - and subst_opt = function - | None -> None - | Some e -> Some (subst e) + let rec subst l = + match l with + | Lvar id -> ( try Ident.find_same id s with Not_found -> l) + | _ -> shallow_map_sharing subst l in subst lam From 5e249cefc24a83b281471cad98e1be4d190fc9e1 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 1 Sep 2026 20:20:53 +0200 Subject: [PATCH 38/46] Retire Lam_iter and derive Lambda.iter from a shallow exists Lam_iter.inner_exists and Lambda.iter were two hand-written walks over the same twenty-two constructors, in different modules. Lambda gains shallow_exists - the short-circuiting query - and iter becomes three lines on top of it. iter_opt existed only to serve iter and goes with it. Lambda now has two shallow traversals rather than four: shallow_map_sharing for rewriting, shallow_exists for querying. Visit order shifts for a couple of node kinds, which nothing observes: iter's only consumers accumulate into a set and into a hash set. Generated JavaScript is unchanged. Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/core/lam_exit_code.ml | 4 +- compiler/core/lam_iter.ml | 65 --------------------------- compiler/core/lam_iter.mli | 25 ----------- compiler/ml/lambda.ml | 82 +++++++++++++--------------------- compiler/ml/lambda.mli | 3 ++ 5 files changed, 35 insertions(+), 144 deletions(-) delete mode 100644 compiler/core/lam_iter.ml delete mode 100644 compiler/core/lam_iter.mli diff --git a/compiler/core/lam_exit_code.ml b/compiler/core/lam_exit_code.ml index 3f42e347427..d5cdcb38463 100644 --- a/compiler/core/lam_exit_code.ml +++ b/compiler/core/lam_exit_code.ml @@ -28,7 +28,7 @@ let has_exit_code lam exits = | Lfunction _ -> false (* static exit can not cross function boundary *) | Lstaticraise (p, _) when exits p -> true - | _ -> Lam_iter.inner_exists lam aux + | _ -> Lambda.shallow_exists aux lam in aux lam @@ -36,4 +36,4 @@ let rec has_exit (lam : Lam.t) = match lam with | Lfunction _ -> false | Lstaticraise (_, _) -> true - | _ -> Lam_iter.inner_exists lam has_exit + | _ -> Lambda.shallow_exists has_exit lam diff --git a/compiler/core/lam_iter.ml b/compiler/core/lam_iter.ml deleted file mode 100644 index 472d377d93d..00000000000 --- a/compiler/core/lam_iter.ml +++ /dev/null @@ -1,65 +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. *) - -type t = Lam.t - -type ident = Ident.t - -let inner_exists (l : t) (f : t -> bool) : bool = - match l with - | Lvar (_ : ident) - | Lglobal_module _ - | Lconst (_ : Lambda.structured_constant) -> - false - | Lapply {ap_func; ap_args; ap_info = _} -> - f ap_func || Ext_list.exists ap_args f - | Lfunction {body; params = _} -> f body - | Llet (_str, _id, arg, body) -> f arg || f body - | Lletrec (decl, body) -> f body || Ext_list.exists_snd decl f - | Lswitch - ( arg, - { - sw_consts; - sw_consts_full = _; - sw_blocks; - sw_blocks_full = _; - sw_failaction; - } ) -> - f arg - || Ext_list.exists_snd sw_consts f - || Ext_list.exists_snd sw_blocks f - || Ext_option.exists sw_failaction f - | Lstringswitch (arg, cases, default) -> - f arg || Ext_list.exists_snd cases f || Ext_option.exists default f - | Lprim {args; primitive = _; loc = _} -> Ext_list.exists args f - | Lstaticraise (_id, args) -> Ext_list.exists args f - | Lstaticcatch (e1, _vars, e2) -> f e1 || f e2 - | Ltrywith (e1, _exn, e2) -> f e1 || f e2 - | Lifthenelse (e1, e2, e3) -> f e1 || f e2 || f e3 - | Lsequence (e1, e2) -> f e1 || f e2 - | Lbreak | Lcontinue -> false - | Lwhile (e1, e2) -> f e1 || f e2 - | Lfor (_v, e1, e2, _dir, e3) -> f e1 || f e2 || f e3 - | Lfor_of (_v, e1, e2) | Lfor_await_of (_v, e1, e2) -> f e1 || f e2 - | Lassign (_id, e) -> f e diff --git a/compiler/core/lam_iter.mli b/compiler/core/lam_iter.mli deleted file mode 100644 index 0077b5a860d..00000000000 --- a/compiler/core/lam_iter.mli +++ /dev/null @@ -1,25 +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. *) - -val inner_exists : Lam.t -> (Lam.t -> bool) -> bool diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index ea695655586..08d60c4cb7a 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -1380,62 +1380,40 @@ let name_lambda strict arg fn = let id = Ident.create "let" in Llet (strict, id, arg, fn id) -let iter_opt f = function - | None -> () - | Some e -> f e - -let iter f = function - | Lvar _ | Lglobal_module _ | Lconst _ -> () - | Lapply {ap_func = fn; ap_args = args} -> - f fn; - List.iter f args +(* Does any immediate child satisfy [f]? Short-circuits. *) +let shallow_exists (f : lambda -> bool) (lam : lambda) : bool = + match lam with + | Lvar _ | Lglobal_module _ | Lconst _ | Lbreak | Lcontinue -> false + | Lapply {ap_func; ap_args} -> f ap_func || Ext_list.exists ap_args f | Lfunction {body} -> f body - | Llet (_str, _id, arg, body) -> - f arg; - f body - | Lletrec (decl, body) -> - f body; - List.iter (fun (_id, exp) -> f exp) decl - | Lprim {primitive = _p; args; loc = _loc} -> List.iter f args - | Lswitch (arg, sw) -> - f arg; - List.iter (fun (_key, case) -> f case) sw.sw_consts; - List.iter (fun (_key, case) -> f case) sw.sw_blocks; - iter_opt f sw.sw_failaction + | Llet (_, _, arg, body) -> f arg || f body + | Lletrec (decl, body) -> f body || Ext_list.exists_snd decl f + | Lprim {args} -> Ext_list.exists args f + | Lswitch (arg, {sw_consts; sw_blocks; sw_failaction}) -> + f arg + || Ext_list.exists_snd sw_consts f + || Ext_list.exists_snd sw_blocks f + || Ext_option.exists sw_failaction f | Lstringswitch (arg, cases, default) -> - f arg; - List.iter (fun (_, act) -> f act) cases; - iter_opt f default - | Lstaticraise (_, args) -> List.iter f args - | Lstaticcatch (e1, _, e2) -> - f e1; - f e2 - | Ltrywith (e1, _, e2) -> - f e1; - f e2 - | Lifthenelse (e1, e2, e3) -> - f e1; - f e2; - f e3 - | Lsequence (e1, e2) -> - f e1; - f e2 - | Lbreak | Lcontinue -> () - | Lwhile (e1, e2) -> - f e1; - f e2 - | Lfor (_v, e1, e2, _dir, e3) -> - f e1; - f e2; - f e3 - | Lfor_of (_v, e1, e2) -> - f e1; - f e2 - | Lfor_await_of (_v, e1, e2) -> - f e1; - f e2 + f arg || Ext_list.exists_snd cases f || Ext_option.exists default f + | Lstaticraise (_, args) -> Ext_list.exists args f + | Lstaticcatch (e1, _, e2) -> f e1 || f e2 + | Ltrywith (e1, _, e2) -> f e1 || f e2 + | Lifthenelse (e1, e2, e3) -> f e1 || f e2 || f e3 + | Lsequence (e1, e2) -> f e1 || f e2 + | Lwhile (e1, e2) -> f e1 || f e2 + | Lfor (_, e1, e2, _, e3) -> f e1 || f e2 || f e3 + | Lfor_of (_, e1, e2) | Lfor_await_of (_, e1, e2) -> f e1 || f e2 | Lassign (_, e) -> f e +let iter f lam = + ignore + (shallow_exists + (fun x -> + f x; + false) + lam) + module Ident_set = Set.Make (Ident) let free_ids get l = diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index 17776dc90e0..74551579d11 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -550,6 +550,9 @@ val mk_builtin : builtin -> lambda list -> Location.t -> lambda val lambda_module_alias : lambda val name_lambda : let_kind -> lambda -> (Ident.t -> lambda) -> lambda +val shallow_exists : (lambda -> bool) -> lambda -> bool +(** Does any immediate child satisfy the predicate? Short-circuits. *) + val iter : (lambda -> unit) -> lambda -> unit module Ident_set : Set.S with type elt = Ident.t val free_variables : lambda -> Ident_set.t From 4419677146c8dd95a80003f5255841162d202938 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 1 Sep 2026 20:36:54 +0200 Subject: [PATCH 39/46] Delete the Lam module Lam was 69 lines of delegation: its type was an alias of Lambda.lambda and every function forwarded. Its users now name Lambda directly. Lam.t becomes Lambda.lambda, the type aliases become the Lambda ones - lambda_switch, lambda_apply, lfunction, prim_info - and the two values Lam spelled differently, unit and false_, become lambda_unit and lambda_false. 63 files touched. Generated JavaScript is unchanged. Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/core/ir_diagnostics.mli | 2 +- compiler/core/js_cmj_format.ml | 4 +- compiler/core/js_cmj_format.mli | 5 +- compiler/core/lam.ml | 69 ----------- compiler/core/lam.mli | 110 ------------------ compiler/core/lam_analysis.ml | 21 ++-- compiler/core/lam_analysis.mli | 10 +- compiler/core/lam_arity_analysis.ml | 4 +- compiler/core/lam_arity_analysis.mli | 2 +- compiler/core/lam_beta_reduce.ml | 13 ++- compiler/core/lam_beta_reduce.mli | 15 ++- compiler/core/lam_beta_reduce_util.ml | 17 +-- compiler/core/lam_beta_reduce_util.mli | 3 +- compiler/core/lam_bounded_vars.ml | 46 ++++---- compiler/core/lam_bounded_vars.mli | 6 +- compiler/core/lam_check.ml | 8 +- compiler/core/lam_check.mli | 2 +- compiler/core/lam_closure.ml | 8 +- compiler/core/lam_closure.mli | 11 +- compiler/core/lam_coercion.ml | 10 +- compiler/core/lam_coercion.mli | 5 +- compiler/core/lam_compile.ml | 101 ++++++++-------- compiler/core/lam_compile.mli | 4 +- compiler/core/lam_compile_context.ml | 10 +- compiler/core/lam_compile_context.mli | 14 ++- compiler/core/lam_compile_env.ml | 2 +- compiler/core/lam_compile_main.ml | 4 +- compiler/core/lam_exit_code.ml | 4 +- compiler/core/lam_exit_code.mli | 4 +- compiler/core/lam_exit_count.ml | 4 +- compiler/core/lam_exit_count.mli | 2 +- compiler/core/lam_group.ml | 10 +- compiler/core/lam_group.mli | 10 +- compiler/core/lam_hit.ml | 2 +- compiler/core/lam_hit.mli | 4 +- compiler/core/lam_id_kind.ml | 8 +- compiler/core/lam_id_kind.mli | 8 +- .../core/lam_pass_collapse_var_aliases.ml | 44 +++---- .../core/lam_pass_collapse_var_aliases.mli | 2 +- compiler/core/lam_pass_collect.ml | 6 +- compiler/core/lam_pass_collect.mli | 2 +- compiler/core/lam_pass_count.ml | 2 +- compiler/core/lam_pass_count.mli | 2 +- compiler/core/lam_pass_deep_flatten.ml | 65 ++++++----- compiler/core/lam_pass_deep_flatten.mli | 2 +- compiler/core/lam_pass_eliminate_ref.ml | 42 +++---- compiler/core/lam_pass_eliminate_ref.mli | 2 +- compiler/core/lam_pass_exits.ml | 60 +++++----- compiler/core/lam_pass_exits.mli | 2 +- compiler/core/lam_pass_guard_raises.ml | 11 +- compiler/core/lam_pass_guard_raises.mli | 4 +- compiler/core/lam_pass_lets_dce.ml | 70 +++++------ compiler/core/lam_pass_lets_dce.mli | 2 +- compiler/core/lam_pass_remove_alias.ml | 77 ++++++------ compiler/core/lam_pass_remove_alias.mli | 2 +- compiler/core/lam_print.ml | 18 +-- compiler/core/lam_print.mli | 6 +- compiler/core/lam_stats_export.ml | 3 +- compiler/core/lam_stats_export.mli | 2 +- compiler/core/lam_util.ml | 38 +++--- compiler/core/lam_util.mli | 17 ++- compiler/core/lam_var_stats.mli | 2 +- compiler/ml/lambda.ml | 2 +- 63 files changed, 462 insertions(+), 585 deletions(-) delete mode 100644 compiler/core/lam.ml delete mode 100644 compiler/core/lam.mli diff --git a/compiler/core/ir_diagnostics.mli b/compiler/core/ir_diagnostics.mli index 9ec4b0804d7..4ebabe38807 100644 --- a/compiler/core/ir_diagnostics.mli +++ b/compiler/core/ir_diagnostics.mli @@ -1,6 +1,6 @@ type t val create : output_prefix:string -> t -val dump_lam : t -> pass:string -> Lam.t -> unit +val dump_lam : t -> pass:string -> Lambda.lambda -> unit val dump_groups : t -> Lam_group.t list -> unit val dump_js : t -> pass:string -> J.program -> unit diff --git a/compiler/core/js_cmj_format.ml b/compiler/core/js_cmj_format.ml index 9f3458aed84..8daedc21dba 100644 --- a/compiler/core/js_cmj_format.ml +++ b/compiler/core/js_cmj_format.ml @@ -29,7 +29,7 @@ type arity = Single of Lam_arity.t | Submodule of Lam_arity.t array (* TODO: add a magic number *) type cmj_value = { arity: arity; - persistent_closed_lambda: Lam.t option; + persistent_closed_lambda: Lambda.lambda option; (** Either constant or closed functor *) } @@ -40,7 +40,7 @@ let single_na = Single Lam_arity.na type keyed_cmj_value = { name: string; arity: arity; - persistent_closed_lambda: Lam.t option; + persistent_closed_lambda: Lambda.lambda option; } type keyed_cmj_values = keyed_cmj_value array diff --git a/compiler/core/js_cmj_format.mli b/compiler/core/js_cmj_format.mli index 18a8c05e145..53d57fd3290 100644 --- a/compiler/core/js_cmj_format.mli +++ b/compiler/core/js_cmj_format.mli @@ -49,7 +49,8 @@ type arity = Single of Lam_arity.t | Submodule of Lam_arity.t array type cmj_value = { arity: arity; - persistent_closed_lambda: Lam.t option; (* Either constant or closed functor *) + persistent_closed_lambda: Lambda.lambda option; + (* Either constant or closed functor *) } type effect_ = string option @@ -57,7 +58,7 @@ type effect_ = string option type keyed_cmj_value = { name: string; arity: arity; - persistent_closed_lambda: Lam.t option; + persistent_closed_lambda: Lambda.lambda option; } type hoisted_export = { diff --git a/compiler/core/lam.ml b/compiler/core/lam.ml deleted file mode 100644 index a126b624dbf..00000000000 --- a/compiler/core/lam.ml +++ /dev/null @@ -1,69 +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. *) - -type ap_info = Lambda.ap_info = { - ap_loc: Location.t; - ap_inlined: Lambda.inline_attribute; -} - -type ident = Ident.t -type lambda_switch = Lambda.lambda_switch -type apply = Lambda.lambda_apply -type lfunction = Lambda.lfunction -type prim_info = Lambda.prim_info -type t = Lambda.lambda - -(* Lam and Lambda are one type. What is left here is the naming the optimizer - uses; the constructors, their normalizations and the traversals all live in - Lambda. *) - -let var = Lambda.var -let global_module = Lambda.global_module -let const = Lambda.const -let apply = Lambda.apply -let function_ = Lambda.function_ -let let_ = Lambda.let_ -let letrec = Lambda.letrec -let prim = Lambda.prim -let switch = Lambda.switch -let stringswitch = Lambda.stringswitch -let staticraise = Lambda.staticraise -let staticcatch = Lambda.staticcatch -let try_ = Lambda.try_ -let if_ = Lambda.if_ -let seq = Lambda.seq -let break = Lambda.break -let continue = Lambda.continue -let while_ = Lambda.while_ -let for_ = Lambda.for_ -let for_of = Lambda.for_of -let for_await_of = Lambda.for_await_of -let assign = Lambda.assign -let not_ = Lambda.not_ -let sequor = Lambda.sequor -let sequand = Lambda.sequand -let false_ = Lambda.lambda_false -let unit = Lambda.lambda_unit -let shallow_map_sharing = Lambda.shallow_map_sharing -let eq_approx = Lambda.eq_approx diff --git a/compiler/core/lam.mli b/compiler/core/lam.mli deleted file mode 100644 index 56285b8fe59..00000000000 --- a/compiler/core/lam.mli +++ /dev/null @@ -1,110 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - 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. *) - -type ap_info = Lambda.ap_info = { - ap_loc: Location.t; - ap_inlined: Lambda.inline_attribute; -} - -type ident = Ident.t - -type lambda_switch = Lambda.lambda_switch - -type apply = Lambda.lambda_apply - -type lfunction = Lambda.lfunction - -type prim_info = Lambda.prim_info - -type t = Lambda.lambda -(** The optimizer's name for {!Lambda.lambda}. It is the same type: the - constructors, their normalizations and the traversals live in Lambda, and - the type is private there, so a term can only be built through them. *) - -(**************************************************************) - -val var : ident -> t - -val global_module : ident -> t - -val const : Lambda.structured_constant -> t - -val apply : ?ap_transformed_jsx:bool -> t -> t list -> ap_info -> t - -val function_ : - loc:Location.t -> - attr:Lambda.function_attribute -> - params:ident list -> - body:t -> - t - -val let_ : Lambda.let_kind -> ident -> t -> t -> t - -val letrec : (ident * t) list -> t -> t - -val if_ : t -> t -> t -> t - -val switch : t -> lambda_switch -> t - -val stringswitch : t -> (string * t) list -> t option -> t - -val false_ : t - -val unit : t - -val sequor : t -> t -> t - -val sequand : t -> t -> t - -val not_ : Location.t -> t -> t - -val seq : t -> t -> t - -val break : t - -val continue : t - -val while_ : t -> t -> t - -val try_ : t -> ident -> t -> t - -val assign : ident -> t -> t - -val prim : primitive:Lambda.primitive -> args:t list -> Location.t -> t - -val staticcatch : t -> int * ident list -> t -> t - -val staticraise : int -> t list -> t - -val for_ : ident -> t -> t -> Asttypes.direction_flag -> t -> t - -val for_of : ident -> t -> t -> t - -val for_await_of : ident -> t -> t -> t - -(**************************************************************) - -val shallow_map_sharing : (t -> t) -> t -> t - -val eq_approx : t -> t -> bool diff --git a/compiler/core/lam_analysis.ml b/compiler/core/lam_analysis.ml index aae2ac3aad6..c619054eab2 100644 --- a/compiler/core/lam_analysis.ml +++ b/compiler/core/lam_analysis.ml @@ -30,7 +30,7 @@ let not_zero_constant (x : Lambda.structured_constant) = | Const_bigint (_, i) -> i <> "0" | _ -> false -let rec no_side_effects (lam : Lam.t) : bool = +let rec no_side_effects (lam : Lambda.lambda) : bool = match lam with | Lvar _ | Lconst _ | Lfunction _ -> true | Lglobal_module _ -> true @@ -141,7 +141,7 @@ let really_big () = raise_notrace Too_big_to_inline (* let big_lambda = 1000 *) -let rec size (lam : Lam.t) = +let rec size (lam : Lambda.lambda) = try match lam with | Lvar _ -> 1 @@ -198,10 +198,10 @@ and size_constant x = | Const_block (_, str) -> Ext_list.fold_left str 0 (fun acc x -> acc + size_constant x) -and size_lams acc (lams : Lam.t list) = +and size_lams acc (lams : Lambda.lambda list) = Ext_list.fold_left lams acc (fun acc l -> acc + size l) -let args_all_const (args : Lam.t list) = +let args_all_const (args : Lambda.lambda list) = Ext_list.for_all args (fun x -> match x with | Lconst _ -> true @@ -220,7 +220,7 @@ let small_inline_size = 5 ideally we should also evaluate its size after inlining, since after partial evaluation, it might still be *very big* *) -let destruct_pattern (body : Lam.t) params args = +let destruct_pattern (body : Lambda.lambda) params args = let rec aux v params args = match (params, args) with | x :: xs, b :: bs -> if Ident.same x v then Some b else aux v xs bs @@ -231,22 +231,23 @@ let destruct_pattern (body : Lam.t) params args = | Lswitch (Lvar v, switch) -> ( match aux v params args with | Some (Lambda.Lconst _ as lam) -> - size (Lam.switch lam switch) < small_inline_size + size (Lambda.switch lam switch) < small_inline_size | Some _ | None -> false) | Lifthenelse (Lvar v, then_, else_) -> ( (* -FIXME *) match aux v params args with | Some (Lconst _ as lam) -> - size (Lam.if_ lam then_ else_) < small_inline_size + size (Lambda.if_ lam then_ else_) < small_inline_size | Some _ | None -> false) | _ -> false (* Async functions cannot be beta reduced *) -let lfunction_can_be_inlined (lfunction : Lam.lfunction) = +let lfunction_can_be_inlined (lfunction : Lambda.lfunction) = (not lfunction.attr.async) && lfunction.attr.directive = None (** Hints to inlining *) -let ok_to_inline_fun_when_app (m : Lam.lfunction) (args : Lam.t list) = +let ok_to_inline_fun_when_app (m : Lambda.lfunction) (args : Lambda.lambda list) + = match m.attr.inline with | Always_inline -> true | Never_inline -> false @@ -261,7 +262,7 @@ let ok_to_inline_fun_when_app (m : Lam.lfunction) (args : Lam.t list) = (* TODO: We can relax this a bit later, but decide whether to inline it later in the call site *) -let safe_to_inline (lam : Lam.t) = +let safe_to_inline (lam : Lambda.lambda) = match lam with | Lfunction _ -> true | Lconst diff --git a/compiler/core/lam_analysis.mli b/compiler/core/lam_analysis.mli index 0451182da40..609f34d7f77 100644 --- a/compiler/core/lam_analysis.mli +++ b/compiler/core/lam_analysis.mli @@ -24,17 +24,17 @@ (** A module which provides some basic analysis over lambda expression *) -val no_side_effects : Lam.t -> bool +val no_side_effects : Lambda.lambda -> bool (** No side effect, but it might depend on data store *) -val size : Lam.t -> int +val size : Lambda.lambda -> int -val lfunction_can_be_inlined : Lam.lfunction -> bool +val lfunction_can_be_inlined : Lambda.lfunction -> bool -val ok_to_inline_fun_when_app : Lam.lfunction -> Lam.t list -> bool +val ok_to_inline_fun_when_app : Lambda.lfunction -> Lambda.lambda list -> bool val small_inline_size : int val exit_inline_size : int -val safe_to_inline : Lam.t -> bool +val safe_to_inline : Lambda.lambda -> bool diff --git a/compiler/core/lam_arity_analysis.ml b/compiler/core/lam_arity_analysis.ml index b0cd7ef6edf..b67a1ec1ed4 100644 --- a/compiler/core/lam_arity_analysis.ml +++ b/compiler/core/lam_arity_analysis.ml @@ -35,7 +35,7 @@ let arity_of_var (meta : Lam_stats.t) (v : Ident.t) = We will keep iterating such environment If not found, we will return [NA] *) -let rec get_arity (meta : Lam_stats.t) (lam : Lam.t) : Lam_arity.t = +let rec get_arity (meta : Lam_stats.t) (lam : Lambda.lambda) : Lam_arity.t = match lam with | Lvar v -> arity_of_var meta v | Lconst _ -> Lam_arity.non_function_arity_info @@ -127,7 +127,7 @@ let rec get_arity (meta : Lam_stats.t) (lam : Lam.t) : Lam_arity.t = | Lwhile _ | Lfor _ | Lfor_of _ | Lfor_await_of _ | Lassign _ -> Lam_arity.non_function_arity_info -and all_lambdas meta (xs : Lam.t list) = +and all_lambdas meta (xs : Lambda.lambda list) = match xs with | y :: ys -> let arity = get_arity meta y in diff --git a/compiler/core/lam_arity_analysis.mli b/compiler/core/lam_arity_analysis.mli index ee148975ae3..810e9b684c9 100644 --- a/compiler/core/lam_arity_analysis.mli +++ b/compiler/core/lam_arity_analysis.mli @@ -24,4 +24,4 @@ (** Utilities for lambda analysis *) -val get_arity : Lam_stats.t -> Lam.t -> Lam_arity.t +val get_arity : Lam_stats.t -> Lambda.lambda -> Lam_arity.t diff --git a/compiler/core/lam_beta_reduce.ml b/compiler/core/lam_beta_reduce.ml index ae6bdd42270..b21ed8bbe88 100644 --- a/compiler/core/lam_beta_reduce.ml +++ b/compiler/core/lam_beta_reduce.ml @@ -45,7 +45,7 @@ we can bound [x] to [100] in a single step *) let propagate_beta_reduce (meta : Lam_stats.t) (params : Ident.t list) - (body : Lam.t) (args : Lam.t list) = + (body : Lambda.lambda) (args : Lambda.lambda list) = match Lam_beta_reduce_util.simple_beta_reduce params body args with | Some x -> x | None -> @@ -56,7 +56,7 @@ let propagate_beta_reduce (meta : Lam_stats.t) (params : Ident.t list) | Lconst _ | Lvar _ -> (rest_bindings, arg :: acc) | _ -> let p = Ident.rename old_param in - ((p, arg) :: rest_bindings, Lam.var p :: acc)) + ((p, arg) :: rest_bindings, Lambda.var p :: acc)) in let new_body = Lam_bounded_vars.rewrite @@ -89,7 +89,7 @@ let propagate_beta_reduce_with_map (meta : Lam_stats.t) | Lconst _ | Lvar _ -> (rest_bindings, arg :: acc) | Lglobal_module _ -> let p = Ident.rename old_param in - ((p, arg) :: rest_bindings, Lam.var p :: acc) + ((p, arg) :: rest_bindings, Lambda.var p :: acc) | _ -> if Lam_analysis.no_side_effects arg then match Map_ident.find_exn map old_param with @@ -98,10 +98,10 @@ let propagate_beta_reduce_with_map (meta : Lam_stats.t) (rest_bindings, arg :: acc) else let p = Ident.rename old_param in - ((p, arg) :: rest_bindings, Lam.var p :: acc) + ((p, arg) :: rest_bindings, Lambda.var p :: acc) else let p = Ident.rename old_param in - ((p, arg) :: rest_bindings, Lam.var p :: acc)) + ((p, arg) :: rest_bindings, Lambda.var p :: acc)) in let new_body = Lam_bounded_vars.rewrite @@ -109,7 +109,8 @@ let propagate_beta_reduce_with_map (meta : Lam_stats.t) body in (* See above: fold left so arguments evaluate in call order. *) - Ext_list.fold_left rest_bindings new_body (fun l (param, (arg : Lam.t)) -> + Ext_list.fold_left rest_bindings new_body + (fun l (param, (arg : Lambda.lambda)) -> (match arg with | Lprim {primitive = Pmakeblock info; args} when Lambda.is_immutable_block info -> diff --git a/compiler/core/lam_beta_reduce.mli b/compiler/core/lam_beta_reduce.mli index 8be5e2d49e8..e1e1a41b66e 100644 --- a/compiler/core/lam_beta_reduce.mli +++ b/compiler/core/lam_beta_reduce.mli @@ -24,7 +24,8 @@ (** Beta reduction of lambda IR *) -val no_names_beta_reduce : Ident.t list -> Lam.t -> Lam.t list -> Lam.t +val no_names_beta_reduce : + Ident.t list -> Lambda.lambda -> Lambda.lambda list -> Lambda.lambda (* Compile-time beta-reduction of functions immediately applied: Lapply(Lfunction(Curried, params, body), args, loc) -> let paramN = argN in ... let param1 = arg1 in body @@ -43,15 +44,19 @@ val no_names_beta_reduce : Ident.t list -> Lam.t -> Lam.t list -> Lam.t *) val propagate_beta_reduce : - Lam_stats.t -> Ident.t list -> Lam.t -> Lam.t list -> Lam.t + Lam_stats.t -> + Ident.t list -> + Lambda.lambda -> + Lambda.lambda list -> + Lambda.lambda val propagate_beta_reduce_with_map : Lam_stats.t -> Lam_var_stats.stats Map_ident.t -> Ident.t list -> - Lam.t -> - Lam.t list -> - Lam.t + Lambda.lambda -> + Lambda.lambda list -> + Lambda.lambda (** {[ Lam_beta_reduce.propogate_beta_reduce_with_map meta param_map diff --git a/compiler/core/lam_beta_reduce_util.ml b/compiler/core/lam_beta_reduce_util.ml index c1855dec203..22d9d73db35 100644 --- a/compiler/core/lam_beta_reduce_util.ml +++ b/compiler/core/lam_beta_reduce_util.ml @@ -31,7 +31,7 @@ other wise the evaluation order is tricky (make sure eval order is correct) *) -type value = {mutable used: bool; lambda: Lam.t} +type value = {mutable used: bool; lambda: Lambda.lambda} let param_hash : _ Hash_ident.t = Hash_ident.create 20 @@ -44,7 +44,7 @@ let param_hash : _ Hash_ident.t = Hash_ident.create 20 {[ when Ext_list.for_all2_no_exn (fun p a -> - match (a : Lam.t) with + match (a : Lambda.lambda) with | Lvar a -> Ident.same p a | _ -> false ) params args' ]} @@ -58,14 +58,14 @@ let simple_beta_reduce params body args = exp.lambda | None -> opt in - let rec aux_exn acc (us : Lam.t list) = + let rec aux_exn acc (us : Lambda.lambda list) = match us with | [] -> List.rev acc | (Lvar x as a) :: rest -> aux_exn (find_param_exn x a :: acc) rest | (Lconst _ as u) :: rest -> aux_exn (u :: acc) rest | _ :: _ -> raise_notrace Not_simple_apply in - match (body : Lam.t) with + match (body : Lambda.lambda) with | Lprim {primitive; args = ap_args; loc = ap_loc} (* There is no lambda in primitive *) -> ( (* catch a special case of primitives *) @@ -77,10 +77,11 @@ let simple_beta_reduce params body args = try let new_args = aux_exn [] ap_args in let result = - Hash_ident.fold param_hash (Lam.prim ~primitive ~args:new_args ap_loc) + Hash_ident.fold param_hash + (Lambda.prim ~primitive ~args:new_args ap_loc) (fun _param stats acc -> let {lambda; used} = stats in - if not used then Lam.seq lambda acc else acc) + if not used then Lambda.seq lambda acc else acc) in Hash_ident.clear param_hash; Some result @@ -113,10 +114,10 @@ let simple_beta_reduce params body args = | _ -> f in let result = - Hash_ident.fold param_hash (Lam.apply f new_args ap_info) + Hash_ident.fold param_hash (Lambda.apply f new_args ap_info) (fun _param stat acc -> let {lambda; used} = stat in - if not used then Lam.seq lambda acc else acc) + if not used then Lambda.seq lambda acc else acc) in Hash_ident.clear param_hash; Some result diff --git a/compiler/core/lam_beta_reduce_util.mli b/compiler/core/lam_beta_reduce_util.mli index 585611be7b5..50ed94fb3a8 100644 --- a/compiler/core/lam_beta_reduce_util.mli +++ b/compiler/core/lam_beta_reduce_util.mli @@ -22,4 +22,5 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val simple_beta_reduce : Ident.t list -> Lam.t -> Lam.t list -> Lam.t option +val simple_beta_reduce : + Ident.t list -> Lambda.lambda -> Lambda.lambda list -> Lambda.lambda option diff --git a/compiler/core/lam_bounded_vars.ml b/compiler/core/lam_bounded_vars.ml index 9a1888736d5..718cdc3d59f 100644 --- a/compiler/core/lam_bounded_vars.ml +++ b/compiler/core/lam_bounded_vars.ml @@ -61,10 +61,10 @@ 2. number of invoked times 3. arguments are const or not *) -let rewrite (map : _ Hash_ident.t) (lam : Lam.t) : Lam.t = +let rewrite (map : _ Hash_ident.t) (lam : Lambda.lambda) : Lambda.lambda = let rebind i = let i' = Ident.rename i in - Hash_ident.add map i (Lam.var i'); + Hash_ident.add map i (Lambda.var i'); i' in (* order matters, especially for let bindings *) @@ -72,14 +72,14 @@ let rewrite (map : _ Hash_ident.t) (lam : Lam.t) : Lam.t = match op with | None -> None | Some x -> Some (aux x) - and aux (lam : Lam.t) : Lam.t = + and aux (lam : Lambda.lambda) : Lambda.lambda = match lam with | Lvar v -> Hash_ident.find_default map v lam | Llet (str, v, l1, l2) -> let v = rebind v in let l1 = aux l1 in let l2 = aux l2 in - Lam.let_ str v l1 l2 + Lambda.let_ str v l1 l2 | Lletrec (bindings, body) -> (*order matters see GPR #405*) let vars = Ext_list.map bindings (fun (k, _) -> rebind k) in @@ -87,41 +87,41 @@ let rewrite (map : _ Hash_ident.t) (lam : Lam.t) : Lam.t = Ext_list.map2 vars bindings (fun var (_, l) -> (var, aux l)) in let body = aux body in - Lam.letrec bindings body + Lambda.letrec bindings body | Lfunction {params; body; attr; loc} -> let params = Ext_list.map params rebind in let body = aux body in - Lam.function_ ~loc ~params ~body ~attr + Lambda.function_ ~loc ~params ~body ~attr | Lstaticcatch (l1, (i, xs), l2) -> let l1 = aux l1 in let xs = Ext_list.map xs rebind in let l2 = aux l2 in - Lam.staticcatch l1 (i, xs) l2 + Lambda.staticcatch l1 (i, xs) l2 | Lfor (ident, l1, l2, dir, l3) -> let ident = rebind ident in let l1 = aux l1 in let l2 = aux l2 in let l3 = aux l3 in - Lam.for_ ident (aux l1) l2 dir l3 + Lambda.for_ ident (aux l1) l2 dir l3 | Lfor_of (ident, l1, l2) -> let ident = rebind ident in let l1 = aux l1 in let l2 = aux l2 in - Lam.for_of ident l1 l2 + Lambda.for_of ident l1 l2 | Lfor_await_of (ident, l1, l2) -> let ident = rebind ident in let l1 = aux l1 in let l2 = aux l2 in - Lam.for_await_of ident l1 l2 + Lambda.for_await_of ident l1 l2 | Lconst _ -> lam | Lprim {primitive; args; loc} -> (* here it makes sure that global vars are not rebound *) - Lam.prim ~primitive ~args:(Ext_list.map args aux) loc + Lambda.prim ~primitive ~args:(Ext_list.map args aux) loc | Lglobal_module _ -> lam | Lapply {ap_func; ap_args; ap_info; ap_transformed_jsx} -> let fn = aux ap_func in let args = Ext_list.map ap_args aux in - Lam.apply ~ap_transformed_jsx fn args ap_info + Lambda.apply ~ap_transformed_jsx fn args ap_info | Lswitch ( l, { @@ -133,7 +133,7 @@ let rewrite (map : _ Hash_ident.t) (lam : Lam.t) : Lam.t = sw_dispatch; } ) -> let l = aux l in - Lam.switch l + Lambda.switch l { sw_consts = Ext_list.map_snd sw_consts aux; sw_blocks = Ext_list.map_snd sw_blocks aux; @@ -144,30 +144,30 @@ let rewrite (map : _ Hash_ident.t) (lam : Lam.t) : Lam.t = } | Lstringswitch (l, sw, d) -> let l = aux l in - Lam.stringswitch l (Ext_list.map_snd sw aux) (option_map d) - | Lstaticraise (i, ls) -> Lam.staticraise i (Ext_list.map ls aux) + Lambda.stringswitch l (Ext_list.map_snd sw aux) (option_map d) + | Lstaticraise (i, ls) -> Lambda.staticraise i (Ext_list.map ls aux) | Ltrywith (l1, v, l2) -> let l1 = aux l1 in let v = rebind v in let l2 = aux l2 in - Lam.try_ l1 v l2 + Lambda.try_ l1 v l2 | Lifthenelse (l1, l2, l3) -> let l1 = aux l1 in let l2 = aux l2 in let l3 = aux l3 in - Lam.if_ l1 l2 l3 + Lambda.if_ l1 l2 l3 | Lsequence (l1, l2) -> let l1 = aux l1 in let l2 = aux l2 in - Lam.seq l1 l2 - | Lbreak -> Lam.break - | Lcontinue -> Lam.continue + Lambda.seq l1 l2 + | Lbreak -> Lambda.break + | Lcontinue -> Lambda.continue | Lwhile (l1, l2) -> let l1 = aux l1 in let l2 = aux l2 in - Lam.while_ l1 l2 - | Lassign (v, l) -> Lam.assign v (aux l) + Lambda.while_ l1 l2 + | Lassign (v, l) -> Lambda.assign v (aux l) in aux lam -(* let refresh lam = rewrite (Hash_ident.create 17 : Lam.t Hash_ident.t ) lam *) +(* let refresh lam = rewrite (Hash_ident.create 17 : Lambda.lambda Hash_ident.t ) lam *) diff --git a/compiler/core/lam_bounded_vars.mli b/compiler/core/lam_bounded_vars.mli index 7969aaf78a2..14efda71a6e 100644 --- a/compiler/core/lam_bounded_vars.mli +++ b/compiler/core/lam_bounded_vars.mli @@ -22,12 +22,12 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val rewrite : Lam.t Hash_ident.t -> Lam.t -> Lam.t +val rewrite : Lambda.lambda Hash_ident.t -> Lambda.lambda -> Lambda.lambda (** [rewrite tbl lam] Given a [tbl] to rewrite all bounded variables in [lam] *) (** refresh lambda to replace all bounded vars for new ones *) (* val refresh : - Lam.t -> - Lam.t *) + Lambda.lambda -> + Lambda.lambda *) diff --git a/compiler/core/lam_check.ml b/compiler/core/lam_check.ml index 3411c304736..4a47c41069c 100644 --- a/compiler/core/lam_check.ml +++ b/compiler/core/lam_check.ml @@ -47,9 +47,9 @@ let check ~file ~pass lam = in let rec check_list xs (cxt : Set_int.t) = Ext_list.iter xs (fun x -> check_staticfails x cxt) - and check_list_snd : 'a. ('a * Lam.t) list -> _ -> unit = + and check_list_snd : 'a. ('a * Lambda.lambda) list -> _ -> unit = fun xs cxt -> Ext_list.iter_snd xs (fun x -> check_staticfails x cxt) - and check_staticfails (l : Lam.t) (cxt : Set_int.t) = + and check_staticfails (l : Lambda.lambda) (cxt : Set_int.t) = match l with | Lvar _ | Lconst _ | Lglobal_module _ -> () | Lprim {args; _} -> check_list args cxt @@ -98,9 +98,9 @@ let check ~file ~pass lam = | Lassign (_id, e) -> check_staticfails e cxt in let rec iter_list xs = Ext_list.iter xs iter - and iter_list_snd : 'a. ('a * Lam.t) list -> unit = + and iter_list_snd : 'a. ('a * Lambda.lambda) list -> unit = fun xs -> Ext_list.iter_snd xs iter - and iter (l : Lam.t) = + and iter (l : Lambda.lambda) = match l with | Lvar id -> use id | Lglobal_module _ -> () diff --git a/compiler/core/lam_check.mli b/compiler/core/lam_check.mli index 2e4b08bc6e0..9d7d58a6dc5 100644 --- a/compiler/core/lam_check.mli +++ b/compiler/core/lam_check.mli @@ -22,4 +22,4 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val check : file:string -> pass:string -> Lam.t -> Lam.t +val check : file:string -> pass:string -> Lambda.lambda -> Lambda.lambda diff --git a/compiler/core/lam_closure.ml b/compiler/core/lam_closure.ml index 2092c92b9ff..eb87d0f3c01 100644 --- a/compiler/core/lam_closure.ml +++ b/compiler/core/lam_closure.ml @@ -52,7 +52,7 @@ let sink_pos = Lam_var_stats.sink An enriched version of [free_varaibles] in {!Lam_free_variables} *) let free_variables (export_idents : Set_ident.t) (params : stats Map_ident.t) - (lam : Lam.t) : stats Map_ident.t = + (lam : Lambda.lambda) : stats Map_ident.t = let fv = ref params in let local_set = ref export_idents in let local_add k = local_set := Set_ident.add !local_set k in @@ -65,7 +65,7 @@ let free_variables (export_idents : Set_ident.t) (params : stats Map_ident.t) if not (Set_ident.mem !local_set v) then fv := adjust !fv cur_pos v in - let rec iter (top : position) (lam : Lam.t) = + let rec iter (top : position) (lam : Lambda.lambda) = match lam with | Lvar v -> used top v | Lconst _ -> () @@ -150,7 +150,7 @@ let free_variables (export_idents : Set_ident.t) (params : stats Map_ident.t) iter Lam_var_stats.fresh_env lam; !fv -(* let is_closed_by (set : Set_ident.t) (lam : Lam.t) : bool = +(* let is_closed_by (set : Set_ident.t) (lam : Lambda.lambda) : bool = Map_ident.is_empty (free_variables set (Map_ident.empty ) lam ) *) (** A bit consverative , it should be empty *) @@ -159,7 +159,7 @@ let is_closed lam = (fun k _ -> Ident.global k) let is_closed_with_map (exports : Set_ident.t) (params : Ident.t list) - (body : Lam.t) : bool * stats Map_ident.t = + (body : Lambda.lambda) : bool * stats Map_ident.t = let param_map = free_variables exports (param_map_of_list params) body in let old_count = List.length params in let new_count = Map_ident.cardinal param_map in diff --git a/compiler/core/lam_closure.mli b/compiler/core/lam_closure.mli index 392cb5caa11..391c2645e50 100644 --- a/compiler/core/lam_closure.mli +++ b/compiler/core/lam_closure.mli @@ -25,16 +25,19 @@ (** [is_closed_by map lam] return [true] if all unbound variables belongs to the given [map] *) -(* val is_closed_by : Set_ident.t -> Lam.t -> bool *) +(* val is_closed_by : Set_ident.t -> Lambda.lambda -> bool *) -val is_closed : Lam.t -> bool +val is_closed : Lambda.lambda -> bool val is_closed_with_map : - Set_ident.t -> Ident.t list -> Lam.t -> bool * Lam_var_stats.stats Map_ident.t + Set_ident.t -> + Ident.t list -> + Lambda.lambda -> + bool * Lam_var_stats.stats Map_ident.t (** The output is mostly used in betat reduction *) val free_variables : Set_ident.t -> Lam_var_stats.stats Map_ident.t -> - Lam.t -> + Lambda.lambda -> Lam_var_stats.stats Map_ident.t diff --git a/compiler/core/lam_coercion.ml b/compiler/core/lam_coercion.ml index e4f441c4001..9bd09da74fb 100644 --- a/compiler/core/lam_coercion.ml +++ b/compiler/core/lam_coercion.ml @@ -72,14 +72,14 @@ type t = { export_list: Ident.t list; export_set: Set_ident.t; - export_map: Lam.t Map_ident.t; + export_map: Lambda.lambda Map_ident.t; (** not used in code generation, mostly used for store some information in cmj files *) groups: Lam_group.t list; (* all code to be compiled later = original code + rebound coercions *) } -let handle_exports (meta : Lam_stats.t) (lambda_exports : Lam.t list) +let handle_exports (meta : Lam_stats.t) (lambda_exports : Lambda.lambda list) (reverse_input : Lam_group.t list) = let (original_exports : Ident.t list) = meta.exports in let (original_export_set : Set_ident.t) = meta.export_idents in @@ -92,7 +92,7 @@ let handle_exports (meta : Lam_stats.t) (lambda_exports : Lam.t list) export_set = original_export_set; export_map = Map_ident.empty; groups = []; - } (fun (original_export_id : Ident.t) (lam : Lam.t) (acc : t) -> + } (fun (original_export_id : Ident.t) (lam : Lambda.lambda) (acc : t) -> let original_name = original_export_id.name in if not @@ Hash_set_string.check_add tbl original_name then Bs_exception.error (Bs_duplicate_exports original_name); @@ -176,8 +176,8 @@ let handle_exports (meta : Lam_stats.t) (lambda_exports : Lam.t list) - [compile_group] and [compile] become mutually recursive function *) -let rec flatten (acc : Lam_group.t list) (lam : Lam.t) : - Lam.t * Lam_group.t list = +let rec flatten (acc : Lam_group.t list) (lam : Lambda.lambda) : + Lambda.lambda * Lam_group.t list = match lam with | Llet (str, id, arg, body) -> let res, l = flatten acc arg in diff --git a/compiler/core/lam_coercion.mli b/compiler/core/lam_coercion.mli index e9163c9d6bd..4fb64d709fa 100644 --- a/compiler/core/lam_coercion.mli +++ b/compiler/core/lam_coercion.mli @@ -25,8 +25,9 @@ type t = { export_list: Ident.t list; export_set: Set_ident.t; - export_map: Lam.t Map_ident.t; + export_map: Lambda.lambda Map_ident.t; groups: Lam_group.t list; } -val coerce_and_group_big_lambda : Lam_stats.t -> Lam.t -> t * Lam_stats.t +val coerce_and_group_big_lambda : + Lam_stats.t -> Lambda.lambda -> t * Lam_stats.t diff --git a/compiler/core/lam_compile.ml b/compiler/core/lam_compile.ml index 810ba7319ec..9ff3c9f882a 100644 --- a/compiler/core/lam_compile.ml +++ b/compiler/core/lam_compile.ml @@ -32,7 +32,7 @@ let with_source_loc loc (exp : J.expression) = | Some source_loc, None -> {exp with source_loc = Some source_loc} | _ -> exp -let rec source_loc_of_lam (lam : Lam.t) = +let rec source_loc_of_lam (lam : Lambda.lambda) = match lam with | Lapply {ap_info = {ap_loc}} -> Some ap_loc | Lprim {loc} | Lfunction {loc} -> Some loc @@ -83,7 +83,7 @@ let with_block_source_loc lam block = | stmt :: rest -> with_statement_source_loc (source_map_loc_of_lam lam) stmt :: rest -let args_either_function_or_const (args : Lam.t list) = +let args_either_function_or_const (args : Lambda.lambda list) = Ext_list.for_all args (fun x -> match x with | Lfunction _ | Lconst _ -> true @@ -95,7 +95,7 @@ let args_either_function_or_const (args : Lam.t list) = an FFI name, whose wrapper carries argument adaptation. Looked up here rather than stamped on the application by an earlier pass. *) let call_info_of_apply (meta : Lam_stats.t) call_transformed_jsx - (appinfo : Lam.apply) : Js_call_info.t = + (appinfo : Lambda.lambda_apply) : Js_call_info.t = let saturated = match Lam_arity.extract_arity @@ -131,8 +131,8 @@ let in_staticcatch (x : Lam_compile_context.tail_type) : -> x *) (* assume outer is [Lstaticcatch] *) -let rec flat_catches (acc : Lam_compile_context.handler list) (x : Lam.t) : - Lam_compile_context.handler list * Lam.t = +let rec flat_catches (acc : Lam_compile_context.handler list) + (x : Lambda.lambda) : Lam_compile_context.handler list * Lambda.lambda = match x with | Lstaticcatch (l, (label, bindings), handler) when acc = [] @@ -143,8 +143,8 @@ let rec flat_catches (acc : Lam_compile_context.handler list) (x : Lam.t) : flat_catches ({label; handler; bindings} :: acc) l | _ -> (acc, x) -let flatten_nested_caches (x : Lam.t) : Lam_compile_context.handler list * Lam.t - = +let flatten_nested_caches (x : Lambda.lambda) : + Lam_compile_context.handler list * Lambda.lambda = flat_catches [] x let morph_declare_to_assign (cxt : Lam_compile_context.t) k = @@ -156,7 +156,7 @@ let morph_declare_to_assign (cxt : Lam_compile_context.t) k = let group_apply ~merge_cases cases callback = Ext_list.flat_map (Ext_list.stable_group cases (fun (tag1, lam) (tag2, lam1) -> - merge_cases tag1 tag2 && Lam.eq_approx lam lam1)) + merge_cases tag1 tag2 && Lambda.eq_approx lam lam1)) (fun group -> Ext_list.map_last group callback) (* TODO: for expression generation, @@ -164,7 +164,7 @@ let group_apply ~merge_cases cases callback = only jmp_table and env needed *) -type default_case = Default of Lam.t | Complete | NonComplete +type default_case = Default of Lambda.lambda | Complete | NonComplete let default_action ~saturated failaction = match failaction with @@ -239,7 +239,7 @@ type initialization = J.block (* 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) = +let functions_before_values (group : (Ident.t * Lambda.lambda) list) = if Ext_list.for_all group (fun (_, x) -> match x with @@ -249,7 +249,7 @@ let functions_before_values (group : (Ident.t * Lam.t) list) = else List.sort (fun (_, lama) (_, lamb) -> - match ((lama : Lam.t), (lamb : Lam.t)) with + match ((lama : Lambda.lambda), (lamb : Lambda.lambda)) with | Lfunction _, Lfunction _ -> 0 | Lfunction _, _ -> -1 | _, Lfunction _ -> 1 @@ -323,8 +323,9 @@ let compile output_prefix = for the function, generative module or functor can be a function, however it can not be global -- global can only module *) - and compile_external_field_apply (appinfo : Lam.apply) (module_id : Ident.t) - (field_name : string) (lambda_cxt : Lam_compile_context.t) : Js_output.t = + and compile_external_field_apply (appinfo : Lambda.lambda_apply) + (module_id : Ident.t) (field_name : string) + (lambda_cxt : Lam_compile_context.t) : Js_output.t = let ident_info = Lam_compile_env.query_external_id_info module_id field_name in @@ -373,7 +374,7 @@ let compile output_prefix = *) and compile_recursive_let ~all_bindings (cxt : Lam_compile_context.t) - (id : Ident.t) (arg : Lam.t) : Js_output.t * initialization = + (id : Ident.t) (arg : Lambda.lambda) : Js_output.t * initialization = match arg with | Lfunction { @@ -537,8 +538,8 @@ let compile output_prefix = ]} *) (compile_lambda {cxt with continuation = Declare (Alias, id)} arg, []) - and compile_recursive_lets_aux cxt (id_args : (Ident.t * Lam.t) list) : - Js_output.t = + and compile_recursive_lets_aux cxt (id_args : (Ident.t * Lambda.lambda) list) + : Js_output.t = (* #1716 *) let output_code, ids = Ext_list.fold_right id_args (Js_output.dummy, []) @@ -570,7 +571,7 @@ let compile output_prefix = switch_exp:J.expression -> default:default_case -> ?merge_cases:('a -> 'a -> bool) -> - ('a * Lam.t) list -> + ('a * Lambda.lambda) list -> J.block = fun (type a) ~(make_exp : a -> J.expression) ~(eq_exp : @@ -582,7 +583,7 @@ let compile output_prefix = _ -> (a * J.case_clause) list -> J.statement) ~(switch_exp : J.expression) ~(default : default_case) - ?(merge_cases = fun _ _ -> true) (cases : (a * Lam.t) list) -> + ?(merge_cases = fun _ _ -> true) (cases : (a * Lambda.lambda) list) -> let output_block_with_source_loc cxt lam = compile_lambda cxt lam |> Js_output.output_as_block |> with_block_source_loc lam @@ -638,7 +639,9 @@ let compile output_prefix = let cases = match default with | Default lam -> - List.filter (fun (_, lam1) -> not (Lam.eq_approx lam lam1)) cases + List.filter + (fun (_, lam1) -> not (Lambda.eq_approx lam lam1)) + cases | _ -> cases in let switch_cxt = Lam_compile_context.enter_switch cxt in @@ -726,7 +729,7 @@ let compile output_prefix = | Switch_constructor _ -> assert false) clauses)) ~switch_exp ~default - and compile_switch (switch_arg : Lam.t) (sw : Lam.lambda_switch) + and compile_switch (switch_arg : Lambda.lambda) (sw : Lambda.lambda_switch) (lambda_cxt : Lam_compile_context.t) = (* TODO: if default is None, we can do some optimizations Use switch vs if/then/else @@ -743,7 +746,7 @@ let compile output_prefix = sw_failaction; sw_dispatch; } - : Lam.lambda_switch) = + : Lambda.lambda_switch) = sw in let sw_num_default = @@ -780,7 +783,7 @@ let compile output_prefix = in let eq_default d1 d2 = match (d1, d2) with - | Default lam1, Default lam2 -> Lam.eq_approx lam1 lam2 + | Default lam1, Default lam2 -> Lambda.eq_approx lam1 lam2 | Complete, Complete -> true | NonComplete, NonComplete -> true | _ -> false @@ -971,7 +974,7 @@ let compile output_prefix = default: (exit 1)) with (1) 2)) *) - and compile_staticraise i (largs : Lam.t list) + and compile_staticraise i (largs : Lambda.lambda list) (lambda_cxt : Lam_compile_context.t) = (* [i] is the jump table, [largs] is the arguments passed to [Lstaticcatch]*) match Lam_compile_context.find_exn lambda_cxt i with @@ -1018,7 +1021,8 @@ let compile output_prefix = ]} *) - and compile_staticcatch (lam : Lam.t) (lambda_cxt : Lam_compile_context.t) = + and compile_staticcatch (lam : Lambda.lambda) + (lambda_cxt : Lam_compile_context.t) = let code_table, body = flatten_nested_caches lam in let exit_id = Ext_ident.create_tmp ~name:"exit" () in match (lambda_cxt.continuation, code_table) with @@ -1104,10 +1108,10 @@ let compile output_prefix = (Js_output.append_output lbody (Js_output.make (compile_cases ~cxt:new_cxt ~switch_exp:exit_expr handlers)))) - and compile_sequand (l : Lam.t) (r : Lam.t) + and compile_sequand (l : Lambda.lambda) (r : Lambda.lambda) (lambda_cxt : Lam_compile_context.t) = if Lam_compile_context.continuation_is_return lambda_cxt.continuation then - compile_lambda lambda_cxt (Lam.sequand l r) + compile_lambda lambda_cxt (Lambda.sequand l r) else let new_cxt = {lambda_cxt with continuation = NeedValue Not_tail} in match compile_lambda new_cxt l with @@ -1143,10 +1147,10 @@ let compile output_prefix = ((S.define_variable ~kind:Variable v E.false_ :: l_block) @ [S.if_ l_expr (r_block @ [S.assign v r_expr])]) ~value:(E.var v))) - and compile_sequor (l : Lam.t) (r : Lam.t) + and compile_sequor (l : Lambda.lambda) (r : Lambda.lambda) (lambda_cxt : Lam_compile_context.t) = if Lam_compile_context.continuation_is_return lambda_cxt.continuation then - compile_lambda lambda_cxt (Lam.sequor l r) + compile_lambda lambda_cxt (Lambda.sequor l r) else let new_cxt = {lambda_cxt with continuation = NeedValue Not_tail} in match compile_lambda new_cxt l with @@ -1190,7 +1194,7 @@ let compile output_prefix = while expression, here we generate for statement, leave optimization later. (Sine OCaml expression can be really complex..) *) - and compile_while (predicate : Lam.t) (body : Lam.t) + and compile_while (predicate : Lambda.lambda) (body : Lambda.lambda) (lambda_cxt : Lam_compile_context.t) = match compile_lambda @@ -1228,9 +1232,9 @@ let compile output_prefix = for(var i = 0 ; i < (console.log(i),10); ++i){console.log('hi')} print i each time, so they are different semantics... *) - and compile_for (id : J.for_ident) (start : Lam.t) (finish : Lam.t) - (direction : Js_op.direction_flag) (body : Lam.t) - (lambda_cxt : Lam_compile_context.t) = + and compile_for (id : J.for_ident) (start : Lambda.lambda) + (finish : Lambda.lambda) (direction : Js_op.direction_flag) + (body : Lambda.lambda) (lambda_cxt : Lam_compile_context.t) = let new_cxt = {lambda_cxt with continuation = NeedValue Not_tail} in let block = match (compile_lambda new_cxt start, compile_lambda new_cxt finish) with @@ -1275,8 +1279,8 @@ let compile output_prefix = in Js_output.output_of_block_and_expression lambda_cxt.continuation block E.unit - and compile_for_of (id : J.for_ident) (iterable : Lam.t) (body : Lam.t) - (lambda_cxt : Lam_compile_context.t) = + and compile_for_of (id : J.for_ident) (iterable : Lambda.lambda) + (body : Lambda.lambda) (lambda_cxt : Lam_compile_context.t) = let new_cxt = {lambda_cxt with continuation = NeedValue Not_tail} in let emitted_id = if Lambda.Ident_set.mem id (Lambda.free_variables body) then id @@ -1298,8 +1302,8 @@ let compile output_prefix = in Js_output.output_of_block_and_expression lambda_cxt.continuation block E.unit - and compile_for_await_of (id : J.for_ident) (iterable : Lam.t) (body : Lam.t) - (lambda_cxt : Lam_compile_context.t) = + and compile_for_await_of (id : J.for_ident) (iterable : Lambda.lambda) + (body : Lambda.lambda) (lambda_cxt : Lam_compile_context.t) = let new_cxt = {lambda_cxt with continuation = NeedValue Not_tail} in let emitted_id = if Lambda.Ident_set.mem id (Lambda.free_variables body) then id @@ -1321,7 +1325,8 @@ let compile output_prefix = in Js_output.output_of_block_and_expression lambda_cxt.continuation block E.unit - and compile_assign id (lambda : Lam.t) (lambda_cxt : Lam_compile_context.t) = + and compile_assign id (lambda : Lambda.lambda) + (lambda_cxt : Lam_compile_context.t) = let block = match lambda with | _ -> ( @@ -1379,8 +1384,8 @@ let compile output_prefix = Js_output.make (aux lambda_cxt {lambda_cxt with continuation = EffectCall new_return_type}) - and compile_ifthenelse (predicate : Lam.t) (t_branch : Lam.t) - (f_branch : Lam.t) (lambda_cxt : Lam_compile_context.t) = + and compile_ifthenelse (predicate : Lambda.lambda) (t_branch : Lambda.lambda) + (f_branch : Lambda.lambda) (lambda_cxt : Lam_compile_context.t) = match compile_lambda {lambda_cxt with continuation = NeedValue Not_tail} @@ -1527,7 +1532,8 @@ let compile output_prefix = in Js_output.make (Ext_list.append_one b (S.if_ e then_output ~else_:else_output)))) - and compile_apply (appinfo : Lam.apply) (lambda_cxt : Lam_compile_context.t) = + and compile_apply (appinfo : Lambda.lambda_apply) + (lambda_cxt : Lam_compile_context.t) = match appinfo with (* External function call: it can not be tailcall in this case*) | { @@ -1612,7 +1618,7 @@ let compile output_prefix = (call_info_of_apply lambda_cxt.meta appinfo.ap_transformed_jsx appinfo) fn_code args))) - and compile_prim (prim_info : Lam.prim_info) + and compile_prim (prim_info : Lambda.prim_info) (lambda_cxt : Lam_compile_context.t) = let compile_primitive_default primitive args loc = let args_block, args_expr = @@ -1761,9 +1767,9 @@ let compile output_prefix = (Ext_list.concat_append args_block block) exp | {primitive; args; loc} -> compile_primitive_default primitive args loc - and collect_dup_overrides (copy_id : Ident.t) (lam : Lam.t) - (acc : (Lambda.set_field_dbg_info * Lam.t) list) : - (Lambda.set_field_dbg_info * Lam.t) list option = + and collect_dup_overrides (copy_id : Ident.t) (lam : Lambda.lambda) + (acc : (Lambda.set_field_dbg_info * Lambda.lambda) list) : + (Lambda.set_field_dbg_info * Lambda.lambda) list option = match lam with | Lsequence ( Lprim @@ -1774,7 +1780,8 @@ let compile output_prefix = | Lvar id' when Ident.same id' copy_id -> Some acc | _ -> None and try_compile_record_spread (lambda_cxt : Lam_compile_context.t) - (id : Ident.t) (arg : Lam.t) (body : Lam.t) : Js_output.t option = + (id : Ident.t) (arg : Lambda.lambda) (body : Lambda.lambda) : + Js_output.t option = match arg with | Lprim {primitive = Pduprecord; args = [init]; loc} -> ( match collect_dup_overrides id body [] with @@ -1814,8 +1821,8 @@ let compile output_prefix = blocks (with_source_loc loc (E.obj ~dup:init_val props)))) | _ -> None - and compile_lambda (lambda_cxt : Lam_compile_context.t) (cur_lam : Lam.t) : - Js_output.t = + and compile_lambda (lambda_cxt : Lam_compile_context.t) + (cur_lam : Lambda.lambda) : Js_output.t = match cur_lam with | Lfunction { diff --git a/compiler/core/lam_compile.mli b/compiler/core/lam_compile.mli index d5ed77b4040..48d20ab7d79 100644 --- a/compiler/core/lam_compile.mli +++ b/compiler/core/lam_compile.mli @@ -27,8 +27,8 @@ val compile_recursive_lets : output_prefix:string -> Lam_compile_context.t -> - (Ident.t * Lam.t) list -> + (Ident.t * Lambda.lambda) list -> Js_output.t val compile_lambda : - output_prefix:string -> Lam_compile_context.t -> Lam.t -> Js_output.t + output_prefix:string -> Lam_compile_context.t -> Lambda.lambda -> Js_output.t diff --git a/compiler/core/lam_compile_context.ml b/compiler/core/lam_compile_context.ml index d917b2d77e7..a153bc5281f 100644 --- a/compiler/core/lam_compile_context.ml +++ b/compiler/core/lam_compile_context.ml @@ -100,7 +100,11 @@ let ensure_loop_label cxt frame = frame.label <- Some label; label -type handler = {label: jbl_label; handler: Lam.t; bindings: Ident.t list} +type handler = { + label: jbl_label; + handler: Lambda.lambda; + bindings: Ident.t list; +} let no_static_raise_in_handler (x : handler) : bool = not (Lam_exit_code.has_exit_code x.handler (fun _code -> true)) @@ -112,7 +116,7 @@ let no_static_raise_in_handler (x : handler) : bool = [handlers] is used for compiling [staticcatch] *) let add_jmps (m : jmp_table) (exit_id : Ident.t) (code_table : handler list) : - jmp_table * (int * Lam.t) list = + jmp_table * (int * Lambda.lambda) list = let map, handlers = Ext_list.fold_left_with_offset code_table (m, []) (Handler_map.cardinal m + 1) @@ -124,7 +128,7 @@ let add_jmps (m : jmp_table) (exit_id : Ident.t) (code_table : handler list) : let add_pseudo_jmp (m : jmp_table) (exit_id : Ident.t) (* TODO not needed, remove it later *) - (code_table : handler) : jmp_table * Lam.t = + (code_table : handler) : jmp_table * Lambda.lambda = ( Handler_map.add m code_table.label {exit_id; bindings = code_table.bindings; order_id = -1}, code_table.handler ) diff --git a/compiler/core/lam_compile_context.mli b/compiler/core/lam_compile_context.mli index 9fe27c9888a..86d61aee9ca 100644 --- a/compiler/core/lam_compile_context.mli +++ b/compiler/core/lam_compile_context.mli @@ -82,13 +82,21 @@ val enter_switch : t -> t val push_loop : t -> t * loop_frame val ensure_loop_label : t -> loop_frame -> J.label -type handler = {label: jbl_label; handler: Lam.t; bindings: Ident.t list} +type handler = { + label: jbl_label; + handler: Lambda.lambda; + bindings: Ident.t list; +} val no_static_raise_in_handler : handler -> bool val add_jmps : - jmp_table -> Ident.t -> handler list -> jmp_table * (jbl_label * Lam.t) list + jmp_table -> + Ident.t -> + handler list -> + jmp_table * (jbl_label * Lambda.lambda) list -val add_pseudo_jmp : jmp_table -> Ident.t -> handler -> jmp_table * Lam.t +val add_pseudo_jmp : + jmp_table -> Ident.t -> handler -> jmp_table * Lambda.lambda val find_exn : t -> jbl_label -> value diff --git a/compiler/core/lam_compile_env.ml b/compiler/core/lam_compile_env.ml index a63388978f4..3482ad7e883 100644 --- a/compiler/core/lam_compile_env.ml +++ b/compiler/core/lam_compile_env.ml @@ -32,7 +32,7 @@ type env_value = type ident_info = Js_cmj_format.keyed_cmj_value = { name: string; arity: Js_cmj_format.arity; - persistent_closed_lambda: Lam.t option; + persistent_closed_lambda: Lambda.lambda option; } (* diff --git a/compiler/core/lam_compile_main.ml b/compiler/core/lam_compile_main.ml index 0aba4dff8ae..3475739e696 100644 --- a/compiler/core/lam_compile_main.ml +++ b/compiler/core/lam_compile_main.ml @@ -128,7 +128,7 @@ let js_hoisted_aliases (export_ids : Ident.t list) | [] -> base | (pos, name) :: fields -> access loc - (Lam.prim + (Lambda.prim ~primitive:(Lambda.Pfield (pos, Lambda.Fld_module {name})) ~args:[base] loc) fields @@ -226,7 +226,7 @@ let js_hoisted_aliases (export_ids : Ident.t list) name else let alias_id = Ident.create name in - let alias = access loc (Lam.var top_id) access_path in + let alias = access loc (Lambda.var top_id) access_path in ( ( Lam_group.Single (Alias, alias_id, alias), alias_id, alias, diff --git a/compiler/core/lam_exit_code.ml b/compiler/core/lam_exit_code.ml index d5cdcb38463..e5e1acef0ca 100644 --- a/compiler/core/lam_exit_code.ml +++ b/compiler/core/lam_exit_code.ml @@ -23,7 +23,7 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) let has_exit_code lam exits = - let rec aux (lam : Lam.t) = + let rec aux (lam : Lambda.lambda) = match lam with | Lfunction _ -> false (* static exit can not cross function boundary *) @@ -32,7 +32,7 @@ let has_exit_code lam exits = in aux lam -let rec has_exit (lam : Lam.t) = +let rec has_exit (lam : Lambda.lambda) = match lam with | Lfunction _ -> false | Lstaticraise (_, _) -> true diff --git a/compiler/core/lam_exit_code.mli b/compiler/core/lam_exit_code.mli index bd89d416545..06a84d11d1d 100644 --- a/compiler/core/lam_exit_code.mli +++ b/compiler/core/lam_exit_code.mli @@ -22,6 +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 has_exit_code : Lam.t -> (int -> bool) -> bool +val has_exit_code : Lambda.lambda -> (int -> bool) -> bool -val has_exit : Lam.t -> bool +val has_exit : Lambda.lambda -> bool diff --git a/compiler/core/lam_exit_count.ml b/compiler/core/lam_exit_count.ml index 045435a44e8..fc72181ae4c 100644 --- a/compiler/core/lam_exit_count.ml +++ b/compiler/core/lam_exit_count.ml @@ -48,9 +48,9 @@ let incr_exit (exits : collection) i = For Lswitch, if it is not exhuastive pattern match, default will be counted twice. Since for pattern match, we will test whether it is an integer or block, both have default cases predicate: [sw_consts_full] vs nconsts *) -let count_helper (lam : Lam.t) : collection = +let count_helper (lam : Lambda.lambda) : collection = let exits : collection = Hash_int.create 17 in - let rec count (lam : Lam.t) = + let rec count (lam : Lambda.lambda) = match lam with | Lstaticraise (i, ls) -> incr_exit exits i; diff --git a/compiler/core/lam_exit_count.mli b/compiler/core/lam_exit_count.mli index 9a621cf5ea1..a23c386978a 100644 --- a/compiler/core/lam_exit_count.mli +++ b/compiler/core/lam_exit_count.mli @@ -24,6 +24,6 @@ type collection -val count_helper : Lam.t -> collection +val count_helper : Lambda.lambda -> collection val count_exit : collection -> int -> int diff --git a/compiler/core/lam_group.ml b/compiler/core/lam_group.ml index 3a913f197c1..3a0133f5d01 100644 --- a/compiler/core/lam_group.ml +++ b/compiler/core/lam_group.ml @@ -24,16 +24,16 @@ (** This is not a recursive type definition *) type t = - | Single of Lambda.let_kind * Ident.t * Lam.t - | Recursive of (Ident.t * Lam.t) list - | Nop of Lam.t + | Single of Lambda.let_kind * Ident.t * Lambda.lambda + | Recursive of (Ident.t * Lambda.lambda) list + | Nop of Lambda.lambda -let single (kind : Lambda.let_kind) id (body : Lam.t) = +let single (kind : Lambda.let_kind) id (body : Lambda.lambda) = match (kind, body) with | (Strict | StrictOpt), (Lvar _ | Lconst _) -> Single (Alias, id, body) | _ -> Single (kind, id, body) -let nop_cons (x : Lam.t) acc = +let nop_cons (x : Lambda.lambda) acc = match x with | Lvar _ | Lconst _ | Lfunction _ -> acc | _ -> Nop x :: acc diff --git a/compiler/core/lam_group.mli b/compiler/core/lam_group.mli index 1e1f620a0ae..544e3905703 100644 --- a/compiler/core/lam_group.mli +++ b/compiler/core/lam_group.mli @@ -23,14 +23,14 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) type t = - | Single of Lambda.let_kind * Ident.t * Lam.t - | Recursive of (Ident.t * Lam.t) list - | Nop of Lam.t + | Single of Lambda.let_kind * Ident.t * Lambda.lambda + | Recursive of (Ident.t * Lambda.lambda) list + | Nop of Lambda.lambda (** Tricky to be complete *) val pp_group : Format.formatter -> t -> unit -val single : Lambda.let_kind -> Ident.t -> Lam.t -> t +val single : Lambda.let_kind -> Ident.t -> Lambda.lambda -> t -val nop_cons : Lam.t -> t list -> t list +val nop_cons : Lambda.lambda -> t list -> t list diff --git a/compiler/core/lam_hit.ml b/compiler/core/lam_hit.ml index fba5f7bdf74..fec457e2ebc 100644 --- a/compiler/core/lam_hit.ml +++ b/compiler/core/lam_hit.ml @@ -22,7 +22,7 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type t = Lam.t +type t = Lambda.lambda let hit_variables (fv : Set_ident.t) (l : t) : bool = let rec hit_opt (x : t option) = diff --git a/compiler/core/lam_hit.mli b/compiler/core/lam_hit.mli index be3199ea189..cc710118291 100644 --- a/compiler/core/lam_hit.mli +++ b/compiler/core/lam_hit.mli @@ -22,6 +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 hit_variables : Set_ident.t -> Lam.t -> bool +val hit_variables : Set_ident.t -> Lambda.lambda -> bool -val hit_variable : Ident.t -> Lam.t -> bool +val hit_variable : Ident.t -> Lambda.lambda -> bool diff --git a/compiler/core/lam_id_kind.ml b/compiler/core/lam_id_kind.ml index 09809a4b5a3..7e068bc15fa 100644 --- a/compiler/core/lam_id_kind.ml +++ b/compiler/core/lam_id_kind.ml @@ -31,13 +31,13 @@ type rec_flag = Lam_rec | Lam_non_rec | Lam_self_rec recursive function *) -type element = NA | SimpleForm of Lam.t +type element = NA | SimpleForm of Lambda.lambda type boxed_nullable = Undefined | Null | Null_undefined type t = - | Normal_optional of Lam.t (* Some [x] *) - | OptionalBlock of Lam.t * boxed_nullable + | Normal_optional of Lambda.lambda (* Some [x] *) + | OptionalBlock of Lambda.lambda * boxed_nullable | ImmutableBlock of element array | MutableBlock of element array | Constant of Lambda.structured_constant @@ -47,7 +47,7 @@ type t = (* TODO: This may contain some closure environment, check how it will interact with dead code elimination *) - lambda: (Lam.t * rec_flag) option; + lambda: (Lambda.lambda * rec_flag) option; } | Exception | Parameter diff --git a/compiler/core/lam_id_kind.mli b/compiler/core/lam_id_kind.mli index d68422b34f5..1c07c482291 100644 --- a/compiler/core/lam_id_kind.mli +++ b/compiler/core/lam_id_kind.mli @@ -31,7 +31,7 @@ type rec_flag = | Lam_self_rec (* not inlining in this case *) -type element = NA | SimpleForm of Lam.t +type element = NA | SimpleForm of Lambda.lambda type boxed_nullable = Undefined | Null | Null_undefined @@ -48,15 +48,15 @@ type boxed_nullable = Undefined | Null | Null_undefined [Lif(v/1)] will be translated into [Lif (v/2 === undefined )] *) type t = - | Normal_optional of Lam.t - | OptionalBlock of Lam.t * boxed_nullable + | Normal_optional of Lambda.lambda + | OptionalBlock of Lambda.lambda * boxed_nullable | ImmutableBlock of element array | MutableBlock of element array | Constant of Lambda.structured_constant | Module of Ident.t (** TODO: static module vs first class module *) | FunctionId of { mutable arity: Lam_arity.t; - lambda: (Lam.t * rec_flag) option; + lambda: (Lambda.lambda * rec_flag) option; } | Exception | Parameter diff --git a/compiler/core/lam_pass_collapse_var_aliases.ml b/compiler/core/lam_pass_collapse_var_aliases.ml index 55447406e9a..641bfaeb787 100644 --- a/compiler/core/lam_pass_collapse_var_aliases.ml +++ b/compiler/core/lam_pass_collapse_var_aliases.ml @@ -10,29 +10,30 @@ let rec resolve tbl id = | None -> id | Some id' -> resolve tbl id' -let collapse ~exports (lam : Lam.t) : Lam.t = +let collapse ~exports (lam : Lambda.lambda) : Lambda.lambda = let tbl = Hash_ident.create 64 in - let rec go (lam : Lam.t) : Lam.t = + let rec go (lam : Lambda.lambda) : Lambda.lambda = match lam with - | Lvar x -> Lam.var (resolve tbl x) + | Lvar x -> Lambda.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 + Lambda.apply (go ap_func) (Ext_list.map ap_args go) ap_info ~ap_transformed_jsx | Lfunction {params; body; attr; loc} -> - Lam.function_ ~loc ~attr ~params ~body:(go body) + Lambda.function_ ~loc ~attr ~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) + if Set_ident.mem exports id then + Lambda.let_ Alias id (Lambda.var u) (go body) else go body - | Llet (kind, id, arg, body) -> Lam.let_ kind id (go arg) (go body) + | Llet (kind, id, arg, body) -> Lambda.let_ kind id (go arg) (go body) | Lletrec (bindings, body) -> - Lam.letrec (Ext_list.map_snd bindings go) (go body) + Lambda.letrec (Ext_list.map_snd bindings go) (go body) | Lprim {primitive; args; loc} -> - Lam.prim ~primitive ~args:(Ext_list.map args go) loc + Lambda.prim ~primitive ~args:(Ext_list.map args go) loc | Lswitch (arg, sw) -> - Lam.switch (go arg) + Lambda.switch (go arg) { sw with sw_consts = Ext_list.map_snd sw.sw_consts go; @@ -40,20 +41,21 @@ let collapse ~exports (lam : Lam.t) : Lam.t = sw_failaction = Ext_option.map sw.sw_failaction go; } | Lstringswitch (arg, cases, default) -> - Lam.stringswitch (go arg) + Lambda.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) + | Lstaticraise (i, args) -> Lambda.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) + Lambda.staticcatch (go body) ids (go handler) + | Ltrywith (body, id, handler) -> Lambda.try_ (go body) id (go handler) + | Lifthenelse (b, t, e) -> Lambda.if_ (go b) (go t) (go e) + | Lsequence (a, b) -> Lambda.seq (go a) (go b) + | Lwhile (b, body) -> Lambda.while_ (go b) (go body) + | Lfor (id, lo, hi, dir, body) -> + Lambda.for_ id (go lo) (go hi) dir (go body) + | Lfor_of (id, iterable, body) -> Lambda.for_of id (go iterable) (go body) | Lfor_await_of (id, iterable, body) -> - Lam.for_await_of id (go iterable) (go body) - | Lassign (id, e) -> Lam.assign id (go e) + Lambda.for_await_of id (go iterable) (go body) + | Lassign (id, e) -> Lambda.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 index 912515d2ff6..6b2c7b932cb 100644 --- a/compiler/core/lam_pass_collapse_var_aliases.mli +++ b/compiler/core/lam_pass_collapse_var_aliases.mli @@ -10,4 +10,4 @@ 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 +val collapse : exports:Set_ident.t -> Lambda.lambda -> Lambda.lambda diff --git a/compiler/core/lam_pass_collect.ml b/compiler/core/lam_pass_collect.ml index fe2ed29bd06..1d0c1cfbfe9 100644 --- a/compiler/core/lam_pass_collect.ml +++ b/compiler/core/lam_pass_collect.ml @@ -42,8 +42,8 @@ let annotate (meta : Lam_stats.t) rec_flag (k : Ident.t) (arity : Lam_arity.t) function definition, alias propgation - and toplevel identifiers, this needs to be exported *) -let collect_info (meta : Lam_stats.t) (lam : Lam.t) = - let rec collect_bind rec_flag (ident : Ident.t) (lam : Lam.t) = +let collect_info (meta : Lam_stats.t) (lam : Lambda.lambda) = + let rec collect_bind rec_flag (ident : Ident.t) (lam : Lambda.lambda) = match lam with | Lconst v -> Hash_ident.replace meta.ident_tbl ident (Constant v) | Lprim {primitive = Pmakeblock info; args = ls} @@ -79,7 +79,7 @@ let collect_info (meta : Lam_stats.t) (lam : Lam.t) = collect x; if Set_ident.mem meta.export_idents ident then annotate meta rec_flag ident (Lam_arity_analysis.get_arity meta x) lam - and collect (lam : Lam.t) = + and collect (lam : Lambda.lambda) = match lam with | Lconst _ -> () | Lvar _ -> () diff --git a/compiler/core/lam_pass_collect.mli b/compiler/core/lam_pass_collect.mli index 4f7c45cd71b..e23df50e3ef 100644 --- a/compiler/core/lam_pass_collect.mli +++ b/compiler/core/lam_pass_collect.mli @@ -68,5 +68,5 @@ - *) -val collect_info : Lam_stats.t -> Lam.t -> unit +val collect_info : Lam_stats.t -> Lambda.lambda -> unit (** Modify existing [meta] *) diff --git a/compiler/core/lam_pass_count.ml b/compiler/core/lam_pass_count.ml index 5e3ee286f60..63a62b4def1 100644 --- a/compiler/core/lam_pass_count.ml +++ b/compiler/core/lam_pass_count.ml @@ -92,7 +92,7 @@ let collect_occurs lam : occ_tbl = ()) in - let rec count (bv : local_tbl) (lam : Lam.t) = + let rec count (bv : local_tbl) (lam : Lambda.lambda) = match lam with | Lfunction {body = l} -> count Map_ident.empty l (* when entering a function local [bv] diff --git a/compiler/core/lam_pass_count.mli b/compiler/core/lam_pass_count.mli index 727aaa40cf5..96e29f45165 100644 --- a/compiler/core/lam_pass_count.mli +++ b/compiler/core/lam_pass_count.mli @@ -25,4 +25,4 @@ type occ_tbl = used_info Hash_ident.t val dummy_info : unit -> used_info -val collect_occurs : Lam.t -> occ_tbl +val collect_occurs : Lambda.lambda -> occ_tbl diff --git a/compiler/core/lam_pass_deep_flatten.ml b/compiler/core/lam_pass_deep_flatten.ml index f0fa4cc419a..bb55519a2a1 100644 --- a/compiler/core/lam_pass_deep_flatten.ml +++ b/compiler/core/lam_pass_deep_flatten.ml @@ -26,7 +26,7 @@ | Not_eliminatable | *) -let rec eliminate_tuple (id : Ident.t) (lam : Lam.t) acc = +let rec eliminate_tuple (id : Ident.t) (lam : Lambda.lambda) acc = match lam with | Llet (Alias, v, Lprim {primitive = Pfield (i, _); args = [Lvar tuple]}, e2) when Ident.same tuple id -> @@ -100,13 +100,13 @@ let rec eliminate_tuple (id : Ident.t) (lam : Lam.t) acc = - also for function compilation, flattening should be done first - [compile_group] and [compile] become mutually recursive function *) -let lambda_of_groups ~(rev_bindings : Lam_group.t list) (result : Lam.t) : Lam.t - = +let lambda_of_groups ~(rev_bindings : Lam_group.t list) (result : Lambda.lambda) + : Lambda.lambda = Ext_list.fold_left rev_bindings result (fun acc x -> match x with - | Nop l -> Lam.seq l acc + | Nop l -> Lambda.seq l acc | Single (kind, ident, lam) -> Lam_util.refine_let ~kind ident lam acc - | Recursive bindings -> Lam.letrec bindings acc) + | Recursive bindings -> Lambda.letrec bindings acc) (* TODO: refine effectful [ket_kind] to be pure or not @@ -114,7 +114,7 @@ let lambda_of_groups ~(rev_bindings : Lam_group.t list) (result : Lam.t) : Lam.t *) (* The shape [let x = in ... in apply f args]: the residue left by beta reduction of an immediately applied function. *) -let rec rhs_is_beta_residue (lam : Lam.t) = +let rec rhs_is_beta_residue (lam : Lambda.lambda) = match lam with | Llet ( (Alias | Strict | StrictOpt), @@ -128,9 +128,9 @@ let rec rhs_is_beta_residue (lam : Lam.t) = | Lapply _ -> true | _ -> false -let deep_flatten (lam : Lam.t) : Lam.t = - let rec flatten (acc : Lam_group.t list) (lam : Lam.t) : - Lam.t * Lam_group.t list = +let deep_flatten (lam : Lambda.lambda) : Lambda.lambda = + let rec flatten (acc : Lam_group.t list) (lam : Lambda.lambda) : + Lambda.lambda * Lam_group.t list = match lam with | Llet ( str, @@ -153,10 +153,10 @@ let deep_flatten (lam : Lam.t) : Lam.t = body ) -> let new_id = Ident.rename id in flatten acc - (Lam.let_ str new_id arg - (Lam.let_ Alias id - (Lam.prim ~primitive - ~args:[Lam.var new_id] + (Lambda.let_ str new_id arg + (Lambda.let_ Alias id + (Lambda.prim ~primitive + ~args:[Lambda.var new_id] Location.none (* FIXME*)) body)) | Llet (str, id, arg, body) when rhs_is_beta_residue arg -> @@ -196,7 +196,7 @@ let deep_flatten (lam : Lam.t) : Lam.t = let res, l = flatten acc l in flatten (Lam_group.nop_cons res l) r | x -> (aux x, acc) - and aux (lam : Lam.t) : Lam.t = + and aux (lam : Lambda.lambda) : Lambda.lambda = match lam with | Llet _ -> let res, groups = flatten [] lam in @@ -231,8 +231,8 @@ let deep_flatten (lam : Lam.t) : Lam.t = in lambda_of_groups ~rev_bindings:rev_wrap (* These bindings are extracted from [letrec] *) - (Lam.letrec (List.rev rev_bindings) (aux body)) - | Lsequence (l, r) -> Lam.seq (aux l) (aux r) + (Lambda.letrec (List.rev rev_bindings) (aux body)) + | Lsequence (l, r) -> Lambda.seq (aux l) (aux r) | Lconst _ -> lam | Lvar _ -> lam (* | Lapply(Lfunction(Curried, params, body), args, _) *) @@ -244,15 +244,15 @@ let deep_flatten (lam : Lam.t) : Lam.t = (* when List.length params = List.length args -> *) (* aux (beta_reduce params body args) *) | Lapply {ap_func = l1; ap_args = ll; ap_info; ap_transformed_jsx} -> - Lam.apply (aux l1) (Ext_list.map ll aux) ap_info ~ap_transformed_jsx + Lambda.apply (aux l1) (Ext_list.map ll aux) ap_info ~ap_transformed_jsx (* This kind of simple optimizations should be done each time and as early as possible *) | Lglobal_module _ -> lam | Lprim {primitive; args; loc} -> let args = Ext_list.map args aux in - Lam.prim ~primitive ~args loc + Lambda.prim ~primitive ~args loc | Lfunction {params; body; attr; loc} -> - Lam.function_ ~loc ~params ~body:(aux body) ~attr + Lambda.function_ ~loc ~params ~body:(aux body) ~attr | Lswitch ( l, { @@ -263,7 +263,7 @@ let deep_flatten (lam : Lam.t) : Lam.t = sw_consts_full; sw_dispatch; } ) -> - Lam.switch (aux l) + Lambda.switch (aux l) { sw_consts = Ext_list.map_snd sw_consts aux; sw_blocks = Ext_list.map_snd sw_blocks aux; @@ -273,21 +273,22 @@ let deep_flatten (lam : Lam.t) : Lam.t = sw_dispatch; } | Lstringswitch (l, sw, d) -> - Lam.stringswitch (aux l) (Ext_list.map_snd sw aux) (Ext_option.map d aux) - | Lstaticraise (i, ls) -> Lam.staticraise i (Ext_list.map ls aux) - | Lstaticcatch (l1, ids, l2) -> Lam.staticcatch (aux l1) ids (aux l2) - | Ltrywith (l1, v, l2) -> Lam.try_ (aux l1) v (aux l2) - | Lifthenelse (l1, l2, l3) -> Lam.if_ (aux l1) (aux l2) (aux l3) - | Lbreak -> Lam.break - | Lcontinue -> Lam.continue - | Lwhile (l1, l2) -> Lam.while_ (aux l1) (aux l2) + Lambda.stringswitch (aux l) (Ext_list.map_snd sw aux) + (Ext_option.map d aux) + | Lstaticraise (i, ls) -> Lambda.staticraise i (Ext_list.map ls aux) + | Lstaticcatch (l1, ids, l2) -> Lambda.staticcatch (aux l1) ids (aux l2) + | Ltrywith (l1, v, l2) -> Lambda.try_ (aux l1) v (aux l2) + | Lifthenelse (l1, l2, l3) -> Lambda.if_ (aux l1) (aux l2) (aux l3) + | Lbreak -> Lambda.break + | Lcontinue -> Lambda.continue + | Lwhile (l1, l2) -> Lambda.while_ (aux l1) (aux l2) | Lfor (flag, l1, l2, dir, l3) -> - Lam.for_ flag (aux l1) (aux l2) dir (aux l3) - | Lfor_of (flag, l1, l2) -> Lam.for_of flag (aux l1) (aux l2) - | Lfor_await_of (flag, l1, l2) -> Lam.for_await_of flag (aux l1) (aux l2) + Lambda.for_ flag (aux l1) (aux l2) dir (aux l3) + | Lfor_of (flag, l1, l2) -> Lambda.for_of flag (aux l1) (aux l2) + | Lfor_await_of (flag, l1, l2) -> Lambda.for_await_of flag (aux l1) (aux l2) | Lassign (v, l) -> (* Lalias-bound variables are never assigned, so don't increase v's refaux *) - Lam.assign v (aux l) + Lambda.assign v (aux l) in aux lam diff --git a/compiler/core/lam_pass_deep_flatten.mli b/compiler/core/lam_pass_deep_flatten.mli index 74e195fa874..e0b06818018 100644 --- a/compiler/core/lam_pass_deep_flatten.mli +++ b/compiler/core/lam_pass_deep_flatten.mli @@ -22,4 +22,4 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val deep_flatten : Lam.t -> Lam.t +val deep_flatten : Lambda.lambda -> Lambda.lambda diff --git a/compiler/core/lam_pass_eliminate_ref.ml b/compiler/core/lam_pass_eliminate_ref.ml index 804daeade20..382b663efc1 100644 --- a/compiler/core/lam_pass_eliminate_ref.ml +++ b/compiler/core/lam_pass_eliminate_ref.ml @@ -13,12 +13,12 @@ exception Real_reference -let rec eliminate_ref id (lam : Lam.t) = +let rec eliminate_ref id (lam : Lambda.lambda) = match lam with (* we can do better escape analysis in Javascript backend *) | Lvar v -> if Ident.same v id then raise_notrace Real_reference else lam | Lprim {primitive = Pfield (0, _); args = [Lvar v]} when Ident.same v id -> - Lam.var id + Lambda.var id | Lfunction _ -> if Lam_hit.hit_variable id lam then raise_notrace Real_reference else lam (* In Javascript backend, its okay, we can reify it later @@ -46,23 +46,23 @@ let rec eliminate_ref id (lam : Lam.t) = (* Lfunction(kind, params, eliminate_ref id body) *) | Lprim {primitive = Psetfield (0, _); args = [Lvar v; e]} when Ident.same v id -> - Lam.assign id (eliminate_ref id e) + Lambda.assign id (eliminate_ref id e) | Lconst _ -> lam | Lapply {ap_func = e1; ap_args = el; ap_info; ap_transformed_jsx} -> - Lam.apply ~ap_transformed_jsx (eliminate_ref id e1) + Lambda.apply ~ap_transformed_jsx (eliminate_ref id e1) (Ext_list.map el (eliminate_ref id)) ap_info | Llet (str, v, e1, e2) -> - Lam.let_ str v (eliminate_ref id e1) (eliminate_ref id e2) + Lambda.let_ str v (eliminate_ref id e1) (eliminate_ref id e2) | Lletrec (idel, e2) -> - Lam.letrec + Lambda.letrec (Ext_list.map idel (fun (v, e) -> (v, eliminate_ref id e))) (eliminate_ref id e2) | Lglobal_module _ -> lam | Lprim {primitive; args; loc} -> - Lam.prim ~primitive ~args:(Ext_list.map args (eliminate_ref id)) loc + Lambda.prim ~primitive ~args:(Ext_list.map args (eliminate_ref id)) loc | Lswitch (e, sw) -> - Lam.switch (eliminate_ref id e) + Lambda.switch (eliminate_ref id e) { sw_consts_full = sw.sw_consts_full; sw_consts = @@ -77,28 +77,28 @@ let rec eliminate_ref id (lam : Lam.t) = sw_dispatch = sw.sw_dispatch; } | Lstringswitch (e, sw, default) -> - Lam.stringswitch (eliminate_ref id e) + Lambda.stringswitch (eliminate_ref id e) (Ext_list.map sw (fun (s, e) -> (s, eliminate_ref id e))) (match default with | None -> None | Some x -> Some (eliminate_ref id x)) | Lstaticraise (i, args) -> - Lam.staticraise i (Ext_list.map args (eliminate_ref id)) + Lambda.staticraise i (Ext_list.map args (eliminate_ref id)) | Lstaticcatch (e1, i, e2) -> - Lam.staticcatch (eliminate_ref id e1) i (eliminate_ref id e2) + Lambda.staticcatch (eliminate_ref id e1) i (eliminate_ref id e2) | Ltrywith (e1, v, e2) -> - Lam.try_ (eliminate_ref id e1) v (eliminate_ref id e2) + Lambda.try_ (eliminate_ref id e1) v (eliminate_ref id e2) | Lifthenelse (e1, e2, e3) -> - Lam.if_ (eliminate_ref id e1) (eliminate_ref id e2) (eliminate_ref id e3) - | Lsequence (e1, e2) -> Lam.seq (eliminate_ref id e1) (eliminate_ref id e2) - | Lbreak -> Lam.break - | Lcontinue -> Lam.continue - | Lwhile (e1, e2) -> Lam.while_ (eliminate_ref id e1) (eliminate_ref id e2) + Lambda.if_ (eliminate_ref id e1) (eliminate_ref id e2) (eliminate_ref id e3) + | Lsequence (e1, e2) -> Lambda.seq (eliminate_ref id e1) (eliminate_ref id e2) + | Lbreak -> Lambda.break + | Lcontinue -> Lambda.continue + | Lwhile (e1, e2) -> Lambda.while_ (eliminate_ref id e1) (eliminate_ref id e2) | Lfor (v, e1, e2, dir, e3) -> - Lam.for_ v (eliminate_ref id e1) (eliminate_ref id e2) dir + Lambda.for_ v (eliminate_ref id e1) (eliminate_ref id e2) dir (eliminate_ref id e3) | Lfor_of (v, e1, e2) -> - Lam.for_of v (eliminate_ref id e1) (eliminate_ref id e2) + Lambda.for_of v (eliminate_ref id e1) (eliminate_ref id e2) | Lfor_await_of (v, e1, e2) -> - Lam.for_await_of v (eliminate_ref id e1) (eliminate_ref id e2) - | Lassign (v, e) -> Lam.assign v (eliminate_ref id e) + Lambda.for_await_of v (eliminate_ref id e1) (eliminate_ref id e2) + | Lassign (v, e) -> Lambda.assign v (eliminate_ref id e) diff --git a/compiler/core/lam_pass_eliminate_ref.mli b/compiler/core/lam_pass_eliminate_ref.mli index e63428a0ef3..4f9842316dd 100644 --- a/compiler/core/lam_pass_eliminate_ref.mli +++ b/compiler/core/lam_pass_eliminate_ref.mli @@ -24,4 +24,4 @@ exception Real_reference -val eliminate_ref : Ident.t -> Lam.t -> Lam.t +val eliminate_ref : Ident.t -> Lambda.lambda -> Lambda.lambda diff --git a/compiler/core/lam_pass_exits.ml b/compiler/core/lam_pass_exits.ml index b4b9428455c..bf7d228701f 100644 --- a/compiler/core/lam_pass_exits.ml +++ b/compiler/core/lam_pass_exits.ml @@ -21,7 +21,7 @@ *) let rec no_list args = Ext_list.for_all args no_bounded_variables -and no_list_snd : 'a. ('a * Lam.t) list -> bool = +and no_list_snd : 'a. ('a * Lambda.lambda) list -> bool = fun args -> Ext_list.for_all_snd args no_bounded_variables and no_opt x = @@ -29,7 +29,7 @@ and no_opt x = | None -> true | Some a -> no_bounded_variables a -and no_bounded_variables (l : Lam.t) = +and no_bounded_variables (l : Lambda.lambda) = match l with | Lvar _ -> true | Lconst _ -> true @@ -82,8 +82,8 @@ and no_bounded_variables (l : Lam.t) = when do the substitution, if its occurence is > 1, we should refresh *) -type lam_subst = Id of Lam.t [@@unboxed] -(* | Refresh of Lam.t *) +type lam_subst = Id of Lambda.lambda [@@unboxed] +(* | Refresh of Lambda.lambda *) type subst_tbl = (Ident.t list * lam_subst) Hash_int.t @@ -152,9 +152,9 @@ let to_lam x = the j is not very indicative *) -let subst_helper (subst : subst_tbl) (query : int -> int) (lam : Lam.t) : Lam.t - = - let rec simplif (lam : Lam.t) = +let subst_helper (subst : subst_tbl) (query : int -> int) (lam : Lambda.lambda) + : Lambda.lambda = + let rec simplif (lam : Lambda.lambda) = match lam with | Lstaticcatch (l1, (i, xs), l2) -> ( let i_occur = query i in @@ -182,7 +182,7 @@ let subst_helper (subst : subst_tbl) (query : int -> int) (lam : Lam.t) : Lam.t if ok_to_inline then ( Hash_int.add subst i (xs, Id l2); simplif l1) - else Lam.staticcatch (simplif l1) (i, xs) l2) + else Lambda.staticcatch (simplif l1) (i, xs) l2) | Lstaticraise (i, []) -> ( match Hash_int.find_opt subst i with | Some (_, handler) -> to_lam handler @@ -195,31 +195,31 @@ let subst_helper (subst : subst_tbl) (query : int -> int) (lam : Lam.t) : Lam.t let ys = Ext_list.map xs Ident.rename in let env = Ext_list.fold_right2 xs ys Ident.empty (fun x y t -> - Ident.add x (Lam.var y) t) + Ident.add x (Lambda.var y) t) in Ext_list.fold_right2 ys ls (Lambda.subst_lambda env handler) - (fun y l r -> Lam.let_ Strict y l r) - | None -> Lam.staticraise i ls) + (fun y l r -> Lambda.let_ Strict y l r) + | None -> Lambda.staticraise i ls) | Lvar _ | Lconst _ -> lam | Lapply {ap_func; ap_args; ap_info; ap_transformed_jsx} -> - Lam.apply (simplif ap_func) + Lambda.apply (simplif ap_func) (Ext_list.map ap_args simplif) ap_info ~ap_transformed_jsx | Lfunction {params; body; attr; loc} -> - Lam.function_ ~loc ~params ~body:(simplif body) ~attr - | Llet (kind, v, l1, l2) -> Lam.let_ kind v (simplif l1) (simplif l2) + Lambda.function_ ~loc ~params ~body:(simplif body) ~attr + | Llet (kind, v, l1, l2) -> Lambda.let_ kind v (simplif l1) (simplif l2) | Lletrec (bindings, body) -> - Lam.letrec (Ext_list.map_snd bindings simplif) (simplif body) + Lambda.letrec (Ext_list.map_snd bindings simplif) (simplif body) | Lglobal_module _ -> lam | Lprim {primitive; args; loc} -> let args = Ext_list.map args simplif in - Lam.prim ~primitive ~args loc + Lambda.prim ~primitive ~args loc | Lswitch (l, sw) -> let new_l = simplif l in let new_consts = Ext_list.map_snd sw.sw_consts simplif in let new_blocks = Ext_list.map_snd sw.sw_blocks simplif in let new_fail = Ext_option.map sw.sw_failaction simplif in - Lam.switch new_l + Lambda.switch new_l { sw with sw_consts = new_consts; @@ -227,24 +227,26 @@ let subst_helper (subst : subst_tbl) (query : int -> int) (lam : Lam.t) : Lam.t sw_failaction = new_fail; } | Lstringswitch (l, sw, d) -> - Lam.stringswitch (simplif l) + Lambda.stringswitch (simplif l) (Ext_list.map_snd sw simplif) (Ext_option.map d simplif) - | Ltrywith (l1, v, l2) -> Lam.try_ (simplif l1) v (simplif l2) - | Lifthenelse (l1, l2, l3) -> Lam.if_ (simplif l1) (simplif l2) (simplif l3) - | Lsequence (l1, l2) -> Lam.seq (simplif l1) (simplif l2) - | Lbreak -> Lam.break - | Lcontinue -> Lam.continue - | Lwhile (l1, l2) -> Lam.while_ (simplif l1) (simplif l2) + | Ltrywith (l1, v, l2) -> Lambda.try_ (simplif l1) v (simplif l2) + | Lifthenelse (l1, l2, l3) -> + Lambda.if_ (simplif l1) (simplif l2) (simplif l3) + | Lsequence (l1, l2) -> Lambda.seq (simplif l1) (simplif l2) + | Lbreak -> Lambda.break + | Lcontinue -> Lambda.continue + | Lwhile (l1, l2) -> Lambda.while_ (simplif l1) (simplif l2) | Lfor (v, l1, l2, dir, l3) -> - Lam.for_ v (simplif l1) (simplif l2) dir (simplif l3) - | Lfor_of (v, l1, l2) -> Lam.for_of v (simplif l1) (simplif l2) - | Lfor_await_of (v, l1, l2) -> Lam.for_await_of v (simplif l1) (simplif l2) - | Lassign (v, l) -> Lam.assign v (simplif l) + Lambda.for_ v (simplif l1) (simplif l2) dir (simplif l3) + | Lfor_of (v, l1, l2) -> Lambda.for_of v (simplif l1) (simplif l2) + | Lfor_await_of (v, l1, l2) -> + Lambda.for_await_of v (simplif l1) (simplif l2) + | Lassign (v, l) -> Lambda.assign v (simplif l) in simplif lam -let simplify_exits (lam : Lam.t) = +let simplify_exits (lam : Lambda.lambda) = let exits = Lam_exit_count.count_helper lam in subst_helper (Hash_int.create 17) (Lam_exit_count.count_exit exits) lam diff --git a/compiler/core/lam_pass_exits.mli b/compiler/core/lam_pass_exits.mli index a48c54d5a0f..dabeaaa9cac 100644 --- a/compiler/core/lam_pass_exits.mli +++ b/compiler/core/lam_pass_exits.mli @@ -15,4 +15,4 @@ [simplif] module *) -val simplify_exits : Lam.t -> Lam.t +val simplify_exits : Lambda.lambda -> Lambda.lambda diff --git a/compiler/core/lam_pass_guard_raises.ml b/compiler/core/lam_pass_guard_raises.ml index af7704fb518..63376d32f31 100644 --- a/compiler/core/lam_pass_guard_raises.ml +++ b/compiler/core/lam_pass_guard_raises.ml @@ -1,8 +1,11 @@ -let rec guard_raises (lam : Lam.t) : Lam.t = +let rec guard_raises (lam : Lambda.lambda) : Lambda.lambda = match lam with | Lifthenelse (a, (Lprim {primitive = Praise} as b), c) -> ( match c with (* A constant alternative is already as flat as it gets. *) - | Lconst _ -> Lam.shallow_map_sharing guard_raises lam - | _ -> Lam.seq (Lam.if_ (guard_raises a) b Lam.unit) (guard_raises c)) - | _ -> Lam.shallow_map_sharing guard_raises lam + | Lconst _ -> Lambda.shallow_map_sharing guard_raises lam + | _ -> + Lambda.seq + (Lambda.if_ (guard_raises a) b Lambda.lambda_unit) + (guard_raises c)) + | _ -> Lambda.shallow_map_sharing guard_raises lam diff --git a/compiler/core/lam_pass_guard_raises.mli b/compiler/core/lam_pass_guard_raises.mli index 2818f7b2b1e..047a329607e 100644 --- a/compiler/core/lam_pass_guard_raises.mli +++ b/compiler/core/lam_pass_guard_raises.mli @@ -1,10 +1,10 @@ -val guard_raises : Lam.t -> Lam.t +val guard_raises : Lambda.lambda -> Lambda.lambda (** Rewrite [if a then raise e else c] into [(if a then raise e else ()); c], so the continuation stops being nested inside a branch - the guard clause idiom in the emitted JavaScript. This is code motion rather than normalization: it changes the shape that - surrounding code matches on, so it cannot live in [Lam.if_]. Matching + surrounding code matches on, so it cannot live in [Lambda.if_]. Matching inspects the terms it has built after the fact, and rewriting them as they are constructed leaves static raises without their catch. diff --git a/compiler/core/lam_pass_lets_dce.ml b/compiler/core/lam_pass_lets_dce.ml index b8d31040ad2..9184c2ecf27 100644 --- a/compiler/core/lam_pass_lets_dce.ml +++ b/compiler/core/lam_pass_lets_dce.ml @@ -11,15 +11,16 @@ (***********************************************************************) (* Adapted for Javascript backend : Hongbo Zhang, *) -let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = - let subst : Lam.t Hash_ident.t = Hash_ident.create 32 in +let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : + Lambda.lambda = + let subst : Lambda.lambda Hash_ident.t = Hash_ident.create 32 in let string_table : string Hash_ident.t = Hash_ident.create 32 in let used v = (count_var v).times > 0 in - let rec simplif (lam : Lam.t) = + let rec simplif (lam : Lambda.lambda) = match lam with | Lvar v -> Hash_ident.find_default subst v lam | Llet ((Strict | Alias | StrictOpt), v, Lvar w, l2) -> - Hash_ident.add subst v (simplif (Lam.var w)); + Hash_ident.add subst v (simplif (Lambda.var w)); simplif l2 | Llet ( (Strict as kind), @@ -35,7 +36,7 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = (Lam_pass_eliminate_ref.eliminate_ref v slbody) with Lam_pass_eliminate_ref.Real_reference -> Lam_util.refine_let ~kind v - (Lam.prim ~primitive ~args:[slinit] loc) + (Lambda.prim ~primitive ~args:[slinit] loc) slbody) | Llet (Alias, v, l1, l2) -> ( (* For alias, [l1] is pure, we can always inline, @@ -62,10 +63,10 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = | _, Lconst (Const_string {s; delim = None}) -> (* only "" added for later inlining *) Hash_ident.add string_table v s; - Lam.let_ Alias v l1 (simplif l2) + Lambda.let_ Alias v l1 (simplif l2) (* we need move [simplif l2] later, since adding Hash does have side effect *) | _ -> - Lam.let_ Alias v (simplif l1) (simplif l2) + Lambda.let_ Alias v (simplif l1) (simplif l2) (* for Alias, in most cases [l1] is already simplified *)) | Llet ((StrictOpt as kind), v, l1, lbody) -> ( if @@ -99,7 +100,7 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = (Lam_pass_eliminate_ref.eliminate_ref v slbody) with Lam_pass_eliminate_ref.Real_reference -> Lam_util.refine_let ~kind v - (Lam.prim ~primitive ~args:[slinit] loc) + (Lambda.prim ~primitive ~args:[slinit] loc) slbody) | _ -> ( let l1 = simplif l1 in @@ -107,23 +108,23 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = | Lconst (Const_string {s; delim = None}) -> Hash_ident.add string_table v s; (* we need move [simplif lbody] later, since adding Hash does have side effect *) - Lam.let_ Alias v l1 (simplif lbody) + Lambda.let_ Alias v l1 (simplif lbody) | _ -> Lam_util.refine_let ~kind v l1 (simplif lbody)) (* TODO: check if it is correct rollback to [StrictOpt]? *)) | Llet (((Strict | Variable) as kind), v, l1, l2) -> ( if not (used v) then let l1 = simplif l1 in let l2 = simplif l2 in - if Lam_analysis.no_side_effects l1 then l2 else Lam.seq l1 l2 + if Lam_analysis.no_side_effects l1 then l2 else Lambda.seq l1 l2 else let l1 = simplif l1 in match (kind, l1) with | Strict, Lconst (Const_string {s; delim = None}) -> Hash_ident.add string_table v s; - Lam.let_ Alias v l1 (simplif l2) + Lambda.let_ Alias v l1 (simplif l2) | _ -> Lam_util.refine_let ~kind v l1 (simplif l2)) - | Lsequence (l1, l2) -> Lam.seq (simplif l1) (simplif l2) + | Lsequence (l1, l2) -> Lambda.seq (simplif l1) (simplif l2) | Lapply {ap_func = Lfunction ({params; body} as lfunction); ap_args = args; _} when Ext_list.same_length params args @@ -137,13 +138,13 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = (* when Ext_list.same_length params args -> *) (* simplif (Lam_beta_reduce.beta_reduce params body args) *) | Lapply {ap_func = l1; ap_args = ll; ap_info; ap_transformed_jsx} -> - Lam.apply (simplif l1) (Ext_list.map ll simplif) ap_info + Lambda.apply (simplif l1) (Ext_list.map ll simplif) ap_info ~ap_transformed_jsx | Lfunction {params; body; attr; loc} -> - Lam.function_ ~loc ~params ~body:(simplif body) ~attr + Lambda.function_ ~loc ~params ~body:(simplif body) ~attr | Lconst _ -> lam | Lletrec (bindings, body) -> - Lam.letrec (Ext_list.map_snd bindings simplif) (simplif body) + Lambda.letrec (Ext_list.map_snd bindings simplif) (simplif body) | Lprim {primitive = Pstringadd; args = [l; r]; loc} -> ( let l' = simplif l in let r' = simplif r in @@ -154,7 +155,7 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = | _ -> None in match opt_l with - | None -> Lam.prim ~primitive:Pstringadd ~args:[l'; r'] loc + | None -> Lambda.prim ~primitive:Pstringadd ~args:[l'; r'] loc | Some l_s -> ( let opt_r = match r' with @@ -163,17 +164,18 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = | _ -> None in match opt_r with - | None -> Lam.prim ~primitive:Pstringadd ~args:[l'; r'] loc - | Some r_s -> Lam.const (Const_string {s = l_s ^ r_s; delim = None}))) + | None -> Lambda.prim ~primitive:Pstringadd ~args:[l'; r'] loc + | Some r_s -> Lambda.const (Const_string {s = l_s ^ r_s; delim = None})) + ) | Lglobal_module _ -> lam | Lprim {primitive; args; loc} -> - Lam.prim ~primitive ~args:(Ext_list.map args simplif) loc + Lambda.prim ~primitive ~args:(Ext_list.map args simplif) loc | Lswitch (l, sw) -> let new_l = simplif l and new_consts = Ext_list.map_snd sw.sw_consts simplif and new_blocks = Ext_list.map_snd sw.sw_blocks simplif and new_fail = Ext_option.map sw.sw_failaction simplif in - Lam.switch new_l + Lambda.switch new_l { sw with sw_consts = new_consts; @@ -181,22 +183,24 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = sw_failaction = new_fail; } | Lstringswitch (l, sw, d) -> - Lam.stringswitch (simplif l) + Lambda.stringswitch (simplif l) (Ext_list.map_snd sw simplif) (Ext_option.map d simplif) - | Lstaticraise (i, ls) -> Lam.staticraise i (Ext_list.map ls simplif) + | Lstaticraise (i, ls) -> Lambda.staticraise i (Ext_list.map ls simplif) | Lstaticcatch (l1, (i, args), l2) -> - Lam.staticcatch (simplif l1) (i, args) (simplif l2) - | Ltrywith (l1, v, l2) -> Lam.try_ (simplif l1) v (simplif l2) - | Lifthenelse (l1, l2, l3) -> Lam.if_ (simplif l1) (simplif l2) (simplif l3) - | Lbreak -> Lam.break - | Lcontinue -> Lam.continue - | Lwhile (l1, l2) -> Lam.while_ (simplif l1) (simplif l2) + Lambda.staticcatch (simplif l1) (i, args) (simplif l2) + | Ltrywith (l1, v, l2) -> Lambda.try_ (simplif l1) v (simplif l2) + | Lifthenelse (l1, l2, l3) -> + Lambda.if_ (simplif l1) (simplif l2) (simplif l3) + | Lbreak -> Lambda.break + | Lcontinue -> Lambda.continue + | Lwhile (l1, l2) -> Lambda.while_ (simplif l1) (simplif l2) | Lfor (v, l1, l2, dir, l3) -> - Lam.for_ v (simplif l1) (simplif l2) dir (simplif l3) - | Lfor_of (v, l1, l2) -> Lam.for_of v (simplif l1) (simplif l2) - | Lfor_await_of (v, l1, l2) -> Lam.for_await_of v (simplif l1) (simplif l2) - | Lassign (v, l) -> Lam.assign v (simplif l) + Lambda.for_ v (simplif l1) (simplif l2) dir (simplif l3) + | Lfor_of (v, l1, l2) -> Lambda.for_of v (simplif l1) (simplif l2) + | Lfor_await_of (v, l1, l2) -> + Lambda.for_await_of v (simplif l1) (simplif l2) + | Lassign (v, l) -> Lambda.assign v (simplif l) in simplif lam @@ -209,6 +213,6 @@ let apply_lets occ lambda = in lets_helper count_var lambda -let simplify_lets (lam : Lam.t) : Lam.t = +let simplify_lets (lam : Lambda.lambda) : Lambda.lambda = let occ = Lam_pass_count.collect_occurs lam in apply_lets occ lam diff --git a/compiler/core/lam_pass_lets_dce.mli b/compiler/core/lam_pass_lets_dce.mli index bad2bf97612..ef3d9759749 100644 --- a/compiler/core/lam_pass_lets_dce.mli +++ b/compiler/core/lam_pass_lets_dce.mli @@ -11,7 +11,7 @@ (***********************************************************************) (* Adapted for Javascript backend: Hongbo Zhang *) -val simplify_lets : Lam.t -> Lam.t +val simplify_lets : Lambda.lambda -> Lambda.lambda (** This pass would do beta reduction, and dead code elimination (adapted from compiler's built-in [Simplif] module ) diff --git a/compiler/core/lam_pass_remove_alias.ml b/compiler/core/lam_pass_remove_alias.ml index 795cad8062f..ad4f6f3a0ea 100644 --- a/compiler/core/lam_pass_remove_alias.ml +++ b/compiler/core/lam_pass_remove_alias.ml @@ -46,8 +46,8 @@ let is_const_some (cst : Lambda.structured_constant) : bool = | Const_some _ -> true | _ -> false -let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = - let rec simpl (lam : Lam.t) : Lam.t = +let simplify_alias (meta : Lam_stats.t) (lam : Lambda.lambda) : Lambda.lambda = + let rec simpl (lam : Lambda.lambda) : Lambda.lambda = match lam with | Lvar _ -> lam (* 7432: prevent optimization in JSX preserve mode *) @@ -58,16 +58,16 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = loc; } when !Js_config.jsx_preserve -> - Lam.prim ~primitive ~args:(field_arg :: Ext_list.map rest simpl) loc + Lambda.prim ~primitive ~args:(field_arg :: Ext_list.map rest simpl) loc | Lprim {primitive = Pfield (i, info) as primitive; args = [arg]; loc} -> ( (* ATTENTION: Main use case, we should detect inline all immutable block .. *) match simpl arg with | Lvar v as l -> Lam_util.field_flatten_get - (fun _ -> Lam.prim ~primitive ~args:[l] loc) + (fun _ -> Lambda.prim ~primitive ~args:[l] loc) v i info meta.ident_tbl - | l -> Lam.prim ~primitive ~args:[l] loc) + | l -> Lambda.prim ~primitive ~args:[l] loc) | Lprim { primitive = (Pval_from_option | Pval_from_option_not_nest) as p; @@ -78,7 +78,7 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = | _ -> if p = Pval_from_option_not_nest then lvar else x) | Lglobal_module _ -> lam | Lprim {primitive; args; loc} -> - Lam.prim ~primitive ~args:(Ext_list.map args simpl) loc + Lambda.prim ~primitive ~args:(Ext_list.map args simpl) loc | Lifthenelse ((Lprim {primitive = Pis_not_none; args = [Lvar id]} as l1), l2, l3) -> ( @@ -86,21 +86,21 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = | Some (Constant c) when is_const_some c -> simpl l2 | Some (ImmutableBlock _ | MutableBlock _ | Normal_optional _) -> simpl l2 | Some (OptionalBlock (l, Null)) -> - Lam.if_ - (Lam.not_ Location.none - (Lam.prim ~primitive:Pis_null ~args:[l] Location.none)) + Lambda.if_ + (Lambda.not_ Location.none + (Lambda.prim ~primitive:Pis_null ~args:[l] Location.none)) (simpl l2) (simpl l3) | Some (OptionalBlock (l, Undefined)) -> - Lam.if_ - (Lam.not_ Location.none - (Lam.prim ~primitive:Pis_undefined ~args:[l] Location.none)) + Lambda.if_ + (Lambda.not_ Location.none + (Lambda.prim ~primitive:Pis_undefined ~args:[l] Location.none)) (simpl l2) (simpl l3) | Some (OptionalBlock (l, Null_undefined)) -> - Lam.if_ - (Lam.not_ Location.none - (Lam.prim ~primitive:Pis_null_undefined ~args:[l] Location.none)) + Lambda.if_ + (Lambda.not_ Location.none + (Lambda.prim ~primitive:Pis_null_undefined ~args:[l] Location.none)) (simpl l2) (simpl l3) - | Some _ | None -> Lam.if_ l1 (simpl l2) (simpl l3)) + | Some _ | None -> Lambda.if_ l1 (simpl l2) (simpl l3)) (* could be the code path {[ match x with | h::hs -> @@ -112,13 +112,13 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = match id_is_for_sure_true_in_boolean meta.ident_tbl id with | Eval_true -> simpl l2 | Eval_false -> simpl l3 - | Eval_unknown -> Lam.if_ (simpl l1) (simpl l2) (simpl l3)) - | _ -> Lam.if_ (simpl l1) (simpl l2) (simpl l3)) + | Eval_unknown -> Lambda.if_ (simpl l1) (simpl l2) (simpl l3)) + | _ -> Lambda.if_ (simpl l1) (simpl l2) (simpl l3)) | Lconst _ -> lam - | Llet (str, v, l1, l2) -> Lam.let_ str v (simpl l1) (simpl l2) + | Llet (str, v, l1, l2) -> Lambda.let_ str v (simpl l1) (simpl l2) | Lletrec (bindings, body) -> let bindings = Ext_list.map_snd bindings simpl in - Lam.letrec bindings (simpl body) + Lambda.letrec bindings (simpl body) (* complicated 1. inline this function 2. ... @@ -155,7 +155,7 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = && Lam_analysis.lfunction_can_be_inlined lfunction -> simpl (Lam_beta_reduce.propagate_beta_reduce meta params body args) | _ -> - Lam.apply (simpl l1) (Ext_list.map args simpl) ap_info + Lambda.apply (simpl l1) (Ext_list.map args simpl) ap_info ?ap_transformed_jsx:None) (* Function inlining interact with other optimizations... @@ -169,7 +169,7 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = (* Ext_log.dwarn __LOC__ "%s/%d" v.name v.stamp; *) let ap_args = Ext_list.map ap_args simpl in let[@local] normal () = - Lam.apply (simpl fn) ap_args ap_info ~ap_transformed_jsx + Lambda.apply (simpl fn) ap_args ap_info ~ap_transformed_jsx in match Hash_ident.find_opt meta.ident_tbl v with | Some @@ -240,9 +240,10 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = (* when Ext_list.same_length params args -> *) (* simpl (Lam_beta_reduce.propogate_beta_reduce meta params body args) *) | Lapply {ap_func = l1; ap_args = ll; ap_info; ap_transformed_jsx} -> - Lam.apply (simpl l1) (Ext_list.map ll simpl) ap_info ~ap_transformed_jsx + Lambda.apply (simpl l1) (Ext_list.map ll simpl) ap_info + ~ap_transformed_jsx | Lfunction {params; body; attr; loc} -> - Lam.function_ ~loc ~params ~body:(simpl body) ~attr + Lambda.function_ ~loc ~params ~body:(simpl body) ~attr | Lswitch ( l, { @@ -253,7 +254,7 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = sw_consts_full; sw_dispatch; } ) -> - Lam.switch (simpl l) + Lambda.switch (simpl l) { sw_consts = Ext_list.map_snd sw_consts simpl; sw_blocks = Ext_list.map_snd sw_blocks simpl; @@ -267,26 +268,26 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = match l with | Lvar s -> ( match Hash_ident.find_opt meta.ident_tbl s with - | Some (Constant s) -> Lam.const s + | Some (Constant s) -> Lambda.const s | Some _ | None -> simpl l) | _ -> simpl l in - Lam.stringswitch l (Ext_list.map_snd sw simpl) (Ext_option.map d simpl) - | Lstaticraise (i, ls) -> Lam.staticraise i (Ext_list.map ls simpl) - | Lstaticcatch (l1, ids, l2) -> Lam.staticcatch (simpl l1) ids (simpl l2) - | Ltrywith (l1, v, l2) -> Lam.try_ (simpl l1) v (simpl l2) - | Lsequence (l1, l2) -> Lam.seq (simpl l1) (simpl l2) - | Lbreak -> Lam.break - | Lcontinue -> Lam.continue - | Lwhile (l1, l2) -> Lam.while_ (simpl l1) (simpl l2) + Lambda.stringswitch l (Ext_list.map_snd sw simpl) (Ext_option.map d simpl) + | Lstaticraise (i, ls) -> Lambda.staticraise i (Ext_list.map ls simpl) + | Lstaticcatch (l1, ids, l2) -> Lambda.staticcatch (simpl l1) ids (simpl l2) + | Ltrywith (l1, v, l2) -> Lambda.try_ (simpl l1) v (simpl l2) + | Lsequence (l1, l2) -> Lambda.seq (simpl l1) (simpl l2) + | Lbreak -> Lambda.break + | Lcontinue -> Lambda.continue + | Lwhile (l1, l2) -> Lambda.while_ (simpl l1) (simpl l2) | Lfor (flag, l1, l2, dir, l3) -> - Lam.for_ flag (simpl l1) (simpl l2) dir (simpl l3) - | Lfor_of (flag, l1, l2) -> Lam.for_of flag (simpl l1) (simpl l2) + Lambda.for_ flag (simpl l1) (simpl l2) dir (simpl l3) + | Lfor_of (flag, l1, l2) -> Lambda.for_of flag (simpl l1) (simpl l2) | Lfor_await_of (flag, l1, l2) -> - Lam.for_await_of flag (simpl l1) (simpl l2) + Lambda.for_await_of flag (simpl l1) (simpl l2) | Lassign (v, l) -> (* Lalias-bound variables are never assigned, so don't increase v's refsimpl *) - Lam.assign v (simpl l) + Lambda.assign v (simpl l) in simpl lam diff --git a/compiler/core/lam_pass_remove_alias.mli b/compiler/core/lam_pass_remove_alias.mli index 3d6b9159194..894155830f7 100644 --- a/compiler/core/lam_pass_remove_alias.mli +++ b/compiler/core/lam_pass_remove_alias.mli @@ -35,4 +35,4 @@ This pass does not change meta data *) -val simplify_alias : Lam_stats.t -> Lam.t -> Lam.t +val simplify_alias : Lam_stats.t -> Lambda.lambda -> Lambda.lambda diff --git a/compiler/core/lam_print.ml b/compiler/core/lam_print.ml index 08d8429c5a9..eb11fd22617 100644 --- a/compiler/core/lam_print.ml +++ b/compiler/core/lam_print.ml @@ -218,7 +218,8 @@ let to_print_kind (k : Lambda.let_kind) : print_kind = | StrictOpt -> StrictOpt | Variable -> Variable -let rec aux (acc : (print_kind * Ident.t * Lam.t) list) (lam : Lam.t) = +let rec aux (acc : (print_kind * Ident.t * Lambda.lambda) list) + (lam : Lambda.lambda) = match lam with | Llet (str3, id3, arg3, body3) -> aux ((to_print_kind str3, id3, arg3) :: acc) body3 @@ -238,7 +239,8 @@ let rec aux (acc : (print_kind * Ident.t * Lam.t) list) (lam : Lam.t) = | Id of left_var *) (* | Nop *) -let flatten (lam : Lam.t) : (print_kind * Ident.t * Lam.t) list * Lam.t = +let flatten (lam : Lambda.lambda) : + (print_kind * Ident.t * Lambda.lambda) list * Lambda.lambda = match lam with | Llet (str, id, arg, body) -> aux [(to_print_kind str, id, arg)] body | Lletrec (bind_args, body) -> @@ -246,7 +248,7 @@ let flatten (lam : Lam.t) : (print_kind * Ident.t * Lam.t) list * Lam.t = | _ -> assert false let lambda ppf v = - let rec lam ppf (l : Lam.t) = + let rec lam ppf (l : Lambda.lambda) = match l with | Lvar id -> Ident.print ppf id | Lglobal_module id -> fprintf ppf "global %a" Ident.print id @@ -297,7 +299,7 @@ let lambda ppf v = in fprintf ppf "@[<2>(%a%a)@]" primitive prim lams largs | Lswitch (larg, sw) -> - let switch ppf (sw : Lam.lambda_switch) = + let switch ppf (sw : Lambda.lambda_switch) = let spc = ref false in List.iter (fun (key, l) -> @@ -390,7 +392,7 @@ let lambda ppf v = (* let structured_constant = struct_const *) -(* let rec flatten_seq acc (lam : Lam.t) = +(* let rec flatten_seq acc (lam : Lambda.lambda) = match lam with | Lsequence(l1,l2) -> flatten_seq (flatten_seq acc l1) l2 @@ -398,7 +400,7 @@ let lambda ppf v = (* exception Not_a_module *) -(* let rec flat (acc : (left * Lam.t) list ) (lam : Lam.t) = +(* let rec flat (acc : (left * Lambda.lambda) list ) (lam : Lambda.lambda) = match lam with | Llet (str,id,arg,body) -> flat ( (Id {kind = to_print_kind str; id}, arg) :: acc) body @@ -411,7 +413,7 @@ let lambda ppf v = flat (flat acc l) r | x -> (Nop, x) :: acc *) -(* let lambda_as_module env ppf (lam : Lam.t) = +(* let lambda_as_module env ppf (lam : Lambda.lambda) = try (* match lam with *) (* | Lprim {primitive = Psetglobal id ; args = [biglambda]; _} *) @@ -442,7 +444,7 @@ let lambda ppf v = lambda ppf lam; fprintf ppf "; lambda-failure" *) -let serialize (filename : string) (lam : Lam.t) : unit = +let serialize (filename : string) (lam : Lambda.lambda) : unit = let ou = open_out filename in let old = Format.get_margin () in let () = Format.set_margin 10000 in diff --git a/compiler/core/lam_print.mli b/compiler/core/lam_print.mli index 235386710a7..8fd4a34ad1a 100644 --- a/compiler/core/lam_print.mli +++ b/compiler/core/lam_print.mli @@ -22,10 +22,10 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val lambda : Format.formatter -> Lam.t -> unit +val lambda : Format.formatter -> Lambda.lambda -> unit val primitive : Format.formatter -> Lambda.primitive -> unit -val serialize : string -> Lam.t -> unit +val serialize : string -> Lambda.lambda -> unit -val lambda_to_string : Lam.t -> string +val lambda_to_string : Lambda.lambda -> string diff --git a/compiler/core/lam_stats_export.ml b/compiler/core/lam_stats_export.ml index 4b72fa98d40..8ecbf087238 100644 --- a/compiler/core/lam_stats_export.ml +++ b/compiler/core/lam_stats_export.ml @@ -26,7 +26,8 @@ let single_na = Js_cmj_format.single_na -let values_of_export (meta : Lam_stats.t) (export_map : Lam.t Map_ident.t) : +let values_of_export (meta : Lam_stats.t) + (export_map : Lambda.lambda Map_ident.t) : Js_cmj_format.cmj_value Map_string.t = Ext_list.fold_left meta.exports Map_string.empty (fun acc x -> let arity : Js_cmj_format.arity = diff --git a/compiler/core/lam_stats_export.mli b/compiler/core/lam_stats_export.mli index 9d8e814581f..999f6b84b89 100644 --- a/compiler/core/lam_stats_export.mli +++ b/compiler/core/lam_stats_export.mli @@ -28,7 +28,7 @@ val get_dependent_module_effect : val export_to_cmj : Lam_stats.t -> Js_cmj_format.effect_ -> - Lam.t Map_ident.t -> + Lambda.lambda Map_ident.t -> Js_cmj_format.hoisted_export list -> Ext_js_file_kind.case -> Js_cmj_format.t diff --git a/compiler/core/lam_util.ml b/compiler/core/lam_util.ml index 6139fea17cd..06bafc803dd 100644 --- a/compiler/core/lam_util.ml +++ b/compiler/core/lam_util.ml @@ -55,7 +55,8 @@ let add_required_modules ( x : Ident.t list) (meta : Lam_stats.t) = Falling through keeps the original binding. Only the Alias clause changes evaluation strategy downstream, so we keep its predicate intentionally syntactic and narrow. *) -let refine_let ~kind param (arg : Lam.t) (l : Lam.t) : Lam.t = +let refine_let ~kind param (arg : Lambda.lambda) (l : Lambda.lambda) : + Lambda.lambda = let is_block_constructor = function | Lambda.Pmakeblock _ -> true | _ -> false @@ -66,7 +67,7 @@ let refine_let ~kind param (arg : Lam.t) (l : Lam.t) : Lam.t = to inline [e] at every use site or drop `const x = e` entirely, so every clause below must ensure that duplicate evaluation of [e] is equivalent to the single eager evaluation promised by [Strict]/[StrictOpt]. *) - let rec is_safe_to_alias (lam : Lam.t) = + let rec is_safe_to_alias (lam : Lambda.lambda) = match lam with | Lvar _ | Lconst _ -> (* var/const --> emitting multiple `const` reads is identical to the @@ -103,33 +104,33 @@ let refine_let ~kind param (arg : Lam.t) (l : Lam.t) : Lam.t = `{ let x = value; Array.length(x) }`, we inline the primitive call with `value`. This only happens for primitives that are pure and do not allocate new blocks, so evaluation order and side effects stay the same. *) - Lam.prim ~primitive ~args:[arg] loc + Lambda.prim ~primitive ~args:[arg] loc | _, _, Lapply {ap_func = fn; ap_args = [Lvar w]; ap_info; ap_transformed_jsx} when Ident.same w param && not (Lam_hit.hit_variable param fn) -> (* For a function call such as `{ let x = value; someFn(x) }`, we can rewrite to `someFn(value)` as long as the callee does not capture `x`. This removes the temporary binding while preserving the call semantics. *) - Lam.apply fn [arg] ap_info ~ap_transformed_jsx + Lambda.apply fn [arg] ap_info ~ap_transformed_jsx | (Strict | StrictOpt), arg, _ when is_safe_to_alias arg -> (* `Strict` and `StrictOpt` bindings both evaluate the RHS immediately (with `StrictOpt` allowing later elimination if unused). When that RHS is pure — `{ let x = Some(value); ... }`, `{ let x = 3; ... }`, or a module field read — we mark it as an alias so downstream passes can inline the original expression and drop the temporary. *) - Lam.let_ Alias param arg l + Lambda.let_ Alias param arg l | Strict, Lfunction _, _ -> (* If we eagerly evaluate a function binding such as `{ let makeGreeting = () => "hi"; ... }`, we end up allocating the closure immediately. Downgrading `Strict` to `StrictOpt` preserves the original laziness while still letting later passes inline when safe. *) - Lam.let_ StrictOpt param arg l + Lambda.let_ StrictOpt param arg l | Strict, _, _ when Lam_analysis.no_side_effects arg -> (* A strict binding whose expression has no side effects — think `{ let x = computePure(); use(x); }` — can be relaxed to `StrictOpt`. This keeps the original semantics yet allows downstream passes to skip evaluating `x` when it turns out to be unused. *) - Lam.let_ StrictOpt param arg l - | kind, _, _ -> Lam.let_ kind param arg l + Lambda.let_ StrictOpt param arg l + | kind, _, _ -> Lambda.let_ kind param arg l let alias_ident_or_global (meta : Lam_stats.t) (k : Ident.t) (v : Ident.t) (v_kind : Lam_id_kind.t) = @@ -173,7 +174,7 @@ let alias_ident_or_global (meta : Lam_stats.t) (k : Ident.t) (v : Ident.t) mutable fields are explicit, since wen can not inline an mutable block access *) -let element_of_lambda (lam : Lam.t) : Lam_id_kind.element = +let element_of_lambda (lam : Lambda.lambda) : Lam_id_kind.element = match lam with | Lvar _ | Lconst _ | Lprim @@ -186,15 +187,16 @@ let element_of_lambda (lam : Lam.t) : Lam_id_kind.element = (* | Lfunction _ *) | _ -> NA -let kind_of_lambda_block (xs : Lam.t list) : Lam_id_kind.t = +let kind_of_lambda_block (xs : Lambda.lambda list) : Lam_id_kind.t = ImmutableBlock (Ext_array.of_list_map xs (fun x -> element_of_lambda x)) -let field_flatten_get lam v i info (tbl : Lam_id_kind.t Hash_ident.t) : Lam.t = +let field_flatten_get lam v i info (tbl : Lam_id_kind.t Hash_ident.t) : + Lambda.lambda = match Hash_ident.find_opt tbl v with | Some (Module g) -> - Lam.prim + Lambda.prim ~primitive:(Pfield (i, info)) - ~args:[Lam.global_module g] + ~args:[Lambda.global_module g] Location.none | Some (ImmutableBlock arr) -> ( match arr.(i) with @@ -209,27 +211,27 @@ let field_flatten_get lam v i info (tbl : Lam_id_kind.t Hash_ident.t) : Lam.t = if fst fields.(i) = name then found := Ext_list.nth_opt ls i done; match !found with - | Some c when not (Lambda.const_is_allocating c) -> Lam.const c + | Some c when not (Lambda.const_is_allocating c) -> Lambda.const c | _ -> lam ()) | _ -> lam ()) | Some (Constant (Const_block (_, ls))) -> ( match Ext_list.nth_opt ls i with | None -> lam () - | Some x when not (Lambda.const_is_allocating x) -> Lam.const x + | Some x when not (Lambda.const_is_allocating x) -> Lambda.const x | Some _ -> lam ()) | Some _ | None -> lam () -let is_function (lam : Lam.t) = +let is_function (lam : Lambda.lambda) = match lam with | Lfunction _ -> true | _ -> false -let not_function (lam : Lam.t) = +let not_function (lam : Lambda.lambda) = match lam with | Lfunction _ -> false | _ -> true (* -let is_var (lam : Lam.t) id = +let is_var (lam : Lambda.lambda) id = match lam with | Lvar id0 -> Ident.same id0 id | _ -> false *) diff --git a/compiler/core/lam_util.mli b/compiler/core/lam_util.mli index f1bc595c20f..286c24b96d4 100644 --- a/compiler/core/lam_util.mli +++ b/compiler/core/lam_util.mli @@ -22,15 +22,15 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val kind_of_lambda_block : Lam.t list -> Lam_id_kind.t +val kind_of_lambda_block : Lambda.lambda list -> Lam_id_kind.t val field_flatten_get : - (unit -> Lam.t) -> + (unit -> Lambda.lambda) -> Ident.t -> int -> Lambda.field_dbg_info -> Lam_stats.ident_tbl -> - Lam.t + Lambda.lambda (** [field_flattern_get cb v i tbl] try to remove the indirection of [v.(i)] by inlining when [v] is a known block, @@ -52,8 +52,13 @@ val field_flatten_get : val alias_ident_or_global : Lam_stats.t -> Ident.t -> Ident.t -> Lam_id_kind.t -> unit -val refine_let : kind:Lambda.let_kind -> Ident.t -> Lam.t -> Lam.t -> Lam.t +val refine_let : + kind:Lambda.let_kind -> + Ident.t -> + Lambda.lambda -> + Lambda.lambda -> + Lambda.lambda -val not_function : Lam.t -> bool +val not_function : Lambda.lambda -> bool -val is_function : Lam.t -> bool +val is_function : Lambda.lambda -> bool diff --git a/compiler/core/lam_var_stats.mli b/compiler/core/lam_var_stats.mli index f4c5b800de6..dcfc21be900 100644 --- a/compiler/core/lam_var_stats.mli +++ b/compiler/core/lam_var_stats.mli @@ -34,7 +34,7 @@ val sink : position val fresh_env : position -val new_position_after_lam : Lam.t -> position -> position +val new_position_after_lam : Lambda.lambda -> position -> position val update : stats -> position -> stats (** The variable used stats update depend diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index 08d60c4cb7a..3e119510597 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -715,7 +715,7 @@ let cmp_float (cmp : comparison) (a : float) b : bool = (* Constructors. The type is private outside this module, so every term is built through one of these. They are plain for now; the normalizations that - Lam.prim / Lam.if_ / Lam.switch perform will move here when the two layers + Lambda.prim / Lambda.if_ / Lambda.switch perform will move here when the two layers become one type. *) let var id : lambda = Lvar id From c7d3285f08fbf2bb8d2ae51df4798d91ada69f80 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 1 Sep 2026 20:42:33 +0200 Subject: [PATCH 40/46] Rename Lambda.lambda to Lambda.t Every module this tree retired named its principal type t - Lam.t, Lam_primitive.t, Lam_constant.t - as do the ext modules. Lambda.lambda was the odd one out, and only because the file arrived from upstream OCaml with that spelling. Deleting Lam had just propagated it to three hundred sites. Comments keep saying lambda, and the compound names are untouched: lambda_switch, lambda_apply, lambda_unit, subst_lambda, name_lambda. Only the type is renamed. printlambda has a value called lambda as well as the type, so inside modules that open Lambda only type positions were rewritten. The core README loses its Lam framing, and its "changing a representation" section states the invariant that actually holds now: the type is private, six constructors normalize as they build, and a constructor may replace a node but not move code between branches. The CLAUDE.md bullet warning that Lam and Lambda are distinct IRs with confusable constructors is gone, being no longer true. Generated JavaScript is unchanged. Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- AGENTS.md | 6 +- compiler/core/README.md | 28 ++-- compiler/core/ir_diagnostics.mli | 2 +- compiler/core/js_cmj_format.ml | 4 +- compiler/core/js_cmj_format.mli | 4 +- compiler/core/lam_analysis.ml | 15 +- compiler/core/lam_analysis.mli | 8 +- compiler/core/lam_arity_analysis.ml | 4 +- compiler/core/lam_arity_analysis.mli | 2 +- compiler/core/lam_beta_reduce.ml | 4 +- compiler/core/lam_beta_reduce.mli | 15 +- compiler/core/lam_beta_reduce_util.ml | 8 +- compiler/core/lam_beta_reduce_util.mli | 2 +- compiler/core/lam_bounded_vars.ml | 6 +- compiler/core/lam_bounded_vars.mli | 6 +- compiler/core/lam_check.ml | 8 +- compiler/core/lam_check.mli | 2 +- compiler/core/lam_closure.ml | 8 +- compiler/core/lam_closure.mli | 8 +- compiler/core/lam_coercion.ml | 10 +- compiler/core/lam_coercion.mli | 5 +- compiler/core/lam_compile.ml | 77 +++++---- compiler/core/lam_compile.mli | 4 +- compiler/core/lam_compile_context.ml | 10 +- compiler/core/lam_compile_context.mli | 11 +- compiler/core/lam_compile_env.ml | 2 +- compiler/core/lam_compile_main.ml | 3 +- compiler/core/lam_compile_main.mli | 2 +- compiler/core/lam_convert.ml | 4 +- compiler/core/lam_convert.mli | 2 +- compiler/core/lam_exit_code.ml | 4 +- compiler/core/lam_exit_code.mli | 4 +- compiler/core/lam_exit_count.ml | 4 +- compiler/core/lam_exit_count.mli | 2 +- compiler/core/lam_group.ml | 10 +- compiler/core/lam_group.mli | 10 +- compiler/core/lam_hit.ml | 2 +- compiler/core/lam_hit.mli | 4 +- compiler/core/lam_id_kind.ml | 8 +- compiler/core/lam_id_kind.mli | 8 +- .../core/lam_pass_collapse_var_aliases.ml | 4 +- .../core/lam_pass_collapse_var_aliases.mli | 2 +- compiler/core/lam_pass_collect.ml | 6 +- compiler/core/lam_pass_collect.mli | 2 +- compiler/core/lam_pass_count.ml | 2 +- compiler/core/lam_pass_count.mli | 2 +- compiler/core/lam_pass_deep_flatten.ml | 16 +- compiler/core/lam_pass_deep_flatten.mli | 2 +- compiler/core/lam_pass_eliminate_ref.ml | 2 +- compiler/core/lam_pass_eliminate_ref.mli | 2 +- compiler/core/lam_pass_exits.ml | 16 +- compiler/core/lam_pass_exits.mli | 2 +- compiler/core/lam_pass_guard_raises.ml | 2 +- compiler/core/lam_pass_guard_raises.mli | 2 +- compiler/core/lam_pass_lets_dce.ml | 10 +- compiler/core/lam_pass_lets_dce.mli | 2 +- compiler/core/lam_pass_remove_alias.ml | 4 +- compiler/core/lam_pass_remove_alias.mli | 2 +- compiler/core/lam_print.ml | 17 +- compiler/core/lam_print.mli | 6 +- compiler/core/lam_stats_export.ml | 3 +- compiler/core/lam_stats_export.mli | 2 +- compiler/core/lam_util.ml | 19 ++- compiler/core/lam_util.mli | 16 +- compiler/core/lam_var_stats.mli | 2 +- compiler/core/polyvar_pattern_match.ml | 2 +- compiler/ml/lambda.ml | 106 ++++++------- compiler/ml/lambda.mli | 149 +++++++++--------- compiler/ml/lambda_scc.ml | 10 +- compiler/ml/lambda_scc.mli | 2 +- compiler/ml/matching.ml | 42 ++--- compiler/ml/matching.mli | 35 ++-- compiler/ml/printlambda.mli | 2 +- compiler/ml/switch.ml | 10 +- compiler/ml/switch.mli | 11 +- compiler/ml/transl_recmodule.ml | 6 +- compiler/ml/transl_recmodule.mli | 6 +- compiler/ml/translattribute.ml | 2 +- compiler/ml/translattribute.mli | 2 +- compiler/ml/translcore.ml | 16 +- compiler/ml/translcore.mli | 12 +- compiler/ml/translmod.ml | 4 +- compiler/ml/translmod.mli | 2 +- 83 files changed, 426 insertions(+), 464 deletions(-) diff --git a/AGENTS.md b/AGENTS.md index 0195d90495d..dd3038a9958 100644 --- a/AGENTS.md +++ b/AGENTS.md @@ -47,8 +47,6 @@ The Makefile’s targets build on each other in this order: - **Don't use unit `()` with mandatory labeled arguments** - When a function has a mandatory labeled argument (like `~config`), don't add a trailing `()` parameter. The labeled argument already prevents accidental partial application. Only use `()` when all parameters are optional and you need to force evaluation. Example: `let forceDelayedItems ~config = ...` not `let forceDelayedItems ~config () = ...` -- **Be careful with similar constructor names across different IRs** - Note that `Lam` (Lambda IR) and `Lambda` (typed lambda) have variants with similar constructor names like `Ltrywith`, but they represent different things in different compilation phases. - - **Avoid warning suppressions** - Never use `[@@warning "..."]` to silence warnings. Instead, fix the underlying issue properly - **Skip trailing `; _` in record patterns** - The warning it targets is disabled in this codebase, so prefer `{field = x}` over `{field = x; _}`. @@ -116,8 +114,8 @@ Read the area guide before changing a compiler subsystem: printing, and JSX transformation - [`compiler/ml/README.md`](compiler/ml/README.md) for the type checker and typed tree -- [`compiler/core/README.md`](compiler/core/README.md) for Lambda, Lam, and - JavaScript generation +- [`compiler/core/README.md`](compiler/core/README.md) for Lambda + optimization and JavaScript generation - [`analysis/README.md`](analysis/README.md) for editor analysis - [`rewatch/README.md`](rewatch/README.md) for the build system - [`tools/README.md`](tools/README.md) for `rescript-tools` diff --git a/compiler/core/README.md b/compiler/core/README.md index 28ef3609bf6..021e56764fd 100644 --- a/compiler/core/README.md +++ b/compiler/core/README.md @@ -1,8 +1,8 @@ -# Lambda, Lam, and JavaScript generation +# Lambda optimization and JavaScript generation This directory contains the compiler backend after typedtree translation. It -owns ReScript's Lam representation, Lam optimization passes, JavaScript IR, -and JavaScript output. +owns the Lambda optimization passes, the JavaScript IR, and JavaScript output. +Lambda itself is defined in [`../ml/lambda.mli`](../ml/lambda.mli). ## Pipeline and code map @@ -11,16 +11,16 @@ Typedtree translation in `compiler/ml/translcore.ml` and `compiler/ml/lambda.mli`. [`lam_convert.ml`](lam_convert.ml) -: Converts `Lambda.lambda` to the ReScript-specific [`Lam.t`](lam.mli), - normalizes aliases, and collects potential module dependencies. +: Collects the modules a compilation unit depends on, read off the Lambda + term. `lam_pass_*.ml` and the other `lam_*.ml` modules -: Analyze and transform Lam. [`lam_compile_main.ml`](lam_compile_main.ml) +: Analyze and transform Lambda. [`lam_compile_main.ml`](lam_compile_main.ml) coordinates the backend pass sequence; read it before inserting or reordering a pass. [`lam_compile.ml`](lam_compile.ml) -: Lowers Lam to JavaScript IR. Primitive-specific and FFI lowering is split +: Lowers Lambda to JavaScript IR. Primitive-specific and FFI lowering is split into `lam_compile_primitive.ml`, `lam_compile_external_call.ml`, and related modules. @@ -34,12 +34,14 @@ Typedtree translation in `compiler/ml/translcore.ml` and ## Changing a representation -`Lambda` and `Lam` have similarly named constructors but are distinct IRs. -When adding or changing one, search every producer, traversal, optimizer, -printer, serializer, and consumer of that specific type. Do not assume a match -on the other representation covers it. +`Lambda.t` is private: every term is built through the constructors in +[`../ml/lambda.mli`](../ml/lambda.mli), six of which normalize as they build. +A constructor may replace a node with an equivalent one, but may not move code +between branches - that is what a pass is for. When adding or changing a +constructor, search every producer, traversal, optimizer, printer, serializer, +and consumer. -Check persistence boundaries as part of the change. `Lam.t` can be stored in +Check persistence boundaries as part of the change. `Lambda.t` can be stored in `.cmj` data through `js_cmj_format`; a constructor or payload change therefore changes cached compiler data even when generated JavaScript is unchanged. @@ -65,5 +67,5 @@ compiler flags below to compare intermediate forms for a small source file: ./cli/bsc.js -drawlambda example.res ``` -For Lam-specific debugging, use [`lam_print.ml`](lam_print.ml) at the relevant +For backend debugging, use [`lam_print.ml`](lam_print.ml) at the relevant pass boundary and remove temporary output before committing. diff --git a/compiler/core/ir_diagnostics.mli b/compiler/core/ir_diagnostics.mli index 4ebabe38807..cb17766afd2 100644 --- a/compiler/core/ir_diagnostics.mli +++ b/compiler/core/ir_diagnostics.mli @@ -1,6 +1,6 @@ type t val create : output_prefix:string -> t -val dump_lam : t -> pass:string -> Lambda.lambda -> unit +val dump_lam : t -> pass:string -> Lambda.t -> unit val dump_groups : t -> Lam_group.t list -> unit val dump_js : t -> pass:string -> J.program -> unit diff --git a/compiler/core/js_cmj_format.ml b/compiler/core/js_cmj_format.ml index 8daedc21dba..5afc6ca5330 100644 --- a/compiler/core/js_cmj_format.ml +++ b/compiler/core/js_cmj_format.ml @@ -29,7 +29,7 @@ type arity = Single of Lam_arity.t | Submodule of Lam_arity.t array (* TODO: add a magic number *) type cmj_value = { arity: arity; - persistent_closed_lambda: Lambda.lambda option; + persistent_closed_lambda: Lambda.t option; (** Either constant or closed functor *) } @@ -40,7 +40,7 @@ let single_na = Single Lam_arity.na type keyed_cmj_value = { name: string; arity: arity; - persistent_closed_lambda: Lambda.lambda option; + persistent_closed_lambda: Lambda.t option; } type keyed_cmj_values = keyed_cmj_value array diff --git a/compiler/core/js_cmj_format.mli b/compiler/core/js_cmj_format.mli index 53d57fd3290..a6a9cf29b77 100644 --- a/compiler/core/js_cmj_format.mli +++ b/compiler/core/js_cmj_format.mli @@ -49,7 +49,7 @@ type arity = Single of Lam_arity.t | Submodule of Lam_arity.t array type cmj_value = { arity: arity; - persistent_closed_lambda: Lambda.lambda option; + persistent_closed_lambda: Lambda.t option; (* Either constant or closed functor *) } @@ -58,7 +58,7 @@ type effect_ = string option type keyed_cmj_value = { name: string; arity: arity; - persistent_closed_lambda: Lambda.lambda option; + persistent_closed_lambda: Lambda.t option; } type hoisted_export = { diff --git a/compiler/core/lam_analysis.ml b/compiler/core/lam_analysis.ml index c619054eab2..8b37b0e17bb 100644 --- a/compiler/core/lam_analysis.ml +++ b/compiler/core/lam_analysis.ml @@ -30,7 +30,7 @@ let not_zero_constant (x : Lambda.structured_constant) = | Const_bigint (_, i) -> i <> "0" | _ -> false -let rec no_side_effects (lam : Lambda.lambda) : bool = +let rec no_side_effects (lam : Lambda.t) : bool = match lam with | Lvar _ | Lconst _ | Lfunction _ -> true | Lglobal_module _ -> true @@ -141,7 +141,7 @@ let really_big () = raise_notrace Too_big_to_inline (* let big_lambda = 1000 *) -let rec size (lam : Lambda.lambda) = +let rec size (lam : Lambda.t) = try match lam with | Lvar _ -> 1 @@ -198,10 +198,10 @@ and size_constant x = | Const_block (_, str) -> Ext_list.fold_left str 0 (fun acc x -> acc + size_constant x) -and size_lams acc (lams : Lambda.lambda list) = +and size_lams acc (lams : Lambda.t list) = Ext_list.fold_left lams acc (fun acc l -> acc + size l) -let args_all_const (args : Lambda.lambda list) = +let args_all_const (args : Lambda.t list) = Ext_list.for_all args (fun x -> match x with | Lconst _ -> true @@ -220,7 +220,7 @@ let small_inline_size = 5 ideally we should also evaluate its size after inlining, since after partial evaluation, it might still be *very big* *) -let destruct_pattern (body : Lambda.lambda) params args = +let destruct_pattern (body : Lambda.t) params args = let rec aux v params args = match (params, args) with | x :: xs, b :: bs -> if Ident.same x v then Some b else aux v xs bs @@ -246,8 +246,7 @@ let lfunction_can_be_inlined (lfunction : Lambda.lfunction) = (not lfunction.attr.async) && lfunction.attr.directive = None (** Hints to inlining *) -let ok_to_inline_fun_when_app (m : Lambda.lfunction) (args : Lambda.lambda list) - = +let ok_to_inline_fun_when_app (m : Lambda.lfunction) (args : Lambda.t list) = match m.attr.inline with | Always_inline -> true | Never_inline -> false @@ -262,7 +261,7 @@ let ok_to_inline_fun_when_app (m : Lambda.lfunction) (args : Lambda.lambda list) (* TODO: We can relax this a bit later, but decide whether to inline it later in the call site *) -let safe_to_inline (lam : Lambda.lambda) = +let safe_to_inline (lam : Lambda.t) = match lam with | Lfunction _ -> true | Lconst diff --git a/compiler/core/lam_analysis.mli b/compiler/core/lam_analysis.mli index 609f34d7f77..e42f736f14d 100644 --- a/compiler/core/lam_analysis.mli +++ b/compiler/core/lam_analysis.mli @@ -24,17 +24,17 @@ (** A module which provides some basic analysis over lambda expression *) -val no_side_effects : Lambda.lambda -> bool +val no_side_effects : Lambda.t -> bool (** No side effect, but it might depend on data store *) -val size : Lambda.lambda -> int +val size : Lambda.t -> int val lfunction_can_be_inlined : Lambda.lfunction -> bool -val ok_to_inline_fun_when_app : Lambda.lfunction -> Lambda.lambda list -> bool +val ok_to_inline_fun_when_app : Lambda.lfunction -> Lambda.t list -> bool val small_inline_size : int val exit_inline_size : int -val safe_to_inline : Lambda.lambda -> bool +val safe_to_inline : Lambda.t -> bool diff --git a/compiler/core/lam_arity_analysis.ml b/compiler/core/lam_arity_analysis.ml index b67a1ec1ed4..cab4cef6569 100644 --- a/compiler/core/lam_arity_analysis.ml +++ b/compiler/core/lam_arity_analysis.ml @@ -35,7 +35,7 @@ let arity_of_var (meta : Lam_stats.t) (v : Ident.t) = We will keep iterating such environment If not found, we will return [NA] *) -let rec get_arity (meta : Lam_stats.t) (lam : Lambda.lambda) : Lam_arity.t = +let rec get_arity (meta : Lam_stats.t) (lam : Lambda.t) : Lam_arity.t = match lam with | Lvar v -> arity_of_var meta v | Lconst _ -> Lam_arity.non_function_arity_info @@ -127,7 +127,7 @@ let rec get_arity (meta : Lam_stats.t) (lam : Lambda.lambda) : Lam_arity.t = | Lwhile _ | Lfor _ | Lfor_of _ | Lfor_await_of _ | Lassign _ -> Lam_arity.non_function_arity_info -and all_lambdas meta (xs : Lambda.lambda list) = +and all_lambdas meta (xs : Lambda.t list) = match xs with | y :: ys -> let arity = get_arity meta y in diff --git a/compiler/core/lam_arity_analysis.mli b/compiler/core/lam_arity_analysis.mli index 810e9b684c9..004449a1f2b 100644 --- a/compiler/core/lam_arity_analysis.mli +++ b/compiler/core/lam_arity_analysis.mli @@ -24,4 +24,4 @@ (** Utilities for lambda analysis *) -val get_arity : Lam_stats.t -> Lambda.lambda -> Lam_arity.t +val get_arity : Lam_stats.t -> Lambda.t -> Lam_arity.t diff --git a/compiler/core/lam_beta_reduce.ml b/compiler/core/lam_beta_reduce.ml index b21ed8bbe88..c8a4fef96dc 100644 --- a/compiler/core/lam_beta_reduce.ml +++ b/compiler/core/lam_beta_reduce.ml @@ -45,7 +45,7 @@ we can bound [x] to [100] in a single step *) let propagate_beta_reduce (meta : Lam_stats.t) (params : Ident.t list) - (body : Lambda.lambda) (args : Lambda.lambda list) = + (body : Lambda.t) (args : Lambda.t list) = match Lam_beta_reduce_util.simple_beta_reduce params body args with | Some x -> x | None -> @@ -110,7 +110,7 @@ let propagate_beta_reduce_with_map (meta : Lam_stats.t) in (* See above: fold left so arguments evaluate in call order. *) Ext_list.fold_left rest_bindings new_body - (fun l (param, (arg : Lambda.lambda)) -> + (fun l (param, (arg : Lambda.t)) -> (match arg with | Lprim {primitive = Pmakeblock info; args} when Lambda.is_immutable_block info -> diff --git a/compiler/core/lam_beta_reduce.mli b/compiler/core/lam_beta_reduce.mli index e1e1a41b66e..9d6a4bc68e6 100644 --- a/compiler/core/lam_beta_reduce.mli +++ b/compiler/core/lam_beta_reduce.mli @@ -24,8 +24,7 @@ (** Beta reduction of lambda IR *) -val no_names_beta_reduce : - Ident.t list -> Lambda.lambda -> Lambda.lambda list -> Lambda.lambda +val no_names_beta_reduce : Ident.t list -> Lambda.t -> Lambda.t list -> Lambda.t (* Compile-time beta-reduction of functions immediately applied: Lapply(Lfunction(Curried, params, body), args, loc) -> let paramN = argN in ... let param1 = arg1 in body @@ -44,19 +43,15 @@ val no_names_beta_reduce : *) val propagate_beta_reduce : - Lam_stats.t -> - Ident.t list -> - Lambda.lambda -> - Lambda.lambda list -> - Lambda.lambda + Lam_stats.t -> Ident.t list -> Lambda.t -> Lambda.t list -> Lambda.t val propagate_beta_reduce_with_map : Lam_stats.t -> Lam_var_stats.stats Map_ident.t -> Ident.t list -> - Lambda.lambda -> - Lambda.lambda list -> - Lambda.lambda + Lambda.t -> + Lambda.t list -> + Lambda.t (** {[ Lam_beta_reduce.propogate_beta_reduce_with_map meta param_map diff --git a/compiler/core/lam_beta_reduce_util.ml b/compiler/core/lam_beta_reduce_util.ml index 22d9d73db35..00b70ce726c 100644 --- a/compiler/core/lam_beta_reduce_util.ml +++ b/compiler/core/lam_beta_reduce_util.ml @@ -31,7 +31,7 @@ other wise the evaluation order is tricky (make sure eval order is correct) *) -type value = {mutable used: bool; lambda: Lambda.lambda} +type value = {mutable used: bool; lambda: Lambda.t} let param_hash : _ Hash_ident.t = Hash_ident.create 20 @@ -44,7 +44,7 @@ let param_hash : _ Hash_ident.t = Hash_ident.create 20 {[ when Ext_list.for_all2_no_exn (fun p a -> - match (a : Lambda.lambda) with + match (a : Lambda.t) with | Lvar a -> Ident.same p a | _ -> false ) params args' ]} @@ -58,14 +58,14 @@ let simple_beta_reduce params body args = exp.lambda | None -> opt in - let rec aux_exn acc (us : Lambda.lambda list) = + let rec aux_exn acc (us : Lambda.t list) = match us with | [] -> List.rev acc | (Lvar x as a) :: rest -> aux_exn (find_param_exn x a :: acc) rest | (Lconst _ as u) :: rest -> aux_exn (u :: acc) rest | _ :: _ -> raise_notrace Not_simple_apply in - match (body : Lambda.lambda) with + match (body : Lambda.t) with | Lprim {primitive; args = ap_args; loc = ap_loc} (* There is no lambda in primitive *) -> ( (* catch a special case of primitives *) diff --git a/compiler/core/lam_beta_reduce_util.mli b/compiler/core/lam_beta_reduce_util.mli index 50ed94fb3a8..335e9e0978f 100644 --- a/compiler/core/lam_beta_reduce_util.mli +++ b/compiler/core/lam_beta_reduce_util.mli @@ -23,4 +23,4 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) val simple_beta_reduce : - Ident.t list -> Lambda.lambda -> Lambda.lambda list -> Lambda.lambda option + Ident.t list -> Lambda.t -> Lambda.t list -> Lambda.t option diff --git a/compiler/core/lam_bounded_vars.ml b/compiler/core/lam_bounded_vars.ml index 718cdc3d59f..4737086a083 100644 --- a/compiler/core/lam_bounded_vars.ml +++ b/compiler/core/lam_bounded_vars.ml @@ -61,7 +61,7 @@ 2. number of invoked times 3. arguments are const or not *) -let rewrite (map : _ Hash_ident.t) (lam : Lambda.lambda) : Lambda.lambda = +let rewrite (map : _ Hash_ident.t) (lam : Lambda.t) : Lambda.t = let rebind i = let i' = Ident.rename i in Hash_ident.add map i (Lambda.var i'); @@ -72,7 +72,7 @@ let rewrite (map : _ Hash_ident.t) (lam : Lambda.lambda) : Lambda.lambda = match op with | None -> None | Some x -> Some (aux x) - and aux (lam : Lambda.lambda) : Lambda.lambda = + and aux (lam : Lambda.t) : Lambda.t = match lam with | Lvar v -> Hash_ident.find_default map v lam | Llet (str, v, l1, l2) -> @@ -170,4 +170,4 @@ let rewrite (map : _ Hash_ident.t) (lam : Lambda.lambda) : Lambda.lambda = in aux lam -(* let refresh lam = rewrite (Hash_ident.create 17 : Lambda.lambda Hash_ident.t ) lam *) +(* let refresh lam = rewrite (Hash_ident.create 17 : Lambda.t Hash_ident.t ) lam *) diff --git a/compiler/core/lam_bounded_vars.mli b/compiler/core/lam_bounded_vars.mli index 14efda71a6e..2e9dffa0aa0 100644 --- a/compiler/core/lam_bounded_vars.mli +++ b/compiler/core/lam_bounded_vars.mli @@ -22,12 +22,12 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val rewrite : Lambda.lambda Hash_ident.t -> Lambda.lambda -> Lambda.lambda +val rewrite : Lambda.t Hash_ident.t -> Lambda.t -> Lambda.t (** [rewrite tbl lam] Given a [tbl] to rewrite all bounded variables in [lam] *) (** refresh lambda to replace all bounded vars for new ones *) (* val refresh : - Lambda.lambda -> - Lambda.lambda *) + Lambda.t -> + Lambda.t *) diff --git a/compiler/core/lam_check.ml b/compiler/core/lam_check.ml index 4a47c41069c..91b71de50d8 100644 --- a/compiler/core/lam_check.ml +++ b/compiler/core/lam_check.ml @@ -47,9 +47,9 @@ let check ~file ~pass lam = in let rec check_list xs (cxt : Set_int.t) = Ext_list.iter xs (fun x -> check_staticfails x cxt) - and check_list_snd : 'a. ('a * Lambda.lambda) list -> _ -> unit = + and check_list_snd : 'a. ('a * Lambda.t) list -> _ -> unit = fun xs cxt -> Ext_list.iter_snd xs (fun x -> check_staticfails x cxt) - and check_staticfails (l : Lambda.lambda) (cxt : Set_int.t) = + and check_staticfails (l : Lambda.t) (cxt : Set_int.t) = match l with | Lvar _ | Lconst _ | Lglobal_module _ -> () | Lprim {args; _} -> check_list args cxt @@ -98,9 +98,9 @@ let check ~file ~pass lam = | Lassign (_id, e) -> check_staticfails e cxt in let rec iter_list xs = Ext_list.iter xs iter - and iter_list_snd : 'a. ('a * Lambda.lambda) list -> unit = + and iter_list_snd : 'a. ('a * Lambda.t) list -> unit = fun xs -> Ext_list.iter_snd xs iter - and iter (l : Lambda.lambda) = + and iter (l : Lambda.t) = match l with | Lvar id -> use id | Lglobal_module _ -> () diff --git a/compiler/core/lam_check.mli b/compiler/core/lam_check.mli index 9d7d58a6dc5..93bb81b74ce 100644 --- a/compiler/core/lam_check.mli +++ b/compiler/core/lam_check.mli @@ -22,4 +22,4 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val check : file:string -> pass:string -> Lambda.lambda -> Lambda.lambda +val check : file:string -> pass:string -> Lambda.t -> Lambda.t diff --git a/compiler/core/lam_closure.ml b/compiler/core/lam_closure.ml index eb87d0f3c01..5386d5ab252 100644 --- a/compiler/core/lam_closure.ml +++ b/compiler/core/lam_closure.ml @@ -52,7 +52,7 @@ let sink_pos = Lam_var_stats.sink An enriched version of [free_varaibles] in {!Lam_free_variables} *) let free_variables (export_idents : Set_ident.t) (params : stats Map_ident.t) - (lam : Lambda.lambda) : stats Map_ident.t = + (lam : Lambda.t) : stats Map_ident.t = let fv = ref params in let local_set = ref export_idents in let local_add k = local_set := Set_ident.add !local_set k in @@ -65,7 +65,7 @@ let free_variables (export_idents : Set_ident.t) (params : stats Map_ident.t) if not (Set_ident.mem !local_set v) then fv := adjust !fv cur_pos v in - let rec iter (top : position) (lam : Lambda.lambda) = + let rec iter (top : position) (lam : Lambda.t) = match lam with | Lvar v -> used top v | Lconst _ -> () @@ -150,7 +150,7 @@ let free_variables (export_idents : Set_ident.t) (params : stats Map_ident.t) iter Lam_var_stats.fresh_env lam; !fv -(* let is_closed_by (set : Set_ident.t) (lam : Lambda.lambda) : bool = +(* let is_closed_by (set : Set_ident.t) (lam : Lambda.t) : bool = Map_ident.is_empty (free_variables set (Map_ident.empty ) lam ) *) (** A bit consverative , it should be empty *) @@ -159,7 +159,7 @@ let is_closed lam = (fun k _ -> Ident.global k) let is_closed_with_map (exports : Set_ident.t) (params : Ident.t list) - (body : Lambda.lambda) : bool * stats Map_ident.t = + (body : Lambda.t) : bool * stats Map_ident.t = let param_map = free_variables exports (param_map_of_list params) body in let old_count = List.length params in let new_count = Map_ident.cardinal param_map in diff --git a/compiler/core/lam_closure.mli b/compiler/core/lam_closure.mli index 391c2645e50..337bfc40e35 100644 --- a/compiler/core/lam_closure.mli +++ b/compiler/core/lam_closure.mli @@ -25,19 +25,19 @@ (** [is_closed_by map lam] return [true] if all unbound variables belongs to the given [map] *) -(* val is_closed_by : Set_ident.t -> Lambda.lambda -> bool *) +(* val is_closed_by : Set_ident.t -> Lambda.t -> bool *) -val is_closed : Lambda.lambda -> bool +val is_closed : Lambda.t -> bool val is_closed_with_map : Set_ident.t -> Ident.t list -> - Lambda.lambda -> + Lambda.t -> bool * Lam_var_stats.stats Map_ident.t (** The output is mostly used in betat reduction *) val free_variables : Set_ident.t -> Lam_var_stats.stats Map_ident.t -> - Lambda.lambda -> + Lambda.t -> Lam_var_stats.stats Map_ident.t diff --git a/compiler/core/lam_coercion.ml b/compiler/core/lam_coercion.ml index 9bd09da74fb..4b11e845ca2 100644 --- a/compiler/core/lam_coercion.ml +++ b/compiler/core/lam_coercion.ml @@ -72,14 +72,14 @@ type t = { export_list: Ident.t list; export_set: Set_ident.t; - export_map: Lambda.lambda Map_ident.t; + export_map: Lambda.t Map_ident.t; (** not used in code generation, mostly used for store some information in cmj files *) groups: Lam_group.t list; (* all code to be compiled later = original code + rebound coercions *) } -let handle_exports (meta : Lam_stats.t) (lambda_exports : Lambda.lambda list) +let handle_exports (meta : Lam_stats.t) (lambda_exports : Lambda.t list) (reverse_input : Lam_group.t list) = let (original_exports : Ident.t list) = meta.exports in let (original_export_set : Set_ident.t) = meta.export_idents in @@ -92,7 +92,7 @@ let handle_exports (meta : Lam_stats.t) (lambda_exports : Lambda.lambda list) export_set = original_export_set; export_map = Map_ident.empty; groups = []; - } (fun (original_export_id : Ident.t) (lam : Lambda.lambda) (acc : t) -> + } (fun (original_export_id : Ident.t) (lam : Lambda.t) (acc : t) -> let original_name = original_export_id.name in if not @@ Hash_set_string.check_add tbl original_name then Bs_exception.error (Bs_duplicate_exports original_name); @@ -176,8 +176,8 @@ let handle_exports (meta : Lam_stats.t) (lambda_exports : Lambda.lambda list) - [compile_group] and [compile] become mutually recursive function *) -let rec flatten (acc : Lam_group.t list) (lam : Lambda.lambda) : - Lambda.lambda * Lam_group.t list = +let rec flatten (acc : Lam_group.t list) (lam : Lambda.t) : + Lambda.t * Lam_group.t list = match lam with | Llet (str, id, arg, body) -> let res, l = flatten acc arg in diff --git a/compiler/core/lam_coercion.mli b/compiler/core/lam_coercion.mli index 4fb64d709fa..bc123aa8dbd 100644 --- a/compiler/core/lam_coercion.mli +++ b/compiler/core/lam_coercion.mli @@ -25,9 +25,8 @@ type t = { export_list: Ident.t list; export_set: Set_ident.t; - export_map: Lambda.lambda Map_ident.t; + export_map: Lambda.t Map_ident.t; groups: Lam_group.t list; } -val coerce_and_group_big_lambda : - Lam_stats.t -> Lambda.lambda -> t * Lam_stats.t +val coerce_and_group_big_lambda : Lam_stats.t -> Lambda.t -> t * Lam_stats.t diff --git a/compiler/core/lam_compile.ml b/compiler/core/lam_compile.ml index 9ff3c9f882a..c6b27c5ff59 100644 --- a/compiler/core/lam_compile.ml +++ b/compiler/core/lam_compile.ml @@ -32,7 +32,7 @@ let with_source_loc loc (exp : J.expression) = | Some source_loc, None -> {exp with source_loc = Some source_loc} | _ -> exp -let rec source_loc_of_lam (lam : Lambda.lambda) = +let rec source_loc_of_lam (lam : Lambda.t) = match lam with | Lapply {ap_info = {ap_loc}} -> Some ap_loc | Lprim {loc} | Lfunction {loc} -> Some loc @@ -83,7 +83,7 @@ let with_block_source_loc lam block = | stmt :: rest -> with_statement_source_loc (source_map_loc_of_lam lam) stmt :: rest -let args_either_function_or_const (args : Lambda.lambda list) = +let args_either_function_or_const (args : Lambda.t list) = Ext_list.for_all args (fun x -> match x with | Lfunction _ | Lconst _ -> true @@ -131,8 +131,8 @@ let in_staticcatch (x : Lam_compile_context.tail_type) : -> x *) (* assume outer is [Lstaticcatch] *) -let rec flat_catches (acc : Lam_compile_context.handler list) - (x : Lambda.lambda) : Lam_compile_context.handler list * Lambda.lambda = +let rec flat_catches (acc : Lam_compile_context.handler list) (x : Lambda.t) : + Lam_compile_context.handler list * Lambda.t = match x with | Lstaticcatch (l, (label, bindings), handler) when acc = [] @@ -143,8 +143,8 @@ let rec flat_catches (acc : Lam_compile_context.handler list) flat_catches ({label; handler; bindings} :: acc) l | _ -> (acc, x) -let flatten_nested_caches (x : Lambda.lambda) : - Lam_compile_context.handler list * Lambda.lambda = +let flatten_nested_caches (x : Lambda.t) : + Lam_compile_context.handler list * Lambda.t = flat_catches [] x let morph_declare_to_assign (cxt : Lam_compile_context.t) k = @@ -164,7 +164,7 @@ let group_apply ~merge_cases cases callback = only jmp_table and env needed *) -type default_case = Default of Lambda.lambda | Complete | NonComplete +type default_case = Default of Lambda.t | Complete | NonComplete let default_action ~saturated failaction = match failaction with @@ -239,7 +239,7 @@ type initialization = J.block (* 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 * Lambda.lambda) list) = +let functions_before_values (group : (Ident.t * Lambda.t) list) = if Ext_list.for_all group (fun (_, x) -> match x with @@ -249,7 +249,7 @@ let functions_before_values (group : (Ident.t * Lambda.lambda) list) = else List.sort (fun (_, lama) (_, lamb) -> - match ((lama : Lambda.lambda), (lamb : Lambda.lambda)) with + match ((lama : Lambda.t), (lamb : Lambda.t)) with | Lfunction _, Lfunction _ -> 0 | Lfunction _, _ -> -1 | _, Lfunction _ -> 1 @@ -374,7 +374,7 @@ let compile output_prefix = *) and compile_recursive_let ~all_bindings (cxt : Lam_compile_context.t) - (id : Ident.t) (arg : Lambda.lambda) : Js_output.t * initialization = + (id : Ident.t) (arg : Lambda.t) : Js_output.t * initialization = match arg with | Lfunction { @@ -538,8 +538,8 @@ let compile output_prefix = ]} *) (compile_lambda {cxt with continuation = Declare (Alias, id)} arg, []) - and compile_recursive_lets_aux cxt (id_args : (Ident.t * Lambda.lambda) list) - : Js_output.t = + and compile_recursive_lets_aux cxt (id_args : (Ident.t * Lambda.t) list) : + Js_output.t = (* #1716 *) let output_code, ids = Ext_list.fold_right id_args (Js_output.dummy, []) @@ -571,7 +571,7 @@ let compile output_prefix = switch_exp:J.expression -> default:default_case -> ?merge_cases:('a -> 'a -> bool) -> - ('a * Lambda.lambda) list -> + ('a * Lambda.t) list -> J.block = fun (type a) ~(make_exp : a -> J.expression) ~(eq_exp : @@ -583,7 +583,7 @@ let compile output_prefix = _ -> (a * J.case_clause) list -> J.statement) ~(switch_exp : J.expression) ~(default : default_case) - ?(merge_cases = fun _ _ -> true) (cases : (a * Lambda.lambda) list) -> + ?(merge_cases = fun _ _ -> true) (cases : (a * Lambda.t) list) -> let output_block_with_source_loc cxt lam = compile_lambda cxt lam |> Js_output.output_as_block |> with_block_source_loc lam @@ -729,7 +729,7 @@ let compile output_prefix = | Switch_constructor _ -> assert false) clauses)) ~switch_exp ~default - and compile_switch (switch_arg : Lambda.lambda) (sw : Lambda.lambda_switch) + and compile_switch (switch_arg : Lambda.t) (sw : Lambda.lambda_switch) (lambda_cxt : Lam_compile_context.t) = (* TODO: if default is None, we can do some optimizations Use switch vs if/then/else @@ -974,7 +974,7 @@ let compile output_prefix = default: (exit 1)) with (1) 2)) *) - and compile_staticraise i (largs : Lambda.lambda list) + and compile_staticraise i (largs : Lambda.t list) (lambda_cxt : Lam_compile_context.t) = (* [i] is the jump table, [largs] is the arguments passed to [Lstaticcatch]*) match Lam_compile_context.find_exn lambda_cxt i with @@ -1021,8 +1021,8 @@ let compile output_prefix = ]} *) - and compile_staticcatch (lam : Lambda.lambda) - (lambda_cxt : Lam_compile_context.t) = + and compile_staticcatch (lam : Lambda.t) (lambda_cxt : Lam_compile_context.t) + = let code_table, body = flatten_nested_caches lam in let exit_id = Ext_ident.create_tmp ~name:"exit" () in match (lambda_cxt.continuation, code_table) with @@ -1108,7 +1108,7 @@ let compile output_prefix = (Js_output.append_output lbody (Js_output.make (compile_cases ~cxt:new_cxt ~switch_exp:exit_expr handlers)))) - and compile_sequand (l : Lambda.lambda) (r : Lambda.lambda) + and compile_sequand (l : Lambda.t) (r : Lambda.t) (lambda_cxt : Lam_compile_context.t) = if Lam_compile_context.continuation_is_return lambda_cxt.continuation then compile_lambda lambda_cxt (Lambda.sequand l r) @@ -1147,7 +1147,7 @@ let compile output_prefix = ((S.define_variable ~kind:Variable v E.false_ :: l_block) @ [S.if_ l_expr (r_block @ [S.assign v r_expr])]) ~value:(E.var v))) - and compile_sequor (l : Lambda.lambda) (r : Lambda.lambda) + and compile_sequor (l : Lambda.t) (r : Lambda.t) (lambda_cxt : Lam_compile_context.t) = if Lam_compile_context.continuation_is_return lambda_cxt.continuation then compile_lambda lambda_cxt (Lambda.sequor l r) @@ -1194,7 +1194,7 @@ let compile output_prefix = while expression, here we generate for statement, leave optimization later. (Sine OCaml expression can be really complex..) *) - and compile_while (predicate : Lambda.lambda) (body : Lambda.lambda) + and compile_while (predicate : Lambda.t) (body : Lambda.t) (lambda_cxt : Lam_compile_context.t) = match compile_lambda @@ -1232,9 +1232,9 @@ let compile output_prefix = for(var i = 0 ; i < (console.log(i),10); ++i){console.log('hi')} print i each time, so they are different semantics... *) - and compile_for (id : J.for_ident) (start : Lambda.lambda) - (finish : Lambda.lambda) (direction : Js_op.direction_flag) - (body : Lambda.lambda) (lambda_cxt : Lam_compile_context.t) = + and compile_for (id : J.for_ident) (start : Lambda.t) (finish : Lambda.t) + (direction : Js_op.direction_flag) (body : Lambda.t) + (lambda_cxt : Lam_compile_context.t) = let new_cxt = {lambda_cxt with continuation = NeedValue Not_tail} in let block = match (compile_lambda new_cxt start, compile_lambda new_cxt finish) with @@ -1279,8 +1279,8 @@ let compile output_prefix = in Js_output.output_of_block_and_expression lambda_cxt.continuation block E.unit - and compile_for_of (id : J.for_ident) (iterable : Lambda.lambda) - (body : Lambda.lambda) (lambda_cxt : Lam_compile_context.t) = + and compile_for_of (id : J.for_ident) (iterable : Lambda.t) (body : Lambda.t) + (lambda_cxt : Lam_compile_context.t) = let new_cxt = {lambda_cxt with continuation = NeedValue Not_tail} in let emitted_id = if Lambda.Ident_set.mem id (Lambda.free_variables body) then id @@ -1302,8 +1302,8 @@ let compile output_prefix = in Js_output.output_of_block_and_expression lambda_cxt.continuation block E.unit - and compile_for_await_of (id : J.for_ident) (iterable : Lambda.lambda) - (body : Lambda.lambda) (lambda_cxt : Lam_compile_context.t) = + and compile_for_await_of (id : J.for_ident) (iterable : Lambda.t) + (body : Lambda.t) (lambda_cxt : Lam_compile_context.t) = let new_cxt = {lambda_cxt with continuation = NeedValue Not_tail} in let emitted_id = if Lambda.Ident_set.mem id (Lambda.free_variables body) then id @@ -1325,8 +1325,8 @@ let compile output_prefix = in Js_output.output_of_block_and_expression lambda_cxt.continuation block E.unit - and compile_assign id (lambda : Lambda.lambda) - (lambda_cxt : Lam_compile_context.t) = + and compile_assign id (lambda : Lambda.t) (lambda_cxt : Lam_compile_context.t) + = let block = match lambda with | _ -> ( @@ -1384,8 +1384,8 @@ let compile output_prefix = Js_output.make (aux lambda_cxt {lambda_cxt with continuation = EffectCall new_return_type}) - and compile_ifthenelse (predicate : Lambda.lambda) (t_branch : Lambda.lambda) - (f_branch : Lambda.lambda) (lambda_cxt : Lam_compile_context.t) = + and compile_ifthenelse (predicate : Lambda.t) (t_branch : Lambda.t) + (f_branch : Lambda.t) (lambda_cxt : Lam_compile_context.t) = match compile_lambda {lambda_cxt with continuation = NeedValue Not_tail} @@ -1767,9 +1767,9 @@ let compile output_prefix = (Ext_list.concat_append args_block block) exp | {primitive; args; loc} -> compile_primitive_default primitive args loc - and collect_dup_overrides (copy_id : Ident.t) (lam : Lambda.lambda) - (acc : (Lambda.set_field_dbg_info * Lambda.lambda) list) : - (Lambda.set_field_dbg_info * Lambda.lambda) list option = + and collect_dup_overrides (copy_id : Ident.t) (lam : Lambda.t) + (acc : (Lambda.set_field_dbg_info * Lambda.t) list) : + (Lambda.set_field_dbg_info * Lambda.t) list option = match lam with | Lsequence ( Lprim @@ -1780,8 +1780,7 @@ let compile output_prefix = | Lvar id' when Ident.same id' copy_id -> Some acc | _ -> None and try_compile_record_spread (lambda_cxt : Lam_compile_context.t) - (id : Ident.t) (arg : Lambda.lambda) (body : Lambda.lambda) : - Js_output.t option = + (id : Ident.t) (arg : Lambda.t) (body : Lambda.t) : Js_output.t option = match arg with | Lprim {primitive = Pduprecord; args = [init]; loc} -> ( match collect_dup_overrides id body [] with @@ -1821,8 +1820,8 @@ let compile output_prefix = blocks (with_source_loc loc (E.obj ~dup:init_val props)))) | _ -> None - and compile_lambda (lambda_cxt : Lam_compile_context.t) - (cur_lam : Lambda.lambda) : Js_output.t = + and compile_lambda (lambda_cxt : Lam_compile_context.t) (cur_lam : Lambda.t) : + Js_output.t = match cur_lam with | Lfunction { diff --git a/compiler/core/lam_compile.mli b/compiler/core/lam_compile.mli index 48d20ab7d79..56ff1d6f66a 100644 --- a/compiler/core/lam_compile.mli +++ b/compiler/core/lam_compile.mli @@ -27,8 +27,8 @@ val compile_recursive_lets : output_prefix:string -> Lam_compile_context.t -> - (Ident.t * Lambda.lambda) list -> + (Ident.t * Lambda.t) list -> Js_output.t val compile_lambda : - output_prefix:string -> Lam_compile_context.t -> Lambda.lambda -> Js_output.t + output_prefix:string -> Lam_compile_context.t -> Lambda.t -> Js_output.t diff --git a/compiler/core/lam_compile_context.ml b/compiler/core/lam_compile_context.ml index a153bc5281f..faab0d7545e 100644 --- a/compiler/core/lam_compile_context.ml +++ b/compiler/core/lam_compile_context.ml @@ -100,11 +100,7 @@ let ensure_loop_label cxt frame = frame.label <- Some label; label -type handler = { - label: jbl_label; - handler: Lambda.lambda; - bindings: Ident.t list; -} +type handler = {label: jbl_label; handler: Lambda.t; bindings: Ident.t list} let no_static_raise_in_handler (x : handler) : bool = not (Lam_exit_code.has_exit_code x.handler (fun _code -> true)) @@ -116,7 +112,7 @@ let no_static_raise_in_handler (x : handler) : bool = [handlers] is used for compiling [staticcatch] *) let add_jmps (m : jmp_table) (exit_id : Ident.t) (code_table : handler list) : - jmp_table * (int * Lambda.lambda) list = + jmp_table * (int * Lambda.t) list = let map, handlers = Ext_list.fold_left_with_offset code_table (m, []) (Handler_map.cardinal m + 1) @@ -128,7 +124,7 @@ let add_jmps (m : jmp_table) (exit_id : Ident.t) (code_table : handler list) : let add_pseudo_jmp (m : jmp_table) (exit_id : Ident.t) (* TODO not needed, remove it later *) - (code_table : handler) : jmp_table * Lambda.lambda = + (code_table : handler) : jmp_table * Lambda.t = ( Handler_map.add m code_table.label {exit_id; bindings = code_table.bindings; order_id = -1}, code_table.handler ) diff --git a/compiler/core/lam_compile_context.mli b/compiler/core/lam_compile_context.mli index 86d61aee9ca..f19f9496f65 100644 --- a/compiler/core/lam_compile_context.mli +++ b/compiler/core/lam_compile_context.mli @@ -82,11 +82,7 @@ val enter_switch : t -> t val push_loop : t -> t * loop_frame val ensure_loop_label : t -> loop_frame -> J.label -type handler = { - label: jbl_label; - handler: Lambda.lambda; - bindings: Ident.t list; -} +type handler = {label: jbl_label; handler: Lambda.t; bindings: Ident.t list} val no_static_raise_in_handler : handler -> bool @@ -94,9 +90,8 @@ val add_jmps : jmp_table -> Ident.t -> handler list -> - jmp_table * (jbl_label * Lambda.lambda) list + jmp_table * (jbl_label * Lambda.t) list -val add_pseudo_jmp : - jmp_table -> Ident.t -> handler -> jmp_table * Lambda.lambda +val add_pseudo_jmp : jmp_table -> Ident.t -> handler -> jmp_table * Lambda.t val find_exn : t -> jbl_label -> value diff --git a/compiler/core/lam_compile_env.ml b/compiler/core/lam_compile_env.ml index 3482ad7e883..17a759da96e 100644 --- a/compiler/core/lam_compile_env.ml +++ b/compiler/core/lam_compile_env.ml @@ -32,7 +32,7 @@ type env_value = type ident_info = Js_cmj_format.keyed_cmj_value = { name: string; arity: Js_cmj_format.arity; - persistent_closed_lambda: Lambda.lambda option; + persistent_closed_lambda: Lambda.t option; } (* diff --git a/compiler/core/lam_compile_main.ml b/compiler/core/lam_compile_main.ml index 3475739e696..4ce76d1842a 100644 --- a/compiler/core/lam_compile_main.ml +++ b/compiler/core/lam_compile_main.ml @@ -242,8 +242,7 @@ let js_hoisted_aliases (export_ids : Ident.t list) (** Actually simplify_lets is kind of global optimization since it requires you to know whether it's used or not *) -let compile (output_prefix : string) export_idents hoisted (lam : Lambda.lambda) - = +let compile (output_prefix : string) export_idents hoisted (lam : Lambda.t) = let debug_ir = !Js_config.debug_ir in let diagnostics = if debug_ir then Some (Ir_diagnostics.create ~output_prefix) else None diff --git a/compiler/core/lam_compile_main.mli b/compiler/core/lam_compile_main.mli index 2cfeef80019..c62ff0dca4e 100644 --- a/compiler/core/lam_compile_main.mli +++ b/compiler/core/lam_compile_main.mli @@ -31,7 +31,7 @@ val compile : string -> Ident.t list -> Lambda.hoisted_function list -> - Lambda.lambda -> + Lambda.t -> J.deps_program (** For toplevel, [filename] is [""] which is the same as {!Env.get_unit_name ()} diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index 2adc5b2198d..61913c90db9 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -25,9 +25,9 @@ (** Global modules a unit depends on. Convert used to drop [Lglobal_module] references and have them added back by module analysis (see #3852); they are collected here instead, from the Lambda term directly. *) -let required_modules (lam : Lambda.lambda) : Lam_module_ident.Hash_set.t = +let required_modules (lam : Lambda.t) : Lam_module_ident.Hash_set.t = let required = Lam_module_ident.Hash_set.create 0 in - let rec collect (lam : Lambda.lambda) = + let rec collect (lam : Lambda.t) = (match lam with | Lglobal_module id -> Lam_module_ident.Hash_set.add required (Lam_module_ident.of_ml id) diff --git a/compiler/core/lam_convert.mli b/compiler/core/lam_convert.mli index 443c6880d70..3c0adbb46a6 100644 --- a/compiler/core/lam_convert.mli +++ b/compiler/core/lam_convert.mli @@ -22,7 +22,7 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val required_modules : Lambda.lambda -> Lam_module_ident.Hash_set.t +val required_modules : Lambda.t -> Lam_module_ident.Hash_set.t (** The other compilation units this one refers to, read off the Lambda term. A reference the optimizer deletes still has to be imported when the module it names is impure. *) diff --git a/compiler/core/lam_exit_code.ml b/compiler/core/lam_exit_code.ml index e5e1acef0ca..79c1770b8e3 100644 --- a/compiler/core/lam_exit_code.ml +++ b/compiler/core/lam_exit_code.ml @@ -23,7 +23,7 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) let has_exit_code lam exits = - let rec aux (lam : Lambda.lambda) = + let rec aux (lam : Lambda.t) = match lam with | Lfunction _ -> false (* static exit can not cross function boundary *) @@ -32,7 +32,7 @@ let has_exit_code lam exits = in aux lam -let rec has_exit (lam : Lambda.lambda) = +let rec has_exit (lam : Lambda.t) = match lam with | Lfunction _ -> false | Lstaticraise (_, _) -> true diff --git a/compiler/core/lam_exit_code.mli b/compiler/core/lam_exit_code.mli index 06a84d11d1d..105590425cb 100644 --- a/compiler/core/lam_exit_code.mli +++ b/compiler/core/lam_exit_code.mli @@ -22,6 +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 has_exit_code : Lambda.lambda -> (int -> bool) -> bool +val has_exit_code : Lambda.t -> (int -> bool) -> bool -val has_exit : Lambda.lambda -> bool +val has_exit : Lambda.t -> bool diff --git a/compiler/core/lam_exit_count.ml b/compiler/core/lam_exit_count.ml index fc72181ae4c..17d07b8d901 100644 --- a/compiler/core/lam_exit_count.ml +++ b/compiler/core/lam_exit_count.ml @@ -48,9 +48,9 @@ let incr_exit (exits : collection) i = For Lswitch, if it is not exhuastive pattern match, default will be counted twice. Since for pattern match, we will test whether it is an integer or block, both have default cases predicate: [sw_consts_full] vs nconsts *) -let count_helper (lam : Lambda.lambda) : collection = +let count_helper (lam : Lambda.t) : collection = let exits : collection = Hash_int.create 17 in - let rec count (lam : Lambda.lambda) = + let rec count (lam : Lambda.t) = match lam with | Lstaticraise (i, ls) -> incr_exit exits i; diff --git a/compiler/core/lam_exit_count.mli b/compiler/core/lam_exit_count.mli index a23c386978a..71f632ca1cd 100644 --- a/compiler/core/lam_exit_count.mli +++ b/compiler/core/lam_exit_count.mli @@ -24,6 +24,6 @@ type collection -val count_helper : Lambda.lambda -> collection +val count_helper : Lambda.t -> collection val count_exit : collection -> int -> int diff --git a/compiler/core/lam_group.ml b/compiler/core/lam_group.ml index 3a0133f5d01..399ad2bdef3 100644 --- a/compiler/core/lam_group.ml +++ b/compiler/core/lam_group.ml @@ -24,16 +24,16 @@ (** This is not a recursive type definition *) type t = - | Single of Lambda.let_kind * Ident.t * Lambda.lambda - | Recursive of (Ident.t * Lambda.lambda) list - | Nop of Lambda.lambda + | Single of Lambda.let_kind * Ident.t * Lambda.t + | Recursive of (Ident.t * Lambda.t) list + | Nop of Lambda.t -let single (kind : Lambda.let_kind) id (body : Lambda.lambda) = +let single (kind : Lambda.let_kind) id (body : Lambda.t) = match (kind, body) with | (Strict | StrictOpt), (Lvar _ | Lconst _) -> Single (Alias, id, body) | _ -> Single (kind, id, body) -let nop_cons (x : Lambda.lambda) acc = +let nop_cons (x : Lambda.t) acc = match x with | Lvar _ | Lconst _ | Lfunction _ -> acc | _ -> Nop x :: acc diff --git a/compiler/core/lam_group.mli b/compiler/core/lam_group.mli index 544e3905703..ba40b1b6a18 100644 --- a/compiler/core/lam_group.mli +++ b/compiler/core/lam_group.mli @@ -23,14 +23,14 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) type t = - | Single of Lambda.let_kind * Ident.t * Lambda.lambda - | Recursive of (Ident.t * Lambda.lambda) list - | Nop of Lambda.lambda + | Single of Lambda.let_kind * Ident.t * Lambda.t + | Recursive of (Ident.t * Lambda.t) list + | Nop of Lambda.t (** Tricky to be complete *) val pp_group : Format.formatter -> t -> unit -val single : Lambda.let_kind -> Ident.t -> Lambda.lambda -> t +val single : Lambda.let_kind -> Ident.t -> Lambda.t -> t -val nop_cons : Lambda.lambda -> t list -> t list +val nop_cons : Lambda.t -> t list -> t list diff --git a/compiler/core/lam_hit.ml b/compiler/core/lam_hit.ml index fec457e2ebc..dcd0dc97007 100644 --- a/compiler/core/lam_hit.ml +++ b/compiler/core/lam_hit.ml @@ -22,7 +22,7 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type t = Lambda.lambda +type t = Lambda.t let hit_variables (fv : Set_ident.t) (l : t) : bool = let rec hit_opt (x : t option) = diff --git a/compiler/core/lam_hit.mli b/compiler/core/lam_hit.mli index cc710118291..673ca072ff3 100644 --- a/compiler/core/lam_hit.mli +++ b/compiler/core/lam_hit.mli @@ -22,6 +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 hit_variables : Set_ident.t -> Lambda.lambda -> bool +val hit_variables : Set_ident.t -> Lambda.t -> bool -val hit_variable : Ident.t -> Lambda.lambda -> bool +val hit_variable : Ident.t -> Lambda.t -> bool diff --git a/compiler/core/lam_id_kind.ml b/compiler/core/lam_id_kind.ml index 7e068bc15fa..667e3add6c4 100644 --- a/compiler/core/lam_id_kind.ml +++ b/compiler/core/lam_id_kind.ml @@ -31,13 +31,13 @@ type rec_flag = Lam_rec | Lam_non_rec | Lam_self_rec recursive function *) -type element = NA | SimpleForm of Lambda.lambda +type element = NA | SimpleForm of Lambda.t type boxed_nullable = Undefined | Null | Null_undefined type t = - | Normal_optional of Lambda.lambda (* Some [x] *) - | OptionalBlock of Lambda.lambda * boxed_nullable + | Normal_optional of Lambda.t (* Some [x] *) + | OptionalBlock of Lambda.t * boxed_nullable | ImmutableBlock of element array | MutableBlock of element array | Constant of Lambda.structured_constant @@ -47,7 +47,7 @@ type t = (* TODO: This may contain some closure environment, check how it will interact with dead code elimination *) - lambda: (Lambda.lambda * rec_flag) option; + lambda: (Lambda.t * rec_flag) option; } | Exception | Parameter diff --git a/compiler/core/lam_id_kind.mli b/compiler/core/lam_id_kind.mli index 1c07c482291..707bde7e842 100644 --- a/compiler/core/lam_id_kind.mli +++ b/compiler/core/lam_id_kind.mli @@ -31,7 +31,7 @@ type rec_flag = | Lam_self_rec (* not inlining in this case *) -type element = NA | SimpleForm of Lambda.lambda +type element = NA | SimpleForm of Lambda.t type boxed_nullable = Undefined | Null | Null_undefined @@ -48,15 +48,15 @@ type boxed_nullable = Undefined | Null | Null_undefined [Lif(v/1)] will be translated into [Lif (v/2 === undefined )] *) type t = - | Normal_optional of Lambda.lambda - | OptionalBlock of Lambda.lambda * boxed_nullable + | Normal_optional of Lambda.t + | OptionalBlock of Lambda.t * boxed_nullable | ImmutableBlock of element array | MutableBlock of element array | Constant of Lambda.structured_constant | Module of Ident.t (** TODO: static module vs first class module *) | FunctionId of { mutable arity: Lam_arity.t; - lambda: (Lambda.lambda * rec_flag) option; + lambda: (Lambda.t * rec_flag) option; } | Exception | Parameter diff --git a/compiler/core/lam_pass_collapse_var_aliases.ml b/compiler/core/lam_pass_collapse_var_aliases.ml index 641bfaeb787..279a1d28424 100644 --- a/compiler/core/lam_pass_collapse_var_aliases.ml +++ b/compiler/core/lam_pass_collapse_var_aliases.ml @@ -10,9 +10,9 @@ let rec resolve tbl id = | None -> id | Some id' -> resolve tbl id' -let collapse ~exports (lam : Lambda.lambda) : Lambda.lambda = +let collapse ~exports (lam : Lambda.t) : Lambda.t = let tbl = Hash_ident.create 64 in - let rec go (lam : Lambda.lambda) : Lambda.lambda = + let rec go (lam : Lambda.t) : Lambda.t = match lam with | Lvar x -> Lambda.var (resolve tbl x) | Lglobal_module _ | Lconst _ | Lbreak | Lcontinue -> lam diff --git a/compiler/core/lam_pass_collapse_var_aliases.mli b/compiler/core/lam_pass_collapse_var_aliases.mli index 6b2c7b932cb..63263a80d69 100644 --- a/compiler/core/lam_pass_collapse_var_aliases.mli +++ b/compiler/core/lam_pass_collapse_var_aliases.mli @@ -10,4 +10,4 @@ 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 -> Lambda.lambda -> Lambda.lambda +val collapse : exports:Set_ident.t -> Lambda.t -> Lambda.t diff --git a/compiler/core/lam_pass_collect.ml b/compiler/core/lam_pass_collect.ml index 1d0c1cfbfe9..383a53f3055 100644 --- a/compiler/core/lam_pass_collect.ml +++ b/compiler/core/lam_pass_collect.ml @@ -42,8 +42,8 @@ let annotate (meta : Lam_stats.t) rec_flag (k : Ident.t) (arity : Lam_arity.t) function definition, alias propgation - and toplevel identifiers, this needs to be exported *) -let collect_info (meta : Lam_stats.t) (lam : Lambda.lambda) = - let rec collect_bind rec_flag (ident : Ident.t) (lam : Lambda.lambda) = +let collect_info (meta : Lam_stats.t) (lam : Lambda.t) = + let rec collect_bind rec_flag (ident : Ident.t) (lam : Lambda.t) = match lam with | Lconst v -> Hash_ident.replace meta.ident_tbl ident (Constant v) | Lprim {primitive = Pmakeblock info; args = ls} @@ -79,7 +79,7 @@ let collect_info (meta : Lam_stats.t) (lam : Lambda.lambda) = collect x; if Set_ident.mem meta.export_idents ident then annotate meta rec_flag ident (Lam_arity_analysis.get_arity meta x) lam - and collect (lam : Lambda.lambda) = + and collect (lam : Lambda.t) = match lam with | Lconst _ -> () | Lvar _ -> () diff --git a/compiler/core/lam_pass_collect.mli b/compiler/core/lam_pass_collect.mli index e23df50e3ef..23aa829f461 100644 --- a/compiler/core/lam_pass_collect.mli +++ b/compiler/core/lam_pass_collect.mli @@ -68,5 +68,5 @@ - *) -val collect_info : Lam_stats.t -> Lambda.lambda -> unit +val collect_info : Lam_stats.t -> Lambda.t -> unit (** Modify existing [meta] *) diff --git a/compiler/core/lam_pass_count.ml b/compiler/core/lam_pass_count.ml index 63a62b4def1..7f3ce84b1ec 100644 --- a/compiler/core/lam_pass_count.ml +++ b/compiler/core/lam_pass_count.ml @@ -92,7 +92,7 @@ let collect_occurs lam : occ_tbl = ()) in - let rec count (bv : local_tbl) (lam : Lambda.lambda) = + let rec count (bv : local_tbl) (lam : Lambda.t) = match lam with | Lfunction {body = l} -> count Map_ident.empty l (* when entering a function local [bv] diff --git a/compiler/core/lam_pass_count.mli b/compiler/core/lam_pass_count.mli index 96e29f45165..9175e809e80 100644 --- a/compiler/core/lam_pass_count.mli +++ b/compiler/core/lam_pass_count.mli @@ -25,4 +25,4 @@ type occ_tbl = used_info Hash_ident.t val dummy_info : unit -> used_info -val collect_occurs : Lambda.lambda -> occ_tbl +val collect_occurs : Lambda.t -> occ_tbl diff --git a/compiler/core/lam_pass_deep_flatten.ml b/compiler/core/lam_pass_deep_flatten.ml index bb55519a2a1..d4bdab9e423 100644 --- a/compiler/core/lam_pass_deep_flatten.ml +++ b/compiler/core/lam_pass_deep_flatten.ml @@ -26,7 +26,7 @@ | Not_eliminatable | *) -let rec eliminate_tuple (id : Ident.t) (lam : Lambda.lambda) acc = +let rec eliminate_tuple (id : Ident.t) (lam : Lambda.t) acc = match lam with | Llet (Alias, v, Lprim {primitive = Pfield (i, _); args = [Lvar tuple]}, e2) when Ident.same tuple id -> @@ -100,8 +100,8 @@ let rec eliminate_tuple (id : Ident.t) (lam : Lambda.lambda) acc = - also for function compilation, flattening should be done first - [compile_group] and [compile] become mutually recursive function *) -let lambda_of_groups ~(rev_bindings : Lam_group.t list) (result : Lambda.lambda) - : Lambda.lambda = +let lambda_of_groups ~(rev_bindings : Lam_group.t list) (result : Lambda.t) : + Lambda.t = Ext_list.fold_left rev_bindings result (fun acc x -> match x with | Nop l -> Lambda.seq l acc @@ -114,7 +114,7 @@ let lambda_of_groups ~(rev_bindings : Lam_group.t list) (result : Lambda.lambda) *) (* The shape [let x = in ... in apply f args]: the residue left by beta reduction of an immediately applied function. *) -let rec rhs_is_beta_residue (lam : Lambda.lambda) = +let rec rhs_is_beta_residue (lam : Lambda.t) = match lam with | Llet ( (Alias | Strict | StrictOpt), @@ -128,9 +128,9 @@ let rec rhs_is_beta_residue (lam : Lambda.lambda) = | Lapply _ -> true | _ -> false -let deep_flatten (lam : Lambda.lambda) : Lambda.lambda = - let rec flatten (acc : Lam_group.t list) (lam : Lambda.lambda) : - Lambda.lambda * Lam_group.t list = +let deep_flatten (lam : Lambda.t) : Lambda.t = + let rec flatten (acc : Lam_group.t list) (lam : Lambda.t) : + Lambda.t * Lam_group.t list = match lam with | Llet ( str, @@ -196,7 +196,7 @@ let deep_flatten (lam : Lambda.lambda) : Lambda.lambda = let res, l = flatten acc l in flatten (Lam_group.nop_cons res l) r | x -> (aux x, acc) - and aux (lam : Lambda.lambda) : Lambda.lambda = + and aux (lam : Lambda.t) : Lambda.t = match lam with | Llet _ -> let res, groups = flatten [] lam in diff --git a/compiler/core/lam_pass_deep_flatten.mli b/compiler/core/lam_pass_deep_flatten.mli index e0b06818018..8f88d8983e6 100644 --- a/compiler/core/lam_pass_deep_flatten.mli +++ b/compiler/core/lam_pass_deep_flatten.mli @@ -22,4 +22,4 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val deep_flatten : Lambda.lambda -> Lambda.lambda +val deep_flatten : Lambda.t -> Lambda.t diff --git a/compiler/core/lam_pass_eliminate_ref.ml b/compiler/core/lam_pass_eliminate_ref.ml index 382b663efc1..3830c09072f 100644 --- a/compiler/core/lam_pass_eliminate_ref.ml +++ b/compiler/core/lam_pass_eliminate_ref.ml @@ -13,7 +13,7 @@ exception Real_reference -let rec eliminate_ref id (lam : Lambda.lambda) = +let rec eliminate_ref id (lam : Lambda.t) = match lam with (* we can do better escape analysis in Javascript backend *) | Lvar v -> if Ident.same v id then raise_notrace Real_reference else lam diff --git a/compiler/core/lam_pass_eliminate_ref.mli b/compiler/core/lam_pass_eliminate_ref.mli index 4f9842316dd..7051b64fd6a 100644 --- a/compiler/core/lam_pass_eliminate_ref.mli +++ b/compiler/core/lam_pass_eliminate_ref.mli @@ -24,4 +24,4 @@ exception Real_reference -val eliminate_ref : Ident.t -> Lambda.lambda -> Lambda.lambda +val eliminate_ref : Ident.t -> Lambda.t -> Lambda.t diff --git a/compiler/core/lam_pass_exits.ml b/compiler/core/lam_pass_exits.ml index bf7d228701f..108588c9974 100644 --- a/compiler/core/lam_pass_exits.ml +++ b/compiler/core/lam_pass_exits.ml @@ -21,7 +21,7 @@ *) let rec no_list args = Ext_list.for_all args no_bounded_variables -and no_list_snd : 'a. ('a * Lambda.lambda) list -> bool = +and no_list_snd : 'a. ('a * Lambda.t) list -> bool = fun args -> Ext_list.for_all_snd args no_bounded_variables and no_opt x = @@ -29,7 +29,7 @@ and no_opt x = | None -> true | Some a -> no_bounded_variables a -and no_bounded_variables (l : Lambda.lambda) = +and no_bounded_variables (l : Lambda.t) = match l with | Lvar _ -> true | Lconst _ -> true @@ -82,8 +82,8 @@ and no_bounded_variables (l : Lambda.lambda) = when do the substitution, if its occurence is > 1, we should refresh *) -type lam_subst = Id of Lambda.lambda [@@unboxed] -(* | Refresh of Lambda.lambda *) +type lam_subst = Id of Lambda.t [@@unboxed] +(* | Refresh of Lambda.t *) type subst_tbl = (Ident.t list * lam_subst) Hash_int.t @@ -152,9 +152,9 @@ let to_lam x = the j is not very indicative *) -let subst_helper (subst : subst_tbl) (query : int -> int) (lam : Lambda.lambda) - : Lambda.lambda = - let rec simplif (lam : Lambda.lambda) = +let subst_helper (subst : subst_tbl) (query : int -> int) (lam : Lambda.t) : + Lambda.t = + let rec simplif (lam : Lambda.t) = match lam with | Lstaticcatch (l1, (i, xs), l2) -> ( let i_occur = query i in @@ -246,7 +246,7 @@ let subst_helper (subst : subst_tbl) (query : int -> int) (lam : Lambda.lambda) in simplif lam -let simplify_exits (lam : Lambda.lambda) = +let simplify_exits (lam : Lambda.t) = let exits = Lam_exit_count.count_helper lam in subst_helper (Hash_int.create 17) (Lam_exit_count.count_exit exits) lam diff --git a/compiler/core/lam_pass_exits.mli b/compiler/core/lam_pass_exits.mli index dabeaaa9cac..68c6727454e 100644 --- a/compiler/core/lam_pass_exits.mli +++ b/compiler/core/lam_pass_exits.mli @@ -15,4 +15,4 @@ [simplif] module *) -val simplify_exits : Lambda.lambda -> Lambda.lambda +val simplify_exits : Lambda.t -> Lambda.t diff --git a/compiler/core/lam_pass_guard_raises.ml b/compiler/core/lam_pass_guard_raises.ml index 63376d32f31..1b6f4005f89 100644 --- a/compiler/core/lam_pass_guard_raises.ml +++ b/compiler/core/lam_pass_guard_raises.ml @@ -1,4 +1,4 @@ -let rec guard_raises (lam : Lambda.lambda) : Lambda.lambda = +let rec guard_raises (lam : Lambda.t) : Lambda.t = match lam with | Lifthenelse (a, (Lprim {primitive = Praise} as b), c) -> ( match c with diff --git a/compiler/core/lam_pass_guard_raises.mli b/compiler/core/lam_pass_guard_raises.mli index 047a329607e..f93b8652cb2 100644 --- a/compiler/core/lam_pass_guard_raises.mli +++ b/compiler/core/lam_pass_guard_raises.mli @@ -1,4 +1,4 @@ -val guard_raises : Lambda.lambda -> Lambda.lambda +val guard_raises : Lambda.t -> Lambda.t (** Rewrite [if a then raise e else c] into [(if a then raise e else ()); c], so the continuation stops being nested inside a branch - the guard clause idiom in the emitted JavaScript. diff --git a/compiler/core/lam_pass_lets_dce.ml b/compiler/core/lam_pass_lets_dce.ml index 9184c2ecf27..0012153f06d 100644 --- a/compiler/core/lam_pass_lets_dce.ml +++ b/compiler/core/lam_pass_lets_dce.ml @@ -11,12 +11,12 @@ (***********************************************************************) (* Adapted for Javascript backend : Hongbo Zhang, *) -let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : - Lambda.lambda = - let subst : Lambda.lambda Hash_ident.t = Hash_ident.create 32 in +let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lambda.t + = + let subst : Lambda.t Hash_ident.t = Hash_ident.create 32 in let string_table : string Hash_ident.t = Hash_ident.create 32 in let used v = (count_var v).times > 0 in - let rec simplif (lam : Lambda.lambda) = + let rec simplif (lam : Lambda.t) = match lam with | Lvar v -> Hash_ident.find_default subst v lam | Llet ((Strict | Alias | StrictOpt), v, Lvar w, l2) -> @@ -213,6 +213,6 @@ let apply_lets occ lambda = in lets_helper count_var lambda -let simplify_lets (lam : Lambda.lambda) : Lambda.lambda = +let simplify_lets (lam : Lambda.t) : Lambda.t = let occ = Lam_pass_count.collect_occurs lam in apply_lets occ lam diff --git a/compiler/core/lam_pass_lets_dce.mli b/compiler/core/lam_pass_lets_dce.mli index ef3d9759749..3ad0e5dc5c7 100644 --- a/compiler/core/lam_pass_lets_dce.mli +++ b/compiler/core/lam_pass_lets_dce.mli @@ -11,7 +11,7 @@ (***********************************************************************) (* Adapted for Javascript backend: Hongbo Zhang *) -val simplify_lets : Lambda.lambda -> Lambda.lambda +val simplify_lets : Lambda.t -> Lambda.t (** This pass would do beta reduction, and dead code elimination (adapted from compiler's built-in [Simplif] module ) diff --git a/compiler/core/lam_pass_remove_alias.ml b/compiler/core/lam_pass_remove_alias.ml index ad4f6f3a0ea..4c4a77169ef 100644 --- a/compiler/core/lam_pass_remove_alias.ml +++ b/compiler/core/lam_pass_remove_alias.ml @@ -46,8 +46,8 @@ let is_const_some (cst : Lambda.structured_constant) : bool = | Const_some _ -> true | _ -> false -let simplify_alias (meta : Lam_stats.t) (lam : Lambda.lambda) : Lambda.lambda = - let rec simpl (lam : Lambda.lambda) : Lambda.lambda = +let simplify_alias (meta : Lam_stats.t) (lam : Lambda.t) : Lambda.t = + let rec simpl (lam : Lambda.t) : Lambda.t = match lam with | Lvar _ -> lam (* 7432: prevent optimization in JSX preserve mode *) diff --git a/compiler/core/lam_pass_remove_alias.mli b/compiler/core/lam_pass_remove_alias.mli index 894155830f7..d74162dcb83 100644 --- a/compiler/core/lam_pass_remove_alias.mli +++ b/compiler/core/lam_pass_remove_alias.mli @@ -35,4 +35,4 @@ This pass does not change meta data *) -val simplify_alias : Lam_stats.t -> Lambda.lambda -> Lambda.lambda +val simplify_alias : Lam_stats.t -> Lambda.t -> Lambda.t diff --git a/compiler/core/lam_print.ml b/compiler/core/lam_print.ml index eb11fd22617..df67cdf6119 100644 --- a/compiler/core/lam_print.ml +++ b/compiler/core/lam_print.ml @@ -218,8 +218,7 @@ let to_print_kind (k : Lambda.let_kind) : print_kind = | StrictOpt -> StrictOpt | Variable -> Variable -let rec aux (acc : (print_kind * Ident.t * Lambda.lambda) list) - (lam : Lambda.lambda) = +let rec aux (acc : (print_kind * Ident.t * Lambda.t) list) (lam : Lambda.t) = match lam with | Llet (str3, id3, arg3, body3) -> aux ((to_print_kind str3, id3, arg3) :: acc) body3 @@ -239,8 +238,8 @@ let rec aux (acc : (print_kind * Ident.t * Lambda.lambda) list) | Id of left_var *) (* | Nop *) -let flatten (lam : Lambda.lambda) : - (print_kind * Ident.t * Lambda.lambda) list * Lambda.lambda = +let flatten (lam : Lambda.t) : (print_kind * Ident.t * Lambda.t) list * Lambda.t + = match lam with | Llet (str, id, arg, body) -> aux [(to_print_kind str, id, arg)] body | Lletrec (bind_args, body) -> @@ -248,7 +247,7 @@ let flatten (lam : Lambda.lambda) : | _ -> assert false let lambda ppf v = - let rec lam ppf (l : Lambda.lambda) = + let rec lam ppf (l : Lambda.t) = match l with | Lvar id -> Ident.print ppf id | Lglobal_module id -> fprintf ppf "global %a" Ident.print id @@ -392,7 +391,7 @@ let lambda ppf v = (* let structured_constant = struct_const *) -(* let rec flatten_seq acc (lam : Lambda.lambda) = +(* let rec flatten_seq acc (lam : Lambda.t) = match lam with | Lsequence(l1,l2) -> flatten_seq (flatten_seq acc l1) l2 @@ -400,7 +399,7 @@ let lambda ppf v = (* exception Not_a_module *) -(* let rec flat (acc : (left * Lambda.lambda) list ) (lam : Lambda.lambda) = +(* let rec flat (acc : (left * Lambda.t) list ) (lam : Lambda.t) = match lam with | Llet (str,id,arg,body) -> flat ( (Id {kind = to_print_kind str; id}, arg) :: acc) body @@ -413,7 +412,7 @@ let lambda ppf v = flat (flat acc l) r | x -> (Nop, x) :: acc *) -(* let lambda_as_module env ppf (lam : Lambda.lambda) = +(* let lambda_as_module env ppf (lam : Lambda.t) = try (* match lam with *) (* | Lprim {primitive = Psetglobal id ; args = [biglambda]; _} *) @@ -444,7 +443,7 @@ let lambda ppf v = lambda ppf lam; fprintf ppf "; lambda-failure" *) -let serialize (filename : string) (lam : Lambda.lambda) : unit = +let serialize (filename : string) (lam : Lambda.t) : unit = let ou = open_out filename in let old = Format.get_margin () in let () = Format.set_margin 10000 in diff --git a/compiler/core/lam_print.mli b/compiler/core/lam_print.mli index 8fd4a34ad1a..d5b909f52ef 100644 --- a/compiler/core/lam_print.mli +++ b/compiler/core/lam_print.mli @@ -22,10 +22,10 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val lambda : Format.formatter -> Lambda.lambda -> unit +val lambda : Format.formatter -> Lambda.t -> unit val primitive : Format.formatter -> Lambda.primitive -> unit -val serialize : string -> Lambda.lambda -> unit +val serialize : string -> Lambda.t -> unit -val lambda_to_string : Lambda.lambda -> string +val lambda_to_string : Lambda.t -> string diff --git a/compiler/core/lam_stats_export.ml b/compiler/core/lam_stats_export.ml index 8ecbf087238..7f04c5abd18 100644 --- a/compiler/core/lam_stats_export.ml +++ b/compiler/core/lam_stats_export.ml @@ -26,8 +26,7 @@ let single_na = Js_cmj_format.single_na -let values_of_export (meta : Lam_stats.t) - (export_map : Lambda.lambda Map_ident.t) : +let values_of_export (meta : Lam_stats.t) (export_map : Lambda.t Map_ident.t) : Js_cmj_format.cmj_value Map_string.t = Ext_list.fold_left meta.exports Map_string.empty (fun acc x -> let arity : Js_cmj_format.arity = diff --git a/compiler/core/lam_stats_export.mli b/compiler/core/lam_stats_export.mli index 999f6b84b89..ba0238adb5f 100644 --- a/compiler/core/lam_stats_export.mli +++ b/compiler/core/lam_stats_export.mli @@ -28,7 +28,7 @@ val get_dependent_module_effect : val export_to_cmj : Lam_stats.t -> Js_cmj_format.effect_ -> - Lambda.lambda Map_ident.t -> + Lambda.t Map_ident.t -> Js_cmj_format.hoisted_export list -> Ext_js_file_kind.case -> Js_cmj_format.t diff --git a/compiler/core/lam_util.ml b/compiler/core/lam_util.ml index 06bafc803dd..56d22841725 100644 --- a/compiler/core/lam_util.ml +++ b/compiler/core/lam_util.ml @@ -55,8 +55,7 @@ let add_required_modules ( x : Ident.t list) (meta : Lam_stats.t) = Falling through keeps the original binding. Only the Alias clause changes evaluation strategy downstream, so we keep its predicate intentionally syntactic and narrow. *) -let refine_let ~kind param (arg : Lambda.lambda) (l : Lambda.lambda) : - Lambda.lambda = +let refine_let ~kind param (arg : Lambda.t) (l : Lambda.t) : Lambda.t = let is_block_constructor = function | Lambda.Pmakeblock _ -> true | _ -> false @@ -67,7 +66,7 @@ let refine_let ~kind param (arg : Lambda.lambda) (l : Lambda.lambda) : to inline [e] at every use site or drop `const x = e` entirely, so every clause below must ensure that duplicate evaluation of [e] is equivalent to the single eager evaluation promised by [Strict]/[StrictOpt]. *) - let rec is_safe_to_alias (lam : Lambda.lambda) = + let rec is_safe_to_alias (lam : Lambda.t) = match lam with | Lvar _ | Lconst _ -> (* var/const --> emitting multiple `const` reads is identical to the @@ -174,7 +173,7 @@ let alias_ident_or_global (meta : Lam_stats.t) (k : Ident.t) (v : Ident.t) mutable fields are explicit, since wen can not inline an mutable block access *) -let element_of_lambda (lam : Lambda.lambda) : Lam_id_kind.element = +let element_of_lambda (lam : Lambda.t) : Lam_id_kind.element = match lam with | Lvar _ | Lconst _ | Lprim @@ -187,11 +186,11 @@ let element_of_lambda (lam : Lambda.lambda) : Lam_id_kind.element = (* | Lfunction _ *) | _ -> NA -let kind_of_lambda_block (xs : Lambda.lambda list) : Lam_id_kind.t = +let kind_of_lambda_block (xs : Lambda.t list) : Lam_id_kind.t = ImmutableBlock (Ext_array.of_list_map xs (fun x -> element_of_lambda x)) -let field_flatten_get lam v i info (tbl : Lam_id_kind.t Hash_ident.t) : - Lambda.lambda = +let field_flatten_get lam v i info (tbl : Lam_id_kind.t Hash_ident.t) : Lambda.t + = match Hash_ident.find_opt tbl v with | Some (Module g) -> Lambda.prim @@ -221,17 +220,17 @@ let field_flatten_get lam v i info (tbl : Lam_id_kind.t Hash_ident.t) : | Some _ -> lam ()) | Some _ | None -> lam () -let is_function (lam : Lambda.lambda) = +let is_function (lam : Lambda.t) = match lam with | Lfunction _ -> true | _ -> false -let not_function (lam : Lambda.lambda) = +let not_function (lam : Lambda.t) = match lam with | Lfunction _ -> false | _ -> true (* -let is_var (lam : Lambda.lambda) id = +let is_var (lam : Lambda.t) id = match lam with | Lvar id0 -> Ident.same id0 id | _ -> false *) diff --git a/compiler/core/lam_util.mli b/compiler/core/lam_util.mli index 286c24b96d4..690d6d35eb6 100644 --- a/compiler/core/lam_util.mli +++ b/compiler/core/lam_util.mli @@ -22,15 +22,15 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val kind_of_lambda_block : Lambda.lambda list -> Lam_id_kind.t +val kind_of_lambda_block : Lambda.t list -> Lam_id_kind.t val field_flatten_get : - (unit -> Lambda.lambda) -> + (unit -> Lambda.t) -> Ident.t -> int -> Lambda.field_dbg_info -> Lam_stats.ident_tbl -> - Lambda.lambda + Lambda.t (** [field_flattern_get cb v i tbl] try to remove the indirection of [v.(i)] by inlining when [v] is a known block, @@ -53,12 +53,8 @@ val alias_ident_or_global : Lam_stats.t -> Ident.t -> Ident.t -> Lam_id_kind.t -> unit val refine_let : - kind:Lambda.let_kind -> - Ident.t -> - Lambda.lambda -> - Lambda.lambda -> - Lambda.lambda + kind:Lambda.let_kind -> Ident.t -> Lambda.t -> Lambda.t -> Lambda.t -val not_function : Lambda.lambda -> bool +val not_function : Lambda.t -> bool -val is_function : Lambda.lambda -> bool +val is_function : Lambda.t -> bool diff --git a/compiler/core/lam_var_stats.mli b/compiler/core/lam_var_stats.mli index dcfc21be900..3761d597d9b 100644 --- a/compiler/core/lam_var_stats.mli +++ b/compiler/core/lam_var_stats.mli @@ -34,7 +34,7 @@ val sink : position val fresh_env : position -val new_position_after_lam : Lambda.lambda -> position -> position +val new_position_after_lam : Lambda.t -> position -> position val update : stats -> position -> stats (** The variable used stats update depend diff --git a/compiler/core/polyvar_pattern_match.ml b/compiler/core/polyvar_pattern_match.ml index 0e41f32eccc..9f342084671 100644 --- a/compiler/core/polyvar_pattern_match.ml +++ b/compiler/core/polyvar_pattern_match.ml @@ -22,7 +22,7 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type lam = Lambda.lambda +type lam = Lambda.t type hash_names = (int * string) list diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index 3e119510597..e0401859696 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -367,7 +367,7 @@ type function_attribute = { one_unit_arg: bool; } -type lambda = +type t = | Lvar of Ident.t | Lglobal_module of Ident.t (** A reference to another compilation unit: a name the module system @@ -375,38 +375,38 @@ type lambda = | Lconst of structured_constant | Lapply of lambda_apply | Lfunction of lfunction - | Llet of let_kind * Ident.t * lambda * lambda - | Lletrec of (Ident.t * lambda) list * lambda + | Llet of let_kind * Ident.t * t * t + | Lletrec of (Ident.t * t) list * t | Lprim of prim_info - | Lswitch of lambda * lambda_switch - | Lstringswitch of lambda * (string * lambda) list * lambda option - | Lstaticraise of int * lambda list - | Lstaticcatch of lambda * (int * Ident.t list) * lambda - | Ltrywith of lambda * Ident.t * lambda - | Lifthenelse of lambda * lambda * lambda - | Lsequence of lambda * lambda + | Lswitch of t * lambda_switch + | Lstringswitch of t * (string * t) list * t option + | Lstaticraise of int * t list + | Lstaticcatch of t * (int * Ident.t list) * t + | Ltrywith of t * Ident.t * t + | Lifthenelse of t * t * t + | Lsequence of t * t | Lbreak | Lcontinue - | Lwhile of lambda * lambda - | Lfor of Ident.t * lambda * lambda * Asttypes.direction_flag * lambda - | Lfor_of of Ident.t * lambda * lambda - | Lfor_await_of of Ident.t * lambda * lambda - | Lassign of Ident.t * lambda + | Lwhile of t * t + | Lfor of Ident.t * t * t * Asttypes.direction_flag * t + | Lfor_of of Ident.t * t * t + | Lfor_await_of of Ident.t * t * t + | Lassign of Ident.t * t and lfunction = { params: Ident.t list; - body: lambda; + body: t; attr: function_attribute; (* specified with [@inline] attribute *) loc: Location.t; } -and prim_info = {primitive: primitive; args: lambda list; loc: Location.t} +and prim_info = {primitive: primitive; args: t list; loc: Location.t} and ap_info = {ap_loc: Location.t; ap_inlined: inline_attribute} and lambda_apply = { - ap_func: lambda; - ap_args: lambda list; + ap_func: t; + ap_args: t list; ap_info: ap_info; ap_transformed_jsx: bool; } @@ -428,7 +428,7 @@ and 'a switch = { sw_dispatch: switch_dispatch; } -and lambda_switch = lambda switch +and lambda_switch = t switch (* This is actually a dummy value not necessary "()", it can be used as a place holder for module @@ -718,28 +718,27 @@ let cmp_float (cmp : comparison) (a : float) b : bool = Lambda.prim / Lambda.if_ / Lambda.switch perform will move here when the two layers become one type. *) -let var id : lambda = Lvar id -let global_module id : lambda = Lglobal_module id -let const ct : lambda = Lconst ct +let var id : t = Lvar id +let global_module id : t = Lglobal_module id +let const ct : t = Lconst ct -let function_ ~loc ~attr ~params ~body : lambda = - Lfunction {params; body; attr; loc} +let function_ ~loc ~attr ~params ~body : t = Lfunction {params; body; attr; loc} -let let_ kind id e body : lambda = Llet (kind, id, e, body) -let letrec bindings body : lambda = Lletrec (bindings, body) +let let_ kind id e body : t = Llet (kind, id, e, body) +let letrec bindings body : t = Lletrec (bindings, body) -let staticraise i args : lambda = Lstaticraise (i, args) -let staticcatch body catch handler : lambda = Lstaticcatch (body, catch, handler) -let try_ body id handler : lambda = Ltrywith (body, id, handler) -let break : lambda = Lbreak -let continue : lambda = Lcontinue -let while_ cond body : lambda = Lwhile (cond, body) -let for_ id from_ to_ dir body : lambda = Lfor (id, from_, to_, dir, body) -let for_of id iterable body : lambda = Lfor_of (id, iterable, body) +let staticraise i args : t = Lstaticraise (i, args) +let staticcatch body catch handler : t = Lstaticcatch (body, catch, handler) +let try_ body id handler : t = Ltrywith (body, id, handler) +let break : t = Lbreak +let continue : t = Lcontinue +let while_ cond body : t = Lwhile (cond, body) +let for_ id from_ to_ dir body : t = Lfor (id, from_, to_, dir, body) +let for_of id iterable body : t = Lfor_of (id, iterable, body) -let for_await_of id iterable body : lambda = Lfor_await_of (id, iterable, body) +let for_await_of id iterable body : t = Lfor_await_of (id, iterable, body) -let assign id body : lambda = Lassign (id, body) +let assign id body : t = Lassign (id, body) exception Not_simple_form @@ -760,15 +759,14 @@ exception Not_simple_form is applied though since `[@variadic]` needs such guarantee. Since `[@variadic] is the tail position *) -let rec is_eta_conversion_exn params inner_args outer_args : lambda list = +let rec is_eta_conversion_exn params inner_args outer_args : t list = match (params, inner_args, outer_args) with | x :: xs, Lvar y :: ys, r :: rest when Ident.same x y -> r :: is_eta_conversion_exn xs ys rest | [], [], [] -> [] | _, _, _ -> raise_notrace Not_simple_form -let rec apply ?(ap_transformed_jsx = false) fn args (ap_info : ap_info) : lambda - = +let rec apply ?(ap_transformed_jsx = false) fn args (ap_info : ap_info) : t = match fn with | Lfunction { @@ -823,7 +821,7 @@ let rec apply ?(ap_transformed_jsx = false) fn args (ap_info : ap_info) : lambda Llet(kind0,id0,e0,Llet (kind, id, e, apply fn args loc status)) *) | _ -> Lapply {ap_func = fn; ap_args = args; ap_info; ap_transformed_jsx} -let rec eq_approx (l1 : lambda) (l2 : lambda) = +let rec eq_approx (l1 : t) (l2 : t) = match l1 with | Lglobal_module i1 -> ( match l2 with @@ -897,7 +895,7 @@ and eq_option l1 l2 = and eq_approx_list ls ls1 = Ext_list.for_all2_no_exn ls ls1 eq_approx -let switch lam (lam_switch : lambda_switch) : lambda = +let switch lam (lam_switch : lambda_switch) : t = let action_or_switch = function | Some action -> action | None -> ( @@ -949,13 +947,13 @@ let switch lam (lam_switch : lambda_switch) : lambda = action_or_switch action | _ -> Lswitch (lam, lam_switch) -let stringswitch (lam : lambda) cases default : lambda = +let stringswitch (lam : t) cases default : t = match lam with | Lconst (Const_string {s; delim = None | Some DNoQuotes}) -> Ext_list.assoc_by_string cases s default | _ -> Lstringswitch (lam, cases, default) -let rec seq (a : lambda) b : lambda = +let rec seq (a : t) b : t = match a with | Lprim {primitive = Pmakeblock _; args = x :: xs} -> seq (Ext_list.fold_left xs x seq) b @@ -964,17 +962,17 @@ let rec seq (a : lambda) b : lambda = | _ -> Lsequence (a, b) module Lift = struct - let int i : lambda = Lconst (Const_int i) + let int i : t = Lconst (Const_int i) let bool b = if b then lambda_true else lambda_false - let string s : lambda = Lconst (Const_string {s; delim = None}) + let string s : t = Lconst (Const_string {s; delim = None}) - let char b : lambda = Lconst (Const_char b) + let char b : t = Lconst (Const_char b) end -let prim ~primitive:(prim : primitive) ~args loc : lambda = - let default () : lambda = Lprim {primitive = prim; args; loc} in +let prim ~primitive:(prim : primitive) ~args loc : t = + let default () : t = Lprim {primitive = prim; args; loc} in match args with | [Lconst a] -> ( match (prim, a) with @@ -1084,13 +1082,13 @@ let prim ~primitive:(prim : primitive) ~args loc : lambda = *) | _ -> default ()) -let not_ loc x : lambda = +let not_ loc x : t = match x with | Lprim ({primitive = Pintcomp Cneq} as prim) -> Lprim {prim with primitive = Pintcomp Ceq} | _ -> prim ~primitive:Pnot ~args:[x] loc -let has_boolean_type (x : lambda) = +let has_boolean_type (x : t) = match x with | Lprim { @@ -1124,7 +1122,7 @@ let rec eval_const_as_bool (v : structured_constant) : bool option = | Some Null | Some Undefined -> Some false | Some (Float _ | BigInt _ | Untagged _) -> None) -let if_ (a : lambda) (b : lambda) (c : lambda) : lambda = +let if_ (a : t) (b : t) (c : t) : t = match a with | Lconst v -> ( match eval_const_as_bool v with @@ -1189,7 +1187,7 @@ let if_ (a : lambda) (b : lambda) (c : lambda) : lambda = and rebuilds the node through its smart constructor, so the result is normalized. A node whose children all come back physically unchanged is returned as-is, so a traversal that rewrites nothing allocates nothing. *) -let shallow_map_sharing (f : lambda -> lambda) (lam : lambda) : lambda = +let shallow_map_sharing (f : t -> t) (lam : t) : t = match lam with | Lvar _ | Lglobal_module _ | Lconst _ | Lbreak | Lcontinue -> lam | Lapply ap -> @@ -1381,7 +1379,7 @@ let name_lambda strict arg fn = Llet (strict, id, arg, fn id) (* Does any immediate child satisfy [f]? Short-circuits. *) -let shallow_exists (f : lambda -> bool) (lam : lambda) : bool = +let shallow_exists (f : t -> bool) (lam : t) : bool = match lam with | Lvar _ | Lglobal_module _ | Lconst _ | Lbreak | Lcontinue -> false | Lapply {ap_func; ap_args} -> f ap_func || Ext_list.exists ap_args f diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index 74551579d11..5257fcf1dcb 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -337,7 +337,7 @@ type function_attribute = { one_unit_arg: bool; } -type lambda = private +type t = private | Lvar of Ident.t | Lglobal_module of Ident.t (** A reference to another compilation unit: a name the module system @@ -345,38 +345,34 @@ type lambda = private | Lconst of structured_constant | Lapply of lambda_apply | Lfunction of lfunction - | Llet of let_kind * Ident.t * lambda * lambda - | Lletrec of (Ident.t * lambda) list * lambda + | Llet of let_kind * Ident.t * t * t + | Lletrec of (Ident.t * t) list * t | Lprim of prim_info - | Lswitch of lambda * lambda_switch + | Lswitch of t * lambda_switch (* switch on strings, clauses are sorted by string order, strings are pairwise distinct *) - | Lstringswitch of lambda * (string * lambda) list * lambda option - | Lstaticraise of int * lambda list - | Lstaticcatch of lambda * (int * Ident.t list) * lambda - | Ltrywith of lambda * Ident.t * lambda - | Lifthenelse of lambda * lambda * lambda - | Lsequence of lambda * lambda + | Lstringswitch of t * (string * t) list * t option + | Lstaticraise of int * t list + | Lstaticcatch of t * (int * Ident.t list) * t + | Ltrywith of t * Ident.t * t + | Lifthenelse of t * t * t + | Lsequence of t * t | Lbreak | Lcontinue - | Lwhile of lambda * lambda - | Lfor of Ident.t * lambda * lambda * direction_flag * lambda - | Lfor_of of Ident.t * lambda * lambda - | Lfor_await_of of Ident.t * lambda * lambda - | Lassign of Ident.t * lambda + | Lwhile of t * t + | Lfor of Ident.t * t * t * direction_flag * t + | Lfor_of of Ident.t * t * t + | Lfor_await_of of Ident.t * t * t + | Lassign of Ident.t * t and lfunction = { params: Ident.t list; - body: lambda; + body: t; attr: function_attribute; (* specified with [@inline] attribute *) loc: Location.t; } -and prim_info = private { - primitive: primitive; - args: lambda list; - loc: Location.t; -} +and prim_info = private {primitive: primitive; args: t list; loc: Location.t} and ap_info = { ap_loc: Location.t; @@ -384,8 +380,8 @@ and ap_info = { } and lambda_apply = private { - ap_func: lambda; - ap_args: lambda list; + ap_func: t; + ap_args: t list; ap_info: ap_info; ap_transformed_jsx: bool; } @@ -407,7 +403,7 @@ and 'a switch = { sw_dispatch: switch_dispatch; } -and lambda_switch = lambda switch +and lambda_switch = t switch (* Lambda code for the middle-end. * In the closure case the code is a sequence of assignments to a @@ -422,7 +418,7 @@ and lambda_switch = lambda switch *) (* Sharing key *) -val make_key : lambda -> lambda option +val make_key : t -> t option val const_int : int -> structured_constant val const_string : string -> string option -> structured_constant @@ -433,8 +429,8 @@ val const_shape_none : structured_constant val const_polyvar : string -> structured_constant val const_polyvar_name : string -> structured_constant val const_module_alias : structured_constant -val lambda_assert_false : lambda -val lambda_unit : lambda +val lambda_assert_false : t +val lambda_unit : t val eq_primitive_approx : primitive -> primitive -> bool @@ -452,7 +448,7 @@ val cmp_int32 : comparison -> int32 -> int32 -> bool val cmp_float : comparison -> float -> float -> bool -(* Constructors. [lambda] is private, so every term outside this module is +(* Constructors. [t] is private, so every term outside this module is built through one of these. Most are plain wrappers. Six normalize as they build, and are the only @@ -476,95 +472,94 @@ val cmp_float : comparison -> float -> float -> bool means during the optimizer's passes rather than at production: the frontend has no constants in operand position yet. *) -val var : Ident.t -> lambda +val var : Ident.t -> t -val global_module : Ident.t -> lambda +val global_module : Ident.t -> t -val const : structured_constant -> lambda +val const : structured_constant -> t -val apply : - ?ap_transformed_jsx:bool -> lambda -> lambda list -> ap_info -> lambda +val apply : ?ap_transformed_jsx:bool -> t -> t list -> ap_info -> t val function_ : loc:Location.t -> attr:function_attribute -> params:Ident.t list -> - body:lambda -> - lambda + body:t -> + t -val let_ : let_kind -> Ident.t -> lambda -> lambda -> lambda +val let_ : let_kind -> Ident.t -> t -> t -> t -val letrec : (Ident.t * lambda) list -> lambda -> lambda +val letrec : (Ident.t * t) list -> t -> t -val prim : primitive:primitive -> args:lambda list -> Location.t -> lambda +val prim : primitive:primitive -> args:t list -> Location.t -> t -val switch : lambda -> lambda_switch -> lambda +val switch : t -> lambda_switch -> t -val stringswitch : lambda -> (string * lambda) list -> lambda option -> lambda +val stringswitch : t -> (string * t) list -> t option -> t -val staticraise : int -> lambda list -> lambda +val staticraise : int -> t list -> t -val staticcatch : lambda -> int * Ident.t list -> lambda -> lambda +val staticcatch : t -> int * Ident.t list -> t -> t -val try_ : lambda -> Ident.t -> lambda -> lambda +val try_ : t -> Ident.t -> t -> t -val if_ : lambda -> lambda -> lambda -> lambda +val if_ : t -> t -> t -> t -val seq : lambda -> lambda -> lambda +val seq : t -> t -> t -val break : lambda +val break : t -val continue : lambda +val continue : t -val while_ : lambda -> lambda -> lambda +val while_ : t -> t -> t -val for_ : Ident.t -> lambda -> lambda -> direction_flag -> lambda -> lambda +val for_ : Ident.t -> t -> t -> direction_flag -> t -> t -val for_of : Ident.t -> lambda -> lambda -> lambda +val for_of : Ident.t -> t -> t -> t -val for_await_of : Ident.t -> lambda -> lambda -> lambda +val for_await_of : Ident.t -> t -> t -> t -val assign : Ident.t -> lambda -> lambda +val assign : Ident.t -> t -> t -val not_ : Location.t -> lambda -> lambda +val not_ : Location.t -> t -> t -val sequor : lambda -> lambda -> lambda +val sequor : t -> t -> t -val sequand : lambda -> lambda -> lambda +val sequand : t -> t -> t -val lambda_true : lambda +val lambda_true : t -val lambda_false : lambda +val lambda_false : t -val shallow_map_sharing : (lambda -> lambda) -> lambda -> lambda +val shallow_map_sharing : (t -> t) -> t -> t (** Rewrite a node's immediate children, rebuilding through the constructors so the result is normalized. A node whose children are all physically unchanged is returned as-is, so a traversal that rewrites nothing allocates nothing. *) -val eq_approx : lambda -> lambda -> bool +val eq_approx : t -> t -> bool -val mk_builtin : builtin -> lambda list -> Location.t -> lambda +val mk_builtin : builtin -> t list -> Location.t -> t (** Expands the non-[Primitive] builtins, which have no IR form. *) -val lambda_module_alias : lambda -val name_lambda : let_kind -> lambda -> (Ident.t -> lambda) -> lambda +val lambda_module_alias : t +val name_lambda : let_kind -> t -> (Ident.t -> t) -> t -val shallow_exists : (lambda -> bool) -> lambda -> bool +val shallow_exists : (t -> bool) -> t -> bool (** Does any immediate child satisfy the predicate? Short-circuits. *) -val iter : (lambda -> unit) -> lambda -> unit +val iter : (t -> unit) -> t -> unit module Ident_set : Set.S with type elt = Ident.t -val free_variables : lambda -> Ident_set.t +val free_variables : t -> Ident_set.t -val transl_normal_path : Path.t -> lambda (* Path.t is already normal *) +val transl_normal_path : Path.t -> t (* Path.t is already normal *) -val transl_module_path : ?loc:Location.t -> Env.t -> Path.t -> lambda -val transl_value_path : ?loc:Location.t -> Env.t -> Path.t -> lambda -val transl_extension_path : ?loc:Location.t -> Env.t -> Path.t -> lambda +val transl_module_path : ?loc:Location.t -> Env.t -> Path.t -> t +val transl_value_path : ?loc:Location.t -> Env.t -> Path.t -> t +val transl_extension_path : ?loc:Location.t -> Env.t -> Path.t -> t -val subst_lambda : lambda Ident.tbl -> lambda -> lambda -val bind : let_kind -> Ident.t -> lambda -> lambda -> lambda +val subst_lambda : t Ident.tbl -> t -> t +val bind : let_kind -> Ident.t -> t -> t -> t val default_function_attribute : function_attribute @@ -575,20 +570,20 @@ val default_function_attribute : function_attribute (* Get a new static failure ident *) val next_raise_count : unit -> int -val make_exit : int -> lambda +val make_exit : int -> t -val as_simple_exit : lambda -> int option +val as_simple_exit : t -> int option (* Exit number to raise to, and a wrapper that puts the catch around a body. *) -val make_catch_delayed : lambda -> int * (lambda -> lambda) +val make_catch_delayed : t -> int * (t -> t) val next_negative_raise_count : unit -> int (* Negative raise counts are used to compile 'match ... with exception x -> ...'. This disabled some simplifications performed by the Simplif module that assume that static raises are in tail position in their handler. *) -val staticfail : lambda (* Anticipated static failure *) +val staticfail : t (* Anticipated static failure *) (* Check anticipated failure, substitute its final value *) -val is_guarded : lambda -> bool -val patch_guarded : lambda -> lambda -> lambda +val is_guarded : t -> bool +val patch_guarded : t -> t -> t diff --git a/compiler/ml/lambda_scc.ml b/compiler/ml/lambda_scc.ml index 2c91bf3e840..8050f6f90bf 100644 --- a/compiler/ml/lambda_scc.ml +++ b/compiler/ml/lambda_scc.ml @@ -24,17 +24,17 @@ open Lambda -type bindings = (Ident.t * lambda) list +type bindings = (Ident.t * Lambda.t) list (* [p] may have side effects (masking). Returning true stops the walk. *) -let exists_var (p : Ident.t -> bool) (l : lambda) : bool = +let exists_var (p : Ident.t -> bool) (l : Lambda.t) : bool = let rec hit_opt = function | None -> false | Some a -> hit a - and hit_list_snd : 'a. ('a * lambda) list -> bool = + and hit_list_snd : 'a. ('a * Lambda.t) list -> bool = fun x -> Ext_list.exists_snd x hit and hit_list xs = Ext_list.exists xs hit - and hit (l : lambda) = + and hit (l : Lambda.t) = match l with | Lvar id -> p id | Lassign (id, e) -> p id || hit e @@ -85,7 +85,7 @@ let preprocess_deps (groups : bindings) : _ * Ident.t array * Vec_int.t array = Vec_int.push base_key key)); (domain, int_mapping, node_vec) -let bind_rec (groups : bindings) (body : lambda) : lambda = +let bind_rec (groups : bindings) (body : Lambda.t) : Lambda.t = match groups with | [(id, bind)] -> if exists_var (Ident.same id) bind then letrec groups body diff --git a/compiler/ml/lambda_scc.mli b/compiler/ml/lambda_scc.mli index b38dc9b6ae0..ed21031d55d 100644 --- a/compiler/ml/lambda_scc.mli +++ b/compiler/ml/lambda_scc.mli @@ -22,6 +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 bind_rec : (Ident.t * Lambda.lambda) list -> Lambda.lambda -> Lambda.lambda +val bind_rec : (Ident.t * Lambda.t) list -> Lambda.t -> Lambda.t (** Split a syntactic [let rec] group into the actual recursive clusters and demote bindings that are not recursive. *) diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index 9ba2a73c1d7..01fec12f2d7 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -346,8 +346,8 @@ let jumps_map f env = List.map (fun (i, pss) -> (i, f pss)) env (* Pattern matching before any compilation *) type pattern_matching = { - mutable cases: (pattern list * lambda) list; - args: (lambda * let_kind) list; + mutable cases: (pattern list * Lambda.t) list; + args: (Lambda.t * let_kind) list; default: (matrix * int) list; } @@ -365,7 +365,7 @@ type pm_half_compiled = | PmVar of pm_var_compiled | Pm of pattern_matching -and pm_var_compiled = {inside: pm_half_compiled; var_arg: lambda} +and pm_var_compiled = {inside: pm_half_compiled; var_arg: Lambda.t} type pm_half_compiled_info = { me: pm_half_compiled; @@ -440,8 +440,8 @@ let pretty_precompiled_res first nexts = *) module Store_exp = Switch.Store (struct - type t = lambda - type key = lambda + type t = Lambda.t + type key = Lambda.t let compare_key = compare let make_key = Lambda.make_key end) @@ -1981,16 +1981,16 @@ let constructor_switch_key (cstr : Types.constructor_description) = type payload_presence_test = Is_present_option | Is_nonempty_list type constructor_matching_plan = - | Use_constructor_action of Lambda.lambda + | Use_constructor_action of Lambda.t (** Every possible constructor reaches the same action. *) | Test_payload_presence of { test: payload_presence_test; - absent: Lambda.lambda; - present: Lambda.lambda; + absent: Lambda.t; + present: Lambda.t; } (** A two-constructor representation whose runtime value directly reveals whether the payload constructor is present. *) - | Test_boolean_value of {if_false: Lambda.lambda; if_true: Lambda.lambda} + | Test_boolean_value of {if_false: Lambda.t; if_true: Lambda.t} (** The predefined boolean constructors are JavaScript booleans. *) | Switch_on_constructors of Lambda.lambda_switch (** General nominal and untagged variant matching. *) @@ -2144,27 +2144,27 @@ let call_switcher_variant_constr loc fail arg int_lambda_list = (List.map (fun (a, (_, c)) -> (a, c)) int_lambda_list)) let call_switcher_variant_constant : - (Lambda.lambda option -> - Lambda.lambda -> - (int * (string * Lambda.lambda)) list -> - Lambda.lambda) + (Lambda.t option -> + Lambda.t -> + (int * (string * Lambda.t)) list -> + Lambda.t) ref = ref call_switcher_variant_constant let call_switcher_variant_constr : (Location.t -> - Lambda.lambda option -> - Lambda.lambda -> - (int * (string * Lambda.lambda)) list -> - Lambda.lambda) + Lambda.t option -> + Lambda.t -> + (int * (string * Lambda.t)) list -> + Lambda.t) ref = ref call_switcher_variant_constr let make_test_sequence_variant_constant : - (Lambda.lambda option -> - Lambda.lambda -> - (int * (string * Lambda.lambda)) list -> - Lambda.lambda) + (Lambda.t option -> + Lambda.t -> + (int * (string * Lambda.t)) list -> + Lambda.t) ref = ref make_test_sequence_variant_constant diff --git a/compiler/ml/matching.mli b/compiler/ml/matching.mli index 3bfe53d7e39..0f34a422fb3 100644 --- a/compiler/ml/matching.mli +++ b/compiler/ml/matching.mli @@ -16,42 +16,39 @@ (* Compilation of pattern-matching *) open Typedtree -open Lambda val call_switcher_variant_constant : - (Lambda.lambda option -> - Lambda.lambda -> - (int * (string * Lambda.lambda)) list -> - Lambda.lambda) + (Lambda.t option -> Lambda.t -> (int * (string * Lambda.t)) list -> Lambda.t) ref val call_switcher_variant_constr : (Location.t -> - Lambda.lambda option -> - Lambda.lambda -> - (int * (string * Lambda.lambda)) list -> - Lambda.lambda) + Lambda.t option -> + Lambda.t -> + (int * (string * Lambda.t)) list -> + Lambda.t) ref val make_test_sequence_variant_constant : - (Lambda.lambda option -> - Lambda.lambda -> - (int * (string * Lambda.lambda)) list -> - Lambda.lambda) + (Lambda.t option -> Lambda.t -> (int * (string * Lambda.t)) list -> Lambda.t) ref (* Entry points to match compiler *) val for_function : Location.t -> int ref option -> - lambda -> - (pattern * lambda) list -> + Lambda.t -> + (pattern * Lambda.t) list -> partial -> - lambda -val for_trywith : lambda -> (pattern * lambda) list -> lambda -val for_let : Location.t -> lambda -> pattern -> lambda -> lambda + Lambda.t +val for_trywith : Lambda.t -> (pattern * Lambda.t) list -> Lambda.t +val for_let : Location.t -> Lambda.t -> pattern -> Lambda.t -> Lambda.t val for_multiple_match : - Location.t -> lambda list -> (pattern * lambda) list -> partial -> lambda + Location.t -> + Lambda.t list -> + (pattern * Lambda.t) list -> + partial -> + Lambda.t exception Cannot_flatten diff --git a/compiler/ml/printlambda.mli b/compiler/ml/printlambda.mli index d20fa3ece0f..86f226c760f 100644 --- a/compiler/ml/printlambda.mli +++ b/compiler/ml/printlambda.mli @@ -18,4 +18,4 @@ open Lambda open Format val structured_constant : formatter -> structured_constant -> unit -val lambda : formatter -> lambda -> unit +val lambda : formatter -> Lambda.t -> unit diff --git a/compiler/ml/switch.ml b/compiler/ml/switch.ml index 839a061c361..714a030eb8d 100644 --- a/compiler/ml/switch.ml +++ b/compiler/ml/switch.ml @@ -99,11 +99,11 @@ let ltint = Pintcomp Clt let geint = Pintcomp Cge let gtint = Pintcomp Cgt -let prim p args : lambda = prim ~primitive:p ~args Location.none +let prim p args : Lambda.t = prim ~primitive:p ~args Location.none (* [covers_range cases ~start ~finish] holds when [cases] is exactly the contiguous integer keys [start .. finish], in order. *) -let rec covers_range (cases : (switch_key * lambda) list) ~start ~finish = +let rec covers_range (cases : (switch_key * Lambda.t) list) ~start ~finish = match cases with | [] -> finish < start | (Switch_int i, _) :: rest -> @@ -141,7 +141,7 @@ let emit_if_in ~offset ~range arg ifso ifno = let lo = -offset and hi = range - offset in if_ (prim Pnot [out_of_range arg ~lo ~hi]) ifso ifno -let emit_switch arg cases acts ~offset : lambda = +let emit_switch arg cases acts ~offset : Lambda.t = let l = ref [] in for i = Array.length cases - 1 downto 0 do l := (Switch_int (offset + i), acts.(cases.(i))) :: !l @@ -179,10 +179,10 @@ let emit_switch arg cases acts ~offset : lambda = *) (* [actions] is instantiated both at [lambda] (the original actions) and at - [t_ctx -> lambda] (cluster actions, which still need a context). *) + [t_ctx -> Lambda.t] (cluster actions, which still need a context). *) type 'a inter = {cases: (int * int * int) array; actions: 'a array} -type t_ctx = {off: int; arg: lambda} +type t_ctx = {off: int; arg: Lambda.t} let cut = ref 8 diff --git a/compiler/ml/switch.mli b/compiler/ml/switch.mli index 1bf69e9fe39..3bac8c7eaef 100644 --- a/compiler/ml/switch.mli +++ b/compiler/ml/switch.mli @@ -60,13 +60,10 @@ end *) val zyva : int * int -> - Lambda.lambda -> + Lambda.t -> (int * int * int) array -> - Lambda.lambda t_store -> - Lambda.lambda + Lambda.t t_store -> + Lambda.t val test_sequence : - Lambda.lambda -> - (int * int * int) array -> - Lambda.lambda t_store -> - Lambda.lambda + Lambda.t -> (int * int * int) array -> Lambda.t t_store -> Lambda.t diff --git a/compiler/ml/transl_recmodule.ml b/compiler/ml/transl_recmodule.ml index f75b7a925d8..b3c41ab3eb5 100644 --- a/compiler/ml/transl_recmodule.ml +++ b/compiler/ml/transl_recmodule.ml @@ -113,7 +113,7 @@ let reorder_rec_bindings bindings = done; List.rev !res -type t = Lambda.lambda +type t = Lambda.t (* Utilities for compiling "module rec" definitions *) @@ -126,7 +126,7 @@ type binding = Ident.t * (loc * shape) option * t (* A shape with no fields: the module has nothing to initialize and nothing to patch, so the runtime dummy and its update are both pointless. The right hand side still has to run for its effects. *) -let shape_is_empty (shape : Lambda.lambda) = +let shape_is_empty (shape : Lambda.t) = match shape with | Lambda.Lconst (Const_block (_, [Const_block (_, [])])) -> true | _ -> false @@ -169,7 +169,7 @@ let eval_rec_bindings_aux (bindings : binding list) (cont : t) : t = if the module creation is just a set of function declarations and consts, it is good *) -let rec is_function_or_const_block (lam : Lambda.lambda) acc = +let rec is_function_or_const_block (lam : Lambda.t) acc = match lam with | Lprim {primitive = Pmakeblock _; args; loc = _} -> Ext_list.for_all args (fun x -> diff --git a/compiler/ml/transl_recmodule.mli b/compiler/ml/transl_recmodule.mli index 82611084451..db2d3cbf1ca 100644 --- a/compiler/ml/transl_recmodule.mli +++ b/compiler/ml/transl_recmodule.mli @@ -22,7 +22,7 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) val compile_recmodule : - (Ident.t -> Typedtree.module_expr -> Location.t -> Lambda.lambda) -> + (Ident.t -> Typedtree.module_expr -> Location.t -> Lambda.t) -> Typedtree.module_binding list -> - Lambda.lambda -> - Lambda.lambda + Lambda.t -> + Lambda.t diff --git a/compiler/ml/translattribute.ml b/compiler/ml/translattribute.ml index b750b7f2767..b4efb4c301f 100644 --- a/compiler/ml/translattribute.ml +++ b/compiler/ml/translattribute.ml @@ -81,7 +81,7 @@ let get_inline_attribute l = let attr, _ = find_attribute is_inline_attribute l in parse_inline_attribute attr -let add_inline_attribute (expr : Lambda.lambda) loc attributes = +let add_inline_attribute (expr : Lambda.t) loc attributes = match (expr, get_inline_attribute attributes) with | expr, Default_inline -> expr | Lfunction ({attr} as funct), inline -> diff --git a/compiler/ml/translattribute.mli b/compiler/ml/translattribute.mli index bac456ba8d8..6570ef8f25b 100644 --- a/compiler/ml/translattribute.mli +++ b/compiler/ml/translattribute.mli @@ -19,7 +19,7 @@ val check_attribute_on_module : Typedtree.module_expr -> Parsetree.attribute -> unit val add_inline_attribute : - Lambda.lambda -> Location.t -> Parsetree.attributes -> Lambda.lambda + Lambda.t -> Location.t -> Parsetree.attributes -> Lambda.t val get_inline_attribute : Parsetree.attributes -> Lambda.inline_attribute diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 9029131edae..d8097648f29 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -32,7 +32,7 @@ exception Error of Location.t * error let transl_module = ref (fun _cc _rootpath _modl -> assert false - : module_coercion -> Path.t option -> module_expr -> lambda) + : module_coercion -> Path.t option -> module_expr -> Lambda.t) (* Number of payload-carrying constructors of the variant declaring [cstr]; part of the runtime representation of its blocks *) @@ -595,7 +595,7 @@ let external_import_needs_adaptation (arg_types : External_arg_spec.params) let transl_adapted_external_import loc env ~(emn : External_ffi_types.external_module_name) ~name ~scopes ~variadic ~(arg_types : External_arg_spec.params) ~return_wrapper - (p : Primitive.description) (val_type : type_expr) : Lambda.lambda = + (p : Primitive.description) (val_type : type_expr) : Lambda.t = let returns_unit = external_returns_unit env p val_type in let send_call receiver args (kind : External_ffi_types.decl_kind) = prim @@ -662,7 +662,7 @@ let transl_adapted_external_import loc env ] loc -let transl_dynamic_import loc (arg : Typedtree.expression) : Lambda.lambda = +let transl_dynamic_import loc (arg : Typedtree.expression) : Lambda.t = match arg.exp_desc with | Texp_ident ( _, @@ -692,7 +692,7 @@ let transl_dynamic_import loc (arg : Typedtree.expression) : Lambda.lambda = | _ -> prim ~primitive:(Pimport (import_source_of_arg arg)) ~args:[] loc let transl_external_application loc env (p : Primitive.description) - ~(val_type : type_expr) argl ~transformed_jsx : Lambda.lambda = + ~(val_type : type_expr) argl ~transformed_jsx : Lambda.t = match p.prim_kind with | Kind_inline_const c -> const (lambda_of_inline_const c) | Kind_external (Ffi_obj_create labels) -> @@ -926,14 +926,14 @@ let wrap_exn loc arg = loc) [arg] {ap_loc = loc; ap_inlined = Default_inline} -let exception_id_destructed (l : lambda) (fv : Ident.t) : bool = +let exception_id_destructed (l : Lambda.t) (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) = + and hit (l : Lambda.t) = match l with | Lprim {primitive = Praise; args = [Lvar _]; loc = _} -> false | Lprim {primitive = _; args; loc = _} -> hit_list args @@ -1005,7 +1005,7 @@ let rec transl_exp e = List.iter (Translattribute.check_attribute e) e.exp_attributes; transl_exp0 e) -and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = +and transl_exp0 (e : Typedtree.expression) : Lambda.t = match e.exp_desc with | Texp_ident (_, _, ({val_kind = Val_prim p} as vd)) -> transl_primitive e.exp_loc p e.exp_env e.exp_type ~val_type:vd.val_type @@ -1393,7 +1393,7 @@ and transl_apply ?(inlined = Default_inline) (List.map (fun (l, x) -> (may_map transl_exp x, Btype.is_optional l)) sargs) - : Lambda.lambda) + : Lambda.t) and transl_function loc (params : function_param list) body = match params with diff --git a/compiler/ml/translcore.mli b/compiler/ml/translcore.mli index 98ea3758700..000953852fb 100644 --- a/compiler/ml/translcore.mli +++ b/compiler/ml/translcore.mli @@ -16,14 +16,14 @@ (* Translation from typed abstract syntax to lambda terms, for the core language *) -val transl_exp : Typedtree.expression -> Lambda.lambda +val transl_exp : Typedtree.expression -> Lambda.t val transl_let : js_hoist:(Ident.t -> Location.t -> unit) option -> Asttypes.rec_flag -> Typedtree.value_binding list -> - Lambda.lambda -> - Lambda.lambda + Lambda.t -> + Lambda.t val transl_primitive : Location.t -> @@ -31,15 +31,15 @@ val transl_primitive : Env.t -> Types.type_expr -> val_type:Types.type_expr -> - Lambda.lambda + Lambda.t val transl_extension_constructor : - Env.t -> Path.t option -> Typedtree.extension_constructor -> Lambda.lambda + Env.t -> Path.t option -> Typedtree.extension_constructor -> Lambda.t (* Forward declaration -- to be filled in by Translmod.transl_module *) val transl_module : (Typedtree.module_coercion -> Path.t option -> Typedtree.module_expr -> - Lambda.lambda) + Lambda.t) ref diff --git a/compiler/ml/translmod.ml b/compiler/ml/translmod.ml index ee70442c48d..e5503ba0eee 100644 --- a/compiler/ml/translmod.ml +++ b/compiler/ml/translmod.ml @@ -57,7 +57,7 @@ let field_path path field : Path.t option = (* Compile type extensions *) let transl_type_extension env rootpath (tyext : Typedtree.type_extension) body : - Lambda.lambda = + Lambda.t = List.fold_right (fun ext body -> let lam = @@ -461,7 +461,7 @@ let _ = Translcore.transl_module := transl_module (* Compile an implementation *) type implementation = { - lambda: Lambda.lambda; + lambda: Lambda.t; exports: Ident.t list; hoisted_functions: Lambda.hoisted_function list; } diff --git a/compiler/ml/translmod.mli b/compiler/ml/translmod.mli index 5da4808c1fa..efd18ad9c83 100644 --- a/compiler/ml/translmod.mli +++ b/compiler/ml/translmod.mli @@ -17,7 +17,7 @@ for the module language *) type implementation = { - lambda: Lambda.lambda; + lambda: Lambda.t; exports: Ident.t list; hoisted_functions: Lambda.hoisted_function list; } From c415457fac37cf330998308d2de8d4ca6def25a8 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 1 Sep 2026 20:44:46 +0200 Subject: [PATCH 41/46] Clear the remaining references to Lam Seven were left, all prose rather than code: the -debug-ir and -check-lam help text, the doc comment on check_lam, the -debug-ir dump messages, two comments pointing at a module that no longer exists, and my own note in lambda.ml saying the raise-guard rewrite "stays a Lam-side rewrite until it can be expressed as a pass" - which it now is, so it points at Lam_pass_guard_raises. The lam_ filenames stay. They read as "the Lambda backend", which is what they are. Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/bsc/rescript_compiler_main.ml | 4 ++-- compiler/common/js_config.mli | 2 +- compiler/core/ir_diagnostics.ml | 4 ++-- compiler/core/lam_compile_external_call.ml | 2 +- compiler/ml/lambda.ml | 4 ++-- compiler/ml/matching.ml | 2 +- 6 files changed, 9 insertions(+), 9 deletions(-) diff --git a/compiler/bsc/rescript_compiler_main.ml b/compiler/bsc/rescript_compiler_main.ml index c1837ee4f79..f245e4629db 100644 --- a/compiler/bsc/rescript_compiler_main.ml +++ b/compiler/bsc/rescript_compiler_main.ml @@ -408,10 +408,10 @@ let command_line_flags : (string * Bsc_args.spec * string) array = "*internal* Disable cross module inlining(experimental)" ); ( "-debug-ir", set Js_config.debug_ir, - "*internal* Dump compiler IR and enable Lam invariant checks" ); + "*internal* Dump compiler IR and enable Lambda invariant checks" ); ( "-check-lam", set Js_config.check_lam, - "*internal* Check Lam invariants after optimization passes" ); + "*internal* Check Lambda invariants after optimization passes" ); ( "-bs-no-check-div-by-zero", clear Js_config.check_div_by_zero, "*internal* unsafe mode, don't check div by zero and mod by zero" ); diff --git a/compiler/common/js_config.mli b/compiler/common/js_config.mli index 2e8dc81a35b..c4098918ca8 100644 --- a/compiler/common/js_config.mli +++ b/compiler/common/js_config.mli @@ -53,7 +53,7 @@ val debug_ir : bool ref (** dump intermediate representations and related diagnostics *) val check_lam : bool ref -(** check Lam invariants after optimization passes *) +(** check Lambda invariants after optimization passes *) val no_builtin_ppx : bool ref (** options for builtin ppx *) diff --git a/compiler/core/ir_diagnostics.ml b/compiler/core/ir_diagnostics.ml index d6fbe8a766e..b0c24755c35 100644 --- a/compiler/core/ir_diagnostics.ml +++ b/compiler/core/ir_diagnostics.ml @@ -29,14 +29,14 @@ let next_path diagnostics ~kind ~pass ~extension = let dump_lam diagnostics ~pass lam = let path = next_path diagnostics ~kind:"lam" ~pass ~extension:".lam" in - Ext_log.dwarn ~__POS__ "Dumping Lam pass %s to %s" pass path; + Ext_log.dwarn ~__POS__ "Dumping pass %s to %s" pass path; Lam_print.serialize path lam let dump_groups diagnostics groups = let path = next_path diagnostics ~kind:"lam" ~pass:"groups" ~extension:".lambda" in - Ext_log.dwarn ~__POS__ "Dumping Lam groups to %s" path; + Ext_log.dwarn ~__POS__ "Dumping groups to %s" path; Ext_fmt.with_file_as_pp path (fun fmt -> Format.pp_print_list ~pp_sep:Format.pp_print_newline Lam_group.pp_group fmt groups) diff --git a/compiler/core/lam_compile_external_call.ml b/compiler/core/lam_compile_external_call.ml index 5979215b04c..751783d7366 100644 --- a/compiler/core/lam_compile_external_call.ml +++ b/compiler/core/lam_compile_external_call.ml @@ -98,7 +98,7 @@ let ocaml_to_js_eff ~(arg_label : External_arg_spec.label_noname) in match arg_type with | Arg_cst _ -> assert false - (* has to be preprocessed by {!Lam} module first *) + (* has to be preprocessed by {!Lambda} first *) | Extern_unit -> ( (if arg_label = Arg_empty then Splice0 else Splice1 E.unit), if Js_analyzer.no_side_effect_expression arg then [] else [arg] ) diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index e0401859696..4ed103a47bc 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -1142,8 +1142,8 @@ let if_ (a : t) (b : t) (c : t) : t = (* [if a then raise e else c] could become [(if a then raise e else ()); c], but that is code motion, not normalization: it changes the shape that matching's own exit bookkeeping inspects after the term is assembled, - and doing it here leaves static raises without their catch. It stays a - Lam-side rewrite until it can be expressed as a pass. *) + and doing it here leaves static raises without their catch. It is + {!Lam_pass_guard_raises} instead. *) | _ -> ( match a with | Lprim {primitive = Pisint; args = [Lvar i]; _} -> ( diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index 01fec12f2d7..d6fdbcf8709 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -1977,7 +1977,7 @@ let constructor_switch_key (cstr : Types.constructor_description) = (* An occurrence-specific plan for one constructor decision-tree node. It is deliberately local to pattern matching: [lower_constructor_matching_plan] immediately expresses the decision with existing Lambda control-flow - nodes, so Lambda and Lam do not acquire another expression language. *) + nodes, so Lambda does not acquire another expression language. *) type payload_presence_test = Is_present_option | Is_nonempty_list type constructor_matching_plan = From b4bc9e8bd4a7890e80b690ac2a317d3f027b7cf3 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 1 Sep 2026 21:05:01 +0200 Subject: [PATCH 42/46] Merge the two Lambda printers into Printlambda lam_print and printlambda printed the same twenty-two constructors and hundred-odd primitives, differing on twenty-eight of them, and both were live: -debug-ir and lam_group went through one, -drawlambda and matching through the other, and the playground rendered the same term twice. printlambda is the base - it carries more information almost everywhere: field debug info (field:var/0 rather than field 0), the block tag (makeblock ext, makeblock module/exports rather than makeblock 0), the import path, unit distinguished from undefined, and readable names where lam_print had bracket noise ([null->opt], [?null], +*). From lam_print: the mutable block distinction, and the serialize and lambda_to_string entry points that -debug-ir and the playground need. Better than either, the comparisons. printlambda printed Pobjcomp, Pboolcomp, Pintcomp, Pstringcomp and Pjscomp all as bare ==, so five primitives were indistinguishable in a dump; lam_print tagged two of the six operators on Pintcomp and left the rest. One helper now tags every comparison with its operand kind - ==[int], ==[string], >[int] - which also retires the bigint comma suffix, which mirrored float's dot but was unguessable. Const_constructor and Const_polyvar also both printed as `name. The polyvar keeps the backtick, matching source syntax; the constructor prints its name. The debug_ir build test asserts dump filenames and numbering rather than content, so the new rendering does not disturb it. Generated JavaScript is unchanged. Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/core/ir_diagnostics.ml | 2 +- compiler/core/lam_group.ml | 6 +- compiler/core/lam_print.ml | 457 -------------------------- compiler/core/lam_print.mli | 31 -- compiler/jsoo/jsoo_playground_main.ml | 2 +- compiler/ml/printlambda.ml | 84 +++-- compiler/ml/printlambda.mli | 7 + 7 files changed, 52 insertions(+), 537 deletions(-) delete mode 100644 compiler/core/lam_print.ml delete mode 100644 compiler/core/lam_print.mli diff --git a/compiler/core/ir_diagnostics.ml b/compiler/core/ir_diagnostics.ml index b0c24755c35..2bcce68f0e9 100644 --- a/compiler/core/ir_diagnostics.ml +++ b/compiler/core/ir_diagnostics.ml @@ -30,7 +30,7 @@ let next_path diagnostics ~kind ~pass ~extension = let dump_lam diagnostics ~pass lam = let path = next_path diagnostics ~kind:"lam" ~pass ~extension:".lam" in Ext_log.dwarn ~__POS__ "Dumping pass %s to %s" pass path; - Lam_print.serialize path lam + Printlambda.serialize path lam let dump_groups diagnostics groups = let path = diff --git a/compiler/core/lam_group.ml b/compiler/core/lam_group.ml index 399ad2bdef3..216bec89551 100644 --- a/compiler/core/lam_group.ml +++ b/compiler/core/lam_group.ml @@ -51,11 +51,11 @@ let pp_group fmt (x : t) = match x with | Single (kind, id, lam) -> Format.fprintf fmt "@[let@ %a@ =%s@ @[%a@]@ @]" Ident.print id - (str_of_kind kind) Lam_print.lambda lam + (str_of_kind kind) Printlambda.lambda lam | Recursive lst -> List.iter (fun (id, lam) -> Format.fprintf fmt "@[let %a@ =r@ %a@ @]" Ident.print id - Lam_print.lambda lam) + Printlambda.lambda lam) lst - | Nop lam -> Lam_print.lambda fmt lam + | Nop lam -> Printlambda.lambda fmt lam diff --git a/compiler/core/lam_print.ml b/compiler/core/lam_print.ml deleted file mode 100644 index df67cdf6119..00000000000 --- a/compiler/core/lam_print.ml +++ /dev/null @@ -1,457 +0,0 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -open Format -open Asttypes - -let rec struct_const ppf (cst : Lambda.structured_constant) = - match cst with - | Const_js_true -> fprintf ppf "#true" - | Const_js_false -> fprintf ppf "#false" - | 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_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 - | Const_bigint (sign, i) -> fprintf ppf "%sn" (Bigint_utils.to_string sign i) - | Const_polyvar name -> fprintf ppf "`%s" name - | Const_constructor {name} -> fprintf ppf "`%s" name - | Const_some n -> fprintf ppf "[some-c]%a" struct_const n - | Const_block (i, []) -> fprintf ppf "[%s]" (Lambda.tag_label_of_tag_info i) - | Const_block (i, sc1 :: scl) -> - let sconsts ppf scl = - List.iter (fun sc -> fprintf ppf "@ %a" struct_const sc) scl - in - fprintf ppf "@[<1>[%s:@ @[%a%a@]]@]" - (Lambda.tag_label_of_tag_info i) - struct_const sc1 sconsts scl - -let primitive ppf (prim : Lambda.primitive) = - match prim with - (* | Pcreate_exception s -> fprintf ppf "[exn-create]%S" s *) - | Pcreate_extension s -> fprintf ppf "[ext-create]%S" s - | Pinit_mod -> fprintf ppf "init_mod!" - | Pupdate_mod -> fprintf ppf "update_mod!" - (* 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 - | Pjs_object_set name -> fprintf ppf "js_object_set[%s]" name - | Pjs_fn_method -> fprintf ppf "js_fn_method" - | Pdebugger -> fprintf ppf "debugger" - | Praw_js_code _ -> fprintf ppf "[raw]" - | Ptypeof -> fprintf ppf "typeof" - | Pnull_to_opt -> fprintf ppf "[null->opt]" - | Pnull_undefined_to_opt -> fprintf ppf "[null/undefined->opt]" - | Pis_null -> fprintf ppf "[?null]" - | Pis_not_none -> fprintf ppf "[?is-not-none]" - | Psome -> fprintf ppf "[some]" - | Psome_not_nest -> fprintf ppf "[some-not-nest]" - | Pval_from_option -> fprintf ppf "[?unbox]" - | Pval_from_option_not_nest -> fprintf ppf "[?unbox-not-nest]" - | Pis_undefined -> fprintf ppf "[?undefined]" - | Pis_null_undefined -> fprintf ppf "[?null?undefined]" - | Pimport _ -> fprintf ppf "[import]" - | Pmakeblock i when Lambda.mutable_flag_of_tag_info i = Immutable -> - fprintf ppf "makeblock %s" (Lambda.tag_label_of_tag_info i) - | Pmakeblock i -> - fprintf ppf "makemutable %s" (Lambda.tag_label_of_tag_info i) - | Pfield (n, field_info) -> ( - match Lambda.str_of_field_info field_info with - | None -> fprintf ppf "field %i" n - | Some s -> fprintf ppf "field %s/%i" s n) - | Psetfield (n, _) -> - let instr = "setfield " in - fprintf ppf "%s%i" instr n - | Pduprecord -> fprintf ppf "duprecord" - | Precord_rest excluded -> - fprintf ppf "record_rest(%s)" (String.concat ", " excluded) - | Pjs_call {prim_name} -> fprintf ppf "%s[js]" prim_name - | Pjs_object_create _ -> fprintf ppf "[js.obj]" - | Praise -> fprintf ppf "raise" - | Pobjcomp Ceq -> fprintf ppf "==" - | Pobjcomp Cneq -> fprintf ppf "!=" - | Pobjcomp Clt -> fprintf ppf "<" - | Pobjcomp Cle -> fprintf ppf "<=" - | Pobjcomp Cgt -> fprintf ppf ">" - | Pobjcomp Cge -> fprintf ppf ">=" - | Pobjorder -> fprintf ppf "compare" - | Pobjmin -> fprintf ppf "min" - | Pobjmax -> fprintf ppf "max" - | Pobjtag -> fprintf ppf "tag" - | Pobjsize -> fprintf ppf "length" - | Psequand -> fprintf ppf "&&" - | Psequor -> fprintf ppf "||" - | Pnot -> fprintf ppf "not" - | Pboolcomp Ceq -> fprintf ppf "==" - | Pboolcomp Cneq -> fprintf ppf "!=" - | Pboolcomp Clt -> fprintf ppf "<" - | Pboolcomp Cle -> fprintf ppf "<=" - | Pboolcomp Cgt -> fprintf ppf ">" - | Pboolcomp Cge -> fprintf ppf ">=" - | Pboolorder -> fprintf ppf "compare" - | Pboolmin -> fprintf ppf "min" - | Pboolmax -> fprintf ppf "max" - | Pnegint -> fprintf ppf "~-" - | Paddint -> fprintf ppf "+" - | Pstringadd -> fprintf ppf "+*" - | Psubint -> fprintf ppf "-" - | Pmulint -> fprintf ppf "*" - | Pdivint -> fprintf ppf "/" - | Pmodint -> fprintf ppf "mod" - | Ppowint -> fprintf ppf "**" - | Pandint -> fprintf ppf "and" - | Porint -> fprintf ppf "or" - | Pxorint -> fprintf ppf "xor" - | Pnotint -> fprintf ppf "~~" - | Plslint -> fprintf ppf "lsl" - | Plsrint -> fprintf ppf "lsr" - | Pasrint -> fprintf ppf "asr" - | Pintcomp Ceq -> fprintf ppf "==[int]" - | Pintcomp Cneq -> fprintf ppf "!=[int]" - | Pintcomp Clt -> fprintf ppf "<" - | Pintcomp Cle -> fprintf ppf "<=" - | Pintcomp Cgt -> fprintf ppf ">" - | Pintcomp Cge -> fprintf ppf ">=" - | Pintorder -> fprintf ppf "compare" - | Pintmin -> fprintf ppf "min" - | Pintmax -> fprintf ppf "max" - | Pintoffloat -> fprintf ppf "int_of_float" - | Pfloatofint -> fprintf ppf "float_of_int" - | Pnegfloat -> fprintf ppf "~." - | Paddfloat -> fprintf ppf "+." - | Psubfloat -> fprintf ppf "-." - | Pmulfloat -> fprintf ppf "*." - | Pdivfloat -> fprintf ppf "/." - | Pmodfloat -> fprintf ppf "mod" - | Ppowfloat -> fprintf ppf "**" - | Pfloatcomp Ceq -> fprintf ppf "==." - | Pfloatcomp Cneq -> fprintf ppf "!=." - | Pfloatcomp Clt -> fprintf ppf "<." - | Pfloatcomp Cle -> fprintf ppf "<=." - | Pfloatcomp Cgt -> fprintf ppf ">." - | Pfloatcomp Cge -> fprintf ppf ">=." - | Pfloatorder -> fprintf ppf "compare" - | Pfloatmin -> fprintf ppf "min" - | Pfloatmax -> fprintf ppf "max" - | Pnegbigint -> fprintf ppf "~-" - | Paddbigint -> fprintf ppf "+" - | Psubbigint -> fprintf ppf "-" - | Pmulbigint -> fprintf ppf "*" - | Pdivbigint -> fprintf ppf "/" - | Pmodbigint -> fprintf ppf "mod" - | Ppowbigint -> fprintf ppf "**" - | Pandbigint -> fprintf ppf "and" - | Porbigint -> fprintf ppf "or" - | Pxorbigint -> fprintf ppf "xor" - | Pnotbigint -> fprintf ppf "~~" - | Plslbigint -> fprintf ppf "lsl" - | Pasrbigint -> fprintf ppf "asr" - | Pbigintcomp Ceq -> fprintf ppf "==" - | Pbigintcomp Cneq -> fprintf ppf "!=" - | Pbigintcomp Clt -> fprintf ppf "<" - | Pbigintcomp Cle -> fprintf ppf "<=" - | Pbigintcomp Cgt -> fprintf ppf ">" - | Pbigintcomp Cge -> fprintf ppf ">=" - | Pbigintorder -> fprintf ppf "compare" - | Pbigintmin -> fprintf ppf "min" - | Pbigintmax -> fprintf ppf "max" - | Pjscomp Ceq -> fprintf ppf "#==" - | Pjscomp Cneq -> fprintf ppf "#!=" - | Pjscomp Clt -> fprintf ppf "#<" - | Pjscomp Cle -> fprintf ppf "#<=" - | Pjscomp Cgt -> fprintf ppf "#>" - | Pjscomp Cge -> fprintf ppf "#>=" - | Pstringlength -> fprintf ppf "string.length" - | Pstringrefu -> fprintf ppf "string.unsafe_get" - | Pstringrefs -> fprintf ppf "string.get" - | Pstringcomp Ceq -> fprintf ppf "==" - | Pstringcomp Cneq -> fprintf ppf "!=" - | Pstringcomp Clt -> fprintf ppf "<" - | Pstringcomp Cle -> fprintf ppf "<=" - | Pstringcomp Cgt -> fprintf ppf ">" - | Pstringcomp Cge -> fprintf ppf ">=" - | Pstringorder -> fprintf ppf "compare" - | Pstringmin -> fprintf ppf "min" - | Pstringmax -> fprintf ppf "max" - | Parraylength -> fprintf ppf "array.length" - | Pmakearray -> fprintf ppf "makearray" - | Pmakelist -> fprintf ppf "makelist" - | Pmakedict -> fprintf ppf "makedict" - | Pdict_has -> fprintf ppf "dict.has" - | Parrayrefu -> fprintf ppf "array.unsafe_get" - | Parraysetu -> fprintf ppf "array.unsafe_set" - | Parrayrefs -> fprintf ppf "array.get" - | Parraysets -> fprintf ppf "array.set" - | Pisint -> fprintf ppf "isint" - | Pis_poly_var_block -> fprintf ppf "#is_poly_var_block" - | Pawait -> fprintf ppf "await" - | Phash -> fprintf ppf "hash" - | Phash_mixint -> fprintf ppf "hash_mix_int" - | Phash_mixstring -> fprintf ppf "hash_mix_string" - | Phash_finalmix -> fprintf ppf "hash_final_mix" - -type print_kind = Alias | Strict | StrictOpt | Variable | Recursive - -let kind = function - | Alias -> "a" - | Strict -> "" - | StrictOpt -> "o" - | Variable -> "v" - | Recursive -> "r" - -let to_print_kind (k : Lambda.let_kind) : print_kind = - match k with - | Alias -> Alias - | Strict -> Strict - | StrictOpt -> StrictOpt - | Variable -> Variable - -let rec aux (acc : (print_kind * Ident.t * Lambda.t) list) (lam : Lambda.t) = - match lam with - | Llet (str3, id3, arg3, body3) -> - aux ((to_print_kind str3, id3, arg3) :: acc) body3 - | Lletrec (bind_args, body) -> - aux - (Ext_list.map_append bind_args acc (fun (id, l) -> (Recursive, id, l))) - body - | e -> (acc, e) - -(* type left_var = - { - kind : print_kind ; - id : Ident.t - } *) - -(* type left = - | Id of left_var *) -(* | Nop *) - -let flatten (lam : Lambda.t) : (print_kind * Ident.t * Lambda.t) list * Lambda.t - = - match lam with - | Llet (str, id, arg, body) -> aux [(to_print_kind str, id, arg)] body - | Lletrec (bind_args, body) -> - aux (Ext_list.map bind_args (fun (id, l) -> (Recursive, id, l))) body - | _ -> assert false - -let lambda ppf v = - let rec lam ppf (l : Lambda.t) = - match l with - | Lvar id -> Ident.print ppf id - | Lglobal_module id -> fprintf ppf "global %a" Ident.print id - | Lconst cst -> struct_const ppf cst - | Lapply {ap_func; ap_args; ap_info = {ap_inlined}} -> - let lams ppf args = List.iter (fun l -> fprintf ppf "@ %a" lam l) args in - fprintf ppf "@[<2>(apply%s@ %a%a)@]" - (match ap_inlined with - | Always_inline -> "%inlned" - | _ -> "") - lam ap_func lams ap_args - | Lfunction {params; body; _} -> - let pr_params ppf params = - List.iter (fun param -> fprintf ppf "@ %a" Ident.print param) params - (* | Tupled -> *) - (* fprintf ppf " ("; *) - (* let first = ref true in *) - (* List.iter *) - (* (fun param -> *) - (* if !first then first := false else fprintf ppf ",@ "; *) - (* Ident.print ppf param) *) - (* params; *) - (* fprintf ppf ")" *) - in - fprintf ppf "@[<2>(function%a@ %a)@]" pr_params params lam body - | (Llet _ | Lletrec _) as x -> - let args, body = flatten x in - let bindings ppf id_arg_list = - let spc = ref false in - List.iter - (fun (k, id, l) -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[<2>%a =%s@ %a@]" Ident.print id (kind k) lam l) - id_arg_list - in - fprintf ppf "@[<2>(let@ (@[%a@]" bindings (List.rev args); - fprintf ppf ")@ %a)@]" lam body - | Lprim - { - primitive = Pfield (n, Fld_module {name = s}); - args = [Lglobal_module id]; - _; - } -> - fprintf ppf "%s.%s/%d" id.name s n - | Lprim {primitive = prim; args = largs; _} -> - let lams ppf largs = - List.iter (fun l -> fprintf ppf "@ %a" lam l) largs - in - fprintf ppf "@[<2>(%a%a)@]" primitive prim lams largs - | Lswitch (larg, sw) -> - let switch ppf (sw : Lambda.lambda_switch) = - let spc = ref false in - List.iter - (fun (key, l) -> - if !spc then fprintf ppf "@ " else spc := true; - match key with - | Lambda.Switch_int ordinal -> - fprintf ppf "@[case int %i:@ %a@]" ordinal lam l - | Lambda.Switch_constructor (Constant {name}) -> - fprintf ppf "@[case constructor %S:@ %a@]" name lam l - | Lambda.Switch_constructor (Block _) -> assert false) - sw.sw_consts; - List.iter - (fun (key, l) -> - if !spc then fprintf ppf "@ " else spc := true; - match key with - | Lambda.Switch_int ordinal -> - fprintf ppf "@[case tag %i:@ %a@]" ordinal lam l - | Lambda.Switch_constructor (Block {runtime = {tag = {name}}}) -> - fprintf ppf "@[case constructor %S:@ %a@]" name lam l - | Lambda.Switch_constructor (Constant _) -> assert false) - sw.sw_blocks; - match sw.sw_failaction with - | None -> () - | Some l -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[default:@ %a@]" lam l - in - fprintf ppf "@[<1>(%s %a@ @[%a@])@]" - (match sw.sw_failaction with - | None -> "switch*" - | _ -> "switch") - lam larg switch sw - | Lstringswitch (arg, cases, default) -> - let switch ppf cases = - let spc = ref false in - List.iter - (fun (s, l) -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[case \"%s\":@ %a@]" (String.escaped s) lam l) - cases; - match default with - | Some default -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[default:@ %a@]" lam default - | None -> () - in - fprintf ppf "@[<1>(stringswitch %a@ @[%a@])@]" lam arg switch cases - | Lstaticraise (i, ls) -> - let lams ppf largs = - List.iter (fun l -> fprintf ppf "@ %a" lam l) largs - in - fprintf ppf "@[<2>(exit@ %d%a)@]" i lams ls - | Lstaticcatch (lbody, (i, vars), lhandler) -> - fprintf ppf "@[<2>(catch@ %a@;<1 -1>with (%d%a)@ %a)@]" lam lbody i - (fun ppf vars -> - match vars with - | [] -> () - | _ -> List.iter (fun x -> fprintf ppf " %a" Ident.print x) vars) - vars lam lhandler - | Ltrywith (lbody, param, lhandler) -> - fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]" lam lbody Ident.print - param lam lhandler - | Lifthenelse (lcond, lif, lelse) -> - fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" lam lcond lam lif lam lelse - | Lsequence (l1, l2) -> - fprintf ppf "@[<2>(seq@ %a@ %a)@]" lam l1 sequence l2 - | Lbreak -> fprintf ppf "break" - | Lcontinue -> fprintf ppf "continue" - | Lwhile (lcond, lbody) -> - fprintf ppf "@[<2>(while@ %a@ %a)@]" lam lcond lam lbody - | Lfor (param, lo, hi, dir, body) -> - fprintf ppf "@[<2>(for %a@ %a@ %s@ %a@ %a)@]" Ident.print param lam lo - (match dir with - | Upto -> "to" - | Downto -> "downto") - lam hi lam body - | Lfor_of (param, iterable, body) -> - fprintf ppf "@[<2>(for %a@ of@ %a@ %a)@]" Ident.print param lam iterable - lam body - | Lfor_await_of (param, iterable, body) -> - fprintf ppf "@[<2>(for await %a@ of@ %a@ %a)@]" Ident.print param lam - iterable lam body - | Lassign (id, expr) -> - fprintf ppf "@[<2>(assign@ %a@ %a)@]" Ident.print id lam expr - and sequence ppf = function - | Lsequence (l1, l2) -> fprintf ppf "%a@ %a" sequence l1 sequence l2 - | l -> lam ppf l - in - lam ppf v - -(* let structured_constant = struct_const *) - -(* let rec flatten_seq acc (lam : Lambda.t) = - match lam with - | Lsequence(l1,l2) -> - flatten_seq (flatten_seq acc l1) l2 - | x -> x :: acc *) - -(* exception Not_a_module *) - -(* let rec flat (acc : (left * Lambda.t) list ) (lam : Lambda.t) = - match lam with - | Llet (str,id,arg,body) -> - flat ( (Id {kind = to_print_kind str; id}, arg) :: acc) body - | Lletrec (bind_args, body) -> - flat - (Ext_list.map_append bind_args acc - (fun (id, arg ) -> (Id {kind = Recursive; id}, arg)) ) - body - | Lsequence (l,r) -> - flat (flat acc l) r - | x -> (Nop, x) :: acc *) - -(* let lambda_as_module env ppf (lam : Lambda.t) = - try - (* match lam with *) - (* | Lprim {primitive = Psetglobal id ; args = [biglambda]; _} *) - (* might be wrong in toplevel *) - (* -> *) - - begin match flat [] lam with - | (Nop, Lprim {primitive = Pmakeblock (_, _); args = toplevels; _}) - :: rest -> - (* let spc = ref false in *) - List.iter - (fun (left, l) -> - match left with - | Id { kind = k; id } -> - fprintf ppf "@[<2>%a =%s@ %a@]@." Ident.print id (kind k) lambda l - | Nop -> - - fprintf ppf "@[<2>%a@]@." lambda l - ) - - @@ List.rev rest - - - | _ -> raise Not_a_module - end - (* | _ -> raise Not_a_module *) - with _ -> - lambda ppf lam; - fprintf ppf "; lambda-failure" *) - -let serialize (filename : string) (lam : Lambda.t) : unit = - let ou = open_out filename in - let old = Format.get_margin () in - let () = Format.set_margin 10000 in - let fmt = Format.formatter_of_out_channel ou in - (* lambda_as_module env fmt lambda; *) - lambda fmt lam; - Format.pp_print_flush fmt (); - close_out ou; - Format.set_margin old - -let lambda_to_string = Format.asprintf "%a" lambda diff --git a/compiler/core/lam_print.mli b/compiler/core/lam_print.mli deleted file mode 100644 index d5b909f52ef..00000000000 --- a/compiler/core/lam_print.mli +++ /dev/null @@ -1,31 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - 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. *) - -val lambda : Format.formatter -> Lambda.t -> unit - -val primitive : Format.formatter -> Lambda.primitive -> unit - -val serialize : string -> Lambda.t -> unit - -val lambda_to_string : Lambda.t -> string diff --git a/compiler/jsoo/jsoo_playground_main.ml b/compiler/jsoo/jsoo_playground_main.ml index 51661236a9a..22a8ee36b48 100644 --- a/compiler/jsoo/jsoo_playground_main.ml +++ b/compiler/jsoo/jsoo_playground_main.ml @@ -547,7 +547,7 @@ module Compile = struct Printer.to_string Printtyped.implementation_with_coercion typed_tree in let lambda_output = Printer.to_string Printlambda.lambda lambda in - let lam = Lam_print.lambda_to_string lambda in + let lam = Printlambda.lambda_to_string lambda in let debug_attrs = Js.Unsafe. [| diff --git a/compiler/ml/printlambda.ml b/compiler/ml/printlambda.ml index 8d10380188c..dae4aa73e59 100644 --- a/compiler/ml/printlambda.ml +++ b/compiler/ml/printlambda.ml @@ -23,7 +23,7 @@ let rec struct_const ppf = function | 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_constructor {name} -> fprintf ppf "`%s" name + | Const_constructor {name} -> fprintf ppf "%s" name | Const_polyvar name -> fprintf ppf "`%s" name | Const_module_alias -> fprintf ppf "module_alias" | Const_assertfalse -> fprintf ppf "assertfalse" @@ -89,12 +89,31 @@ let print_taginfo ppf = function | Blk_record_inlined {fields = ss} -> fprintf ppf "[%s]" (String.concat ";" (List.map fst (Array.to_list ss))) +(* Every comparison prints its operand kind, so [Pintcomp], [Pjscomp], + [Pstringcomp] and friends stay distinguishable. *) +let comparison ppf kind (cmp : Lambda.comparison) = + let op = + match cmp with + | Ceq -> "==" + | Cneq -> "!=" + | Clt -> "<" + | Cle -> "<=" + | Cgt -> ">" + | Cge -> ">=" + in + fprintf ppf "%s[%s]" op kind + let primitive ppf = function | Pdebugger -> fprintf ppf "debugger" | Ptypeof -> fprintf ppf "typeof" | Psome -> fprintf ppf "some" | Psome_not_nest -> fprintf ppf "some_not_nest" - | Pmakeblock taginfo -> fprintf ppf "makeblock %a" print_taginfo taginfo + | Pmakeblock taginfo -> + let what = + if Lambda.mutable_flag_of_tag_info taginfo = Immutable then "makeblock" + else "makemutable" + in + fprintf ppf "%s %a" what print_taginfo taginfo | Pfield (n, fld) -> fprintf ppf "field:%s/%i" (str_of_field_info fld) n | Psetfield (n, _) -> fprintf ppf "setfield %i" n | Pduprecord -> fprintf ppf "duprecord" @@ -105,12 +124,7 @@ let primitive ppf = function | Pjs_object_get name -> fprintf ppf "js_object_get[%s]" name | Pjs_object_set name -> fprintf ppf "js_object_set[%s]" name | Praise -> fprintf ppf "raise" - | Pobjcomp Ceq -> fprintf ppf "==" - | Pobjcomp Cneq -> fprintf ppf "!=" - | Pobjcomp Clt -> fprintf ppf "<" - | Pobjcomp Cle -> fprintf ppf "<=" - | Pobjcomp Cgt -> fprintf ppf ">" - | Pobjcomp Cge -> fprintf ppf ">=" + | Pobjcomp cmp -> comparison ppf "obj" cmp | Pobjorder -> fprintf ppf "compare" | Pobjmin -> fprintf ppf "min" | Pobjmax -> fprintf ppf "max" @@ -119,12 +133,7 @@ let primitive ppf = function | Psequand -> fprintf ppf "&&" | Psequor -> fprintf ppf "||" | Pnot -> fprintf ppf "not" - | Pboolcomp Ceq -> fprintf ppf "==" - | Pboolcomp Cneq -> fprintf ppf "!=" - | Pboolcomp Clt -> fprintf ppf "<" - | Pboolcomp Cle -> fprintf ppf "<=" - | Pboolcomp Cgt -> fprintf ppf ">" - | Pboolcomp Cge -> fprintf ppf ">=" + | Pboolcomp cmp -> comparison ppf "bool" cmp | Pboolorder -> fprintf ppf "compare" | Pboolmin -> fprintf ppf "min" | Pboolmax -> fprintf ppf "max" @@ -142,12 +151,7 @@ let primitive ppf = function | Plslint -> fprintf ppf "lsl" | Plsrint -> fprintf ppf "lsr" | Pasrint -> fprintf ppf "asr" - | Pintcomp Ceq -> fprintf ppf "==" - | Pintcomp Cneq -> fprintf ppf "!=" - | Pintcomp Clt -> fprintf ppf "<" - | Pintcomp Cle -> fprintf ppf "<=" - | Pintcomp Cgt -> fprintf ppf ">" - | Pintcomp Cge -> fprintf ppf ">=" + | Pintcomp cmp -> comparison ppf "int" cmp | Pintorder -> fprintf ppf "compare" | Pintmin -> fprintf ppf "min" | Pintmax -> fprintf ppf "max" @@ -160,12 +164,7 @@ let primitive ppf = function | Pdivfloat -> fprintf ppf "/." | Pmodfloat -> fprintf ppf "mod" | Ppowfloat -> fprintf ppf "**" - | Pfloatcomp Ceq -> fprintf ppf "==." - | Pfloatcomp Cneq -> fprintf ppf "!=." - | Pfloatcomp Clt -> fprintf ppf "<." - | Pfloatcomp Cle -> fprintf ppf "<=." - | Pfloatcomp Cgt -> fprintf ppf ">." - | Pfloatcomp Cge -> fprintf ppf ">=." + | Pfloatcomp cmp -> comparison ppf "float" cmp | Pfloatorder -> fprintf ppf "compare" | Pfloatmin -> fprintf ppf "min" | Pfloatmax -> fprintf ppf "max" @@ -182,24 +181,14 @@ let primitive ppf = function | Pasrbigint -> fprintf ppf "asr" | Pdivbigint -> fprintf ppf "/" | Pmodbigint -> fprintf ppf "mod" - | Pbigintcomp Ceq -> fprintf ppf "==," - | Pbigintcomp Cneq -> fprintf ppf "!=," - | Pbigintcomp Clt -> fprintf ppf "<," - | Pbigintcomp Cle -> fprintf ppf "<=," - | Pbigintcomp Cgt -> fprintf ppf ">," - | Pbigintcomp Cge -> fprintf ppf ">=," + | Pbigintcomp cmp -> comparison ppf "bigint" cmp | Pbigintorder -> fprintf ppf "compare" | Pbigintmin -> fprintf ppf "min" | Pbigintmax -> fprintf ppf "max" | Pstringlength -> fprintf ppf "string.length" | Pstringrefu -> fprintf ppf "string.unsafe_get" | Pstringrefs -> fprintf ppf "string.get" - | Pstringcomp Ceq -> fprintf ppf "==" - | Pstringcomp Cneq -> fprintf ppf "!=" - | Pstringcomp Clt -> fprintf ppf "<" - | Pstringcomp Cle -> fprintf ppf "<=" - | Pstringcomp Cgt -> fprintf ppf ">" - | Pstringcomp Cge -> fprintf ppf ">=" + | Pstringcomp cmp -> comparison ppf "string" cmp | Pstringorder -> fprintf ppf "compare" | Pstringmin -> fprintf ppf "min" | Pstringmax -> fprintf ppf "max" @@ -229,12 +218,7 @@ let primitive ppf = function | Phash_mixint -> fprintf ppf "hash_mix_int" | Phash_mixstring -> fprintf ppf "hash_mix_string" | Phash_finalmix -> fprintf ppf "hash_final_mix" - | Pjscomp Ceq -> fprintf ppf "==" - | Pjscomp Cneq -> fprintf ppf "!=" - | Pjscomp Clt -> fprintf ppf "<" - | Pjscomp Cle -> fprintf ppf "<=" - | Pjscomp Cgt -> fprintf ppf ">" - | Pjscomp Cge -> fprintf ppf ">=" + | Pjscomp cmp -> comparison ppf "js" cmp | Pnull_to_opt -> fprintf ppf "null_to_opt" | Pnull_undefined_to_opt -> fprintf ppf "nullable_to_opt" | Pis_not_none -> fprintf ppf "#is_not_none" @@ -395,3 +379,15 @@ and sequence ppf = function let structured_constant = struct_const let lambda = lam + +let serialize (filename : string) (l : Lambda.t) : unit = + let ou = open_out filename in + let old = Format.get_margin () in + Format.set_margin 10000; + let fmt = Format.formatter_of_out_channel ou in + lambda fmt l; + Format.pp_print_flush fmt (); + close_out ou; + Format.set_margin old + +let lambda_to_string = Format.asprintf "%a" lambda diff --git a/compiler/ml/printlambda.mli b/compiler/ml/printlambda.mli index 86f226c760f..d4e1dfbd09d 100644 --- a/compiler/ml/printlambda.mli +++ b/compiler/ml/printlambda.mli @@ -19,3 +19,10 @@ open Format val structured_constant : formatter -> structured_constant -> unit val lambda : formatter -> Lambda.t -> unit + +val primitive : formatter -> Lambda.primitive -> unit + +val serialize : string -> Lambda.t -> unit +(** Print a term to a file, unwrapped: used for the -debug-ir dumps. *) + +val lambda_to_string : Lambda.t -> string From 48723089cf4a40a3c658d4c3cf70a2ccaa5f1934 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 1 Sep 2026 21:08:28 +0200 Subject: [PATCH 43/46] Fold required_modules into its only caller lam_convert was down to one function with one caller, and its name had not described it since conversion became the identity. The function moves next to its use in lam_compile_main. Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/core/lam_compile_main.ml | 20 +++++++++++++++- compiler/core/lam_convert.ml | 38 ------------------------------- compiler/core/lam_convert.mli | 28 ----------------------- 3 files changed, 19 insertions(+), 67 deletions(-) delete mode 100644 compiler/core/lam_convert.ml delete mode 100644 compiler/core/lam_convert.mli diff --git a/compiler/core/lam_compile_main.ml b/compiler/core/lam_compile_main.ml index 4ce76d1842a..21b83d11403 100644 --- a/compiler/core/lam_compile_main.ml +++ b/compiler/core/lam_compile_main.ml @@ -239,9 +239,27 @@ let js_hoisted_aliases (export_ids : Ident.t list) | None -> missing_path ()) | [] -> missing_path ())) +(* The other compilation units this one refers to. Conversion used to drop + [Lglobal_module] references and have module analysis add them back (see + #3852); they are read off the Lambda term instead. A reference the + optimizer deletes still has to be imported when the module it names is + impure. *) + (** Actually simplify_lets is kind of global optimization since it requires you to know whether it's used or not *) +let required_modules (lam : Lambda.t) : Lam_module_ident.Hash_set.t = + let required = Lam_module_ident.Hash_set.create 0 in + let rec collect (lam : Lambda.t) = + (match lam with + | Lglobal_module id -> + Lam_module_ident.Hash_set.add required (Lam_module_ident.of_ml id) + | _ -> ()); + Lambda.iter collect lam + in + collect lam; + required + let compile (output_prefix : string) export_idents hoisted (lam : Lambda.t) = let debug_ir = !Js_config.debug_ir in let diagnostics = @@ -271,7 +289,7 @@ let compile (output_prefix : string) export_idents hoisted (lam : Lambda.t) = Ext_log.dwarn ~__POS__ "export idents: %s/%d" id.name id.stamp); Lam_compile_env.reset () in - let may_required_modules = Lam_convert.required_modules lam in + let may_required_modules = required_modules 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 deleted file mode 100644 index 61913c90db9..00000000000 --- a/compiler/core/lam_convert.ml +++ /dev/null @@ -1,38 +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. *) - -(** Global modules a unit depends on. Convert used to drop [Lglobal_module] - references and have them added back by module analysis (see #3852); they - are collected here instead, from the Lambda term directly. *) -let required_modules (lam : Lambda.t) : Lam_module_ident.Hash_set.t = - let required = Lam_module_ident.Hash_set.create 0 in - let rec collect (lam : Lambda.t) = - (match lam with - | Lglobal_module id -> - Lam_module_ident.Hash_set.add required (Lam_module_ident.of_ml id) - | _ -> ()); - Lambda.iter collect lam - in - collect lam; - required diff --git a/compiler/core/lam_convert.mli b/compiler/core/lam_convert.mli deleted file mode 100644 index 3c0adbb46a6..00000000000 --- a/compiler/core/lam_convert.mli +++ /dev/null @@ -1,28 +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. *) - -val required_modules : Lambda.t -> Lam_module_ident.Hash_set.t -(** The other compilation units this one refers to, read off the Lambda term. - A reference the optimizer deletes still has to be imported when the module - it names is impure. *) From 6f54af0caa5afcc0c96867b321fee3374fd0ab6f Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 1 Sep 2026 21:17:51 +0200 Subject: [PATCH 44/46] Consolidate the four ident sets into Set_ident There were four: Set_ident in compiler/ext, used throughout compiler/core, and Set.Make (Ident) written out again in lambda.ml, mtype.ml and - under the name Id_set - parmatch.ml. They all go through Set_ident now. The orderings were already equivalent, which had to be checked rather than assumed: matching lists the elements of an intersection to name ambiguous or-pattern variables, and parmatch does the same for its ambiguity warnings, so a different order would have changed both generated code and warning text. Set_ident takes the set first where the stdlib takes it last, so all 56 call sites needed flipping. The argument types differ, so the compiler checked every one. Generated JavaScript is unchanged, and the syntax and analysis suites - which cover the warning text - pass. Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- compiler/core/lam_compile.ml | 4 ++-- compiler/core/lam_dce.ml | 10 ++++---- compiler/ml/lambda.ml | 22 ++++++++---------- compiler/ml/lambda.mli | 3 +-- compiler/ml/matching.ml | 20 ++++++++-------- compiler/ml/mtype.ml | 14 +++++------ compiler/ml/parmatch.ml | 41 ++++++++++++++++----------------- compiler/ml/transl_recmodule.ml | 2 +- compiler/ml/translmod.ml | 8 +++---- 9 files changed, 57 insertions(+), 67 deletions(-) diff --git a/compiler/core/lam_compile.ml b/compiler/core/lam_compile.ml index c6b27c5ff59..9d3663244f1 100644 --- a/compiler/core/lam_compile.ml +++ b/compiler/core/lam_compile.ml @@ -1283,7 +1283,7 @@ let compile output_prefix = (lambda_cxt : Lam_compile_context.t) = let new_cxt = {lambda_cxt with continuation = NeedValue Not_tail} in let emitted_id = - if Lambda.Ident_set.mem id (Lambda.free_variables body) then id + if Set_ident.mem (Lambda.free_variables body) id then id else Ext_ident.create_tmp ~name:"_for_of" () in let block = @@ -1306,7 +1306,7 @@ let compile output_prefix = (body : Lambda.t) (lambda_cxt : Lam_compile_context.t) = let new_cxt = {lambda_cxt with continuation = NeedValue Not_tail} in let emitted_id = - if Lambda.Ident_set.mem id (Lambda.free_variables body) then id + if Set_ident.mem (Lambda.free_variables body) id then id else Ext_ident.create_tmp ~name:"_for_await_of" () in let block = diff --git a/compiler/core/lam_dce.ml b/compiler/core/lam_dce.ml index 951dadd0ef9..7b7a012da75 100644 --- a/compiler/core/lam_dce.ml +++ b/compiler/core/lam_dce.ml @@ -23,7 +23,7 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) let transitive_closure (initial_idents : Ident.t list) - (ident_freevars : Lambda.Ident_set.t Hash_ident.t) = + (ident_freevars : Set_ident.t Hash_ident.t) = let visited = Hash_set_ident.create 31 in let rec dfs (id : Ident.t) : unit = if not (Hash_set_ident.mem visited id || Ext_ident.is_js_or_global id) then ( @@ -32,7 +32,7 @@ let transitive_closure (initial_idents : Ident.t list) | None -> Ext_fmt.failwithf ~loc:__LOC__ "%s/%d not found" (Ident.name id) id.stamp - | Some e -> Lambda.Ident_set.iter dfs e) + | Some e -> Set_ident.iter e dfs) in Ext_list.iter initial_idents dfs; visited @@ -60,10 +60,8 @@ let remove export_idents (rest : Lam_group.t list) : Lam_group.t list = if Lam_analysis.no_side_effects lam then acc else (* its free varaibles here will be defined above *) - Lambda.Ident_set.fold - (fun x acc -> x :: acc) - (Lambda.free_variables lam) - acc) + Set_ident.fold (Lambda.free_variables lam) acc (fun x acc -> + x :: acc)) in let visited = transitive_closure initial_idents ident_free_vars in Ext_list.fold_left rest [] (fun acc x -> diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index 4ed103a47bc..9e045e99330 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -1412,26 +1412,24 @@ let iter f lam = false) lam) -module Ident_set = Set.Make (Ident) - let free_ids get l = - let fv = ref Ident_set.empty in + let fv = ref Set_ident.empty in let rec free l = iter free l; - fv := List.fold_right Ident_set.add (get l) !fv; + fv := List.fold_left Set_ident.add !fv (get l); match l with | Lfunction {params} -> - List.iter (fun param -> fv := Ident_set.remove param !fv) params - | Llet (_str, id, _arg, _body) -> fv := Ident_set.remove id !fv + List.iter (fun param -> fv := Set_ident.remove !fv param) params + | Llet (_str, id, _arg, _body) -> fv := Set_ident.remove !fv id | Lletrec (decl, _body) -> - List.iter (fun (id, _exp) -> fv := Ident_set.remove id !fv) decl + List.iter (fun (id, _exp) -> fv := Set_ident.remove !fv id) decl | Lstaticcatch (_e1, (_, vars), _e2) -> - List.iter (fun id -> fv := Ident_set.remove id !fv) vars - | Ltrywith (_e1, exn, _e2) -> fv := Ident_set.remove exn !fv - | Lfor (v, _e1, _e2, _dir, _e3) -> fv := Ident_set.remove v !fv + List.iter (fun id -> fv := Set_ident.remove !fv id) vars + | Ltrywith (_e1, exn, _e2) -> fv := Set_ident.remove !fv exn + | Lfor (v, _e1, _e2, _dir, _e3) -> fv := Set_ident.remove !fv v | Lfor_of (v, _e1, _e2) | Lfor_await_of (v, _e1, _e2) -> - fv := Ident_set.remove v !fv - | Lassign (id, _e) -> fv := Ident_set.add id !fv + fv := Set_ident.remove !fv v + | Lassign (id, _e) -> fv := Set_ident.add !fv id | Lvar _ | Lglobal_module _ | Lconst _ | Lapply _ | Lprim _ | Lswitch _ | Lstringswitch _ | Lstaticraise _ | Lifthenelse _ | Lsequence _ | Lbreak | Lcontinue | Lwhile _ -> diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index 5257fcf1dcb..4ddc6ea8918 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -549,8 +549,7 @@ val shallow_exists : (t -> bool) -> t -> bool (** Does any immediate child satisfy the predicate? Short-circuits. *) val iter : (t -> unit) -> t -> unit -module Ident_set : Set.S with type elt = Ident.t -val free_variables : t -> Ident_set.t +val free_variables : t -> Set_ident.t val transl_normal_path : Path.t -> t (* Path.t is already normal *) diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index d6fdbcf8709..324db00a6a8 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -600,14 +600,14 @@ let default_compat p def = (* Or-pattern expansion, variables are a complication w.r.t. the article *) let rec extract_vars r p = match p.pat_desc with - | Tpat_var (id, _) -> Ident_set.add id r - | Tpat_alias (p, id, _) -> extract_vars (Ident_set.add id r) p + | Tpat_var (id, _) -> Set_ident.add r id + | Tpat_alias (p, id, _) -> extract_vars (Set_ident.add r id) p | Tpat_tuple pats -> List.fold_left extract_vars r pats | Tpat_record (lpats, _, rest) -> ( let r = List.fold_left (fun r (_, _, p, _) -> extract_vars r p) r lpats in match rest with | None -> r - | Some rest -> Ident_set.add rest.rest_ident r) + | Some rest -> Set_ident.add r rest.rest_ident) | Tpat_construct (_, _, pats) -> List.fold_left extract_vars r pats | Tpat_array pats -> List.fold_left extract_vars r pats | Tpat_variant (_, Some p, _) -> extract_vars r p @@ -643,8 +643,8 @@ let rec explode_or_pat arg patl mk_action rem vars aliases = function let pm_free_variables {cases} = List.fold_right - (fun (_, act) r -> Ident_set.union (free_variables act) r) - cases Ident_set.empty + (fun (_, act) r -> Set_ident.union (free_variables act) r) + cases Set_ident.empty (* Basic grouping predicates *) let pat_as_constr = function @@ -726,8 +726,8 @@ let insert_or_append p ps act ors no = if is_or q then if may_compat p q then if - Ident_set.is_empty (extract_vars Ident_set.empty p) - && Ident_set.is_empty (extract_vars Ident_set.empty q) + Set_ident.is_empty (extract_vars Set_ident.empty p) + && Set_ident.is_empty (extract_vars Set_ident.empty q) && equiv_pat p q then (* attempt insert, for equivalent orpats with no variables *) @@ -1037,9 +1037,9 @@ and precompile_or argo cls ors args def k = } in let vars = - Ident_set.elements - (Ident_set.inter - (extract_vars Ident_set.empty orp) + Set_ident.elements + (Set_ident.inter + (extract_vars Set_ident.empty orp) (pm_free_variables orpm)) in let or_num = next_raise_count () in diff --git a/compiler/ml/mtype.ml b/compiler/ml/mtype.ml index f6f243ade16..0f284fdaf7b 100644 --- a/compiler/ml/mtype.ml +++ b/compiler/ml/mtype.ml @@ -290,8 +290,6 @@ let contains_type env mty = module Path_set = Set.Make (Path) module Path_map = Map.Make (Path) -module Ident_set = Set.Make (Ident) - let rec get_prefixes = function | Pident _ -> Path_set.empty | Pdot (p, _, _) | Papply (p, _) -> Path_set.add p (get_prefixes p) @@ -318,10 +316,10 @@ let rec collect_ids subst bindings p = | Pident id -> let ids = try collect_ids subst bindings (Ident.find_same id bindings) - with Not_found -> Ident_set.empty + with Not_found -> Set_ident.empty in - Ident_set.add id ids - | _ -> Ident_set.empty + Set_ident.add ids id + | _ -> Set_ident.empty let collect_arg_paths mty = let open Btype in @@ -350,8 +348,8 @@ let collect_arg_paths mty = it.it_module_type it mty; it.it_module_type unmark_iterators mty; Path_set.fold - (fun p -> Ident_set.union (collect_ids !subst !bindings p)) - !paths Ident_set.empty + (fun p -> Set_ident.union (collect_ids !subst !bindings p)) + !paths Set_ident.empty let rec remove_aliases env excl mty = match mty with @@ -369,7 +367,7 @@ and remove_aliases_sig env excl sg = | Sig_module (id, md, rs) :: rem -> let mty = match md.md_type with - | Mty_alias _ when Ident_set.mem id excl -> md.md_type + | Mty_alias _ when Set_ident.mem excl id -> md.md_type | mty -> remove_aliases env excl mty in Sig_module (id, {md with md_type = mty}, rs) diff --git a/compiler/ml/parmatch.ml b/compiler/ml/parmatch.ml index a688e05e72f..297b68129af 100644 --- a/compiler/ml/parmatch.ml +++ b/compiler/ml/parmatch.ml @@ -2335,23 +2335,21 @@ let check_partial_gadt ?partial_match_warning_hint pred loc casel = to a specific guard. *) -module Id_set = Set.Make (Ident) - -let pattern_vars p = Id_set.of_list (Typedtree.pat_bound_idents p) +let pattern_vars p = Set_ident.of_list (Typedtree.pat_bound_idents p) (* Row for ambiguous variable search, unseen is the traditional pattern row, seen is a list of position bindings *) -type amb_row = {unseen: pattern list; seen: Id_set.t list} +type amb_row = {unseen: pattern list; seen: Set_ident.t list} (* Push binding variables now *) let rec do_push r p ps seen k = match p.pat_desc with - | Tpat_alias (p, x, _) -> do_push (Id_set.add x r) p ps seen k + | Tpat_alias (p, x, _) -> do_push (Set_ident.add r x) p ps seen k | Tpat_var (x, _) -> - (omega, {unseen = ps; seen = Id_set.add x r :: seen}) :: k + (omega, {unseen = ps; seen = Set_ident.add r x :: seen}) :: k | Tpat_or (p1, p2, _) -> do_push r p1 ps seen (do_push r p2 ps seen k) | _ -> (p, {unseen = ps; seen = r :: seen}) :: k @@ -2359,7 +2357,7 @@ let rec push_vars = function | [] -> [] | {unseen = []} :: _ -> assert false | {unseen = p :: ps; seen} :: rem -> - do_push Id_set.empty p ps seen (push_vars rem) + do_push Set_ident.empty p ps seen (push_vars rem) let collect_stable = function | [] -> assert false @@ -2367,11 +2365,11 @@ let collect_stable = function let rec c_rec xss = function | [] -> xss | {seen = yss; _} :: rem -> - let xss = List.map2 Id_set.inter xss yss in + let xss = List.map2 Set_ident.inter xss yss in c_rec xss rem in let inters = c_rec xss rem in - List.fold_left Id_set.union Id_set.empty inters + List.fold_left Set_ident.union Set_ident.empty inters (*********************************************) (* Filtering utilities for our specific rows *) @@ -2470,8 +2468,8 @@ let rec do_stable rs = (* If the first column is incoherent, then all the variables of this matrix are stable. *) List.fold_left - (fun acc (_, {seen; _}) -> List.fold_left Id_set.union acc seen) - Id_set.empty rs + (fun acc (_, {seen; _}) -> List.fold_left Set_ident.union acc seen) + Set_ident.empty rs else (* If the column is ill-typed but deemed coherent, we might spuriously warn about some variables being unstable. @@ -2481,7 +2479,7 @@ let rec do_stable rs = | [] -> do_stable (List.map snd rs) | (_, rs) :: env -> List.fold_left - (fun xs (_, rs) -> Id_set.inter xs (do_stable rs)) + (fun xs (_, rs) -> Set_ident.inter xs (do_stable rs)) (do_stable rs) env) let stable p = do_stable [{unseen = [p]; seen = []}] @@ -2505,13 +2503,13 @@ let stable p = do_stable [{unseen = [p]; seen = []}] *) let all_rhs_idents exp = - let ids = ref Id_set.empty in + let ids = ref Set_ident.empty in let module Iterator = Typedtree_iter.Make_iterator (struct include Typedtree_iter.Default_iterator_argument let enter_expression exp = match exp.exp_desc with | Texp_ident (path, _lid, _descr) -> - List.iter (fun id -> ids := Id_set.add id !ids) (Path.heads path) + List.iter (fun id -> ids := Set_ident.add !ids id) (Path.heads path) | _ -> () (* Very hackish, detect unpack pattern compilation @@ -2531,8 +2529,9 @@ let all_rhs_idents exp = ({exp_desc = Texp_ident (Path.Pident id_exp, _, _)}, _); }, _ ) -> - assert (Id_set.mem id_exp !ids); - if not (Id_set.mem id_mod !ids) then ids := Id_set.remove id_exp !ids + assert (Set_ident.mem !ids id_exp); + if not (Set_ident.mem !ids id_mod) then + ids := Set_ident.remove !ids id_exp | _ -> assert false end) in Iterator.iter_expression exp; @@ -2548,12 +2547,12 @@ let check_ambiguous_bindings = match case with | {c_guard = None; _} -> () | {c_lhs = p; c_guard = Some g; _} -> - let all = Id_set.inter (pattern_vars p) (all_rhs_idents g) in - if not (Id_set.is_empty all) then + let all = Set_ident.inter (pattern_vars p) (all_rhs_idents g) in + if not (Set_ident.is_empty all) then let st = stable p in - let ambiguous = Id_set.diff all st in - if not (Id_set.is_empty ambiguous) then - let pps = Id_set.elements ambiguous |> List.map Ident.name in + let ambiguous = Set_ident.diff all st in + if not (Set_ident.is_empty ambiguous) then + let pps = Set_ident.elements ambiguous |> List.map Ident.name in let warn = Ambiguous_pattern pps in Location.prerr_warning p.pat_loc warn) cases diff --git a/compiler/ml/transl_recmodule.ml b/compiler/ml/transl_recmodule.ml index b3c41ab3eb5..436fb419a27 100644 --- a/compiler/ml/transl_recmodule.ml +++ b/compiler/ml/transl_recmodule.ml @@ -100,7 +100,7 @@ let reorder_rec_bindings bindings = if init.(i) = None then ( status.(i) <- Inprogress; for j = 0 to num_bindings - 1 do - if Ident_set.mem id.(j) fv.(i) then emit_binding j + if Set_ident.mem fv.(i) id.(j) then emit_binding j done); res := (id.(i), init.(i), rhs.(i)) :: !res; status.(i) <- Defined diff --git a/compiler/ml/translmod.ml b/compiler/ml/translmod.ml index e5503ba0eee..cd8125fc221 100644 --- a/compiler/ml/translmod.ml +++ b/compiler/ml/translmod.ml @@ -121,7 +121,7 @@ and wrap_id_pos_list loc id_pos_list get_field lam = let lam, s = List.fold_left (fun (lam, s) (id', pos, c) -> - if Lambda.Ident_set.mem id' fv then + if Set_ident.mem fv id' then let id'' = Ident.create (Ident.name id') in ( Lambda.let_ Alias id'' (apply_coercion loc Alias c (get_field (Ident.name id') pos)) @@ -324,9 +324,7 @@ and transl_structure loc fields cc rootpath final_env = function assert (List.length runtime_fields = List.length pos_cc_list); let v = Ext_array.reverse_of_list fields in let get_field pos = Lambda.var v.(pos) - and ids = - List.fold_right Lambda.Ident_set.add fields Lambda.Ident_set.empty - in + and ids = List.fold_left Set_ident.add Set_ident.empty fields in let get_field_name _name = get_field in let result = List.fold_right @@ -353,7 +351,7 @@ and transl_structure loc fields cc rootpath final_env = function ~args:result loc and id_pos_list = Ext_list.filter id_pos_list (fun (id, _, _) -> - not (Lambda.Ident_set.mem id ids)) + not (Set_ident.mem ids id)) in ( wrap_id_pos_list loc id_pos_list get_field_name lam, List.length pos_cc_list ) From 87d243c65ce6d791bf170e90d1b189a3e3f1a3c4 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 1 Sep 2026 21:28:52 +0200 Subject: [PATCH 45/46] Add changelog entries for the Lambda/Lam merge Three bug fixes and five internal entries, linking PR 8607. Also corrects the constructor comment in lambda.mli, which said six constructors normalize where there are seven. Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- CHANGELOG.md | 8 ++++++++ compiler/ml/lambda.mli | 2 +- 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index d819e75070a..4ff21542f8d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -32,6 +32,9 @@ #### :bug: Bug fix +- Fix a recursive module with an empty signature discarding its right-hand side. Lambda-to-Lam conversion rewrote `Pupdate_mod` to unit when the module's shape had no fields, dropping the primitive's arguments - one of which is the right-hand side - so `module rec M: {} = { let () = Console.log("effect") }` emitted nothing for `M`. The elision now happens where the bindings are produced, with the right-hand side still in hand. https://github.com/rescript-lang/rescript/pull/8607 +- Fix `Int.Ref.increment` and `Int.Ref.decrement` evaluating their argument twice: `Int.Ref.increment(mkRef())` emitted `mkRef().contents = mkRef().contents + 1 | 0`. The `%incr` and `%decr` builtins lowered to an assignment that repeated the argument expression; they now bind the reference before the read-modify-write. Inlining decisions around an increment are taken on the code it stands for rather than on a single primitive node. https://github.com/rescript-lang/rescript/pull/8607 +- Fix a compiler crash on a polymorphic variant whose numeric name exceeds the `int32` range. `#99999999999("a")` and the same name in a pattern failed with `Failure("Int32.of_string")` and no location, because the range check ran in the frontend AST pass and matched only payload-free expressions. It now runs in `Typecore`, next to the integer literal decoding whose overflow error it mirrors, and covers both label positions. A bare `type t = [#99999999999]` still compiles, since nothing decodes a row field name. https://github.com/rescript-lang/rescript/pull/8607 - Object typing errors now describe fields directly: assigning to a field without `@set` reports that the field is not settable and suggests the annotation, and missing-property errors name the field instead of a phantom `"x#="` member. https://github.com/rescript-lang/rescript/pull/8597 - Fix signature inclusion rejecting equivalent object externals after type-alias expansion. https://github.com/rescript-lang/rescript/pull/8581 - Fix externals whose result type is an alias of `unit` so they use the same unit-return behavior as externals declared to return `unit`. https://github.com/rescript-lang/rescript/pull/8581 @@ -60,6 +63,11 @@ #### :house: Internal +- Merge the Lam intermediate representation into Lambda. With conversion already structural, `Lam.t` was `Lambda.lambda` constructor for constructor, so it becomes that type: `Lam_convert` and its one-to-one rebuild are gone, and `Lam`, `Lam_primitive`, `Lam_constant`, `Lam_compat`, `Lam_tag_info`, `Lam_free_variables`, `Lam_subst`, `Lam_iter` and `Lam_print` retire with it. `Lambda.t` is private with a constructor per variant, seven of which normalize as they build, so a pass cannot bypass normalization by writing a constructor directly. Generated JavaScript is unchanged. https://github.com/rescript-lang/rescript/pull/8607 +- Give Lambda the constant and shape decisions conversion used to make: JavaScript null, undefined, `Some`, assert-false, module-alias and nominal-constructor constants are explicit; polymorphic variant runtime names are produced at translation; a block's mutability is derived from its tag info; and a module reference is an `Lglobal_module` name in Lambda too, with the dependencies read off the term. Erasing builtins are classified in the primitive table rather than carried as a `Peliminated` primitive through both layers. https://github.com/rescript-lang/rescript/pull/8607 +- Remove the primitives and passes the merged representation no longer needs: the curried-application machinery (`Primitive_curry._N`, `ap_status`, `Js_call_info.arity`, `Curry_gen`), `%function_arity`, `Poffsetref`, `Poffsetint`, `Pisout` with `E.is_out`, and `Lam_pass_apply_arity` with `Lam_eta_conversion`. An `external` declared as `"%function_arity"`, `"%succint"` or `"%predint"` is now rejected as an unknown builtin. Generated JavaScript is unchanged apart from the operand order of two-value range tests, which was previously decided by whether the offset landed in an addition or a subtraction. https://github.com/rescript-lang/rescript/pull/8607 +- Specialize the switch compiler to Lambda. `Switch.Make` has had a single instantiation since native code generation was dropped, so the functor goes, along with a dead signature member and a location threaded through it for nothing. The range test the switcher wraps around a jump table is folded into the switch's failaction where it is produced, since a JavaScript `switch` has a native `default`; and the guard-clause rewrite that lifts a raising branch out of an `if` becomes a scheduled pass, being code motion rather than normalization. https://github.com/rescript-lang/rescript/pull/8607 +- Add sharing variants of the list and option maps, and a shallow Lambda traversal built on them, so a pass that rewrites nothing returns its input physically unchanged and allocates nothing. Consolidate the four ident set implementations - `Set_ident` plus `Set.Make (Ident)` written out again in `lambda.ml`, `mtype.ml` and `parmatch.ml` - into `Set_ident`. Merge the two Lambda printers, keeping `Printlambda`'s field debug info, block tags and import paths, `Lam_print`'s mutable-block form and file dumps, and tagging every comparison with its operand kind so `Pintcomp`, `Pjscomp` and `Pstringcomp` are no longer all printed `==`. https://github.com/rescript-lang/rescript/pull/8607 - Rework the object-type representation end to end: object rows are plain field chains carrying a per-field mutability state (no phantom setter members), object literals are typed directly and property access and assignment are first-class AST and Lambda nodes shared between the Lambda and JS pipelines, and dead class-system remnants (the field-presence lattice, the class-abbreviation memo on object types, method-send typing) are removed. https://github.com/rescript-lang/rescript/pull/8597 - Upgrade the development toolchain and primary CI builds to OCaml 5.5 while retaining OCaml 5.0 as the minimum supported version. https://github.com/rescript-lang/rescript/pull/8589 - Upgrade the vendored Flow parser from 0.267.0 to 0.320.0, the final release of the OCaml implementation. https://github.com/rescript-lang/rescript/pull/8588 diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index 4ddc6ea8918..895faedfae1 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -451,7 +451,7 @@ val cmp_float : comparison -> float -> float -> bool (* Constructors. [t] is private, so every term outside this module is built through one of these. - Most are plain wrappers. Six normalize as they build, and are the only + Most are plain wrappers. Seven normalize as they build, and are the only place that normalization happens - a pass cannot bypass it by writing a constructor directly: From a0c916bca82045a22318fdcd047c7f53982624aa Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 1 Sep 2026 21:35:37 +0200 Subject: [PATCH 46/46] Point the changelog entries at the actual PR number The predicted number was taken between prediction and creation. Co-Authored-By: Claude Opus 5 (1M context) Claude-Session: https://claude.ai/code/session_01W8g8qwBARAcvW9MyuKQq8H --- CHANGELOG.md | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 4ff21542f8d..23104a040a7 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -32,9 +32,9 @@ #### :bug: Bug fix -- Fix a recursive module with an empty signature discarding its right-hand side. Lambda-to-Lam conversion rewrote `Pupdate_mod` to unit when the module's shape had no fields, dropping the primitive's arguments - one of which is the right-hand side - so `module rec M: {} = { let () = Console.log("effect") }` emitted nothing for `M`. The elision now happens where the bindings are produced, with the right-hand side still in hand. https://github.com/rescript-lang/rescript/pull/8607 -- Fix `Int.Ref.increment` and `Int.Ref.decrement` evaluating their argument twice: `Int.Ref.increment(mkRef())` emitted `mkRef().contents = mkRef().contents + 1 | 0`. The `%incr` and `%decr` builtins lowered to an assignment that repeated the argument expression; they now bind the reference before the read-modify-write. Inlining decisions around an increment are taken on the code it stands for rather than on a single primitive node. https://github.com/rescript-lang/rescript/pull/8607 -- Fix a compiler crash on a polymorphic variant whose numeric name exceeds the `int32` range. `#99999999999("a")` and the same name in a pattern failed with `Failure("Int32.of_string")` and no location, because the range check ran in the frontend AST pass and matched only payload-free expressions. It now runs in `Typecore`, next to the integer literal decoding whose overflow error it mirrors, and covers both label positions. A bare `type t = [#99999999999]` still compiles, since nothing decodes a row field name. https://github.com/rescript-lang/rescript/pull/8607 +- Fix a recursive module with an empty signature discarding its right-hand side. Lambda-to-Lam conversion rewrote `Pupdate_mod` to unit when the module's shape had no fields, dropping the primitive's arguments - one of which is the right-hand side - so `module rec M: {} = { let () = Console.log("effect") }` emitted nothing for `M`. The elision now happens where the bindings are produced, with the right-hand side still in hand. https://github.com/rescript-lang/rescript/pull/8608 +- Fix `Int.Ref.increment` and `Int.Ref.decrement` evaluating their argument twice: `Int.Ref.increment(mkRef())` emitted `mkRef().contents = mkRef().contents + 1 | 0`. The `%incr` and `%decr` builtins lowered to an assignment that repeated the argument expression; they now bind the reference before the read-modify-write. Inlining decisions around an increment are taken on the code it stands for rather than on a single primitive node. https://github.com/rescript-lang/rescript/pull/8608 +- Fix a compiler crash on a polymorphic variant whose numeric name exceeds the `int32` range. `#99999999999("a")` and the same name in a pattern failed with `Failure("Int32.of_string")` and no location, because the range check ran in the frontend AST pass and matched only payload-free expressions. It now runs in `Typecore`, next to the integer literal decoding whose overflow error it mirrors, and covers both label positions. A bare `type t = [#99999999999]` still compiles, since nothing decodes a row field name. https://github.com/rescript-lang/rescript/pull/8608 - Object typing errors now describe fields directly: assigning to a field without `@set` reports that the field is not settable and suggests the annotation, and missing-property errors name the field instead of a phantom `"x#="` member. https://github.com/rescript-lang/rescript/pull/8597 - Fix signature inclusion rejecting equivalent object externals after type-alias expansion. https://github.com/rescript-lang/rescript/pull/8581 - Fix externals whose result type is an alias of `unit` so they use the same unit-return behavior as externals declared to return `unit`. https://github.com/rescript-lang/rescript/pull/8581 @@ -63,11 +63,11 @@ #### :house: Internal -- Merge the Lam intermediate representation into Lambda. With conversion already structural, `Lam.t` was `Lambda.lambda` constructor for constructor, so it becomes that type: `Lam_convert` and its one-to-one rebuild are gone, and `Lam`, `Lam_primitive`, `Lam_constant`, `Lam_compat`, `Lam_tag_info`, `Lam_free_variables`, `Lam_subst`, `Lam_iter` and `Lam_print` retire with it. `Lambda.t` is private with a constructor per variant, seven of which normalize as they build, so a pass cannot bypass normalization by writing a constructor directly. Generated JavaScript is unchanged. https://github.com/rescript-lang/rescript/pull/8607 -- Give Lambda the constant and shape decisions conversion used to make: JavaScript null, undefined, `Some`, assert-false, module-alias and nominal-constructor constants are explicit; polymorphic variant runtime names are produced at translation; a block's mutability is derived from its tag info; and a module reference is an `Lglobal_module` name in Lambda too, with the dependencies read off the term. Erasing builtins are classified in the primitive table rather than carried as a `Peliminated` primitive through both layers. https://github.com/rescript-lang/rescript/pull/8607 -- Remove the primitives and passes the merged representation no longer needs: the curried-application machinery (`Primitive_curry._N`, `ap_status`, `Js_call_info.arity`, `Curry_gen`), `%function_arity`, `Poffsetref`, `Poffsetint`, `Pisout` with `E.is_out`, and `Lam_pass_apply_arity` with `Lam_eta_conversion`. An `external` declared as `"%function_arity"`, `"%succint"` or `"%predint"` is now rejected as an unknown builtin. Generated JavaScript is unchanged apart from the operand order of two-value range tests, which was previously decided by whether the offset landed in an addition or a subtraction. https://github.com/rescript-lang/rescript/pull/8607 -- Specialize the switch compiler to Lambda. `Switch.Make` has had a single instantiation since native code generation was dropped, so the functor goes, along with a dead signature member and a location threaded through it for nothing. The range test the switcher wraps around a jump table is folded into the switch's failaction where it is produced, since a JavaScript `switch` has a native `default`; and the guard-clause rewrite that lifts a raising branch out of an `if` becomes a scheduled pass, being code motion rather than normalization. https://github.com/rescript-lang/rescript/pull/8607 -- Add sharing variants of the list and option maps, and a shallow Lambda traversal built on them, so a pass that rewrites nothing returns its input physically unchanged and allocates nothing. Consolidate the four ident set implementations - `Set_ident` plus `Set.Make (Ident)` written out again in `lambda.ml`, `mtype.ml` and `parmatch.ml` - into `Set_ident`. Merge the two Lambda printers, keeping `Printlambda`'s field debug info, block tags and import paths, `Lam_print`'s mutable-block form and file dumps, and tagging every comparison with its operand kind so `Pintcomp`, `Pjscomp` and `Pstringcomp` are no longer all printed `==`. https://github.com/rescript-lang/rescript/pull/8607 +- Merge the Lam intermediate representation into Lambda. With conversion already structural, `Lam.t` was `Lambda.lambda` constructor for constructor, so it becomes that type: `Lam_convert` and its one-to-one rebuild are gone, and `Lam`, `Lam_primitive`, `Lam_constant`, `Lam_compat`, `Lam_tag_info`, `Lam_free_variables`, `Lam_subst`, `Lam_iter` and `Lam_print` retire with it. `Lambda.t` is private with a constructor per variant, seven of which normalize as they build, so a pass cannot bypass normalization by writing a constructor directly. Generated JavaScript is unchanged. https://github.com/rescript-lang/rescript/pull/8608 +- Give Lambda the constant and shape decisions conversion used to make: JavaScript null, undefined, `Some`, assert-false, module-alias and nominal-constructor constants are explicit; polymorphic variant runtime names are produced at translation; a block's mutability is derived from its tag info; and a module reference is an `Lglobal_module` name in Lambda too, with the dependencies read off the term. Erasing builtins are classified in the primitive table rather than carried as a `Peliminated` primitive through both layers. https://github.com/rescript-lang/rescript/pull/8608 +- Remove the primitives and passes the merged representation no longer needs: the curried-application machinery (`Primitive_curry._N`, `ap_status`, `Js_call_info.arity`, `Curry_gen`), `%function_arity`, `Poffsetref`, `Poffsetint`, `Pisout` with `E.is_out`, and `Lam_pass_apply_arity` with `Lam_eta_conversion`. An `external` declared as `"%function_arity"`, `"%succint"` or `"%predint"` is now rejected as an unknown builtin. Generated JavaScript is unchanged apart from the operand order of two-value range tests, which was previously decided by whether the offset landed in an addition or a subtraction. https://github.com/rescript-lang/rescript/pull/8608 +- Specialize the switch compiler to Lambda. `Switch.Make` has had a single instantiation since native code generation was dropped, so the functor goes, along with a dead signature member and a location threaded through it for nothing. The range test the switcher wraps around a jump table is folded into the switch's failaction where it is produced, since a JavaScript `switch` has a native `default`; and the guard-clause rewrite that lifts a raising branch out of an `if` becomes a scheduled pass, being code motion rather than normalization. https://github.com/rescript-lang/rescript/pull/8608 +- Add sharing variants of the list and option maps, and a shallow Lambda traversal built on them, so a pass that rewrites nothing returns its input physically unchanged and allocates nothing. Consolidate the four ident set implementations - `Set_ident` plus `Set.Make (Ident)` written out again in `lambda.ml`, `mtype.ml` and `parmatch.ml` - into `Set_ident`. Merge the two Lambda printers, keeping `Printlambda`'s field debug info, block tags and import paths, `Lam_print`'s mutable-block form and file dumps, and tagging every comparison with its operand kind so `Pintcomp`, `Pjscomp` and `Pstringcomp` are no longer all printed `==`. https://github.com/rescript-lang/rescript/pull/8608 - Rework the object-type representation end to end: object rows are plain field chains carrying a per-field mutability state (no phantom setter members), object literals are typed directly and property access and assignment are first-class AST and Lambda nodes shared between the Lambda and JS pipelines, and dead class-system remnants (the field-presence lattice, the class-abbreviation memo on object types, method-send typing) are removed. https://github.com/rescript-lang/rescript/pull/8597 - Upgrade the development toolchain and primary CI builds to OCaml 5.5 while retaining OCaml 5.0 as the minimum supported version. https://github.com/rescript-lang/rescript/pull/8589 - Upgrade the vendored Flow parser from 0.267.0 to 0.320.0, the final release of the OCaml implementation. https://github.com/rescript-lang/rescript/pull/8588