From c63b7df2379502cf7a9c3e8c99f4a497189568e1 Mon Sep 17 00:00:00 2001 From: Hyeseong Kim Date: Sun, 14 Jun 2026 04:46:06 +0900 Subject: [PATCH 1/5] TS backend phase 0 - Typed lambda This is a split from #8118 and explains the most basic part of the entire work. Therefore, this should provide sufficient explanation to the LLM agents and should not conflict with other backend modifications (e.g., sourcemap) yet. - Before: Gentype; a separated pipeline that parses and reanalyzes serialized type information. - After: Attach the full type information to the Lambda IR and pass it directly to the codegen backend. Although the compiler's intermediate layer still does not use type information, passing through it simplifying the type-related code generation as it can directly access already computed type information without any extra parsing. Next phases: - 1. Implementing dts file emission: Provide it as an additional option. Stabilizes the dts format independently of the existing JS IR and deprecates Gentype. - 2. Rewriting codegen backend entirely: New, fully-typed, well-structured codegen IR that unifies all the fragmented codegen logic. It should covers JS/TS/d.ts in a single path (Need research. It may not be possible or complicated) - Implementation only: JavaScript output - Type only: d.ts output - Implementation + Type: TypeScript output --- compiler/bsc/rescript_compiler_main.ml | 6 ++ compiler/core/js_implementation.ml | 7 +- compiler/core/lam.ml | 91 +++++++++++++++------ compiler/core/lam.mli | 15 +++- compiler/core/lam_analysis.ml | 4 +- compiler/core/lam_arity_analysis.ml | 2 +- compiler/core/lam_beta_reduce_util.ml | 3 +- compiler/core/lam_bounded_vars.ml | 12 +-- compiler/core/lam_check.ml | 4 +- compiler/core/lam_closure.ml | 2 +- compiler/core/lam_coercion.ml | 2 +- compiler/core/lam_compile.ml | 4 +- compiler/core/lam_compile_main.cppo.ml | 13 ++- compiler/core/lam_convert.ml | 47 ++++++----- compiler/core/lam_eta_conversion.ml | 49 +++++++---- compiler/core/lam_exit_count.ml | 2 +- compiler/core/lam_free_variables.ml | 2 +- compiler/core/lam_hit.ml | 4 +- compiler/core/lam_iter.ml | 4 +- compiler/core/lam_pass_alpha_conversion.ml | 27 +++--- compiler/core/lam_pass_collect.ml | 2 +- compiler/core/lam_pass_count.ml | 4 +- compiler/core/lam_pass_deep_flatten.ml | 27 ++++-- compiler/core/lam_pass_eliminate_ref.ml | 10 ++- compiler/core/lam_pass_exits.ml | 14 ++-- compiler/core/lam_pass_lets_dce.ml | 32 +++++--- compiler/core/lam_pass_remove_alias.ml | 32 ++++++-- compiler/core/lam_print.ml | 6 +- compiler/core/lam_scc.ml | 7 +- compiler/core/lam_subst.ml | 14 ++-- compiler/core/lam_ts_emit.ml | 92 +++++++++++++++++++++ compiler/core/lam_type_dump.ml | 95 ++++++++++++++++++++++ compiler/core/lam_util.cppo.ml | 15 ++-- compiler/core/polyvar_pattern_match.ml | 2 +- compiler/jsoo/jsoo_playground_main.ml | 13 +-- compiler/ml/clflags.ml | 4 + compiler/ml/clflags.mli | 2 + compiler/ml/lambda.ml | 41 +++++----- compiler/ml/lambda.mli | 10 ++- compiler/ml/matching.ml | 16 ++-- compiler/ml/printlambda.ml | 24 ++---- compiler/ml/transl_recmodule.ml | 8 +- compiler/ml/translcore.ml | 52 +++++++----- compiler/ml/translmod.ml | 26 +++--- compiler/ml/translmod.mli | 3 +- 45 files changed, 590 insertions(+), 261 deletions(-) create mode 100644 compiler/core/lam_ts_emit.ml create mode 100644 compiler/core/lam_type_dump.ml diff --git a/compiler/bsc/rescript_compiler_main.ml b/compiler/bsc/rescript_compiler_main.ml index 24023535e0c..71070b14215 100644 --- a/compiler/bsc/rescript_compiler_main.ml +++ b/compiler/bsc/rescript_compiler_main.ml @@ -397,6 +397,12 @@ let command_line_flags : (string * Bsc_args.spec * string) array = ("-dtypedtree", set Clflags.dump_typedtree, "*internal* debug typedtree"); ("-dparsetree", set Clflags.dump_parsetree, "*internal* debug parsetree"); ("-drawlambda", set Clflags.dump_rawlambda, "*internal* debug raw lambda"); + ( "-dlamtypes", + set Clflags.dump_lamtypes, + "*internal* dump Lam IR type annotations" ); + ( "-emit-typedefs", + set Clflags.emit_typedefs, + "*internal* emit .d.ts declarations" ); ("-dsource", set Clflags.dump_source, "*internal* print source"); ( "-reprint-source", string_call reprint_source_file, diff --git a/compiler/core/js_implementation.ml b/compiler/core/js_implementation.ml index df6ab959d12..7603253b51d 100644 --- a/compiler/core/js_implementation.ml +++ b/compiler/core/js_implementation.ml @@ -133,7 +133,7 @@ let after_parsing_impl ppf outputprefix (ast : Parsetree.structure) = Lam_compile_env.reset (); let env = Res_compmisc.initial_env ~modulename () in Env.set_unit_name modulename; - let typedtree, coercion, _, _ = + let typedtree, coercion, finalenv, _ = Typemod.type_implementation_more ?check_exists:(if !Js_config.force_cmi then None else Some ()) !Location.input_name outputprefix modulename env ast @@ -143,8 +143,9 @@ let after_parsing_impl ppf outputprefix (ast : Parsetree.structure) = Printtyped.implementation_with_coercion typedtree_coercion; (if !Js_config.cmi_only then Warnings.check_fatal () else - let lambda, exports = - Translmod.transl_implementation modulename typedtree_coercion + let env, lambda, exports = + Translmod.transl_implementation modulename finalenv + typedtree_coercion in let js_program = print_if_pipe ppf Clflags.dump_rawlambda Printlambda.lambda lambda diff --git a/compiler/core/lam.ml b/compiler/core/lam.ml index 15875608b97..8276b05f8d9 100644 --- a/compiler/core/lam.ml +++ b/compiler/core/lam.ml @@ -31,7 +31,7 @@ type ap_info = { ap_status: apply_status; } -module Types = struct +module Lam_types = struct type lambda_switch = { sw_consts_full: bool; (* TODO: refine its representation *) @@ -47,6 +47,7 @@ module Types = struct params: ident list; body: t; attr: Lambda.function_attribute; + ty: Types.type_expr option; } (* @@ -86,6 +87,7 @@ module Types = struct ap_args: t list; ap_info: ap_info; ap_transformed_jsx: bool; + ap_result_type: Types.type_expr option; } and t = @@ -94,7 +96,7 @@ module Types = struct | Lconst of Lam_constant.t | Lapply of apply | Lfunction of lfunction - | Llet of Lam_compat.let_kind * ident * t * t + | Llet of Lam_compat.let_kind * ident * Types.type_expr option * t * t | Lletrec of (ident * t) list * t | Lprim of prim_info | Lswitch of t * lambda_switch @@ -115,7 +117,7 @@ module Types = struct end module X = struct - type lambda_switch = Types.lambda_switch = { + type lambda_switch = Lam_types.lambda_switch = { sw_consts_full: bool; sw_consts: (int * t) list; sw_blocks_full: bool; @@ -124,33 +126,35 @@ module X = struct sw_names: Ast_untagged_variants.switch_names option; } - and prim_info = Types.prim_info = { + and prim_info = Lam_types.prim_info = { primitive: Lam_primitive.t; args: t list; loc: Location.t; } - and apply = Types.apply = { + and apply = Lam_types.apply = { ap_func: t; ap_args: t list; ap_info: ap_info; ap_transformed_jsx: bool; + ap_result_type: Types.type_expr option; } - and lfunction = Types.lfunction = { + and lfunction = Lam_types.lfunction = { arity: int; params: ident list; body: t; attr: Lambda.function_attribute; + ty: Types.type_expr option; } - and t = Types.t = + and t = Lam_types.t = | Lvar of ident | Lglobal_module of ident * bool | Lconst of Lam_constant.t | Lapply of apply | Lfunction of lfunction - | Llet of Lam_compat.let_kind * ident * t * t + | Llet of Lam_compat.let_kind * ident * Types.type_expr option * t * t | Lletrec of (ident * t) list * t | Lprim of prim_info | Lswitch of t * lambda_switch @@ -170,24 +174,24 @@ module X = struct (* | Lsend of Lam_compat.meth_kind * t * t * t list * Location.t *) end -include Types +include Lam_types (** apply [f] to direct successor which has type [Lam.t] *) let inner_map (l : t) (f : t -> X.t) : X.t = match l with | Lvar (_ : ident) | Lconst (_ : Lam_constant.t) -> ((* Obj.magic *) l : X.t) - | Lapply {ap_func; ap_args; ap_info; ap_transformed_jsx} -> + | Lapply {ap_func; ap_args; ap_info; ap_transformed_jsx; ap_result_type} -> let ap_func = f ap_func in let ap_args = Ext_list.map ap_args f in - Lapply {ap_func; ap_args; ap_info; ap_transformed_jsx} - | Lfunction {body; arity; params; attr} -> + Lapply {ap_func; ap_args; ap_info; ap_transformed_jsx; ap_result_type} + | Lfunction {body; arity; params; attr; ty} -> let body = f body in - Lfunction {body; arity; params; attr} - | Llet (str, id, arg, body) -> + Lfunction {body; arity; params; attr; ty} + | Llet (str, id, ty, arg, body) -> let arg = f arg in let body = f body in - Llet (str, id, arg, body) + Llet (str, id, ty, arg, body) | Lletrec (decl, body) -> let body = f body in let decl = Ext_list.map_snd decl f in @@ -307,7 +311,8 @@ let rec is_eta_conversion_exn params inner_args outer_args : t list = | _, _, _ -> 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 = +let rec apply ?(ap_transformed_jsx = false) + ~(ap_result_type : Types.type_expr option) fn args (ap_info : ap_info) : t = match fn with | Lfunction { @@ -328,7 +333,14 @@ let rec apply ?(ap_transformed_jsx = false) fn args (ap_info : ap_info) : t = 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}) + Lapply + { + ap_func = fn; + ap_args = args; + ap_info; + ap_transformed_jsx; + ap_result_type; + }) | Lfunction { params; @@ -337,7 +349,14 @@ let rec apply ?(ap_transformed_jsx = false) fn args (ap_info : ap_info) : t = 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}) + Lapply + { + ap_func = fn; + ap_args = args; + ap_info; + ap_transformed_jsx; + ap_result_type; + }) | Lfunction { params; @@ -350,17 +369,37 @@ let rec apply ?(ap_transformed_jsx = false) fn args (ap_info : ap_info) : t = | 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} + Lapply + { + ap_func = fn; + ap_args = args; + ap_info; + ap_transformed_jsx; + ap_result_type; + } (* | 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 (kind, id, ty, e, (Lfunction _ as fn)) -> + Llet + ( kind, + id, + ty, + e, + apply fn args ap_info ~ap_transformed_jsx ~ap_result_type ) (* | 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} + | _ -> + Lapply + { + ap_func = fn; + ap_args = args; + ap_info; + ap_transformed_jsx; + ap_result_type; + } let rec eq_approx (l1 : t) (l2 : t) = match l1 with @@ -419,7 +458,7 @@ let rec eq_approx (l1 : t) (l2 : t) = (fun ((k : string), v) (k2, v2) -> k = k2 && eq_approx v v2) | _ -> false) | Lfunction _ - | Llet (_, _, _, _) + | Llet (_, _, _, _, _) | Lletrec _ | Lswitch _ | Lstaticcatch _ | Ltrywith _ | Lfor (_, _, _, _, _) | Lfor_of (_, _, _) @@ -475,10 +514,10 @@ let global_module ?(dynamic_import = false) id = Lglobal_module (id, dynamic_import) let const ct : t = Lconst ct -let function_ ~attr ~arity ~params ~body : t = - Lfunction {arity; params; body; attr} +let function_ ~attr ~arity ~params ~body ~ty : t = + Lfunction {arity; params; body; attr; ty} -let let_ kind id e body : t = Llet (kind, id, e, body) +let let_ kind id ty e body : t = Llet (kind, id, ty, 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) diff --git a/compiler/core/lam.mli b/compiler/core/lam.mli index f6a398d677b..ed921fc6ce6 100644 --- a/compiler/core/lam.mli +++ b/compiler/core/lam.mli @@ -46,6 +46,7 @@ and apply = private { ap_args: t list; ap_info: ap_info; ap_transformed_jsx: bool; + ap_result_type: Types.type_expr option; } and lfunction = { @@ -53,6 +54,7 @@ and lfunction = { params: ident list; body: t; attr: Lambda.function_attribute; + ty: Types.type_expr option; } and prim_info = private { @@ -67,7 +69,7 @@ and t = private | Lconst of Lam_constant.t | Lapply of apply | Lfunction of lfunction - | Llet of Lam_compat.let_kind * ident * t * t + | Llet of Lam_compat.let_kind * ident * Types.type_expr option * t * t | Lletrec of (ident * t) list * t | Lprim of prim_info | Lswitch of t * lambda_switch @@ -113,16 +115,23 @@ val global_module : ?dynamic_import:bool -> ident -> t val const : Lam_constant.t -> t -val apply : ?ap_transformed_jsx:bool -> t -> t list -> ap_info -> t +val apply : + ?ap_transformed_jsx:bool -> + ap_result_type:Types.type_expr option -> + t -> + t list -> + ap_info -> + t val function_ : attr:Lambda.function_attribute -> arity:int -> params:ident list -> body:t -> + ty:Types.type_expr option -> t -val let_ : Lam_compat.let_kind -> ident -> t -> t -> t +val let_ : Lam_compat.let_kind -> ident -> Types.type_expr option -> t -> t -> t val letrec : (ident * t) list -> t -> t diff --git a/compiler/core/lam_analysis.ml b/compiler/core/lam_analysis.ml index 29a8d3a1602..daf85b418f1 100644 --- a/compiler/core/lam_analysis.ml +++ b/compiler/core/lam_analysis.ml @@ -102,7 +102,7 @@ let rec no_side_effects (lam : Lam.t) : bool = (* byte swap *) | Parraysets | Parraysetu | Poffsetref _ | Praise | Psetfield _ -> false) - | Llet (_, _, arg, body) -> no_side_effects arg && no_side_effects body + | Llet (_, _, _, arg, body) -> no_side_effects arg && no_side_effects body | Lswitch (_, _) -> false | Lstringswitch (_, _, _) -> false | Lstaticraise _ -> false @@ -149,7 +149,7 @@ let rec size (lam : Lam.t) = match lam with | Lvar _ -> 1 | Lconst c -> size_constant c - | Llet (_, _, l1, l2) -> 1 + size l1 + size l2 + | Llet (_, _, _, l1, l2) -> 1 + size l1 + size l2 | Lletrec _ -> really_big () | Lprim { diff --git a/compiler/core/lam_arity_analysis.ml b/compiler/core/lam_arity_analysis.ml index 5a5d4bbccda..9527adc3677 100644 --- a/compiler/core/lam_arity_analysis.ml +++ b/compiler/core/lam_arity_analysis.ml @@ -39,7 +39,7 @@ let rec get_arity (meta : Lam_stats.t) (lam : Lam.t) : Lam_arity.t = match lam with | Lvar v -> arity_of_var meta v | Lconst _ -> Lam_arity.non_function_arity_info - | Llet (_, _, _, l) -> get_arity meta l + | Llet (_, _, _, _, l) -> get_arity meta l | Lprim { primitive = Pfield (_, Fld_module {name}); diff --git a/compiler/core/lam_beta_reduce_util.ml b/compiler/core/lam_beta_reduce_util.ml index c1855dec203..c685539740f 100644 --- a/compiler/core/lam_beta_reduce_util.ml +++ b/compiler/core/lam_beta_reduce_util.ml @@ -113,7 +113,8 @@ 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 + (Lam.apply ~ap_result_type:None f new_args ap_info) (fun _param stat acc -> let {lambda; used} = stat in if not used then Lam.seq lambda acc else acc) diff --git a/compiler/core/lam_bounded_vars.ml b/compiler/core/lam_bounded_vars.ml index 5499bb77ab4..c29de6a262f 100644 --- a/compiler/core/lam_bounded_vars.ml +++ b/compiler/core/lam_bounded_vars.ml @@ -75,11 +75,11 @@ let rewrite (map : _ Hash_ident.t) (lam : Lam.t) : Lam.t = and aux (lam : Lam.t) : Lam.t = match lam with | Lvar v -> Hash_ident.find_default map v lam - | Llet (str, v, l1, l2) -> + | Llet (str, v, ty, l1, l2) -> let v = rebind v in let l1 = aux l1 in let l2 = aux l2 in - Lam.let_ str v l1 l2 + Lam.let_ str v ty l1 l2 | Lletrec (bindings, body) -> (*order matters see GPR #405*) let vars = Ext_list.map bindings (fun (k, _) -> rebind k) in @@ -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} -> + | Lfunction {arity; params; body; attr; ty} -> let params = Ext_list.map params rebind in let body = aux body in - Lam.function_ ~arity ~params ~body ~attr + Lam.function_ ~arity ~params ~body ~attr ~ty | Lstaticcatch (l1, (i, xs), l2) -> let l1 = aux l1 in let xs = Ext_list.map xs rebind in @@ -118,10 +118,10 @@ let rewrite (map : _ Hash_ident.t) (lam : Lam.t) : Lam.t = (* here it makes sure that global vars are not rebound *) Lam.prim ~primitive ~args:(Ext_list.map args aux) loc | Lglobal_module _ -> lam - | Lapply {ap_func; ap_args; ap_info; ap_transformed_jsx} -> + | Lapply {ap_func; ap_args; ap_info; ap_transformed_jsx; ap_result_type} -> let fn = aux ap_func in let args = Ext_list.map ap_args aux in - Lam.apply ~ap_transformed_jsx fn args ap_info + Lam.apply ~ap_transformed_jsx ~ap_result_type fn args ap_info | Lswitch ( l, { diff --git a/compiler/core/lam_check.ml b/compiler/core/lam_check.ml index f5e63d45afe..668c2384b02 100644 --- a/compiler/core/lam_check.ml +++ b/compiler/core/lam_check.ml @@ -69,7 +69,7 @@ let check file lam = check_staticfails e1 cxt; check_staticfails e2 Set_int.empty | Lbreak | Lcontinue -> () - | Llet (_str, _id, arg, body) -> check_list [arg; body] cxt + | Llet (_str, _id, _, arg, body) -> check_list [arg; body] cxt | Lletrec (decl, body) -> check_list_snd decl cxt; check_staticfails body cxt @@ -110,7 +110,7 @@ let check file lam = | Lfunction {body; params} -> List.iter def params; iter body - | Llet (_str, id, arg, body) -> + | Llet (_str, id, _, arg, body) -> iter arg; def id; iter body diff --git a/compiler/core/lam_closure.ml b/compiler/core/lam_closure.ml index 2092c92b9ff..62ea8269c40 100644 --- a/compiler/core/lam_closure.ml +++ b/compiler/core/lam_closure.ml @@ -80,7 +80,7 @@ let free_variables (export_idents : Set_ident.t) (params : stats Map_ident.t) | Lfunction {params; body} -> local_add_list params; iter sink_pos body (* Do we need continue *) - | Llet (_, id, arg, body) -> + | Llet (_, id, _, arg, body) -> iter top arg; local_add id; iter sink_pos body diff --git a/compiler/core/lam_coercion.ml b/compiler/core/lam_coercion.ml index 2ddddc7cfd0..60e3edbbe8c 100644 --- a/compiler/core/lam_coercion.ml +++ b/compiler/core/lam_coercion.ml @@ -179,7 +179,7 @@ let handle_exports (meta : Lam_stats.t) (lambda_exports : Lam.t list) let rec flatten (acc : Lam_group.t list) (lam : Lam.t) : Lam.t * Lam_group.t list = match lam with - | Llet (str, id, arg, body) -> + | Llet (str, id, _, arg, body) -> let res, l = flatten acc arg in flatten (Single (str, id, res) :: l) body | Lletrec (bind_args, body) -> flatten (Recursive bind_args :: acc) body diff --git a/compiler/core/lam_compile.ml b/compiler/core/lam_compile.ml index 97f6bec84e5..2da884f2330 100644 --- a/compiler/core/lam_compile.ml +++ b/compiler/core/lam_compile.ml @@ -1545,7 +1545,7 @@ let compile output_prefix = else {outer_ap_info with ap_inlined} in compile_lambda lambda_cxt - (Lam.apply ap_func + (Lam.apply ~ap_result_type:appinfo.ap_result_type 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*) @@ -1859,7 +1859,7 @@ let compile output_prefix = } body))) | Lapply appinfo -> compile_apply appinfo lambda_cxt - | Llet (let_kind, id, arg, body) -> + | Llet (let_kind, id, _, arg, body) -> (* Order matters.. see comment below in [Lletrec] *) let args_code = compile_lambda diff --git a/compiler/core/lam_compile_main.cppo.ml b/compiler/core/lam_compile_main.cppo.ml index cdecf32ef8e..ae7674f78df 100644 --- a/compiler/core/lam_compile_main.cppo.ml +++ b/compiler/core/lam_compile_main.cppo.ml @@ -210,10 +210,21 @@ let compile #endif in - let ({Lam_coercion.groups = groups } as coerced_input , meta) = + if !Clflags.dump_lamtypes then + Lam_type_dump.collect lam; + + let ({Lam_coercion.groups = groups; export_map = _} as coerced_input , meta) = Lam_coercion.coerce_and_group_big_lambda meta lam in + if !Clflags.emit_typedefs then begin + let dts_name = + Ext_filename.new_extension !Location.input_name ".d.ts" + in + Ext_fmt.with_file_as_pp dts_name (fun ppf -> + Lam_ts_emit.emit_decls ppf groups meta.exports) + end; + #ifndef RELEASE let () = Ext_log.dwarn ~__POS__ "After coercion: %a@." Lam_stats.print meta ; diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index 9e0bccdaa93..0491e7c7f02 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -86,7 +86,7 @@ let exception_id_destructed (l : Lam.t) (fv : Ident.t) : bool = | Lstaticcatch (e1, (_, _vars), e2) -> hit e1 || hit e2 | Ltrywith (e1, _exn, e2) -> hit e1 || hit e2 | Lfunction {body; params = _} -> hit body - | Llet (_str, _id, arg, body) -> hit arg || hit body + | Llet (_str, _id, _, arg, body) -> hit arg || hit body | Lletrec (decl, body) -> hit body || hit_list_snd decl | Lfor (_v, e1, e2, _dir, e3) -> hit e1 || hit e2 || hit e3 | Lfor_of (_v, e1, e2) | Lfor_await_of (_v, e1, e2) -> hit e1 || hit e2 @@ -326,21 +326,22 @@ let rec rename_optional_parameters map params (body : Lambda.lambda) = match body with | Llet ( k, - value_kind, id, + ty, Lifthenelse ( Lprim (p, [Lvar ({name = "*opt*"} as opt)], p_loc), Lprim (p1, [Lvar ({name = "*opt*"} as opt2)], x_loc), f ), rest ) - when Ident.same opt opt2 && List.mem opt params -> + when Ident.same opt opt2 + && List.exists (fun (p, _) -> Ident.same p opt) params -> let map, rest = rename_optional_parameters map params rest in let new_id = Ident.create (id.name ^ "Opt") in ( Map_ident.add map opt new_id, Lambda.Llet ( k, - value_kind, id, + ty, Lifthenelse ( Lprim (p, [Lvar new_id], p_loc), Lprim (p1, [Lvar new_id], x_loc), @@ -379,7 +380,7 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : match lam with | Lvar x -> Lam.var (Hash_ident.find_default alias_tbl x x) | Lconst x -> Lam.const (Lam_constant_convert.convert_constant x) - | Lapply {ap_func = Lsend (name, obj, loc); ap_args} + | Lapply {ap_func = Lsend (name, obj, loc); ap_args; _} when Ext_string.ends_with name Literals.setter_suffix -> let obj = convert_aux obj in let args = obj :: Ext_list.map ap_args convert_aux in @@ -402,25 +403,27 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : ap_loc = loc; ap_inlined; ap_transformed_jsx; + ap_result_type; } -> - (* 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 - | Lfunction {params; body; attr} -> + ~ap_transformed_jsx ~ap_result_type + | Lfunction {params; body; attr; ty} -> let new_map, body = rename_optional_parameters Map_ident.empty params body in + let strip_types params = Ext_list.map params fst in if Map_ident.is_empty new_map then - Lam.function_ ~attr ~arity:(List.length params) ~params - ~body:(convert_aux body) + Lam.function_ ~attr ~arity:(List.length params) + ~params:(strip_types params) ~body:(convert_aux body) ~ty else let params = - Ext_list.map params (fun x -> Map_ident.find_default new_map x x) + Ext_list.map params (fun (x, _ty) -> + (Map_ident.find_default new_map x x, _ty)) in - Lam.function_ ~attr ~arity:(List.length params) ~params - ~body:(convert_aux body) + Lam.function_ ~attr ~arity:(List.length params) + ~params:(strip_types params) ~body:(convert_aux body) ~ty | Llet (_, _, _, Lprim (Pgetglobal id, args, _), _body) when dynamic_import -> (* @@ -437,7 +440,7 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : may_depend may_depends (Lam_module_ident.of_ml ~dynamic_import id); assert (args = []); Lam.global_module ~dynamic_import id - | Llet (kind, Pgenval, id, e, body) (*FIXME*) -> convert_let kind id e body + | Llet (kind, id, ty, e, body) -> convert_let kind id ty e body | Lletrec (bindings, body) -> let bindings = Ext_list.map_snd bindings convert_aux in let body = convert_aux body in @@ -500,7 +503,7 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : if exception_id_destructed handler id then let new_id = Ident.create ("raw_" ^ id.name) in Lam.try_ body new_id - (Lam.let_ StrictOpt id + (Lam.let_ StrictOpt id None (prim ~primitive:Pwrap_exn ~args:[Lam.var new_id] Location.none) handler) else Lam.try_ body id handler @@ -517,14 +520,14 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : | Lfor_await_of (id, iterable, body) -> Lam.for_await_of id (convert_aux iterable) (convert_aux body) | Lassign (id, body) -> Lam.assign id (convert_aux body) - and convert_let (kind : Lam_compat.let_kind) id (e : Lambda.lambda) body : - Lam.t = + and convert_let (kind : Lam_compat.let_kind) id (ty : Types.type_expr option) + (e : Lambda.lambda) body : Lam.t = match (kind, e) with | Alias, Lvar u -> let new_u = Hash_ident.find_default alias_tbl u u in Hash_ident.add alias_tbl id new_u; if Set_ident.mem exports id then - Lam.let_ kind id (Lam.var new_u) (convert_aux body) + Lam.let_ kind id ty (Lam.var new_u) (convert_aux body) else convert_aux body | _, _ -> ( let new_e = convert_aux e in @@ -564,7 +567,7 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : sw_consts = Ext_list.map sw_consts (fun (i, act) -> (i - offset, act)); } - | _ -> Lam.let_ kind id new_e new_body) + | _ -> Lam.let_ kind id ty new_e new_body) and convert_pipe (f : Lambda.lambda) (x : Lambda.lambda) outer_loc = let x = convert_aux x in let f = convert_aux f in @@ -582,8 +585,8 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : when Ext_list.for_all2_no_exn inner_args params lam_is_var && Ext_list.length_larger_than_n inner_args args 1 -> Lam.prim ~primitive ~args:(Ext_list.append_one args x) outer_loc - | Lapply {ap_func; ap_args; ap_info; ap_transformed_jsx} -> - Lam.apply ~ap_transformed_jsx ap_func + | Lapply {ap_func; ap_args; ap_info; ap_transformed_jsx; ap_result_type} -> + Lam.apply ~ap_transformed_jsx ~ap_result_type ap_func (Ext_list.append_one ap_args x) { ap_loc = outer_loc; @@ -591,7 +594,7 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : ap_status = App_na; } | _ -> - Lam.apply f [x] + Lam.apply ~ap_result_type:None f [x] {ap_loc = outer_loc; ap_inlined = Default_inline; ap_status = App_na} and convert_switch (e : Lambda.lambda) (s : Lambda.lambda_switch) = let e = convert_aux e in diff --git a/compiler/core/lam_eta_conversion.ml b/compiler/core/lam_eta_conversion.ml index 220fa760221..cbfbd65664c 100644 --- a/compiler/core/lam_eta_conversion.ml +++ b/compiler/core/lam_eta_conversion.ml @@ -63,15 +63,23 @@ let transform_under_supply n ap_info fn args = *) Lam.function_ ~arity:n ~params:extra_args ~attr:Lambda.default_function_attribute - ~body:(Lam.apply fn (Ext_list.append args extra_lambdas) ap_info) + ~body: + (Lam.apply ~ap_result_type:None fn + (Ext_list.append args extra_lambdas) + ap_info) + ~ty:None | fn :: args, bindings -> let rest : Lam.t = Lam.function_ ~arity:n ~params:extra_args ~attr:Lambda.default_function_attribute - ~body:(Lam.apply fn (Ext_list.append args extra_lambdas) ap_info) + ~body: + (Lam.apply ~ap_result_type:None fn + (Ext_list.append args extra_lambdas) + ap_info) + ~ty:None in Ext_list.fold_left bindings rest (fun lam (id, x) -> - Lam.let_ Strict id x lam) + Lam.let_ Strict id None x lam) | _, _ -> assert false (* Invariant: mk0 : (unit -> 'a0) -> 'a0 t @@ -126,7 +134,8 @@ let unsafe_adjust_to_arity loc ~(to_ : int) ?(from : int option) (fn : Lam.t) : | Lfunction {params = [param]; body} -> Lam.function_ ~arity:0 ~attr:Lambda.default_function_attribute ~params:[] - ~body:(Lam.let_ Alias param Lam.unit body) + ~body:(Lam.let_ Alias param None Lam.unit body) + ~ty:None (* could be only introduced by {[ Pjs_fn_make 0 ]} <- {[ fun [@bs] () -> .. ]} @@ -150,12 +159,13 @@ let unsafe_adjust_to_arity loc ~(to_ : int) ?(from : int option) (fn : Lam.t) : let cont = Lam.function_ ~attr:Lambda.default_function_attribute ~arity:0 ~params:[] - ~body:(Lam.apply new_fn [Lam.unit] ap_info) + ~body:(Lam.apply ~ap_result_type:None new_fn [Lam.unit] ap_info) + ~ty:None in match wrapper with | None -> cont - | Some partial_arg -> Lam.let_ Strict partial_arg fn cont) + | Some partial_arg -> Lam.let_ Strict partial_arg None fn cont) else if to_ > from then match fn with | Lfunction {params; body} -> @@ -168,11 +178,13 @@ let unsafe_adjust_to_arity loc ~(to_ : int) ?(from : int option) (fn : Lam.t) : let rec mk_apply body vars = match vars with | [] -> body - | var :: vars -> mk_apply (Lam.apply body [var] ap_info) vars + | var :: vars -> + mk_apply (Lam.apply ~ap_result_type:None body [var] ap_info) vars in Lam.function_ ~attr:Lambda.default_function_attribute ~arity:to_ ~params:(Ext_list.append params extra_args) ~body:(mk_apply body (Ext_list.map extra_args Lam.var)) + ~ty:None | _ -> ( let arity = to_ in let extra_args = @@ -197,16 +209,17 @@ let unsafe_adjust_to_arity loc ~(to_ : int) ?(from : int option) (fn : Lam.t) : ~params:extra_args ~body: (let first_args, rest_args = Ext_list.split_at extra_args from in - Lam.apply - (Lam.apply new_fn + Lam.apply ~ap_result_type:None + (Lam.apply ~ap_result_type:None new_fn (Ext_list.map first_args Lam.var) {ap_info with ap_status = App_infer_full}) (Ext_list.map rest_args Lam.var) ap_info) + ~ty:None in match wrapper with | None -> cont - | Some partial_arg -> Lam.let_ Strict partial_arg fn cont) + | Some partial_arg -> Lam.let_ Strict partial_arg None fn cont) else (* add3 --adjust to arity 1 -> fun x -> (fun y z -> add3 x y z ) @@ -227,7 +240,8 @@ let unsafe_adjust_to_arity loc ~(to_ : int) ?(from : int option) (fn : Lam.t) : ~body: (Lam.function_ ~arity:(from - to_) ~attr:Lambda.default_function_attribute ~params:extra_inner_args - ~body) + ~body ~ty:None) + ~ty:None | _ -> ( let extra_outer_args = Ext_list.init to_ (fun _ -> Ident.create Literals.param) @@ -257,15 +271,17 @@ let unsafe_adjust_to_arity loc ~(to_ : int) ?(from : int option) (fn : Lam.t) : Lam.function_ ~arity ~params:extra_inner_args ~attr:Lambda.default_function_attribute ~body: - (Lam.apply new_fn + (Lam.apply ~ap_result_type:None new_fn (Ext_list.map_append extra_outer_args (Ext_list.map extra_inner_args Lam.var) Lam.var) - {ap_info with ap_status = App_infer_full})) + {ap_info with ap_status = App_infer_full}) + ~ty:None) + ~ty:None in match wrapper with | None -> cont - | Some partial_arg -> Lam.let_ Strict partial_arg fn cont)) + | Some partial_arg -> Lam.let_ Strict partial_arg None fn cont)) | None, _ -> (* In this case [fn] is not [Lfunction], otherwise we would get [arity] *) if to_ = 0 then @@ -287,12 +303,13 @@ let unsafe_adjust_to_arity loc ~(to_ : int) ?(from : int option) (fn : Lam.t) : let cont = Lam.function_ ~attr:Lambda.default_function_attribute ~arity:0 ~params:[] - ~body:(Lam.apply new_fn [Lam.unit] ap_info) + ~body:(Lam.apply ~ap_result_type:None new_fn [Lam.unit] ap_info) + ~ty:None in match wrapper with | None -> cont - | Some partial_arg -> Lam.let_ Strict partial_arg fn cont + | Some partial_arg -> Lam.let_ Strict partial_arg None fn cont else transform_under_supply to_ ap_info fn [] (* | _ -> diff --git a/compiler/core/lam_exit_count.ml b/compiler/core/lam_exit_count.ml index 045435a44e8..20679b61e44 100644 --- a/compiler/core/lam_exit_count.ml +++ b/compiler/core/lam_exit_count.ml @@ -67,7 +67,7 @@ let count_helper (lam : Lam.t) : collection = count ap_func; Ext_list.iter ap_args count | Lfunction {body} -> count body - | Llet (_, _, l1, l2) -> + | Llet (_, _, _, l1, l2) -> count l2; count l1 | Lletrec (bindings, body) -> diff --git a/compiler/core/lam_free_variables.ml b/compiler/core/lam_free_variables.ml index d269c78c7cb..6e6e2153790 100644 --- a/compiler/core/lam_free_variables.ml +++ b/compiler/core/lam_free_variables.ml @@ -44,7 +44,7 @@ let pass_free_variables (l : Lam.t) : Set_ident.t = | Lfunction {body; params} -> free body; Ext_list.iter params (fun param -> fv := Set_ident.remove !fv param) - | Llet (_str, id, arg, body) -> + | Llet (_str, id, _, arg, body) -> free arg; free body; fv := Set_ident.remove !fv id diff --git a/compiler/core/lam_hit.ml b/compiler/core/lam_hit.ml index fba5f7bdf74..0b81b21b9d7 100644 --- a/compiler/core/lam_hit.ml +++ b/compiler/core/lam_hit.ml @@ -40,7 +40,7 @@ let hit_variables (fv : Set_ident.t) (l : t) : bool = | Lstaticcatch (e1, (_, _vars), e2) -> hit e1 || hit e2 | Ltrywith (e1, _exn, e2) -> hit e1 || hit e2 | Lfunction {body; params = _} -> hit body - | Llet (_str, _id, arg, body) -> hit arg || hit body + | Llet (_str, _id, _, arg, body) -> hit arg || hit body | Lletrec (decl, body) -> hit body || hit_list_snd decl | Lfor (_v, e1, e2, _dir, e3) -> hit e1 || hit e2 || hit e3 | Lfor_of (_v, e1, e2) | Lfor_await_of (_v, e1, e2) -> hit e1 || hit e2 @@ -77,7 +77,7 @@ let hit_variable (fv : Ident.t) (l : t) : bool = | Lstaticcatch (e1, (_, _vars), e2) -> hit e1 || hit e2 | Ltrywith (e1, _exn, e2) -> hit e1 || hit e2 | Lfunction {body; params = _} -> hit body - | Llet (_str, _id, arg, body) -> hit arg || hit body + | Llet (_str, _id, _, arg, body) -> hit arg || hit body | Lletrec (decl, body) -> hit body || hit_list_snd decl | Lfor (_v, e1, e2, _dir, e3) -> hit e1 || hit e2 || hit e3 | Lfor_of (_v, e1, e2) | Lfor_await_of (_v, e1, e2) -> hit e1 || hit e2 diff --git a/compiler/core/lam_iter.ml b/compiler/core/lam_iter.ml index eae83894b77..c5edaef6f23 100644 --- a/compiler/core/lam_iter.ml +++ b/compiler/core/lam_iter.ml @@ -33,7 +33,7 @@ let inner_iter (l : t) (f : t -> unit) : unit = f ap_func; List.iter f ap_args | Lfunction {body; arity = _; params = _} -> f body - | Llet (_str, _id, arg, body) -> + | Llet (_str, _id, _, arg, body) -> f arg; f body | Lletrec (decl, body) -> @@ -94,7 +94,7 @@ let inner_exists (l : t) (f : t -> bool) : bool = | Lapply {ap_func; ap_args; ap_info = _} -> f ap_func || Ext_list.exists ap_args f | Lfunction {body; arity = _; params = _} -> f body - | Llet (_str, _id, arg, body) -> f arg || f body + | Llet (_str, _id, _, arg, body) -> f arg || f body | Lletrec (decl, body) -> f body || Ext_list.exists_snd decl f | Lswitch ( arg, diff --git a/compiler/core/lam_pass_alpha_conversion.ml b/compiler/core/lam_pass_alpha_conversion.ml index 7965cfc6011..5fa13deb715 100644 --- a/compiler/core/lam_pass_alpha_conversion.ml +++ b/compiler/core/lam_pass_alpha_conversion.ml @@ -23,15 +23,16 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) let alpha_conversion (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = - let rec populate_apply_info ?(ap_transformed_jsx = false) + let rec populate_apply_info ?(ap_transformed_jsx = false) ~ap_result_type (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 + Lam.apply ~ap_result_type (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) + Lam.apply ~ap_result_type (simpl fn) (Ext_list.map args simpl) {ap_info with ap_status = App_infer_full} ~ap_transformed_jsx else if x > len then @@ -42,8 +43,8 @@ let alpha_conversion (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = 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) + Lam.apply ~ap_transformed_jsx ~ap_result_type + (Lam.apply ~ap_result_type (simpl fn) (Ext_list.map first simpl) {ap_info with ap_status = App_infer_full}) (Ext_list.map rest simpl) ap_info (* TODO refien *) @@ -51,15 +52,15 @@ let alpha_conversion (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = match lam with | Lconst _ -> lam | Lvar _ -> lam - | Lapply {ap_func; ap_args; ap_info; ap_transformed_jsx} -> + | Lapply {ap_func; ap_args; ap_info; ap_transformed_jsx; ap_result_type} -> (* 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) + populate_apply_info ~ap_transformed_jsx ~ap_result_type args_arity len + ap_func ap_args ap_info + | Llet (str, v, ty, l1, l2) -> Lam.let_ str v ty (simpl l1) (simpl l2) | Lletrec (bindings, body) -> let bindings = Ext_list.map_snd bindings simpl in Lam.letrec bindings (simpl body) @@ -75,19 +76,19 @@ let alpha_conversion (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = | Lprim {primitive = Pjs_fn_make_unit; args = [arg]; loc} -> let arg = match arg with - | Lfunction {arity = 1; params = [x]; attr; body} + | Lfunction {arity = 1; params = [x]; attr; body; ty} when Ident.name x = "param" (* "()" *) -> Lam.function_ ~params:[x] ~attr:{attr with one_unit_arg = true} - ~body ~arity:1 + ~body ~arity:1 ~ty | _ -> arg in simpl arg | Lprim {primitive; args; loc} -> Lam.prim ~primitive ~args:(Ext_list.map args simpl) loc - | Lfunction {arity; params; body; attr} -> + | Lfunction {arity; params; body; attr; ty} -> (* Lam_mk.lfunction kind params (simpl l) *) - Lam.function_ ~arity ~params ~body:(simpl body) ~attr + Lam.function_ ~arity ~params ~body:(simpl body) ~attr ~ty | Lswitch ( l, { diff --git a/compiler/core/lam_pass_collect.ml b/compiler/core/lam_pass_collect.ml index 807e9323f3b..b0777023e17 100644 --- a/compiler/core/lam_pass_collect.ml +++ b/compiler/core/lam_pass_collect.ml @@ -102,7 +102,7 @@ let collect_info (meta : Lam_stats.t) (lam : Lam.t) = (* functor ? *) List.iter (fun p -> Hash_ident.add meta.ident_tbl p Parameter) params; collect l - | Llet (_kind, ident, arg, body) -> + | Llet (_kind, ident, _, arg, body) -> collect_bind Lam_non_rec ident arg; collect body | Lletrec (bindings, body) -> diff --git a/compiler/core/lam_pass_count.ml b/compiler/core/lam_pass_count.ml index 53bdf406ddf..a2d5d95b896 100644 --- a/compiler/core/lam_pass_count.ml +++ b/compiler/core/lam_pass_count.ml @@ -129,12 +129,12 @@ let collect_occurs lam : occ_tbl = count Map_ident.empty l1; count Map_ident.empty l2 | Lvar v -> add_one_use bv v - | Llet (_, v, Lvar w, l2) -> + | Llet (_, v, _, Lvar w, l2) -> (* v will be replaced by w in l2, so each occurrence of v in l2 increases w's refcount *) count (bind_var bv v) l2; inherit_use bv w v - | Llet (kind, v, l1, l2) -> + | Llet (kind, v, _, l1, l2) -> count (bind_var bv v) l2; (* count [l2] first, If v is unused, l1 will be removed, so don't count its variables *) diff --git a/compiler/core/lam_pass_deep_flatten.ml b/compiler/core/lam_pass_deep_flatten.ml index 6e94a78a587..f017a3e2d09 100644 --- a/compiler/core/lam_pass_deep_flatten.ml +++ b/compiler/core/lam_pass_deep_flatten.ml @@ -28,7 +28,8 @@ let rec eliminate_tuple (id : Ident.t) (lam : Lam.t) acc = match lam with - | Llet (Alias, v, Lprim {primitive = Pfield (i, _); args = [Lvar tuple]}, e2) + | Llet + (Alias, v, _, Lprim {primitive = Pfield (i, _); args = [Lvar tuple]}, e2) when Ident.same tuple id -> eliminate_tuple id e2 (Map_int.add acc i v) (* it is okay to have duplicates*) @@ -121,6 +122,7 @@ let deep_flatten (lam : Lam.t) : Lam.t = | Llet ( str, id, + _, (Lprim { primitive = Pnull_to_opt | Pnull_undefined_to_opt; @@ -131,6 +133,7 @@ let deep_flatten (lam : Lam.t) : Lam.t = | Llet ( str, id, + _, Lprim { primitive = (Pnull_to_opt | Pnull_undefined_to_opt) as primitive; @@ -139,13 +142,13 @@ 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.let_ str new_id None arg + (Lam.let_ Alias id None (Lam.prim ~primitive ~args:[Lam.var new_id] Location.none (* FIXME*)) body)) - | Llet (str, id, arg, body) -> ( + | Llet (str, id, _, arg, body) -> ( (* {[ let match = (a,b,c) let d = (match/1) @@ -221,16 +224,24 @@ let deep_flatten (lam : Lam.t) : Lam.t = (* can we switch to the tupled backend? *\) *) (* when List.length params = List.length args -> *) (* aux (beta_reduce params body args) *) - | Lapply {ap_func = l1; ap_args = ll; ap_info; ap_transformed_jsx} -> - Lam.apply (aux l1) (Ext_list.map ll aux) ap_info ~ap_transformed_jsx + | Lapply + { + ap_func = l1; + ap_args = ll; + ap_info; + ap_transformed_jsx; + ap_result_type; + } -> + Lam.apply ~ap_result_type (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 - | Lfunction {arity; params; body; attr} -> - Lam.function_ ~arity ~params ~body:(aux body) ~attr + | Lfunction {arity; params; body; attr; ty} -> + Lam.function_ ~arity ~params ~body:(aux body) ~attr ~ty | Lswitch ( l, { diff --git a/compiler/core/lam_pass_eliminate_ref.ml b/compiler/core/lam_pass_eliminate_ref.ml index 030f0c54f10..2dbba30e132 100644 --- a/compiler/core/lam_pass_eliminate_ref.ml +++ b/compiler/core/lam_pass_eliminate_ref.ml @@ -52,12 +52,14 @@ let rec eliminate_ref id (lam : Lam.t) = 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) + | Lapply + {ap_func = e1; ap_args = el; ap_info; ap_transformed_jsx; ap_result_type} + -> + Lam.apply ~ap_transformed_jsx ~ap_result_type (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) + | Llet (str, v, ty, e1, e2) -> + Lam.let_ str v ty (eliminate_ref id e1) (eliminate_ref id e2) | Lletrec (idel, e2) -> Lam.letrec (Ext_list.map idel (fun (v, e) -> (v, eliminate_ref id e))) diff --git a/compiler/core/lam_pass_exits.ml b/compiler/core/lam_pass_exits.ml index e47be329551..de092ca20e6 100644 --- a/compiler/core/lam_pass_exits.ml +++ b/compiler/core/lam_pass_exits.ml @@ -14,7 +14,7 @@ (** [no_bounded_varaibles lambda] checks if [lambda] contains bounded variable, for - example [Llet (str,id,arg,body) ] will fail such check. + example [Llet (str,id,_,arg,body) ] will fail such check. This is used to indicate such lambda expression if it is okay to inline directly since if it contains bounded variables it must be rebounded before inlining @@ -198,16 +198,16 @@ let subst_helper (subst : subst_tbl) (query : int -> int) (lam : Lam.t) : Lam.t Map_ident.add t x (Lam.var y)) in Ext_list.fold_right2 ys ls (Lam_subst.subst env handler) (fun y l r -> - Lam.let_ Strict y l r) + Lam.let_ Strict y None l r) | None -> Lam.staticraise i ls) | Lvar _ | Lconst _ -> lam - | Lapply {ap_func; ap_args; ap_info; ap_transformed_jsx} -> - Lam.apply (simplif ap_func) + | Lapply {ap_func; ap_args; ap_info; ap_transformed_jsx; ap_result_type} -> + Lam.apply ~ap_result_type (simplif ap_func) (Ext_list.map ap_args simplif) ap_info ~ap_transformed_jsx - | Lfunction {arity; params; body; attr} -> - Lam.function_ ~arity ~params ~body:(simplif body) ~attr - | Llet (kind, v, l1, l2) -> Lam.let_ kind v (simplif l1) (simplif l2) + | Lfunction {arity; params; body; attr; ty} -> + Lam.function_ ~arity ~params ~body:(simplif body) ~attr ~ty + | Llet (kind, v, ty, l1, l2) -> Lam.let_ kind v ty (simplif l1) (simplif l2) | Lletrec (bindings, body) -> Lam.letrec (Ext_list.map_snd bindings simplif) (simplif body) | Lglobal_module _ -> lam diff --git a/compiler/core/lam_pass_lets_dce.ml b/compiler/core/lam_pass_lets_dce.ml index 503e90c1f81..47d807e16fc 100644 --- a/compiler/core/lam_pass_lets_dce.ml +++ b/compiler/core/lam_pass_lets_dce.ml @@ -18,12 +18,13 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = let rec simplif (lam : Lam.t) = match lam with | Lvar v -> Hash_ident.find_default subst v lam - | Llet ((Strict | Alias | StrictOpt), v, Lvar w, l2) -> + | Llet ((Strict | Alias | StrictOpt), v, _, Lvar w, l2) -> Hash_ident.add subst v (simplif (Lam.var w)); simplif l2 | Llet ( (Strict as kind), v, + _, Lprim { primitive = Pmakeblock (0, _, Mutable) as primitive; @@ -41,7 +42,7 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = Lam_util.refine_let ~kind v (Lam.prim ~primitive ~args:[slinit] loc) slbody) - | Llet (Alias, v, l1, l2) -> ( + | Llet (Alias, v, ty, l1, l2) -> ( (* For alias, [l1] is pure, we can always inline, when captured, we should avoid recomputation *) @@ -66,12 +67,12 @@ 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) + Lam.let_ Alias v ty l1 (simplif l2) (* we need move [simplif l2] later, since adding Hash does have side effect *) | _ -> - Lam.let_ Alias v (simplif l1) (simplif l2) + Lam.let_ Alias v ty (simplif l1) (simplif l2) (* for Alias, in most cases [l1] is already simplified *)) - | Llet ((StrictOpt as kind), v, l1, lbody) -> ( + | Llet ((StrictOpt as kind), v, ty, l1, lbody) -> ( if (* can not be inlined since [l1] depend on the store {[ @@ -115,10 +116,10 @@ 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) + Lam.let_ Alias v ty 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) -> ( + | Llet (((Strict | Variable) as kind), v, ty, l1, l2) -> ( if not (used v) then let l1 = simplif l1 in let l2 = simplif l2 in @@ -129,7 +130,7 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = 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) + Lam.let_ Alias v ty l1 (simplif l2) | _ -> Lam_util.refine_let ~kind v l1 (simplif l2)) | Lsequence (l1, l2) -> Lam.seq (simplif l1) (simplif l2) | Lapply @@ -144,11 +145,18 @@ 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 + | Lapply + { + ap_func = l1; + ap_args = ll; + ap_info; + ap_transformed_jsx; + ap_result_type; + } -> + Lam.apply ~ap_result_type (simplif l1) (Ext_list.map ll simplif) ap_info ~ap_transformed_jsx - | Lfunction {arity; params; body; attr} -> - Lam.function_ ~arity ~params ~body:(simplif body) ~attr + | Lfunction {arity; params; body; attr; ty} -> + Lam.function_ ~arity ~params ~body:(simplif body) ~attr ~ty | 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 52a88ad02eb..e608f98193e 100644 --- a/compiler/core/lam_pass_remove_alias.ml +++ b/compiler/core/lam_pass_remove_alias.ml @@ -116,7 +116,7 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = | Eval_unknown -> Lam.if_ (simpl l1) (simpl l2) (simpl l3)) | _ -> Lam.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, ty, l1, l2) -> Lam.let_ str v ty (simpl l1) (simpl l2) | Lletrec (bindings, body) -> let bindings = Ext_list.map_snd bindings simpl in Lam.letrec bindings (simpl body) @@ -139,6 +139,7 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = } as l1; ap_args = args; ap_info; + ap_result_type; } -> ( match Lam_compile_env.query_external_id_info ~dynamic_import ident fld_name @@ -158,7 +159,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 + Lam.apply ~ap_result_type (simpl l1) (Ext_list.map args simpl) ap_info ?ap_transformed_jsx:None) (* Function inlining interact with other optimizations... @@ -166,13 +167,20 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = - scope issues - code bloat *) - | Lapply {ap_func = Lvar v as fn; ap_args; ap_info; ap_transformed_jsx} -> ( + | Lapply + { + ap_func = Lvar v as fn; + ap_args; + ap_info; + ap_transformed_jsx; + ap_result_type; + } -> ( (* Check info for always inlining *) (* Ext_log.dwarn __LOC__ "%s/%d" v.name v.stamp; *) let ap_args = Ext_list.map ap_args simpl in let[@local] normal () = - Lam.apply (simpl fn) ap_args ap_info ~ap_transformed_jsx + Lam.apply ~ap_result_type (simpl fn) ap_args ap_info ~ap_transformed_jsx in match Hash_ident.find_opt meta.ident_tbl v with | Some @@ -242,10 +250,18 @@ 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 - | Lfunction {arity; params; body; attr} -> - Lam.function_ ~arity ~params ~body:(simpl body) ~attr + | Lapply + { + ap_func = l1; + ap_args = ll; + ap_info; + ap_transformed_jsx; + ap_result_type; + } -> + Lam.apply ~ap_result_type (simpl l1) (Ext_list.map ll simpl) ap_info + ~ap_transformed_jsx + | Lfunction {arity; params; body; attr; ty} -> + Lam.function_ ~arity ~params ~body:(simpl body) ~attr ~ty | Lswitch ( l, { diff --git a/compiler/core/lam_print.ml b/compiler/core/lam_print.ml index 9408b11aea4..b0c192f88e6 100644 --- a/compiler/core/lam_print.ml +++ b/compiler/core/lam_print.ml @@ -229,7 +229,7 @@ let to_print_kind (k : Lam_compat.let_kind) : print_kind = let rec aux (acc : (print_kind * Ident.t * Lam.t) list) (lam : Lam.t) = match lam with - | Llet (str3, id3, arg3, body3) -> + | Llet (str3, id3, _, arg3, body3) -> aux ((to_print_kind str3, id3, arg3) :: acc) body3 | Lletrec (bind_args, body) -> aux @@ -249,7 +249,7 @@ let rec aux (acc : (print_kind * Ident.t * Lam.t) list) (lam : Lam.t) = let flatten (lam : Lam.t) : (print_kind * Ident.t * Lam.t) list * Lam.t = match lam with - | Llet (str, id, arg, body) -> aux [(to_print_kind str, id, arg)] body + | 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 @@ -439,7 +439,7 @@ let lambda ppf v = (* let rec flat (acc : (left * Lam.t) list ) (lam : Lam.t) = match lam with - | Llet (str,id,arg,body) -> + | Llet (str,id,_,arg,body) -> flat ( (Id {kind = to_print_kind str; id}, arg) :: acc) body | Lletrec (bind_args, body) -> flat diff --git a/compiler/core/lam_scc.ml b/compiler/core/lam_scc.ml index 6f1e1b7583c..f471f1065e0 100644 --- a/compiler/core/lam_scc.ml +++ b/compiler/core/lam_scc.ml @@ -45,7 +45,7 @@ let hit_mask (mask : Hash_set_ident_mask.t) (l : Lam.t) : bool = | Lstaticcatch (e1, (_, _), e2) -> hit e1 || hit e2 | Ltrywith (e1, _exn, e2) -> hit e1 || hit e2 | Lfunction {body; params = _} -> hit body - | Llet (_str, _id, arg, body) -> hit arg || hit body + | Llet (_str, _id, _, arg, body) -> hit arg || hit body | Lletrec (decl, body) -> hit body || hit_list_snd decl | Lfor (_v, e1, e2, _dir, e3) -> hit e1 || hit e2 || hit e3 | Lfor_of (_v, e1, e2) | Lfor_await_of (_v, e1, e2) -> hit e1 || hit e2 @@ -133,7 +133,8 @@ let scc_bindings (groups : bindings) : bindings list = let scc (groups : bindings) (lam : Lam.t) (body : Lam.t) = match groups with | [(id, bind)] -> - if Lam_hit.hit_variable id bind then lam else Lam.let_ Strict id bind body + if Lam_hit.hit_variable id bind then lam + else Lam.let_ Strict id None bind body | _ -> let domain, int_mapping, node_vec = preprocess_deps groups in let clusters = Ext_scc.graph node_vec in @@ -154,6 +155,6 @@ let scc (groups : bindings) (lam : Lam.t) (body : Lam.t) = let base_key = Ordered_hash_map_local_ident.rank domain id in if Int_vec_util.mem base_key node_vec.(base_key) then Lam.letrec bindings acc - else Lam.let_ Strict id lam acc + else Lam.let_ Strict id None lam acc | _ -> Lam.letrec bindings acc) clusters body diff --git a/compiler/core/lam_subst.ml b/compiler/core/lam_subst.ml index e449102dc5e..cfab4d056c1 100644 --- a/compiler/core/lam_subst.ml +++ b/compiler/core/lam_subst.ml @@ -33,12 +33,14 @@ let subst (s : Lam.t Map_ident.t) lam = 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 {arity; params; body; attr} -> - Lam.function_ ~arity ~params ~body:(subst_aux body) ~attr - | Llet (str, id, arg, body) -> - Lam.let_ str id (subst_aux arg) (subst_aux body) + | Lapply {ap_func; ap_args; ap_info; ap_result_type} -> + Lam.apply ~ap_result_type (subst_aux ap_func) + (Ext_list.map ap_args subst_aux) + ap_info + | Lfunction {arity; params; body; attr; ty} -> + Lam.function_ ~arity ~params ~body:(subst_aux body) ~attr ~ty + | Llet (str, id, ty, arg, body) -> + Lam.let_ str id ty (subst_aux arg) (subst_aux body) | Lletrec (decl, body) -> Lam.letrec (Ext_list.map decl subst_decl) (subst_aux body) | Lprim {primitive; args; loc} -> diff --git a/compiler/core/lam_ts_emit.ml b/compiler/core/lam_ts_emit.ml new file mode 100644 index 00000000000..65e874357fd --- /dev/null +++ b/compiler/core/lam_ts_emit.ml @@ -0,0 +1,92 @@ +let rec path_to_ts (path : Path.t) : string = + match path with + | Pident id -> Ident.name id + | Pdot (p, s, _) -> + let parent = path_to_ts p in + parent ^ "." ^ s + | Papply _ -> "unknown" + +let rec type_expr_to_ts (ty : Types.type_expr) : string = + match ty.desc with + | Tvar None -> "unknown" + | Tvar (Some s) -> s + | Tarrow ({lbl = Nolabel; typ = arg_ty}, ret_ty, _, _) -> + let arg = type_expr_to_ts arg_ty in + let ret = type_expr_to_ts ret_ty in + "(" ^ arg ^ ") => " ^ ret + | Tarrow ({lbl = Labelled {txt = l}; typ = arg_ty}, ret_ty, _, _) -> + let arg = type_expr_to_ts arg_ty in + let ret = type_expr_to_ts ret_ty in + l ^ ": " ^ arg ^ " => " ^ ret + | Tarrow ({lbl = Optional {txt = l}; typ = arg_ty}, ret_ty, _, _) -> + let arg = type_expr_to_ts arg_ty in + let ret = type_expr_to_ts ret_ty in + l ^ "?: " ^ arg ^ " => " ^ ret + | Ttuple tys -> "[" ^ String.concat ", " (List.map type_expr_to_ts tys) ^ "]" + | Tconstr (path, args, _) -> + let name = path_to_ts path in + let name = + match name with + | "int" -> "number" + | "float" -> "number" + | "string" -> "string" + | "bool" -> "boolean" + | "unit" -> "void" + | "array" -> "Array" + | "list" -> "Array" + | "option" -> "unknown" + | "promise" -> "Promise" + | _ -> name + in + if args = [] then name + else name ^ "<" ^ String.concat ", " (List.map type_expr_to_ts args) ^ ">" + | Tlink ty -> type_expr_to_ts ty + | Tpoly (ty, _) -> type_expr_to_ts ty + | Tnil -> "undefined" + | _ -> "unknown" + +let rec function_arity (lam : Lam.t) : int option = + match lam with + | Lam.Lfunction {arity; _} -> Some arity + | Lam.Llet (_, _, _, _, body) -> function_arity body + | _ -> None + +let emit_decls ppf (groups : Lam_group.t list) (exports : Ident.t list) = + let export_set = Set_ident.of_list exports in + let walk_group (group : Lam_group.t) = + match group with + | Lam_group.Single (_, id, lam) when Set_ident.mem export_set id -> ( + let ts_ty = + match lam with + | Lam.Llet (_, _, ty, _, _) -> ( + match ty with + | Some ty -> Some (type_expr_to_ts ty) + | None -> None) + | Lam.Lfunction {ty; _} -> ( + match ty with + | Some ty -> Some (type_expr_to_ts ty) + | None -> None) + | _ -> None + in + let is_fn = function_arity lam in + match (is_fn, ts_ty) with + | Some _, Some ts -> Format.fprintf ppf "export const %s: %s@." id.name ts + | Some _, None -> + Format.fprintf ppf "export function %s(...args: unknown[]): unknown@." + id.name + | None, Some ts -> Format.fprintf ppf "export const %s: %s@." id.name ts + | None, None -> Format.fprintf ppf "export const %s: unknown@." id.name) + | Lam_group.Recursive bindings -> + List.iter + (fun (id, lam) -> + if Set_ident.mem export_set id then + match function_arity lam with + | Some _ -> + Format.fprintf ppf + "export function %s(...args: unknown[]): unknown@." id.name + | None -> Format.fprintf ppf "export const %s: unknown@." id.name) + bindings + | _ -> () + in + Format.fprintf ppf "// Type declarations generated by ReScript@.@."; + List.iter walk_group groups diff --git a/compiler/core/lam_type_dump.ml b/compiler/core/lam_type_dump.ml new file mode 100644 index 00000000000..84eee2e6036 --- /dev/null +++ b/compiler/core/lam_type_dump.ml @@ -0,0 +1,95 @@ +let collect (lam : Lam.t) : unit = + let let_count = ref 0 in + let let_typed_count = ref 0 in + let fn_count = ref 0 in + let fn_typed_count = ref 0 in + let apply_count = ref 0 in + let apply_typed_count = ref 0 in + let rec walk (lam : Lam.t) = + match lam with + | Lvar _ | Lglobal_module _ | Lconst _ | Lbreak | Lcontinue -> () + | Lapply {ap_func; ap_args; ap_result_type; _} -> + incr apply_count; + (match ap_result_type with + | Some ty -> + incr apply_typed_count; + Format.printf " apply result: %a@." Printtyp.type_expr ty + | None -> ()); + walk ap_func; + List.iter walk ap_args + | Lfunction {params = _; body; ty; _} -> + incr fn_count; + (match ty with + | Some ty -> + incr fn_typed_count; + Format.printf " function: %a@." Printtyp.type_expr ty + | None -> ()); + walk body + | Llet (_, id, ty, arg, body) -> + incr let_count; + (match ty with + | Some ty -> + incr let_typed_count; + Format.printf " let %s : %a@." id.name Printtyp.type_expr ty + | None -> ()); + walk arg; + walk body + | Lletrec (bindings, body) -> + List.iter (fun (_, l) -> walk l) bindings; + walk body + | Lprim {args; _} -> List.iter walk args + | Lswitch (arg, sw) -> + walk arg; + List.iter (fun (_, l) -> walk l) sw.sw_consts; + List.iter (fun (_, l) -> walk l) sw.sw_blocks; + (match sw.sw_failaction with + | Some l -> walk l + | None -> ()); + List.iter (fun (_, l) -> walk l) sw.sw_consts; + List.iter (fun (_, l) -> walk l) sw.sw_blocks + | Lstringswitch (arg, cases, default) -> ( + walk arg; + List.iter (fun (_, l) -> walk l) cases; + match default with + | Some l -> walk l + | None -> ()) + | Lstaticraise (_, args) -> List.iter walk args + | Lstaticcatch (e1, _, e2) -> + walk e1; + walk e2 + | Ltrywith (e1, _, e2) -> + walk e1; + walk e2 + | Lifthenelse (e1, e2, e3) -> + walk e1; + walk e2; + walk e3 + | Lsequence (e1, e2) -> + walk e1; + walk e2 + | Lwhile (e1, e2) -> + walk e1; + walk e2 + | Lfor (_, e1, e2, _, e3) -> + walk e1; + walk e2; + walk e3 + | Lfor_of (_, e1, e2) -> + walk e1; + walk e2 + | Lfor_await_of (_, e1, e2) -> + walk e1; + walk e2 + | Lassign (_, e) -> walk e + in + walk lam; + Format.printf "Lam IR type summary:@."; + Format.printf " Llet: %d total, %d typed (%d%%)@." !let_count + !let_typed_count + (if !let_count > 0 then !let_typed_count * 100 / !let_count else 0); + Format.printf " Lfunction: %d total, %d typed (%d%%)@." !fn_count + !fn_typed_count + (if !fn_count > 0 then !fn_typed_count * 100 / !fn_count else 0); + Format.printf " Lapply: %d total, %d typed (%d%%)@." !apply_count + !apply_typed_count + (if !apply_count > 0 then !apply_typed_count * 100 / !apply_count else 0) diff --git a/compiler/core/lam_util.cppo.ml b/compiler/core/lam_util.cppo.ml index 9d7334930c9..ea77a0ec14e 100644 --- a/compiler/core/lam_util.cppo.ml +++ b/compiler/core/lam_util.cppo.ml @@ -109,33 +109,30 @@ let add_required_modules ( x : Ident.t list) (meta : Lam_stats.t) = 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 - | _, _, Lapply { ap_func = fn; ap_args = [ Lvar w ]; ap_info; ap_transformed_jsx } + | _, _, Lapply { ap_func = fn; ap_args = [ Lvar w ]; ap_info; ap_transformed_jsx; ap_result_type } 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 + Lam.apply ~ap_result_type 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 + Lam.let_ Alias param None 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 + Lam.let_ StrictOpt param None 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 + Lam.let_ StrictOpt param None arg l | kind, _, _ -> - Lam.let_ kind param arg l + Lam.let_ kind param None arg l let alias_ident_or_global (meta : Lam_stats.t) (k:Ident.t) (v:Ident.t) (v_kind : Lam_id_kind.t) = diff --git a/compiler/core/polyvar_pattern_match.ml b/compiler/core/polyvar_pattern_match.ml index fea0b53f1d7..fc6460f055d 100644 --- a/compiler/core/polyvar_pattern_match.ml +++ b/compiler/core/polyvar_pattern_match.ml @@ -109,7 +109,7 @@ let call_switcher_variant_constr (loc : Location.t) (fail : lam option) let v = Ident.create "variant" in Llet ( Alias, - Pgenval, v, + None, Lprim (Pfield (0, Fld_poly_var_tag), [arg], loc), call_switcher_variant_constant loc fail (Lvar v) int_lambda_list names ) diff --git a/compiler/jsoo/jsoo_playground_main.ml b/compiler/jsoo/jsoo_playground_main.ml index a78cf8c3eb3..e027fed477c 100644 --- a/compiler/jsoo/jsoo_playground_main.ml +++ b/compiler/jsoo/jsoo_playground_main.ml @@ -509,17 +509,18 @@ module Compile = struct (* default *) let ast = impl str in let ast = Ppx_entry.rewrite_implementation ast in - let typed_tree = - let a, b, _, signature = + let typed_tree, finalenv = + let a, b, finalenv, signature = Typemod.type_implementation_more modulename modulename modulename env ast in - (* finalenv := c ; *) types_signature := signature; - (a, b) + let typed_tree = (a, b) in + (typed_tree, finalenv) + in + let env, lam, exports = + Translmod.transl_implementation modulename finalenv typed_tree in - typed_tree |> Translmod.transl_implementation modulename - |> (* Printlambda.lambda ppf *) fun (lam, exports) -> let buffer = Buffer.create 1000 in let () = Js_dump_program.pp_deps_program ~output_prefix:"" diff --git a/compiler/ml/clflags.ml b/compiler/ml/clflags.ml index f0cd88115e7..a680662ca2c 100644 --- a/compiler/ml/clflags.ml +++ b/compiler/ml/clflags.ml @@ -38,6 +38,10 @@ and dump_rawlambda = ref false (* -drawlambda *) and dump_lambda = ref false (* -dlambda *) +and dump_lamtypes = ref false (* -dlamtypes *) + +and emit_typedefs = ref false (* -emit-typedefs *) + and only_parse = ref false (* -only-parse *) and editor_mode = ref false (* -editor-mode *) diff --git a/compiler/ml/clflags.mli b/compiler/ml/clflags.mli index 0cb5f1ea3e5..76e10b0be3e 100644 --- a/compiler/ml/clflags.mli +++ b/compiler/ml/clflags.mli @@ -21,6 +21,8 @@ val dump_parsetree : bool ref val dump_typedtree : bool ref val dump_rawlambda : bool ref val dump_lambda : bool ref +val dump_lamtypes : bool ref +val emit_typedefs : bool ref val dont_write_files : bool ref val keep_locs : bool ref val only_parse : bool ref diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index e078a2a28f8..53719f9d81d 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -311,10 +311,10 @@ type primitive = and comparison = Ceq | Cneq | Clt | Cgt | Cle | Cge -and value_kind = Pgenval - and raise_kind = Raise_regular | Raise_reraise +type type_expr = Types.type_expr + type pointer_info = | Pt_constructor of { name: string; @@ -355,7 +355,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 * type_expr option * lambda * lambda | Lletrec of (Ident.t * lambda) list * lambda | Lprim of primitive * lambda list * Location.t | Lswitch of lambda * lambda_switch * Location.t @@ -376,10 +376,11 @@ type lambda = | Lsend of string * lambda * Location.t and lfunction = { - params: Ident.t list; + params: (Ident.t * type_expr option) list; body: lambda; attr: function_attribute; (* specified with [@inline] attribute *) loc: Location.t; + ty: type_expr option; } and lambda_apply = { @@ -388,6 +389,7 @@ and lambda_apply = { ap_loc: Location.t; ap_inlined: inline_attribute; ap_transformed_jsx: bool; + ap_result_type: type_expr option; } and lambda_switch = { @@ -454,18 +456,19 @@ let make_key e = ap_func = tr_rec env ap.ap_func; ap_args = tr_recs env ap.ap_args; ap_loc = Location.none; + ap_result_type = None; } - | Llet (Alias, _k, x, ex, e) -> + | Llet (Alias, x, _ty, 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, _ty, ex, Lvar v) when Ident.same v x -> tr_rec env ex - | Llet (str, k, x, ex, e) -> + | Llet (str, x, _ty, 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, None, 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, _) -> @@ -510,7 +513,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, None, arg, fn id) let iter_opt f = function | None -> () @@ -522,7 +525,7 @@ let iter f = function f fn; List.iter f args | Lfunction {body} -> f body - | Llet (_str, _k, _id, arg, body) -> + | Llet (_str, _id, _ty, arg, body) -> f arg; f body | Lletrec (decl, body) -> @@ -578,8 +581,8 @@ let free_ids get l = fv := List.fold_right Ident_set.add (get l) !fv; 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 + List.iter (fun (param, _ty) -> fv := Ident_set.remove param !fv) params + | Llet (_str, id, _ty, _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) -> @@ -622,14 +625,14 @@ 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, _ty, _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, ty, lam, body) -> + Llet (str, id, ty, lam, patch_guarded patch body) | _ -> assert false (* Translate an access path *) @@ -672,9 +675,9 @@ let subst_lambda s lam = 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, k, id, arg, body) -> Llet (str, k, id, subst arg, subst body) + | Lfunction {params; body; attr; loc; ty} -> + Lfunction {params; body = subst body; attr; loc; ty} + | Llet (str, id, ty, arg, body) -> Llet (str, id, ty, 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) -> @@ -717,7 +720,7 @@ 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, None, exp, body) let raise_kind = function | Raise_regular -> "raise" diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index 99f399aa0ac..70eb288342a 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -279,10 +279,10 @@ type primitive = and comparison = Ceq | Cneq | Clt | Cgt | Cle | Cge -and value_kind = Pgenval - and raise_kind = Raise_regular | Raise_reraise +type type_expr = Types.type_expr + type structured_constant = | Const_base of constant | Const_pointer of int * pointer_info @@ -323,7 +323,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 * type_expr option * lambda * lambda | Lletrec of (Ident.t * lambda) list * lambda | Lprim of primitive * lambda list * Location.t | Lswitch of lambda * lambda_switch * Location.t @@ -346,10 +346,11 @@ type lambda = | Lsend of string * lambda * Location.t and lfunction = { - params: Ident.t list; + params: (Ident.t * type_expr option) list; body: lambda; attr: function_attribute; (* specified with [@inline] attribute *) loc: Location.t; + ty: type_expr option; } and lambda_apply = { @@ -358,6 +359,7 @@ and lambda_apply = { ap_loc: Location.t; ap_inlined: inline_attribute; (* specified with the [@inlined] attribute *) ap_transformed_jsx: bool; + ap_result_type: type_expr option; } and lambda_switch = { diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index 916646ea08a..7ba1bfd51d8 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -459,7 +459,7 @@ let make_catch d k = (* 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, _id, _ty, _, e) -> as_simple_exit e | _ -> None let make_catch_delayed handler = @@ -1536,7 +1536,7 @@ let bind_sw arg k = | Lvar _ -> k arg | _ -> let id = Ident.create "switch" in - Llet (Strict, Pgenval, id, arg, k (Lvar id)) + Llet (Strict, id, None, arg, k (Lvar id)) (* Sequential equality tests *) @@ -2136,7 +2136,7 @@ let combine_constructor sw_names loc arg ex_pat cstr partial ctx def (Lprim (Pextension_slot_eq, [Lvar tag; ext], loc), act, rem)) extension_cases default in - Llet (Alias, Pgenval, tag, arg, tests) + Llet (Alias, tag, None, arg, tests) in (lambda1, jumps_union local_jumps total1) else @@ -2226,8 +2226,8 @@ let call_switcher_variant_constr loc fail arg int_lambda_list names = let v = Ident.create "variant" in Llet ( Alias, - Pgenval, v, + None, Lprim (Pfield (0, Fld_poly_var_tag), [arg], loc), call_switcher loc fail (Lvar v) min_int max_int (List.map (fun (a, (_, c)) -> (a, c)) int_lambda_list) @@ -2406,7 +2406,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, _id, _ty, l1, l2) -> approx_present v l1 || approx_present v l2 | Lvar vv -> Ident.same v vv | _ -> true @@ -2427,9 +2427,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, k, 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, k, lv, lower_bind v arg l) | Lvar u when Ident.same u v && Ident.name u = "*sth*" -> arg (* eliminate let *sth* = from_option x in *sth* *) | _ -> bind Alias v arg lam @@ -2808,7 +2808,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, Some pat.pat_type, 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 e30f3c867f2..29eb2e4edf4 100644 --- a/compiler/ml/printlambda.ml +++ b/compiler/ml/printlambda.ml @@ -42,15 +42,6 @@ let rec struct_const ppf = function | Const_false -> fprintf ppf "false" | Const_true -> fprintf ppf "true" -let value_kind = function - | Pgenval -> "" - -(* let field_kind = function - | Pgenval -> "*" - | Pintval -> "int" - | Pfloatval -> "float" - | Pboxedintval bi -> boxed_integer_name bi *) - let string_of_loc_kind = function | Loc_FILE -> "loc_FILE" | Loc_LINE -> "loc_LINE" @@ -288,11 +279,13 @@ let rec lam ppf = function apply_inlined_attribute ap.ap_inlined | Lfunction {params; body; attr} -> let pr_params ppf params = - List.iter (fun param -> fprintf ppf "@ %a" Ident.print param) params + List.iter + (fun (param, _ty) -> fprintf ppf "@ %a" Ident.print param) + params 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, _ty, arg, body) -> let kind = function | Alias -> "a" | Strict -> "" @@ -300,14 +293,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, _ty, 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 77617eda5d6..585473cf4fd 100644 --- a/compiler/ml/transl_recmodule.ml +++ b/compiler/ml/transl_recmodule.ml @@ -139,8 +139,8 @@ let eval_rec_bindings_aux (bindings : binding list) (cont : t) : t = | (id, Some (loc, shape), _rhs) :: rem -> Lambda.Llet ( Strict, - Pgenval, id, + None, Lprim (Pinit_mod, [loc; shape], Location.none), bind_inits rem acc ) in @@ -148,7 +148,7 @@ let eval_rec_bindings_aux (bindings : binding list) (cont : t) : t = match args with | [] -> acc | (id, None, rhs) :: rem -> - Lambda.Llet (Strict, Pgenval, id, rhs, bind_strict rem acc) + Lambda.Llet (Strict, id, None, rhs, bind_strict rem acc) | (_id, Some _, _rhs) :: rem -> bind_strict rem acc in let rec patch_forwards args = @@ -174,7 +174,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,7 +188,7 @@ let rec is_function_or_const_block (lam : Lambda.lambda) acc = | 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 (_, 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 69fbcab4729..1d3b4011bb3 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -472,24 +472,25 @@ let transl_primitive loc p env ty = let param = Ident.create "prim" in Lfunction { - params = [param]; + params = [(param, None)]; attr = default_function_attribute; loc; body = Lprim (Pmakeblock Blk_tuple, [lam; Lvar param], loc); + ty = Some ty; } | _ -> assert false) | _ -> let rec make_params n total = if n <= 0 then [] else - Ident.create ("prim" ^ string_of_int (total - n)) + (Ident.create ("prim" ^ string_of_int (total - n)), None) :: make_params (n - 1) total in let prim_arity = p.prim_arity in if p.prim_from_constructor || prim_arity = 0 then Lprim (prim, [], loc) else let params = - if prim_arity = 1 then [Ident.create "prim"] + if prim_arity = 1 then [(Ident.create "prim", None)] else make_params prim_arity prim_arity in Lfunction @@ -497,7 +498,8 @@ let transl_primitive loc p env ty = params; attr = default_function_attribute; loc; - body = Lprim (prim, List.map (fun id -> Lvar id) params, loc); + body = Lprim (prim, List.map (fun (id, _) -> Lvar id) params, loc); + ty = Some ty; } let transl_primitive_application loc prim env ty args = @@ -701,7 +703,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = } in let loc = e.exp_loc in - let lambda = Lfunction {params; body; attr; loc} in + let lambda = Lfunction {params; body; attr; loc; ty = Some e.exp_type} in match arity with | Some arity -> let prim = @@ -755,7 +757,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = let inlined, _ = Translattribute.get_and_remove_inlined_attribute funct in - transl_apply ~inlined ~transformed_jsx f args' e.exp_loc + transl_apply ~inlined ~transformed_jsx e.exp_type f args' e.exp_loc in let args = List.map @@ -807,7 +809,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = else None in transl_apply ~inlined ~uncurried_partial_application ~transformed_jsx - (transl_exp funct) oargs e.exp_loc + e.exp_type (transl_exp funct) oargs e.exp_loc | Texp_match (arg, pat_expr_list, exn_pat_expr_list, partial) -> transl_match e arg pat_expr_list exn_pat_expr_list partial | Texp_try (body, pat_expr_list) -> @@ -949,12 +951,12 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = Lsend (nm, obj, 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, None, defining_expr, transl_exp body) | Texp_letexception (cd, body) -> Llet ( Strict, - Pgenval, cd.ext_id, + None, transl_extension_constructor e.exp_env None cd, transl_exp body ) | Texp_pack modl -> !transl_module Tcoerce_none None modl @@ -989,8 +991,8 @@ and transl_case_try {c_lhs; c_guard; c_rhs} = and transl_cases_try cases = List.map transl_case_try cases and transl_apply ?(inlined = Default_inline) - ?(uncurried_partial_application = None) ?(transformed_jsx = false) lam sargs - loc = + ?(uncurried_partial_application = None) ?(transformed_jsx = false) + (result_type : Types.type_expr) lam sargs loc = let lapply ap_func ap_args = Lapply { @@ -999,6 +1001,7 @@ and transl_apply ?(inlined = Default_inline) ap_args; ap_inlined = inlined; ap_transformed_jsx = transformed_jsx; + ap_result_type = Some result_type; } in let rec build_apply lam args = function @@ -1022,19 +1025,20 @@ and transl_apply ?(inlined = Default_inline) and id_arg = Ident.create "param" in let body = match build_apply handle ((Lvar id_arg, optional) :: args') l with - | Lfunction {params = ids; body = lam; attr; loc} -> - Lfunction {params = id_arg :: ids; body = lam; attr; loc} + | Lfunction {params = ids; body = lam; attr; loc; ty} -> + Lfunction {params = (id_arg, None) :: ids; body = lam; attr; loc; ty} | lam -> Lfunction { - params = [id_arg]; + params = [(id_arg, None)]; body = lam; attr = default_function_attribute; loc; + ty = Some result_type; } in List.fold_left - (fun body (id, lam) -> Llet (Strict, Pgenval, id, lam, body)) + (fun body (id, lam) -> Llet (Strict, id, None, lam, body)) body !defs | (Some arg, optional) :: l -> build_apply lam ((arg, optional) :: args) l | [] -> lapply lam (List.rev_map fst args) @@ -1048,13 +1052,14 @@ and transl_apply ?(inlined = Default_inline) | _, Some e -> Some (transl_exp e) | _, None -> let id_arg = Ident.create "none" in - none_ids := id_arg :: !none_ids; + none_ids := (id_arg, None) :: !none_ids; Some (Lvar id_arg)) in let extra_ids = - Array.init extra_arity (fun _ -> Ident.create "extra") |> Array.to_list + Array.init extra_arity (fun _ -> (Ident.create "extra", None)) + |> 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, _) -> Lvar id) in let ap_args = args @ extra_args in let l0 = Lapply @@ -1064,6 +1069,7 @@ and transl_apply ?(inlined = Default_inline) ap_inlined = inlined; ap_loc = loc; ap_transformed_jsx = transformed_jsx; + ap_result_type = Some result_type; } in Lfunction @@ -1072,6 +1078,7 @@ and transl_apply ?(inlined = Default_inline) body = l0; attr = default_function_attribute; loc; + ty = Some result_type; } | _ -> (build_apply lam [] @@ -1103,11 +1110,11 @@ and transl_function loc partial param case = let params, body, return_unit = transl_function exp.exp_loc partial' param' case in - ( param :: params, + ( (param, Some pat.pat_type) :: params, Matching.for_function loc None (Lvar param) [(pat, body)] partial, return_unit ) | {c_rhs = {exp_env; exp_type}; _} -> - ( [param], + ( [(param, Some case.c_lhs.pat_type)], Matching.for_function loc None (Lvar param) [transl_case case] partial, is_base_type exp_env exp_type Predef.path_unit ) @@ -1256,7 +1263,8 @@ and transl_record loc env fields repres opt_init_expr = match opt_init_expr with | None -> lam | Some init_expr -> - Llet (Strict, Pgenval, init_id, transl_exp init_expr, lam) + Llet + (Strict, init_id, Some init_expr.exp_type, transl_exp init_expr, lam) else (* Take a shallow copy of the init record, then mutate the fields of the copy *) @@ -1283,8 +1291,8 @@ and transl_record loc env fields repres opt_init_expr = | Some init_expr -> Llet ( Strict, - Pgenval, copy_id, + Some init_expr.exp_type, 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 7e846adbb6f..b53f52c4d87 100644 --- a/compiler/ml/translmod.ml +++ b/compiler/ml/translmod.ml @@ -53,7 +53,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, None, lam, body)) tyext.tyext_constructors body (* Compile a coercion *) @@ -89,7 +89,7 @@ and apply_coercion_result loc strict funct param arg cc_res = Lambda.name_lambda strict funct (fun id -> Lfunction { - params = [param]; + params = [(param, None)]; attr = {Lambda.default_function_attribute with is_a_functor = true}; loc; body = @@ -101,7 +101,9 @@ and apply_coercion_result loc strict funct param arg cc_res = ap_args = [arg]; ap_inlined = Default_inline; ap_transformed_jsx = false; + ap_result_type = None; }); + ty = None; }) and wrap_id_pos_list loc id_pos_list get_field lam = @@ -116,8 +118,8 @@ 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'', + None, apply_coercion loc Alias c (get_field (Ident.name id') pos), lam ), Ident.add id' (Lambda.Lvar id'') s ) @@ -234,11 +236,11 @@ let rec compile_functor mexp coercion root_path loc = 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) + (Alias, param, None, arg, transl_module res_coercion body_path body) in Lambda.Lfunction { - params = [param']; + params = [(param', None)]; attr = { inline = inline_attribute; @@ -250,6 +252,7 @@ let rec compile_functor mexp coercion root_path loc = }; loc; body; + ty = None; } (* Compile a module expression *) @@ -278,6 +281,7 @@ and transl_module cc rootpath mexp = ap_args = [transl_module ccarg None arg]; ap_inlined = inlined_attribute; ap_transformed_jsx = false; + ap_result_type = None; }) | Tmod_constraint (arg, _, _, ccarg) -> transl_module (compose_coercions cc ccarg) rootpath arg @@ -385,8 +389,8 @@ and transl_structure loc fields cc rootpath final_env = function in ( Llet ( Strict, - Pgenval, id, + None, Translcore.transl_extension_constructor item.str_env path ext, body ), size ) @@ -404,7 +408,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, None, module_body, body), size) | Tstr_recmodule bindings -> let ext_fields = List.rev_append (List.map (fun mb -> mb.mb_id) bindings) fields @@ -429,8 +433,8 @@ 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, + None, Lprim ( Pfield (pos, Fld_module {name = Ident.name id}), [Lvar mid], @@ -441,8 +445,8 @@ and transl_structure loc fields cc rootpath final_env = function let body, size = rebind_idents 0 fields ids in ( Llet ( pure_module modl, - Pgenval, mid, + None, transl_module Tcoerce_none None modl, body ), size ) @@ -457,11 +461,11 @@ let _ = Translcore.transl_module := transl_module (* Compile an implementation *) -let transl_implementation module_name (str, cc) = +let transl_implementation module_name env (str, cc) = export_identifiers := []; let module_id = Ident.create_persistent module_name in let body, _ = transl_struct Location.none [] cc (global_path module_id) str in - (body, !export_identifiers) + (env, body, !export_identifiers) (* Build the list of value identifiers defined by a toplevel structure (excluding primitive declarations). *) diff --git a/compiler/ml/translmod.mli b/compiler/ml/translmod.mli index 74ef747e105..f88fe1e869b 100644 --- a/compiler/ml/translmod.mli +++ b/compiler/ml/translmod.mli @@ -18,8 +18,9 @@ val transl_implementation : string -> + Env.t -> Typedtree.structure * Typedtree.module_coercion -> - Lambda.lambda * Ident.t list + Env.t * Lambda.lambda * Ident.t list type error (* exception Error of Location.t * error *) From 14ec0df484a80cbacde40f2c05c5b5f84650d704 Mon Sep 17 00:00:00 2001 From: Hyeseong Kim Date: Sun, 14 Jun 2026 06:17:57 +0900 Subject: [PATCH 2/5] fix carrying types Type annotations on value bindings (`let n: int = 42`) were lost before reaching the export grouping phase, causing `-emit-typedefs` to emit `unknown` for all non-function exports. Root cause: `let n: int = 42` produces `Tpat_alias(Tpat_any, n, ...)` in the typedtree, not `Tpat_var`. The `for_let` fast path only matched `Tpat_var`, so annotated bindings fell through to `simple_for_let`, which does not carry the type through to `Lambda.Llet`. Fix chain: - Add `Tpat_alias({pat_desc = Tpat_any}, id, _)` to `for_let` fast path so `Some pat.pat_type` reaches `Lambda.Llet` - Add `Types.type_expr option` field to `Lam_group.Single` to carry the type through `flatten` and `coerce_and_group_big_lambda` - Thread `~ty` through `Lam_util.refine_let` so reconstructed `Llet` nodes preserve the annotation after `deep_flatten` - Capture types in `Lam_stats.export_type_tbl` during `collect_info` before DCE inlines simple exported constants - Use `export_type_tbl` in `handle_exports` to pass types to `Single` when the original `Llet` has been eliminated - `Lam_ts_emit.emit_decls` reads `ty` from `Single` instead of trying to recover it from the bound expression Also fixes the `make_key` regression that caused identical switch arms to lose action sharing: type metadata in `Lapply.ap_result_type` and `Llet` fields is now zeroed in sharing keys to prevent false inequality. Assisted-by: OpenCode:glm-5.2 --- compiler/core/lam_beta_reduce.ml | 6 ++--- compiler/core/lam_coercion.ml | 14 +++++++---- compiler/core/lam_compile_main.cppo.ml | 4 ++-- compiler/core/lam_dce.ml | 4 ++-- compiler/core/lam_group.ml | 10 ++++---- compiler/core/lam_group.mli | 5 ++-- compiler/core/lam_pass_collect.ml | 6 ++++- compiler/core/lam_pass_deep_flatten.ml | 21 +++++++++-------- compiler/core/lam_pass_lets_dce.ml | 12 +++++----- compiler/core/lam_stats.ml | 4 ++++ compiler/core/lam_stats.mli | 3 +++ compiler/core/lam_ts_emit.ml | 18 ++++++--------- compiler/core/lam_util.cppo.ml | 32 +++++++++++++------------- compiler/core/lam_util.mli | 8 ++++++- compiler/ml/matching.ml | 2 +- 15 files changed, 84 insertions(+), 65 deletions(-) diff --git a/compiler/core/lam_beta_reduce.ml b/compiler/core/lam_beta_reduce.ml index e7f9842bbc7..1ee3f60bbfc 100644 --- a/compiler/core/lam_beta_reduce.ml +++ b/compiler/core/lam_beta_reduce.ml @@ -71,7 +71,7 @@ let propagate_beta_reduce (meta : Lam_stats.t) (params : Ident.t list) | Lprim {primitive = Psome | Psome_not_nest; args = [v]; _} -> Hash_ident.replace meta.ident_tbl param (Normal_optional v) | _ -> ()); - Lam_util.refine_let ~kind:Strict param arg l) + Lam_util.refine_let ~kind:Strict ~ty:None param arg l) let propagate_beta_reduce_with_map (meta : Lam_stats.t) (map : Lam_var_stats.stats Map_ident.t) params body args = @@ -112,11 +112,11 @@ let propagate_beta_reduce_with_map (meta : Lam_stats.t) | Lprim {primitive = Psome | Psome_not_nest; args = [v]} -> Hash_ident.replace meta.ident_tbl param (Normal_optional v) | _ -> ()); - Lam_util.refine_let ~kind:Strict param arg l) + Lam_util.refine_let ~kind:Strict ~ty:None param arg l) let no_names_beta_reduce params body args = match Lam_beta_reduce_util.simple_beta_reduce params body args with | Some x -> x | None -> Ext_list.fold_left2 params args body (fun param arg l -> - Lam_util.refine_let ~kind:Strict param arg l) + Lam_util.refine_let ~kind:Strict ~ty:None param arg l) diff --git a/compiler/core/lam_coercion.ml b/compiler/core/lam_coercion.ml index 60e3edbbe8c..5ed34527d0b 100644 --- a/compiler/core/lam_coercion.ml +++ b/compiler/core/lam_coercion.ml @@ -113,11 +113,12 @@ let handle_exports (meta : Lam_stats.t) (lambda_exports : Lam.t list) let newid = Ident.rename original_export_id in let kind : Lam_compat.let_kind = Alias in Lam_util.alias_ident_or_global meta newid id NA; + let ty = Hash_ident.find_opt meta.export_type_tbl id in { acc with export_list = newid :: acc.export_list; export_map = Map_ident.add acc.export_map newid lam; - groups = Single (kind, newid, lam) :: acc.groups; + groups = Single (kind, newid, ty, lam) :: acc.groups; } | _ -> (* @@ -149,11 +150,14 @@ let handle_exports (meta : Lam_stats.t) (lambda_exports : Lam.t list) | Lfunction _ -> Some (lam, Lam_non_rec) | _ -> None); })); + let ty = + Hash_ident.find_opt meta.export_type_tbl original_export_id + in { acc with export_list = newid :: acc.export_list; export_map = Map_ident.add acc.export_map newid lam; - groups = Single (Strict, newid, lam) :: acc.groups; + groups = Single (Strict, newid, ty, lam) :: acc.groups; }) in @@ -161,7 +165,7 @@ let handle_exports (meta : Lam_stats.t) (lambda_exports : Lam.t list) Ext_list.fold_left reverse_input (result.export_map, result.groups) (fun (export_map, acc) x -> ( (match x with - | Single (_, id, lam) when Set_ident.mem export_set id -> + | Single (_, id, _, lam) when Set_ident.mem export_set id -> Map_ident.add export_map id lam (* relies on the Invariant that [eoid] can not be bound before FIX: such invariant may not hold @@ -179,9 +183,9 @@ let handle_exports (meta : Lam_stats.t) (lambda_exports : Lam.t list) let rec flatten (acc : Lam_group.t list) (lam : Lam.t) : Lam.t * Lam_group.t list = match lam with - | Llet (str, id, _, arg, body) -> + | Llet (str, id, ty, arg, body) -> let res, l = flatten acc arg in - flatten (Single (str, id, res) :: l) body + flatten (Single (str, id, ty, res) :: l) body | Lletrec (bind_args, body) -> flatten (Recursive bind_args :: acc) body | Lsequence (l, r) -> let res, l = flatten acc l in diff --git a/compiler/core/lam_compile_main.cppo.ml b/compiler/core/lam_compile_main.cppo.ml index ae7674f78df..5d311a95318 100644 --- a/compiler/core/lam_compile_main.cppo.ml +++ b/compiler/core/lam_compile_main.cppo.ml @@ -56,7 +56,7 @@ let compile_group output_prefix (meta : Lam_stats.t) so it should be safe *) - | Single (kind, id, lam) -> + | Single (kind, id, _ty, lam) -> (* let lam = Optimizer.simplify_lets [] lam in *) (* can not apply again, it's wrong USE it with care*) (* ([Js_stmt_make.comment (Gen_of_env.query_type id env )], None) ++ *) @@ -93,7 +93,7 @@ let compile_group output_prefix (meta : Lam_stats.t) let no_side_effects (rest : Lam_group.t list) : string option = Ext_list.find_opt rest (fun x -> match x with - | Single(kind,id,body) -> + | Single (kind, id, _ty, body) -> begin match kind with | Strict | Variable -> diff --git a/compiler/core/lam_dce.ml b/compiler/core/lam_dce.ml index ee476b3da81..fbc046294bc 100644 --- a/compiler/core/lam_dce.ml +++ b/compiler/core/lam_dce.ml @@ -45,7 +45,7 @@ let remove export_idents (rest : Lam_group.t list) : Lam_group.t list = let initial_idents = Ext_list.fold_left rest export_idents (fun acc x -> match x with - | Single (kind, id, lam) -> ( + | Single (kind, id, _ty, lam) -> ( Hash_ident.add ident_free_vars id (Lam_free_variables.pass_free_variables lam); match kind with @@ -68,7 +68,7 @@ let remove export_idents (rest : Lam_group.t list) : Lam_group.t list = let visited = transitive_closure initial_idents ident_free_vars in Ext_list.fold_left rest [] (fun acc x -> match x with - | Single (_, id, _) -> + | Single (_, id, _, _) -> if Hash_set_ident.mem visited id then x :: acc else acc | Nop _ -> x :: acc | Recursive bindings -> ( diff --git a/compiler/core/lam_group.ml b/compiler/core/lam_group.ml index 357222cd641..0c75423f793 100644 --- a/compiler/core/lam_group.ml +++ b/compiler/core/lam_group.ml @@ -24,14 +24,14 @@ (** This is not a recursive type definition *) type t = - | Single of Lam_compat.let_kind * Ident.t * Lam.t + | Single of Lam_compat.let_kind * Ident.t * Types.type_expr option * 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 : Lam_compat.let_kind) id ty (body : Lam.t) = match (kind, body) with - | (Strict | StrictOpt), (Lvar _ | Lconst _) -> Single (Alias, id, body) - | _ -> Single (kind, id, body) + | (Strict | StrictOpt), (Lvar _ | Lconst _) -> Single (Alias, id, ty, body) + | _ -> Single (kind, id, ty, body) let nop_cons (x : Lam.t) acc = match x with @@ -49,7 +49,7 @@ let str_of_kind (kind : Lam_compat.let_kind) = let pp_group fmt (x : t) = match x with - | Single (kind, id, lam) -> + | Single (kind, id, _ty, lam) -> Format.fprintf fmt "@[let@ %a@ =%s@ @[%a@]@ @]" Ident.print id (str_of_kind kind) Lam_print.lambda lam | Recursive lst -> diff --git a/compiler/core/lam_group.mli b/compiler/core/lam_group.mli index c6325acc923..e9a823ae8cc 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 Lam_compat.let_kind * Ident.t * Types.type_expr option * Lam.t | Recursive of (Ident.t * Lam.t) list | Nop of Lam.t @@ -31,6 +31,7 @@ type t = val pp_group : Format.formatter -> t -> unit -val single : Lam_compat.let_kind -> Ident.t -> Lam.t -> t +val single : + Lam_compat.let_kind -> Ident.t -> Types.type_expr option -> Lam.t -> t val nop_cons : Lam.t -> t list -> t list diff --git a/compiler/core/lam_pass_collect.ml b/compiler/core/lam_pass_collect.ml index b0777023e17..6de51f4853a 100644 --- a/compiler/core/lam_pass_collect.ml +++ b/compiler/core/lam_pass_collect.ml @@ -102,7 +102,11 @@ let collect_info (meta : Lam_stats.t) (lam : Lam.t) = (* functor ? *) List.iter (fun p -> Hash_ident.add meta.ident_tbl p Parameter) params; collect l - | Llet (_kind, ident, _, arg, body) -> + | Llet (_kind, ident, ty, arg, body) -> + (match ty with + | Some ty when Set_ident.mem meta.export_idents ident -> + Hash_ident.replace meta.export_type_tbl ident ty + | _ -> ()); collect_bind Lam_non_rec ident arg; collect body | Lletrec (bindings, body) -> diff --git a/compiler/core/lam_pass_deep_flatten.ml b/compiler/core/lam_pass_deep_flatten.ml index f017a3e2d09..baacf27715b 100644 --- a/compiler/core/lam_pass_deep_flatten.ml +++ b/compiler/core/lam_pass_deep_flatten.ml @@ -106,7 +106,8 @@ let lambda_of_groups ~(rev_bindings : Lam_group.t list) (result : Lam.t) : Lam.t Ext_list.fold_left rev_bindings result (fun acc x -> match x with | Nop l -> Lam.seq l acc - | Single (kind, ident, lam) -> Lam_util.refine_let ~kind ident lam acc + | Single (kind, ident, ty, lam) -> + Lam_util.refine_let ~kind ~ty ident lam acc | Recursive bindings -> Lam.letrec bindings acc) (* TODO: @@ -122,18 +123,18 @@ let deep_flatten (lam : Lam.t) : Lam.t = | Llet ( str, id, - _, + ty, (Lprim { primitive = Pnull_to_opt | Pnull_undefined_to_opt; args = [Lvar _]; } as arg), body ) -> - flatten (Single (str, id, aux arg) :: acc) body + flatten (Single (str, id, ty, aux arg) :: acc) body | Llet ( str, id, - _, + ty, Lprim { primitive = (Pnull_to_opt | Pnull_undefined_to_opt) as primitive; @@ -143,12 +144,12 @@ let deep_flatten (lam : Lam.t) : Lam.t = let new_id = Ident.rename id in flatten acc (Lam.let_ str new_id None arg - (Lam.let_ Alias id None + (Lam.let_ Alias id ty (Lam.prim ~primitive ~args:[Lam.var new_id] Location.none (* FIXME*)) body)) - | Llet (str, id, _, arg, body) -> ( + | Llet (str, id, ty, arg, body) -> ( (* {[ let match = (a,b,c) let d = (match/1) @@ -167,10 +168,10 @@ let deep_flatten (lam : Lam.t) : Lam.t = (Ext_list.fold_left_with_offset args accux 0 (fun arg acc i -> match Map_int.find_opt tuple_mapping i with | None -> Lam_group.nop_cons arg acc - | Some key -> Lam_group.single str key arg :: acc)) + | Some key -> Lam_group.single str key None arg :: acc)) body - | None -> flatten (Single (str, id, res) :: accux) body) - | _ -> flatten (Single (str, id, res) :: accux) body) + | None -> flatten (Single (str, id, ty, res) :: accux) body) + | _ -> flatten (Single (str, id, ty, res) :: accux) body) | Lletrec (bind_args, body) -> flatten (Recursive (Ext_list.map_snd bind_args aux) :: acc) body | Lsequence (l, r) -> @@ -207,7 +208,7 @@ let deep_flatten (lam : Lam.t) : Lam.t = ((id, lam) :: inner_recursive_bindings, wrap, true) else ( inner_recursive_bindings, - Lam_group.Single (Strict, id, lam) :: wrap, + Lam_group.Single (Strict, id, None, lam) :: wrap, false )) in lambda_of_groups diff --git a/compiler/core/lam_pass_lets_dce.ml b/compiler/core/lam_pass_lets_dce.ml index 47d807e16fc..e7ac0e48def 100644 --- a/compiler/core/lam_pass_lets_dce.ml +++ b/compiler/core/lam_pass_lets_dce.ml @@ -36,10 +36,10 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = let slbody = simplif lbody in try (* TODO: record all references variables *) - Lam_util.refine_let ~kind:Variable v slinit + Lam_util.refine_let ~kind:Variable ~ty:None v slinit (Lam_pass_eliminate_ref.eliminate_ref v slbody) with Lam_pass_eliminate_ref.Real_reference -> - Lam_util.refine_let ~kind v + Lam_util.refine_let ~kind ~ty:None v (Lam.prim ~primitive ~args:[slinit] loc) slbody) | Llet (Alias, v, ty, l1, l2) -> ( @@ -104,10 +104,10 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = let slbody = simplif lbody in try (* TODO: record all references variables *) - Lam_util.refine_let ~kind:Variable v slinit + Lam_util.refine_let ~kind:Variable ~ty:None v slinit (Lam_pass_eliminate_ref.eliminate_ref v slbody) with Lam_pass_eliminate_ref.Real_reference -> - Lam_util.refine_let ~kind v + Lam_util.refine_let ~kind ~ty:None v (Lam.prim ~primitive ~args:[slinit] loc) slbody) | _ -> ( @@ -117,7 +117,7 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = Hash_ident.add string_table v s; (* we need move [simplif lbody] later, since adding Hash does have side effect *) Lam.let_ Alias v ty l1 (simplif lbody) - | _ -> Lam_util.refine_let ~kind v l1 (simplif lbody)) + | _ -> Lam_util.refine_let ~kind ~ty:None v l1 (simplif lbody)) (* TODO: check if it is correct rollback to [StrictOpt]? *)) | Llet (((Strict | Variable) as kind), v, ty, l1, l2) -> ( if not (used v) then @@ -131,7 +131,7 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = | Strict, Lconst (Const_string {s; delim = None}) -> Hash_ident.add string_table v s; Lam.let_ Alias v ty l1 (simplif l2) - | _ -> Lam_util.refine_let ~kind v l1 (simplif l2)) + | _ -> Lam_util.refine_let ~kind ~ty:None v l1 (simplif l2)) | Lsequence (l1, l2) -> Lam.seq (simplif l1) (simplif l2) | Lapply {ap_func = Lfunction ({params; body} as lfunction); ap_args = args; _} diff --git a/compiler/core/lam_stats.ml b/compiler/core/lam_stats.ml index 0a99af9393c..4eef9511cb8 100644 --- a/compiler/core/lam_stats.ml +++ b/compiler/core/lam_stats.ml @@ -48,6 +48,9 @@ type t = { (** we don't need count arities for all identifiers, for identifiers for sure it's not a function, there is no need to count them *) + mutable export_type_tbl: Types.type_expr Hash_ident.t; + (** Captures type annotations for exported identifiers before + optimization passes eliminate the carrying [Llet] nodes. *) } let pp = Format.fprintf @@ -70,4 +73,5 @@ let make ~export_idents ~export_ident_sets : t = ident_tbl = Hash_ident.create 31; exports = export_idents; export_idents = export_ident_sets; + export_type_tbl = Hash_ident.create 31; } diff --git a/compiler/core/lam_stats.mli b/compiler/core/lam_stats.mli index e2246eefc64..f58608757ee 100644 --- a/compiler/core/lam_stats.mli +++ b/compiler/core/lam_stats.mli @@ -36,6 +36,9 @@ type t = { (** we don't need count arities for all identifiers, for identifiers for sure it's not a function, there is no need to count them *) + mutable export_type_tbl: Types.type_expr Hash_ident.t; + (** Captures type annotations for exported identifiers before + optimization passes eliminate the carrying [Llet] nodes. *) } val print : Format.formatter -> t -> unit diff --git a/compiler/core/lam_ts_emit.ml b/compiler/core/lam_ts_emit.ml index 65e874357fd..531769360f9 100644 --- a/compiler/core/lam_ts_emit.ml +++ b/compiler/core/lam_ts_emit.ml @@ -55,18 +55,14 @@ let emit_decls ppf (groups : Lam_group.t list) (exports : Ident.t list) = let export_set = Set_ident.of_list exports in let walk_group (group : Lam_group.t) = match group with - | Lam_group.Single (_, id, lam) when Set_ident.mem export_set id -> ( + | Lam_group.Single (_, id, ty, lam) when Set_ident.mem export_set id -> ( let ts_ty = - match lam with - | Lam.Llet (_, _, ty, _, _) -> ( - match ty with - | Some ty -> Some (type_expr_to_ts ty) - | None -> None) - | Lam.Lfunction {ty; _} -> ( - match ty with - | Some ty -> Some (type_expr_to_ts ty) - | None -> None) - | _ -> None + match ty with + | Some ty -> Some (type_expr_to_ts ty) + | None -> ( + match lam with + | Lam.Lfunction {ty = Some ty; _} -> Some (type_expr_to_ts ty) + | _ -> None) in let is_fn = function_arity lam in match (is_fn, ts_ty) with diff --git a/compiler/core/lam_util.cppo.ml b/compiler/core/lam_util.cppo.ml index ea77a0ec14e..b210f74810f 100644 --- a/compiler/core/lam_util.cppo.ml +++ b/compiler/core/lam_util.cppo.ml @@ -65,7 +65,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 : Lam.t) (l : Lam.t) : Lam.t = + let refine_let ~kind ~ty param (arg : Lam.t) (l : Lam.t) : Lam.t = let is_block_constructor = function | Lam_primitive.Pmakeblock _ -> true | _ -> false @@ -118,21 +118,21 @@ let add_required_modules ( x : Ident.t list) (meta : Lam_stats.t) = 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 None 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 None 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 None arg l - | kind, _, _ -> - Lam.let_ kind param None arg l + Lam.let_ Alias param ty 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 ty 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 ty arg l + | kind, _, _ -> + Lam.let_ kind param ty arg l let alias_ident_or_global (meta : Lam_stats.t) (k:Ident.t) (v:Ident.t) (v_kind : Lam_id_kind.t) = diff --git a/compiler/core/lam_util.mli b/compiler/core/lam_util.mli index 25e257665b5..2eb10832a1f 100644 --- a/compiler/core/lam_util.mli +++ b/compiler/core/lam_util.mli @@ -52,7 +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:Lam_compat.let_kind -> Ident.t -> Lam.t -> Lam.t -> Lam.t +val refine_let : + kind:Lam_compat.let_kind -> + ty:Types.type_expr option -> + Ident.t -> + Lam.t -> + Lam.t -> + Lam.t val dump : string -> Lam.t -> unit (** [dump] when {!Js_config.is_same_file}*) diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index 7ba1bfd51d8..182ca316f3f 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -2806,7 +2806,7 @@ let for_let loc param pat body = (* This eliminates a useless variable (and stack slot in bytecode) for "let _ = ...". See #6865. *) Lsequence (param, body) - | Tpat_var (id, _) -> + | Tpat_var (id, _) | Tpat_alias ({pat_desc = Tpat_any}, id, _) -> (* fast path, and keep track of simple bindings to unboxable numbers *) Llet (Strict, id, Some pat.pat_type, param, body) | _ -> simple_for_let loc param pat body From 7072581bf61b12e9e37c074e3ac3fc739614ef9f Mon Sep 17 00:00:00 2001 From: Hyeseong Kim Date: Sun, 14 Jun 2026 06:28:21 +0900 Subject: [PATCH 3/5] emit with arg name --- compiler/core/lam_ts_emit.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/compiler/core/lam_ts_emit.ml b/compiler/core/lam_ts_emit.ml index 531769360f9..169afbce74f 100644 --- a/compiler/core/lam_ts_emit.ml +++ b/compiler/core/lam_ts_emit.ml @@ -13,15 +13,15 @@ let rec type_expr_to_ts (ty : Types.type_expr) : string = | Tarrow ({lbl = Nolabel; typ = arg_ty}, ret_ty, _, _) -> let arg = type_expr_to_ts arg_ty in let ret = type_expr_to_ts ret_ty in - "(" ^ arg ^ ") => " ^ ret + "(_: " ^ arg ^ ") => " ^ ret | Tarrow ({lbl = Labelled {txt = l}; typ = arg_ty}, ret_ty, _, _) -> let arg = type_expr_to_ts arg_ty in let ret = type_expr_to_ts ret_ty in - l ^ ": " ^ arg ^ " => " ^ ret + "(" ^ l ^ ": " ^ arg ^ ") => " ^ ret | Tarrow ({lbl = Optional {txt = l}; typ = arg_ty}, ret_ty, _, _) -> let arg = type_expr_to_ts arg_ty in let ret = type_expr_to_ts ret_ty in - l ^ "?: " ^ arg ^ " => " ^ ret + "(" ^ l ^ "?: " ^ arg ^ ") => " ^ ret | Ttuple tys -> "[" ^ String.concat ", " (List.map type_expr_to_ts tys) ^ "]" | Tconstr (path, args, _) -> let name = path_to_ts path in From 4204bf792953c51656db9e6603b0285abd021332 Mon Sep 17 00:00:00 2001 From: Hyeseong Kim Date: Sun, 14 Jun 2026 06:41:35 +0900 Subject: [PATCH 4/5] emit type bindings and generic params --- compiler/core/js_implementation.ml | 2 +- compiler/core/lam_compile_main.cppo.ml | 7 +- compiler/core/lam_compile_main.mli | 7 +- compiler/core/lam_ts_emit.ml | 125 +++++++++++++++++++++++-- 4 files changed, 130 insertions(+), 11 deletions(-) diff --git a/compiler/core/js_implementation.ml b/compiler/core/js_implementation.ml index 7603253b51d..7d8dc6e88c8 100644 --- a/compiler/core/js_implementation.ml +++ b/compiler/core/js_implementation.ml @@ -149,7 +149,7 @@ let after_parsing_impl ppf outputprefix (ast : Parsetree.structure) = in let js_program = print_if_pipe ppf Clflags.dump_rawlambda Printlambda.lambda lambda - |> Lam_compile_main.compile outputprefix exports + |> Lam_compile_main.compile ~typedtree outputprefix exports in if not !Js_config.cmj_only then Lam_compile_main.lambda_as_module js_program outputprefix); diff --git a/compiler/core/lam_compile_main.cppo.ml b/compiler/core/lam_compile_main.cppo.ml index 5d311a95318..5397de767cb 100644 --- a/compiler/core/lam_compile_main.cppo.ml +++ b/compiler/core/lam_compile_main.cppo.ml @@ -130,10 +130,11 @@ let _j = Js_pass_debug.dump (** Actually simplify_lets is kind of global optimization since it requires you to know whether it's used or not *) -let compile +let compile + ?(typedtree : Typedtree.structure option) (output_prefix : string) export_idents - (lam : Lambda.lambda) = + (lam : Lambda.lambda) = let export_ident_sets = Set_ident.of_list export_idents in (* To make toplevel happy - reentrant for js-demo *) let () = @@ -222,7 +223,7 @@ let compile Ext_filename.new_extension !Location.input_name ".d.ts" in Ext_fmt.with_file_as_pp dts_name (fun ppf -> - Lam_ts_emit.emit_decls ppf groups meta.exports) + Lam_ts_emit.emit_decls ?typedtree ppf groups meta.exports) end; #ifndef RELEASE diff --git a/compiler/core/lam_compile_main.mli b/compiler/core/lam_compile_main.mli index fcd298ce3aa..9aabfe0a2bb 100644 --- a/compiler/core/lam_compile_main.mli +++ b/compiler/core/lam_compile_main.mli @@ -27,7 +27,12 @@ (** Compile and register the hook of function to compile a lambda to JS IR *) -val compile : string -> Ident.t list -> Lambda.lambda -> J.deps_program +val compile : + ?typedtree:Typedtree.structure -> + string -> + Ident.t list -> + Lambda.lambda -> + J.deps_program (** For toplevel, [filename] is [""] which is the same as {!Env.get_unit_name ()} *) diff --git a/compiler/core/lam_ts_emit.ml b/compiler/core/lam_ts_emit.ml index 169afbce74f..69de59984ad 100644 --- a/compiler/core/lam_ts_emit.ml +++ b/compiler/core/lam_ts_emit.ml @@ -6,10 +6,42 @@ let rec path_to_ts (path : Path.t) : string = parent ^ "." ^ s | Papply _ -> "unknown" +let var_to_ts (name : string) : string = + let buf = Buffer.create (String.length name + 1) in + Buffer.add_char buf (Char.uppercase_ascii name.[0]); + Buffer.add_string buf (String.sub name 1 (String.length name - 1)); + Buffer.contents buf + +let collect_type_vars (ty : Types.type_expr) : Types.type_expr list = + let seen = Hashtbl.create 8 in + let acc = ref [] in + let rec visit (ty : Types.type_expr) = + match ty.Types.desc with + | Tvar (Some _) -> + if not (Hashtbl.mem seen ty) then ( + Hashtbl.add seen ty (); + acc := ty :: !acc) + | Tarrow (arg, ret_ty, _, _) -> + visit arg.typ; + visit ret_ty + | Ttuple ls -> List.iter visit ls + | Tconstr (_, args, _) -> List.iter visit args + | Tlink t -> visit t + | Tpoly (t, _) -> visit t + | _ -> () + in + visit ty; + List.rev !acc + +let type_var_to_ts (ty : Types.type_expr) : string = + match ty.desc with + | Tvar (Some s) -> var_to_ts s + | _ -> "unknown" + let rec type_expr_to_ts (ty : Types.type_expr) : string = match ty.desc with | Tvar None -> "unknown" - | Tvar (Some s) -> s + | Tvar (Some s) -> var_to_ts s | Tarrow ({lbl = Nolabel; typ = arg_ty}, ret_ty, _, _) -> let arg = type_expr_to_ts arg_ty in let ret = type_expr_to_ts ret_ty in @@ -41,27 +73,109 @@ let rec type_expr_to_ts (ty : Types.type_expr) : string = if args = [] then name else name ^ "<" ^ String.concat ", " (List.map type_expr_to_ts args) ^ ">" | Tlink ty -> type_expr_to_ts ty - | Tpoly (ty, _) -> type_expr_to_ts ty + | Tpoly (ty, []) -> type_expr_to_ts ty + | Tpoly (ty, tvs) -> + let params = List.map type_var_to_ts tvs in + "<" ^ String.concat ", " params ^ ">" ^ type_expr_to_ts ty | Tnil -> "undefined" | _ -> "unknown" +let type_expr_to_ts_with_generics (ty : Types.type_expr) : string = + let body = type_expr_to_ts ty in + let vars = collect_type_vars ty in + match vars with + | [] -> body + | _ -> + let params = List.map type_var_to_ts vars in + "<" ^ String.concat ", " params ^ ">" ^ body + let rec function_arity (lam : Lam.t) : int option = match lam with | Lam.Lfunction {arity; _} -> Some arity | Lam.Llet (_, _, _, _, body) -> function_arity body | _ -> None -let emit_decls ppf (groups : Lam_group.t list) (exports : Ident.t list) = +let core_type_to_ts (ct : Typedtree.core_type) : string = + match ct.Typedtree.ctyp_desc with + | Typedtree.Ttyp_var s -> var_to_ts s + | _ -> type_expr_to_ts ct.Typedtree.ctyp_type + +let params_to_ts (params : (Typedtree.core_type * _) list) : string = + match params with + | [] -> "" + | _ -> + let names = List.map (fun (ct, _) -> core_type_to_ts ct) params in + "<" ^ String.concat ", " names ^ ">" + +let emit_type_decl ppf (td : Typedtree.type_declaration) = + let name = td.Typedtree.typ_name.Location.txt in + let params = params_to_ts td.Typedtree.typ_params in + let body = + match td.Typedtree.typ_kind with + | Typedtree.Ttype_abstract -> ( + match td.Typedtree.typ_manifest with + | Some manifest -> core_type_to_ts manifest + | None -> "unknown") + | Typedtree.Ttype_variant ctors -> + let parts = + List.filter_map + (fun (cd : Typedtree.constructor_declaration) -> + let cname = cd.Typedtree.cd_name.Location.txt in + match cd.Typedtree.cd_args with + | Typedtree.Cstr_tuple [] -> Some ("\"" ^ cname ^ "\"") + | Typedtree.Cstr_tuple args -> + let arg_types = List.map core_type_to_ts args in + let fields = + List.mapi + (fun i ty -> "_" ^ string_of_int i ^ ": " ^ ty) + arg_types + in + Some + ("{ TAG: \"" ^ cname ^ "\"; " ^ String.concat "; " fields ^ " }") + | Typedtree.Cstr_record _ -> None) + ctors + in + if parts = [] then "unknown" else String.concat " | " parts + | Typedtree.Ttype_record labels -> + let fields = + List.map + (fun (ld : Typedtree.label_declaration) -> + let fname = ld.Typedtree.ld_name.Location.txt in + let ftype = core_type_to_ts ld.Typedtree.ld_type in + (if ld.Typedtree.ld_optional then fname ^ "?" else fname) + ^ ": " ^ ftype) + labels + in + "{ " ^ String.concat "; " fields ^ " }" + | Typedtree.Ttype_open -> "unknown" + in + Format.fprintf ppf "export type %s%s = %s@." name params body + +let emit_type_decls ppf (str : Typedtree.structure) = + List.iter + (fun item -> + match item.Typedtree.str_desc with + | Typedtree.Tstr_type (_, decls) -> List.iter (emit_type_decl ppf) decls + | _ -> ()) + str.Typedtree.str_items + +let emit_decls ?(typedtree : Typedtree.structure option) ppf + (groups : Lam_group.t list) (exports : Ident.t list) = + Format.fprintf ppf "// Type declarations generated by ReScript@.@."; + (match typedtree with + | Some str -> emit_type_decls ppf str + | None -> ()); let export_set = Set_ident.of_list exports in let walk_group (group : Lam_group.t) = match group with | Lam_group.Single (_, id, ty, lam) when Set_ident.mem export_set id -> ( let ts_ty = match ty with - | Some ty -> Some (type_expr_to_ts ty) + | Some ty -> Some (type_expr_to_ts_with_generics ty) | None -> ( match lam with - | Lam.Lfunction {ty = Some ty; _} -> Some (type_expr_to_ts ty) + | Lam.Lfunction {ty = Some ty; _} -> + Some (type_expr_to_ts_with_generics ty) | _ -> None) in let is_fn = function_arity lam in @@ -84,5 +198,4 @@ let emit_decls ppf (groups : Lam_group.t list) (exports : Ident.t list) = bindings | _ -> () in - Format.fprintf ppf "// Type declarations generated by ReScript@.@."; List.iter walk_group groups From fc3bd1e0c652c0169a7093c06bcce3a36c8bc61b Mon Sep 17 00:00:00 2001 From: Hyeseong Kim Date: Sun, 14 Jun 2026 07:24:03 +0900 Subject: [PATCH 5/5] chore --- compiler/core/lam_type_dump.ml | 8 +++----- compiler/core/lam_util.cppo.ml | 28 ++++++++++++++-------------- 2 files changed, 17 insertions(+), 19 deletions(-) diff --git a/compiler/core/lam_type_dump.ml b/compiler/core/lam_type_dump.ml index 84eee2e6036..dcdb88e3fb1 100644 --- a/compiler/core/lam_type_dump.ml +++ b/compiler/core/lam_type_dump.ml @@ -38,15 +38,13 @@ let collect (lam : Lam.t) : unit = List.iter (fun (_, l) -> walk l) bindings; walk body | Lprim {args; _} -> List.iter walk args - | Lswitch (arg, sw) -> + | Lswitch (arg, sw) -> ( walk arg; List.iter (fun (_, l) -> walk l) sw.sw_consts; List.iter (fun (_, l) -> walk l) sw.sw_blocks; - (match sw.sw_failaction with + match sw.sw_failaction with | Some l -> walk l - | None -> ()); - List.iter (fun (_, l) -> walk l) sw.sw_consts; - List.iter (fun (_, l) -> walk l) sw.sw_blocks + | None -> ()) | Lstringswitch (arg, cases, default) -> ( walk arg; List.iter (fun (_, l) -> walk l) cases; diff --git a/compiler/core/lam_util.cppo.ml b/compiler/core/lam_util.cppo.ml index b210f74810f..68db5472458 100644 --- a/compiler/core/lam_util.cppo.ml +++ b/compiler/core/lam_util.cppo.ml @@ -119,20 +119,20 @@ let add_required_modules ( x : Ident.t list) (meta : Lam_stats.t) = field read — we mark it as an alias so downstream passes can inline the original expression and drop the temporary. *) Lam.let_ Alias param ty 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 ty 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 ty arg l - | kind, _, _ -> - Lam.let_ kind param ty 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 ty 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 ty arg l + | kind, _, _ -> + Lam.let_ kind param ty arg l let alias_ident_or_global (meta : Lam_stats.t) (k:Ident.t) (v:Ident.t) (v_kind : Lam_id_kind.t) =