diff --git a/compiler/bsc/rescript_compiler_main.ml b/compiler/bsc/rescript_compiler_main.ml index 24023535e0..71070b1421 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 df6ab959d1..7d8dc6e88c 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,12 +143,13 @@ 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 - |> 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.ml b/compiler/core/lam.ml index 15875608b9..8276b05f8d 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 f6a398d677..ed921fc6ce 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 29a8d3a160..daf85b418f 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 5a5d4bbccd..9527adc367 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.ml b/compiler/core/lam_beta_reduce.ml index e7f9842bbc..1ee3f60bbf 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_beta_reduce_util.ml b/compiler/core/lam_beta_reduce_util.ml index c1855dec20..c685539740 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 5499bb77ab..c29de6a262 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 f5e63d45af..668c2384b0 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 2092c92b9f..62ea8269c4 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 2ddddc7cfd..5ed34527d0 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.ml b/compiler/core/lam_compile.ml index 97f6bec84e..2da884f233 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 cdecf32ef8..5397de767c 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 -> @@ -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 () = @@ -210,10 +211,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 ?typedtree 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_compile_main.mli b/compiler/core/lam_compile_main.mli index fcd298ce3a..9aabfe0a2b 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_convert.ml b/compiler/core/lam_convert.ml index 9e0bccdaa9..0491e7c7f0 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_dce.ml b/compiler/core/lam_dce.ml index ee476b3da8..fbc046294b 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_eta_conversion.ml b/compiler/core/lam_eta_conversion.ml index 220fa76022..cbfbd65664 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 045435a44e..20679b61e4 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 d269c78c7c..6e6e215379 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_group.ml b/compiler/core/lam_group.ml index 357222cd64..0c75423f79 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 c6325acc92..e9a823ae8c 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_hit.ml b/compiler/core/lam_hit.ml index fba5f7bdf7..0b81b21b9d 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 eae83894b7..c5edaef6f2 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 7965cfc601..5fa13deb71 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 807e9323f3..6de51f4853 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_count.ml b/compiler/core/lam_pass_count.ml index 53bdf406dd..a2d5d95b89 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 6e94a78a58..baacf27715 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*) @@ -105,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: @@ -121,16 +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; @@ -139,13 +143,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 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) @@ -164,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) -> @@ -204,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 @@ -221,16 +225,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 030f0c54f1..2dbba30e13 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 e47be32955..de092ca20e 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 503e90c1f8..e7ac0e48de 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; @@ -35,13 +36,13 @@ 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, 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 {[ @@ -103,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) | _ -> ( @@ -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_util.refine_let ~kind v l1 (simplif lbody)) + Lam.let_ Alias v ty 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, 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,8 +130,8 @@ 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_util.refine_let ~kind v l1 (simplif l2)) + Lam.let_ Alias v ty 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; _} @@ -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 52a88ad02e..e608f98193 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 9408b11aea..b0c192f88e 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 6f1e1b7583..f471f1065e 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_stats.ml b/compiler/core/lam_stats.ml index 0a99af9393..4eef9511cb 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 e2246eefc6..f58608757e 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_subst.ml b/compiler/core/lam_subst.ml index e449102dc5..cfab4d056c 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 0000000000..69de59984a --- /dev/null +++ b/compiler/core/lam_ts_emit.ml @@ -0,0 +1,201 @@ +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 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) -> 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 + "(_: " ^ 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 + | 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 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_with_generics ty) + | None -> ( + match lam with + | Lam.Lfunction {ty = Some ty; _} -> + Some (type_expr_to_ts_with_generics ty) + | _ -> 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 + 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 0000000000..dcdb88e3fb --- /dev/null +++ b/compiler/core/lam_type_dump.ml @@ -0,0 +1,93 @@ +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 -> ()) + | 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 9d7334930c..68db547245 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 @@ -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 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 arg l + (* 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 arg l + (* 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 arg l + 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 25e257665b..2eb10832a1 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/core/polyvar_pattern_match.ml b/compiler/core/polyvar_pattern_match.ml index fea0b53f1d..fc6460f055 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 a78cf8c3eb..e027fed477 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 f0cd88115e..a680662ca2 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 0cb5f1ea3e..76e10b0be3 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 e078a2a28f..53719f9d81 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 99f399aa0a..70eb288342 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 916646ea08..182ca316f3 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 @@ -2806,9 +2806,9 @@ 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, 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 e30f3c867f..29eb2e4edf 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 77617eda5d..585473cf4f 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 69fbcab472..1d3b4011bb 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 7e846adbb6..b53f52c4d8 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 74ef747e10..f88fe1e869 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 *)