diff --git a/AGENTS.md b/AGENTS.md index 0195d90495d..dd3038a9958 100644 --- a/AGENTS.md +++ b/AGENTS.md @@ -47,8 +47,6 @@ The Makefile’s targets build on each other in this order: - **Don't use unit `()` with mandatory labeled arguments** - When a function has a mandatory labeled argument (like `~config`), don't add a trailing `()` parameter. The labeled argument already prevents accidental partial application. Only use `()` when all parameters are optional and you need to force evaluation. Example: `let forceDelayedItems ~config = ...` not `let forceDelayedItems ~config () = ...` -- **Be careful with similar constructor names across different IRs** - Note that `Lam` (Lambda IR) and `Lambda` (typed lambda) have variants with similar constructor names like `Ltrywith`, but they represent different things in different compilation phases. - - **Avoid warning suppressions** - Never use `[@@warning "..."]` to silence warnings. Instead, fix the underlying issue properly - **Skip trailing `; _` in record patterns** - The warning it targets is disabled in this codebase, so prefer `{field = x}` over `{field = x; _}`. @@ -116,8 +114,8 @@ Read the area guide before changing a compiler subsystem: printing, and JSX transformation - [`compiler/ml/README.md`](compiler/ml/README.md) for the type checker and typed tree -- [`compiler/core/README.md`](compiler/core/README.md) for Lambda, Lam, and - JavaScript generation +- [`compiler/core/README.md`](compiler/core/README.md) for Lambda + optimization and JavaScript generation - [`analysis/README.md`](analysis/README.md) for editor analysis - [`rewatch/README.md`](rewatch/README.md) for the build system - [`tools/README.md`](tools/README.md) for `rescript-tools` diff --git a/CHANGELOG.md b/CHANGELOG.md index d819e75070a..23104a040a7 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -32,6 +32,9 @@ #### :bug: Bug fix +- Fix a recursive module with an empty signature discarding its right-hand side. Lambda-to-Lam conversion rewrote `Pupdate_mod` to unit when the module's shape had no fields, dropping the primitive's arguments - one of which is the right-hand side - so `module rec M: {} = { let () = Console.log("effect") }` emitted nothing for `M`. The elision now happens where the bindings are produced, with the right-hand side still in hand. https://github.com/rescript-lang/rescript/pull/8608 +- Fix `Int.Ref.increment` and `Int.Ref.decrement` evaluating their argument twice: `Int.Ref.increment(mkRef())` emitted `mkRef().contents = mkRef().contents + 1 | 0`. The `%incr` and `%decr` builtins lowered to an assignment that repeated the argument expression; they now bind the reference before the read-modify-write. Inlining decisions around an increment are taken on the code it stands for rather than on a single primitive node. https://github.com/rescript-lang/rescript/pull/8608 +- Fix a compiler crash on a polymorphic variant whose numeric name exceeds the `int32` range. `#99999999999("a")` and the same name in a pattern failed with `Failure("Int32.of_string")` and no location, because the range check ran in the frontend AST pass and matched only payload-free expressions. It now runs in `Typecore`, next to the integer literal decoding whose overflow error it mirrors, and covers both label positions. A bare `type t = [#99999999999]` still compiles, since nothing decodes a row field name. https://github.com/rescript-lang/rescript/pull/8608 - Object typing errors now describe fields directly: assigning to a field without `@set` reports that the field is not settable and suggests the annotation, and missing-property errors name the field instead of a phantom `"x#="` member. https://github.com/rescript-lang/rescript/pull/8597 - Fix signature inclusion rejecting equivalent object externals after type-alias expansion. https://github.com/rescript-lang/rescript/pull/8581 - Fix externals whose result type is an alias of `unit` so they use the same unit-return behavior as externals declared to return `unit`. https://github.com/rescript-lang/rescript/pull/8581 @@ -60,6 +63,11 @@ #### :house: Internal +- Merge the Lam intermediate representation into Lambda. With conversion already structural, `Lam.t` was `Lambda.lambda` constructor for constructor, so it becomes that type: `Lam_convert` and its one-to-one rebuild are gone, and `Lam`, `Lam_primitive`, `Lam_constant`, `Lam_compat`, `Lam_tag_info`, `Lam_free_variables`, `Lam_subst`, `Lam_iter` and `Lam_print` retire with it. `Lambda.t` is private with a constructor per variant, seven of which normalize as they build, so a pass cannot bypass normalization by writing a constructor directly. Generated JavaScript is unchanged. https://github.com/rescript-lang/rescript/pull/8608 +- Give Lambda the constant and shape decisions conversion used to make: JavaScript null, undefined, `Some`, assert-false, module-alias and nominal-constructor constants are explicit; polymorphic variant runtime names are produced at translation; a block's mutability is derived from its tag info; and a module reference is an `Lglobal_module` name in Lambda too, with the dependencies read off the term. Erasing builtins are classified in the primitive table rather than carried as a `Peliminated` primitive through both layers. https://github.com/rescript-lang/rescript/pull/8608 +- Remove the primitives and passes the merged representation no longer needs: the curried-application machinery (`Primitive_curry._N`, `ap_status`, `Js_call_info.arity`, `Curry_gen`), `%function_arity`, `Poffsetref`, `Poffsetint`, `Pisout` with `E.is_out`, and `Lam_pass_apply_arity` with `Lam_eta_conversion`. An `external` declared as `"%function_arity"`, `"%succint"` or `"%predint"` is now rejected as an unknown builtin. Generated JavaScript is unchanged apart from the operand order of two-value range tests, which was previously decided by whether the offset landed in an addition or a subtraction. https://github.com/rescript-lang/rescript/pull/8608 +- Specialize the switch compiler to Lambda. `Switch.Make` has had a single instantiation since native code generation was dropped, so the functor goes, along with a dead signature member and a location threaded through it for nothing. The range test the switcher wraps around a jump table is folded into the switch's failaction where it is produced, since a JavaScript `switch` has a native `default`; and the guard-clause rewrite that lifts a raising branch out of an `if` becomes a scheduled pass, being code motion rather than normalization. https://github.com/rescript-lang/rescript/pull/8608 +- Add sharing variants of the list and option maps, and a shallow Lambda traversal built on them, so a pass that rewrites nothing returns its input physically unchanged and allocates nothing. Consolidate the four ident set implementations - `Set_ident` plus `Set.Make (Ident)` written out again in `lambda.ml`, `mtype.ml` and `parmatch.ml` - into `Set_ident`. Merge the two Lambda printers, keeping `Printlambda`'s field debug info, block tags and import paths, `Lam_print`'s mutable-block form and file dumps, and tagging every comparison with its operand kind so `Pintcomp`, `Pjscomp` and `Pstringcomp` are no longer all printed `==`. https://github.com/rescript-lang/rescript/pull/8608 - Rework the object-type representation end to end: object rows are plain field chains carrying a per-field mutability state (no phantom setter members), object literals are typed directly and property access and assignment are first-class AST and Lambda nodes shared between the Lambda and JS pipelines, and dead class-system remnants (the field-presence lattice, the class-abbreviation memo on object types, method-send typing) are removed. https://github.com/rescript-lang/rescript/pull/8597 - Upgrade the development toolchain and primary CI builds to OCaml 5.5 while retaining OCaml 5.0 as the minimum supported version. https://github.com/rescript-lang/rescript/pull/8589 - Upgrade the vendored Flow parser from 0.267.0 to 0.320.0, the final release of the OCaml implementation. https://github.com/rescript-lang/rescript/pull/8588 diff --git a/compiler/bsc/rescript_compiler_main.ml b/compiler/bsc/rescript_compiler_main.ml index c1837ee4f79..f245e4629db 100644 --- a/compiler/bsc/rescript_compiler_main.ml +++ b/compiler/bsc/rescript_compiler_main.ml @@ -408,10 +408,10 @@ let command_line_flags : (string * Bsc_args.spec * string) array = "*internal* Disable cross module inlining(experimental)" ); ( "-debug-ir", set Js_config.debug_ir, - "*internal* Dump compiler IR and enable Lam invariant checks" ); + "*internal* Dump compiler IR and enable Lambda invariant checks" ); ( "-check-lam", set Js_config.check_lam, - "*internal* Check Lam invariants after optimization passes" ); + "*internal* Check Lambda invariants after optimization passes" ); ( "-bs-no-check-div-by-zero", clear Js_config.check_div_by_zero, "*internal* unsafe mode, don't check div by zero and mod by zero" ); diff --git a/compiler/common/js_config.mli b/compiler/common/js_config.mli index 2e8dc81a35b..c4098918ca8 100644 --- a/compiler/common/js_config.mli +++ b/compiler/common/js_config.mli @@ -53,7 +53,7 @@ val debug_ir : bool ref (** dump intermediate representations and related diagnostics *) val check_lam : bool ref -(** check Lam invariants after optimization passes *) +(** check Lambda invariants after optimization passes *) val no_builtin_ppx : bool ref (** options for builtin ppx *) diff --git a/compiler/core/README.md b/compiler/core/README.md index 28ef3609bf6..021e56764fd 100644 --- a/compiler/core/README.md +++ b/compiler/core/README.md @@ -1,8 +1,8 @@ -# Lambda, Lam, and JavaScript generation +# Lambda optimization and JavaScript generation This directory contains the compiler backend after typedtree translation. It -owns ReScript's Lam representation, Lam optimization passes, JavaScript IR, -and JavaScript output. +owns the Lambda optimization passes, the JavaScript IR, and JavaScript output. +Lambda itself is defined in [`../ml/lambda.mli`](../ml/lambda.mli). ## Pipeline and code map @@ -11,16 +11,16 @@ Typedtree translation in `compiler/ml/translcore.ml` and `compiler/ml/lambda.mli`. [`lam_convert.ml`](lam_convert.ml) -: Converts `Lambda.lambda` to the ReScript-specific [`Lam.t`](lam.mli), - normalizes aliases, and collects potential module dependencies. +: Collects the modules a compilation unit depends on, read off the Lambda + term. `lam_pass_*.ml` and the other `lam_*.ml` modules -: Analyze and transform Lam. [`lam_compile_main.ml`](lam_compile_main.ml) +: Analyze and transform Lambda. [`lam_compile_main.ml`](lam_compile_main.ml) coordinates the backend pass sequence; read it before inserting or reordering a pass. [`lam_compile.ml`](lam_compile.ml) -: Lowers Lam to JavaScript IR. Primitive-specific and FFI lowering is split +: Lowers Lambda to JavaScript IR. Primitive-specific and FFI lowering is split into `lam_compile_primitive.ml`, `lam_compile_external_call.ml`, and related modules. @@ -34,12 +34,14 @@ Typedtree translation in `compiler/ml/translcore.ml` and ## Changing a representation -`Lambda` and `Lam` have similarly named constructors but are distinct IRs. -When adding or changing one, search every producer, traversal, optimizer, -printer, serializer, and consumer of that specific type. Do not assume a match -on the other representation covers it. +`Lambda.t` is private: every term is built through the constructors in +[`../ml/lambda.mli`](../ml/lambda.mli), six of which normalize as they build. +A constructor may replace a node with an equivalent one, but may not move code +between branches - that is what a pass is for. When adding or changing a +constructor, search every producer, traversal, optimizer, printer, serializer, +and consumer. -Check persistence boundaries as part of the change. `Lam.t` can be stored in +Check persistence boundaries as part of the change. `Lambda.t` can be stored in `.cmj` data through `js_cmj_format`; a constructor or payload change therefore changes cached compiler data even when generated JavaScript is unchanged. @@ -65,5 +67,5 @@ compiler flags below to compare intermediate forms for a small source file: ./cli/bsc.js -drawlambda example.res ``` -For Lam-specific debugging, use [`lam_print.ml`](lam_print.ml) at the relevant +For backend debugging, use [`lam_print.ml`](lam_print.ml) at the relevant pass boundary and remove temporary output before committing. diff --git a/compiler/core/ir_diagnostics.ml b/compiler/core/ir_diagnostics.ml index d6fbe8a766e..2bcce68f0e9 100644 --- a/compiler/core/ir_diagnostics.ml +++ b/compiler/core/ir_diagnostics.ml @@ -29,14 +29,14 @@ let next_path diagnostics ~kind ~pass ~extension = let dump_lam diagnostics ~pass lam = let path = next_path diagnostics ~kind:"lam" ~pass ~extension:".lam" in - Ext_log.dwarn ~__POS__ "Dumping Lam pass %s to %s" pass path; - Lam_print.serialize path lam + Ext_log.dwarn ~__POS__ "Dumping pass %s to %s" pass path; + Printlambda.serialize path lam let dump_groups diagnostics groups = let path = next_path diagnostics ~kind:"lam" ~pass:"groups" ~extension:".lambda" in - Ext_log.dwarn ~__POS__ "Dumping Lam groups to %s" path; + Ext_log.dwarn ~__POS__ "Dumping groups to %s" path; Ext_fmt.with_file_as_pp path (fun fmt -> Format.pp_print_list ~pp_sep:Format.pp_print_newline Lam_group.pp_group fmt groups) diff --git a/compiler/core/ir_diagnostics.mli b/compiler/core/ir_diagnostics.mli index 9ec4b0804d7..cb17766afd2 100644 --- a/compiler/core/ir_diagnostics.mli +++ b/compiler/core/ir_diagnostics.mli @@ -1,6 +1,6 @@ type t val create : output_prefix:string -> t -val dump_lam : t -> pass:string -> Lam.t -> unit +val dump_lam : t -> pass:string -> Lambda.t -> unit val dump_groups : t -> Lam_group.t list -> unit val dump_js : t -> pass:string -> J.program -> unit diff --git a/compiler/core/js_block_runtime.ml b/compiler/core/js_block_runtime.ml index b328237ec96..1d235210f5d 100644 --- a/compiler/core/js_block_runtime.ml +++ b/compiler/core/js_block_runtime.ml @@ -24,10 +24,7 @@ let option_id = Ident.create_persistent Primitive_modules.option -let curry_id = Ident.create_persistent Primitive_modules.curry - let check_additional_id (x : J.expression) : Ident.t option = match x.expression_desc with | Optional_block (_, false) -> Some option_id - | Call (_, _, {arity = NA}) -> Some curry_id | _ -> None diff --git a/compiler/core/js_call_info.ml b/compiler/core/js_call_info.ml index c58aad901f0..09a991636b0 100644 --- a/compiler/core/js_call_info.ml +++ b/compiler/core/js_call_info.ml @@ -22,8 +22,6 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type arity = Full | NA - type call_info = | Call_ml (* called by plain ocaml expression *) | Call_builtin_runtime (* built-in externals *) @@ -33,15 +31,12 @@ type call_info = {[ fun x y -> (f x y) === f ]} when [f] is an atom *) -type t = {call_info: call_info; arity: arity; call_transformed_jsx: bool} - -let dummy = {arity = NA; call_info = Call_na; call_transformed_jsx = false} +type t = {call_info: call_info; call_transformed_jsx: bool} let builtin_runtime_call = - {arity = Full; call_info = Call_builtin_runtime; call_transformed_jsx = false} + {call_info = Call_builtin_runtime; call_transformed_jsx = false} -let ml_full_call = - {arity = Full; call_info = Call_ml; call_transformed_jsx = false} +let ml_full_call = {call_info = Call_ml; call_transformed_jsx = false} let na_full_call transformed_jsx = - {arity = Full; call_info = Call_na; call_transformed_jsx = transformed_jsx} + {call_info = Call_na; call_transformed_jsx = transformed_jsx} diff --git a/compiler/core/js_call_info.mli b/compiler/core/js_call_info.mli index ff0d3ad875e..3696e778ce8 100644 --- a/compiler/core/js_call_info.mli +++ b/compiler/core/js_call_info.mli @@ -24,8 +24,6 @@ (** Type for collecting call site information, used in JS IR *) -type arity = Full | NA - type call_info = | Call_ml (* called by plain ocaml expression *) | Call_builtin_runtime (* built-in externals *) @@ -35,9 +33,7 @@ type call_info = {[ fun x y -> f x y === f ]} when [f] is an atom *) -type t = {call_info: call_info; arity: arity; call_transformed_jsx: bool} - -val dummy : t +type t = {call_info: call_info; call_transformed_jsx: bool} val builtin_runtime_call : t diff --git a/compiler/core/js_cmj_format.ml b/compiler/core/js_cmj_format.ml index 9f3458aed84..5afc6ca5330 100644 --- a/compiler/core/js_cmj_format.ml +++ b/compiler/core/js_cmj_format.ml @@ -29,7 +29,7 @@ type arity = Single of Lam_arity.t | Submodule of Lam_arity.t array (* TODO: add a magic number *) type cmj_value = { arity: arity; - persistent_closed_lambda: Lam.t option; + persistent_closed_lambda: Lambda.t option; (** Either constant or closed functor *) } @@ -40,7 +40,7 @@ let single_na = Single Lam_arity.na type keyed_cmj_value = { name: string; arity: arity; - persistent_closed_lambda: Lam.t option; + persistent_closed_lambda: Lambda.t option; } type keyed_cmj_values = keyed_cmj_value array diff --git a/compiler/core/js_cmj_format.mli b/compiler/core/js_cmj_format.mli index 18a8c05e145..a6a9cf29b77 100644 --- a/compiler/core/js_cmj_format.mli +++ b/compiler/core/js_cmj_format.mli @@ -49,7 +49,8 @@ type arity = Single of Lam_arity.t | Submodule of Lam_arity.t array type cmj_value = { arity: arity; - persistent_closed_lambda: Lam.t option; (* Either constant or closed functor *) + persistent_closed_lambda: Lambda.t option; + (* Either constant or closed functor *) } type effect_ = string option @@ -57,7 +58,7 @@ type effect_ = string option type keyed_cmj_value = { name: string; arity: arity; - persistent_closed_lambda: Lam.t option; + persistent_closed_lambda: Lambda.t option; } type hoisted_export = { diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index 0584e3852b2..b24c5b8a587 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -56,7 +56,6 @@ module S = Js_stmt_make module L = Js_dump_lit (* There modules are dynamically inserted in the last stage - {Caml_curry} {Caml_option} They can appear anywhere so even if you have a module @@ -72,26 +71,6 @@ module L = Js_dump_lit (our call Js_fun_env.get_unbounded env) is not precise *) -module Curry_gen = struct - let pp_curry_dot f = - P.string f Primitive_modules.curry; - P.string f L.dot - - let pp_optimize_curry (f : P.t) (len : int) = - pp_curry_dot f; - P.string f "__"; - P.string f (Printf.sprintf "%d" len) - - let pp_app_any (f : P.t) = - pp_curry_dot f; - P.string f "app" - - let pp_app (f : P.t) (len : int) = - pp_curry_dot f; - P.string f "_"; - P.string f (Printf.sprintf "%d" len) -end - type cxt = Ext_pp_scope.t let semi f = P.string f L.semi @@ -156,7 +135,7 @@ let rec exp_need_paren ?(arrow = false) (e : J.expression) = | Caml_block ( _, _, - ( Blk_record _ | Blk_module _ | Blk_poly_var _ | Blk_extension + ( Blk_record _ | Blk_module _ | Blk_poly_var | Blk_extension | Blk_record_ext _ | Blk_record_inlined _ | Blk_constructor _ ) ) | Object _ -> true @@ -279,12 +258,6 @@ f/122 --> else check last bumped id, increase it and register *) -(** - Turn [function f (x,y) { return a (x,y)} ] into [Curry.__2(a)], - The idea is that [Curry.__2] will guess the arity of [a], if it does - hit, then there is no cost when passed -*) - let is_var (b : J.expression) a = match b.expression_desc with | Var (Id i) -> Ident.same i a @@ -313,11 +286,7 @@ let default_fn_exp_state = No_name {single_arg = false} (* TODO: refactoring Note that {!pp_function} could print both statement and expression when [No_name] is given *) -let rec try_optimize_curry cxt f len function_id = - Curry_gen.pp_optimize_curry f len; - P.paren_group f 1 (fun _ -> expression ~level:1 cxt f function_id) - -and pp_function ~return_unit ~async ~is_method ?directive cxt (f : P.t) +let rec pp_function ~return_unit ~async ~is_method ?directive cxt (f : P.t) ~fn_state (l : Ident.t list) (b : J.block) (env : Js_fun_env.t) : cxt = match b with | [ @@ -327,35 +296,28 @@ and pp_function ~return_unit ~async ~is_method ?directive cxt (f : P.t) { expression_desc = Call - ( ({expression_desc = Var v; _} as function_id), + ( {expression_desc = Var v; _}, ls, - { - arity = (Full | NA) as arity (* see #234*); - (* TODO: need a case to justify it*) - call_info = Call_builtin_runtime | Call_ml; - } ); + {call_info = Call_builtin_runtime | Call_ml} ); }; }; ] - when (* match such case: - {[ function(x,y){ return u(x,y) } ]} - it can be optimized in to either [u] or [Curry.__n(u)] - *) + when (* Eta reduce a wrapper around a saturated call: + {[ function(x,y){ return u(x,y) } ]} prints as [u]. + Only for a ReScript callee of exactly this arity: [Call_na] is an + FFI name, where the wrapper truncates extra arguments the JS callee + would otherwise see, defers the name's resolution to call time, and + keeps it from capturing a local of the same name. *) (not is_method) && params_match_call l ls v -> ( - let optimize len ~p cxt f v = - if p then try_optimize_curry cxt f len function_id else vident cxt f v - in - let len = List.length l in - (* length *) match fn_state with | Name_top i | Name_non_top i -> let cxt = pp_var_assign cxt f i in - let cxt = optimize len ~p:(arity = NA && len <= 8) cxt f v in + let cxt = vident cxt f v in semi f; cxt | Is_return | No_name _ -> if fn_state = Is_return then return_sp f; - optimize len ~p:(arity = NA && len <= 8) cxt f v) + vident cxt f v) | _ -> let set_env : Set_ident.t = (* identifiers will be printed following*) @@ -685,61 +647,46 @@ and expression_desc cxt ~(level : int) f x : cxt = | _ -> (* This should not happen, we fallback to the general case *) expression_desc cxt ~level f - (Call - ( e, - el, - {call_transformed_jsx = false; arity = Full; call_info = Call_ml} - ))) - | Call (e, el, info) -> + (Call (e, el, {call_transformed_jsx = false; call_info = Call_ml}))) + | Call (e, el, _info) -> P.cond_paren_group f (level > 15) (fun _ -> P.group f 0 (fun _ -> - match (info, el) with - | {arity = Full}, _ | _, [] -> - let cxt = - P.cond_paren_group f - (match e.expression_desc with - | Fun _ -> true - | _ -> false) - (fun () -> expression ~level:15 cxt f e) - in - P.paren_group f 0 (fun _ -> - match el with - | [ - { - expression_desc = - Fun - { - is_method; - params; - body; - env; - return_unit; - async; - directive; - }; - }; - ] -> - pp_function ?directive ~is_method ~return_unit ~async - ~fn_state:(No_name {single_arg = true}) - cxt f params body env - | _ -> - let el = - match el with - | [e] when e.expression_desc = Undefined {is_unit = true} - -> - (* omit passing undefined when the call is f() *) - [] - | _ -> el - in - arguments cxt f el) - | _, _ -> - let len = List.length el in - if 1 <= len && len <= 8 then ( - Curry_gen.pp_app f len; - P.paren_group f 0 (fun _ -> arguments cxt f (e :: el))) - else ( - Curry_gen.pp_app_any f; - P.paren_group f 0 (fun _ -> arguments cxt f [e; E.array el])))) + let cxt = + P.cond_paren_group f + (match e.expression_desc with + | Fun _ -> true + | _ -> false) + (fun () -> expression ~level:15 cxt f e) + in + P.paren_group f 0 (fun _ -> + match el with + | [ + { + expression_desc = + Fun + { + is_method; + params; + body; + env; + return_unit; + async; + directive; + }; + }; + ] -> + pp_function ?directive ~is_method ~return_unit ~async + ~fn_state:(No_name {single_arg = true}) + cxt f params body env + | _ -> + let el = + match el with + | [e] when e.expression_desc = Undefined {is_unit = true} -> + (* omit passing undefined when the call is f() *) + [] + | _ -> el + in + arguments cxt f el))) | Tagged_template (call_expr, string_args, value_args) -> let cxt = expression cxt ~level f call_expr in P.string f "`"; @@ -943,7 +890,7 @@ and expression_desc cxt ~(level : int) f x : cxt = | _ -> Some (Js_op.Lit f, x)) in expression_desc cxt ~level f (Object (None, fields)) - | Caml_block (el, _, Blk_poly_var _) -> ( + | Caml_block (el, _, Blk_poly_var) -> ( match el with | [tag; value] -> expression_desc cxt ~level f @@ -1014,8 +961,7 @@ and expression_desc cxt ~(level : int) f x : cxt = | _ -> J.Object (None, objs) in expression_desc cxt ~level f exp - | Caml_block (_, _, (Blk_module_export _ | Blk_some | Blk_some_not_nested)) -> - assert false + | Caml_block (_, _, Blk_module_export _) -> assert false | Caml_block (el, _, Blk_tuple) -> expression_desc cxt ~level f (Array el) | Caml_block_tag (e, tag) -> P.group f 1 (fun _ -> diff --git a/compiler/core/js_exp_make.ml b/compiler/core/js_exp_make.ml index a10df47a627..5e8d25b979c 100644 --- a/compiler/core/js_exp_make.ml +++ b/compiler/core/js_exp_make.ml @@ -308,18 +308,17 @@ let method_ ?comment ?immutable_mask ~async ~return_unit params body : t = } (** ATTENTION: This is coupuled with {!Caml_obj.caml_update_dummy} *) -let dummy_obj ?comment (info : Lam_tag_info.t) : t = +let dummy_obj ?comment (info : Lambda.tag_info) : t = (* TODO: for record it is [{}] for other it is [[]] *) match info with | Blk_record _ | Blk_module _ | Blk_constructor _ | Blk_record_inlined _ - | Blk_poly_var _ | Blk_extension | Blk_record_ext _ -> + | Blk_poly_var | Blk_extension | Blk_record_ext _ -> {comment; source_loc = None; expression_desc = Object (None, [])} | Blk_tuple | Blk_module_export _ -> {comment; source_loc = None; expression_desc = Array []} - | Blk_some | Blk_some_not_nested -> assert false (* TODO: complete pure ... @@ -640,14 +639,6 @@ let string_length ?comment (e : t) : t = (* No optimization for {j||j}*) | _ -> {expression_desc = Length e; comment; source_loc = None} -let function_length ?comment (e : t) : t = - match e.expression_desc with - | Fun {is_method; params} -> - let params_length = List.length params in - int ?comment - (Int32.of_int (if is_method then params_length - 1 else params_length)) - | _ -> {expression_desc = Length e; comment; source_loc = None} - let rec string_append ?comment (e : t) (el : t) : t = let concat a b ~delim = {e with expression_desc = Str {txt = a ^ b; delim}} in match (e.expression_desc, el.expression_desc) with @@ -1452,7 +1443,7 @@ let to_int32 ?comment (e : J.expression) : J.expression = int32_bor ?comment e zero_int_literal (* TODO: if we already know the input is int32, [x|0] can be reduced into [x] *) -let string_comp (cmp : Lam_compat.comparison) ?comment (e0 : t) (e1 : t) = +let string_comp (cmp : Lambda.comparison) ?comment (e0 : t) (e1 : t) = match (e0.expression_desc, e1.expression_desc) with | Str {txt = a0; delim = d0}, Str {txt = a1; delim = d1} -> ( match (cmp, str_equal a0 d0 a1 d1) with @@ -1471,7 +1462,7 @@ let is_type_object (e : t) : t = string_equal (typeof e) (str "object") let obj_length ?comment e : t = to_int32 {expression_desc = Length e; comment; source_loc = None} -let compare_int_aux (cmp : Lam_compat.comparison) (l : int) r = +let compare_int_aux (cmp : Lambda.comparison) (l : int) r = match cmp with | Ceq -> l = r | Cneq -> l <> r @@ -1480,7 +1471,7 @@ let compare_int_aux (cmp : Lam_compat.comparison) (l : int) r = | Cle -> l <= r | Cge -> l >= r -let rec int_comp (cmp : Lam_compat.comparison) ?comment (e0 : t) (e1 : t) = +let rec int_comp (cmp : Lambda.comparison) ?comment (e0 : t) (e1 : t) = match (cmp, e0.expression_desc, e1.expression_desc) with | _, Number (Int {i = l}), Number (Int {i = r}) -> let l = Ext_int.int32_unsigned_to_int l in @@ -1508,7 +1499,7 @@ let rec int_comp (cmp : Lam_compat.comparison) ?comment (e0 : t) (e1 : t) = true_ | _ -> bin ?comment (Lam_compile_util.jsop_of_comp cmp) e0 e1 -let bool_comp (cmp : Lam_compat.comparison) ?comment (e0 : t) (e1 : t) = +let bool_comp (cmp : Lambda.comparison) ?comment (e0 : t) (e1 : t) = match (e0, e1) with | {expression_desc = Bool l}, {expression_desc = Bool r} -> bool @@ -1554,60 +1545,6 @@ let rec int32_lsr ?comment (e1 : J.expression) (e2 : J.expression) : we can apply a more general optimization here, do some algebraic rewerite rules to rewrite [triple_equal] *) -let rec is_out ?comment (e : t) (range : t) : t = - match (range.expression_desc, e.expression_desc) with - | Number (Int {i = 1l}), Var _ -> - not (or_ (triple_equal e zero_int_literal) (triple_equal e one_int_literal)) - | ( Number (Int {i = 1l}), - ( Bin - ( Plus, - {expression_desc = Number (Int {i; _})}, - ({expression_desc = Var _; _} as x) ) - | Bin - ( Plus, - ({expression_desc = Var _; _} as x), - {expression_desc = Number (Int {i; _})} ) ) ) -> - not - (or_ - (triple_equal x (int (Int32.neg i))) - (triple_equal x (int (Int32.sub Int32.one i)))) - | ( Number (Int {i = 1l}), - Bin - ( Minus, - ({expression_desc = Var _; _} as x), - {expression_desc = Number (Int {i; _})} ) ) -> - not (or_ (triple_equal x (int (Int32.add i 1l))) (triple_equal x (int i))) - (* (x - i >>> 0 ) > k *) - | ( Number (Int {i = k}), - Bin - ( Minus, - ({expression_desc = Var _; _} as x), - {expression_desc = Number (Int {i; _})} ) ) -> - or_ (int_comp Cgt x (int (Int32.add i k))) (int_comp Clt x (int i)) - | Number (Int {i = k}), Var _ -> - (* Note that js support [ 1 < x < 3], - we can optimize it into [ not ( 0<= x <= k)] - *) - or_ (int_comp Cgt e (int k)) (int_comp Clt e zero_int_literal) - | ( _, - Bin - ( Bor, - ({ - expression_desc = - ( Bin - ( (Plus | Minus), - {expression_desc = Number (Int {i = _; _})}, - {expression_desc = Var _; _} ) - | Bin - ( (Plus | Minus), - {expression_desc = Var _; _}, - {expression_desc = Number (Int {i = _; _})} ) ); - } as e), - {expression_desc = Number (Int {i = 0l}); _} ) ) -> - (* TODO: check correctness *) - is_out ?comment e range - | _, _ -> int_comp ?comment Cgt e range - let rec float_add ?comment (e1 : t) (e2 : t) = match (e1.expression_desc, e2.expression_desc) with | Number (Int {i; _}), Number (Int {i = j; _}) -> int ?comment (Int32.add i j) @@ -1732,7 +1669,7 @@ let rec int32_band ?comment (e1 : J.expression) (e2 : J.expression) : let bigint_op ?comment op (e1 : t) (e2 : t) = bin ?comment op e1 e2 -let bigint_comp (cmp : Lam_compat.comparison) ?comment (e0 : t) (e1 : t) = +let bigint_comp (cmp : Lambda.comparison) ?comment (e0 : t) (e1 : t) = let normalize s = let len = String.length s in let buf = Buffer.create len in diff --git a/compiler/core/js_exp_make.mli b/compiler/core/js_exp_make.mli index 95e599fc53e..459884cd1eb 100644 --- a/compiler/core/js_exp_make.mli +++ b/compiler/core/js_exp_make.mli @@ -119,11 +119,6 @@ val zero_float_lit : t val zero_bigint_literal : t -val is_out : ?comment:string -> t -> t -> t -(** [is_out e range] is equivalent to [e > range or e <0] - -*) - val dot : ?comment:string -> t -> string -> t val module_access : t -> string -> int32 -> t @@ -132,8 +127,6 @@ val array_length : ?comment:string -> t -> t val string_length : ?comment:string -> t -> t -val function_length : ?comment:string -> t -> t - val string_append : ?comment:string -> t -> t -> t (** When in ES6 mode, we can use Symbol to guarantee its uniquess, @@ -237,21 +230,21 @@ val float_mod : ?comment:string -> t -> t -> t val float_pow : ?comment:string -> t -> t -> t -val int_comp : Lam_compat.comparison -> ?comment:string -> t -> t -> t +val int_comp : Lambda.comparison -> ?comment:string -> t -> t -> t -val bool_comp : Lam_compat.comparison -> ?comment:string -> t -> t -> t +val bool_comp : Lambda.comparison -> ?comment:string -> t -> t -> t -val string_comp : Lam_compat.comparison -> ?comment:string -> t -> t -> t +val string_comp : Lambda.comparison -> ?comment:string -> t -> t -> t val bigint_op : ?comment:string -> Js_op.binop -> t -> t -> t -val bigint_comp : Lam_compat.comparison -> ?comment:string -> t -> t -> t +val bigint_comp : Lambda.comparison -> ?comment:string -> t -> t -> t val bigint_div : checked:bool -> ?comment:string -> t -> t -> t val bigint_mod : checked:bool -> ?comment:string -> t -> t -> t -val js_comp : Lam_compat.comparison -> ?comment:string -> t -> t -> t +val js_comp : Lambda.comparison -> ?comment:string -> t -> t -> t val not : t -> t @@ -309,7 +302,7 @@ val in_ : t -> t -> t (** we don't expose a general interface, since a general interface is generally not safe *) -val dummy_obj : ?comment:string -> Lam_tag_info.t -> t +val dummy_obj : ?comment:string -> Lambda.tag_info -> t (** used combined with [caml_update_dummy]*) val of_block : ?comment:string -> ?e:J.expression -> J.statement list -> t diff --git a/compiler/core/js_of_lam_block.ml b/compiler/core/js_of_lam_block.ml index 82a4609a6f7..27c00d38ea4 100644 --- a/compiler/core/js_of_lam_block.ml +++ b/compiler/core/js_of_lam_block.ml @@ -24,13 +24,13 @@ module E = Js_exp_make -let make_block mutable_flag (tag_info : Lam_tag_info.t) args = +let make_block mutable_flag (tag_info : Lambda.tag_info) args = E.make_block tag_info args mutable_flag -let field (field_info : Lam_compat.field_dbg_info) e (i : int32) = +let field (field_info : Lambda.field_dbg_info) e (i : int32) = match field_info with | Fld_tuple -> - E.array_index_by_int ?comment:(Lam_compat.str_of_field_info field_info) e i + E.array_index_by_int ?comment:(Lambda.str_of_field_info field_info) e i | Fld_poly_var_content -> E.poly_var_value_access e | Fld_poly_var_tag -> E.poly_var_tag_access e | Fld_record_extension {name} -> E.extension_access e (Some name) i @@ -41,7 +41,7 @@ let field (field_info : Lam_compat.field_dbg_info) e (i : int32) = | Fld_record {name} -> E.record_access e name i | Fld_module {name} -> E.module_access e name i -let set_field (field_info : Lam_compat.set_field_dbg_info) e i e0 = +let set_field (field_info : Lambda.set_field_dbg_info) e i e0 = match field_info with | Fld_record_extension_set name -> E.extension_assign e i name e0 | Fld_record_inline_set name | Fld_record_set name -> diff --git a/compiler/core/js_of_lam_block.mli b/compiler/core/js_of_lam_block.mli index 4e1f0a86df1..c43336ed54d 100644 --- a/compiler/core/js_of_lam_block.mli +++ b/compiler/core/js_of_lam_block.mli @@ -25,12 +25,12 @@ (** Utilities for creating block of lambda expression in JS IR *) val make_block : - Js_op.mutable_flag -> Lam_tag_info.t -> J.expression list -> J.expression + Js_op.mutable_flag -> Lambda.tag_info -> J.expression list -> J.expression -val field : Lam_compat.field_dbg_info -> J.expression -> int32 -> J.expression +val field : Lambda.field_dbg_info -> J.expression -> int32 -> J.expression val set_field : - Lam_compat.set_field_dbg_info -> + Lambda.set_field_dbg_info -> J.expression -> int32 -> J.expression -> diff --git a/compiler/core/js_of_lam_variant.ml b/compiler/core/js_of_lam_variant.ml index 8cb33ed7dae..cc5b185ffe9 100644 --- a/compiler/core/js_of_lam_variant.ml +++ b/compiler/core/js_of_lam_variant.ml @@ -64,7 +64,7 @@ let eval (arg : J.expression) (dispatches : (string * string) list) : E.t = let eval_as_event (arg : J.expression) (dispatches : (string * string) list option) = match arg.expression_desc with - | Caml_block ([{expression_desc = Str {txt}}; cb], _, Blk_poly_var _) + | Caml_block ([{expression_desc = Str {txt}}; cb], _, Blk_poly_var) when Js_analyzer.no_side_effect_expression cb -> let v = match dispatches with diff --git a/compiler/core/js_op.ml b/compiler/core/js_op.ml index 3b187075463..c610fc7d78d 100644 --- a/compiler/core/js_op.ml +++ b/compiler/core/js_op.ml @@ -61,7 +61,7 @@ type kind = import_attributes: External_ffi_types.import_attributes option; } -type property = Lam_compat.let_kind = Strict | Alias | StrictOpt | Variable +type property = Lambda.let_kind = Strict | Alias | StrictOpt | Variable type property_name = Lit of string | Symbol_name @@ -113,4 +113,4 @@ type ident_info = {mutable used_stats: used_stats} type exports = Ident.t list -type tag_info = Lam_tag_info.t +type tag_info = Lambda.tag_info diff --git a/compiler/core/js_stmt_make.mli b/compiler/core/js_stmt_make.mli index 98759f2caf2..b3dbcd9b008 100644 --- a/compiler/core/js_stmt_make.mli +++ b/compiler/core/js_stmt_make.mli @@ -30,7 +30,7 @@ val throw_stmt : ?comment:string -> J.expression -> t val if_ : ?comment:string -> - ?declaration:Lam_compat.let_kind * Ident.t -> + ?declaration:Lambda.let_kind * Ident.t -> (* when it's not None, we also need make a variable declaration in the begininnig, however, we can optmize such case *) @@ -47,7 +47,7 @@ val block : ?comment:string -> J.block -> t val int_switch : ?comment:string -> - ?declaration:Lam_compat.let_kind * Ident.t -> + ?declaration:Lambda.let_kind * Ident.t -> ?default:J.block -> J.expression -> (int * J.case_clause) list -> @@ -70,7 +70,7 @@ val int_switch : val string_switch : ?comment:string -> - ?declaration:Lam_compat.let_kind * Ident.t -> + ?declaration:Lambda.let_kind * Ident.t -> ?default:J.block -> J.expression -> (Variant_runtime.tag_type * J.case_clause) list -> @@ -79,7 +79,7 @@ val string_switch : val declare_variable : ?comment:string -> ?ident_info:J.ident_info -> - kind:Lam_compat.let_kind -> + kind:Lambda.let_kind -> Ident.t -> t (** Just declaration without initialization *) @@ -88,7 +88,7 @@ val declare_variable : val define_variable : ?comment:string -> ?ident_info:J.ident_info -> - kind:Lam_compat.let_kind -> + kind:Lambda.let_kind -> Ident.t -> J.expression -> t diff --git a/compiler/core/lam.ml b/compiler/core/lam.ml deleted file mode 100644 index 67c346d85c6..00000000000 --- a/compiler/core/lam.ml +++ /dev/null @@ -1,624 +0,0 @@ -(* Copyright (C) 2018 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type ident = Ident.t -type apply_status = App_na | App_infer_full | App_uncurry - -type ap_info = { - ap_loc: Location.t; - ap_inlined: Lambda.inline_attribute; - ap_status: apply_status; -} - -module Types = struct - type lambda_switch = t Lambda.switch - - and lfunction = { - arity: int; - params: ident list; - body: t; - attr: Lambda.function_attribute; - loc: Location.t; - } - - (* - Invariant: - length (sw_consts) <= sw_consts_full - when length (sw_consts) >= sw_consts_full -> true - Note that failaction would appear in both - {[ - match x with - | .. - | .. - | _ -> 2 - ]} - since compiler would first test [x] is a const pointer - or not then the [default] applies to each branch. - - In most cases: {[ - let sw = - {sw_consts_full = List.length consts >= num_consts; - sw_consts = consts; - sw_blocks_full = List.length nonconsts >= num_nonconsts; - sw_blocks = nonconsts; - sw_failaction = None} in - ]} - where the counts come from the variant layout. - - but there are some edge cases (see https://caml.inria.fr/mantis/view.php?id=6033) - one predicate used is - {[ - (sw.sw_consts_full - List.length sw.sw_consts) + - (sw.sw_blocks_full - List.length sw.sw_blocks) > 1 - ]} - if [= 1] with [some fail] -- called once - if [= 0] could not have [some fail] - *) - and prim_info = {primitive: Lam_primitive.t; args: t list; loc: Location.t} - - and apply = { - ap_func: t; - ap_args: t list; - ap_info: ap_info; - ap_transformed_jsx: bool; - } - - and t = - | Lvar of ident - | Lglobal_module of ident - | Lconst of Lam_constant.t - | Lapply of apply - | Lfunction of lfunction - | Llet of Lam_compat.let_kind * ident * t * t - | Lletrec of (ident * t) list * t - | Lprim of prim_info - | Lswitch of t * lambda_switch - | Lstringswitch of t * (string * t) list * t option - | Lstaticraise of int * t list - | Lstaticcatch of t * (int * ident list) * t - | Ltrywith of t * ident * t - | Lifthenelse of t * t * t - | Lsequence of t * t - | Lbreak - | Lcontinue - | Lwhile of t * t - | Lfor of ident * t * t * Asttypes.direction_flag * t - | Lfor_of of ident * t * t - | Lfor_await_of of ident * t * t - | Lassign of ident * t -end - -include Types - -exception Not_simple_form - -(** - - - [is_eta_conversion_exn params inner_args outer_args] - case 1: - {{ - (fun params -> wrap (primitive (inner_args)) args - }} - when [inner_args] are the same as [params], it can be simplified as - [wrap (primitive args)] - - where [wrap] used to be simple instructions - Note that [external] functions are forced to do eta-conversion - when combined with [|>] operator, we need to make sure beta-reduction - is applied though since `[@variadic]` needs such guarantee. - Since `[@variadic] is the tail position -*) -let rec is_eta_conversion_exn params inner_args outer_args : t list = - match (params, inner_args, outer_args) with - | x :: xs, Lvar y :: ys, r :: rest when Ident.same x y -> - r :: is_eta_conversion_exn xs ys rest - | [], [], [] -> [] - | _, _, _ -> raise_notrace Not_simple_form - -(** FIXME: more robust inlining check later, we should inline it before we add stub code*) -let rec apply ?(ap_transformed_jsx = false) fn args (ap_info : ap_info) : t = - match fn with - | Lfunction - { - params; - body = - Lprim - { - primitive = - ( Pnull_to_opt | Pnull_undefined_to_opt | Pis_null - | Pis_null_undefined | Ptypeof ) as wrap; - args = - [Lprim ({primitive = _; args = inner_args} as primitive_call)]; - }; - } -> ( - match is_eta_conversion_exn params inner_args args with - | args -> - let loc = ap_info.ap_loc in - Lprim - {primitive = wrap; args = [Lprim {primitive_call with args; loc}]; loc} - | exception Not_simple_form -> - Lapply {ap_func = fn; ap_args = args; ap_info; ap_transformed_jsx}) - | Lfunction - { - params; - body = Lprim ({primitive = _; args = inner_args} as primitive_call); - } -> ( - match is_eta_conversion_exn params inner_args args with - | args -> Lprim {primitive_call with args; loc = ap_info.ap_loc} - | exception _ -> - Lapply {ap_func = fn; ap_args = args; ap_info; ap_transformed_jsx}) - | Lfunction - { - params; - body = - Lsequence - ( Lprim ({primitive = _; args = inner_args} as primitive_call), - (Lconst _ as const) ); - } -> ( - match is_eta_conversion_exn params inner_args args with - | args -> - Lsequence (Lprim {primitive_call with args; loc = ap_info.ap_loc}, const) - | exception _ -> - Lapply {ap_func = fn; ap_args = args; ap_info; ap_transformed_jsx} - (* | Lfunction {params;body} when Ext_list.same_length params args -> - Ext_list.fold_right2 (fun p arg acc -> - Llet(Strict,p,arg,acc) - ) params args body *) - (* TODO: more rigirous analysis on [let_kind] *)) - | Llet (kind, id, e, (Lfunction _ as fn)) -> - Llet (kind, id, e, apply fn args ap_info ~ap_transformed_jsx) - (* | Llet (kind0, id0, e0, Llet (kind,id, e, (Lfunction _ as fn))) -> - Llet(kind0,id0,e0,Llet (kind, id, e, apply fn args loc status)) *) - | _ -> Lapply {ap_func = fn; ap_args = args; ap_info; ap_transformed_jsx} - -let rec eq_approx (l1 : t) (l2 : t) = - match l1 with - | Lglobal_module i1 -> ( - match l2 with - | Lglobal_module i2 -> Ident.same i1 i2 - | _ -> false) - | Lvar i1 -> ( - match l2 with - | Lvar i2 -> Ident.same i1 i2 - | _ -> false) - | Lconst c1 -> ( - match l2 with - | Lconst c2 -> Lam_constant.eq_approx c1 c2 - | _ -> false) - | Lapply app1 -> ( - match l2 with - | Lapply app2 -> - eq_approx app1.ap_func app2.ap_func - && eq_approx_list app1.ap_args app2.ap_args - | _ -> false) - | Lifthenelse (a, b, c) -> ( - match l2 with - | Lifthenelse (a0, b0, c0) -> - eq_approx a a0 && eq_approx b b0 && eq_approx c c0 - | _ -> false) - | Lsequence (a, b) -> ( - match l2 with - | Lsequence (a0, b0) -> eq_approx a a0 && eq_approx b b0 - | _ -> false) - | Lbreak -> l2 = Lbreak - | Lcontinue -> l2 = Lcontinue - | Lwhile (p, b) -> ( - match l2 with - | Lwhile (p0, b0) -> eq_approx p p0 && eq_approx b b0 - | _ -> false) - | Lassign (v0, l0) -> ( - match l2 with - | Lassign (v1, l1) -> Ident.same v0 v1 && eq_approx l0 l1 - | _ -> false) - | Lstaticraise (id, ls) -> ( - match l2 with - | Lstaticraise (id1, ls1) -> id = id1 && eq_approx_list ls ls1 - | _ -> false) - | Lprim info1 -> ( - match l2 with - | Lprim info2 -> - Lam_primitive.eq_primitive_approx info1.primitive info2.primitive - && eq_approx_list info1.args info2.args - | _ -> false) - | Lstringswitch (arg, patterns, default) -> ( - match l2 with - | Lstringswitch (arg2, patterns2, default2) -> - eq_approx arg arg2 && eq_option default default2 - && Ext_list.for_all2_no_exn patterns patterns2 - (fun ((k : string), v) (k2, v2) -> k = k2 && eq_approx v v2) - | _ -> false) - | Lfunction _ - | Llet (_, _, _, _) - | Lletrec _ | Lswitch _ | Lstaticcatch _ | Ltrywith _ - | Lfor (_, _, _, _, _) - | Lfor_of (_, _, _) - | Lfor_await_of (_, _, _) -> - false - -and eq_option l1 l2 = - match l1 with - | None -> l2 = None - | Some l1 -> ( - match l2 with - | Some l2 -> eq_approx l1 l2 - | None -> false) - -and eq_approx_list ls ls1 = Ext_list.for_all2_no_exn ls ls1 eq_approx - -let switch lam (lam_switch : lambda_switch) : t = - let action_or_switch = function - | Some action -> action - | None -> ( - match lam_switch.sw_failaction with - | Some action -> action - | None -> Lswitch (lam, lam_switch)) - in - match lam with - | Lconst (Const_constructor cstr_name) -> - let action = - Ext_list.find_opt lam_switch.sw_consts (fun (key, action) -> - match key with - | Lambda.Switch_constructor (Constant tag) when cstr_name = tag -> - Some action - | Switch_int _ | Switch_constructor _ -> None) - in - action_or_switch action - | Lconst (Const_int i) -> - (* Because of inlining and dead code, we might be looking at a value of unexpected type - e.g. an integer, so the const case might not be found *) - let i = Int32.to_int i in - let action = - Ext_list.find_opt lam_switch.sw_consts (fun (key, action) -> - match key with - | Lambda.Switch_int ordinal when ordinal = i -> Some action - | Switch_constructor - (Constant {tag_type = Some (Variant_runtime.Int value)}) - when value = i -> - Some action - | Switch_int _ | Switch_constructor _ -> None) - in - action_or_switch action - | Lconst (Const_block (tag_info, _)) -> - let runtime = - match tag_info with - | Lambda.Blk_constructor {runtime} | Blk_record_inlined {runtime} -> - Some runtime - | Blk_tuple | Blk_poly_var _ | Blk_record _ | Blk_record_ext _ - | Blk_module _ | Blk_module_export _ | Blk_extension | Blk_some - | Blk_some_not_nested -> - None - in - let action = - Ext_list.find_opt lam_switch.sw_blocks (fun (key, action) -> - match key with - | Switch_constructor (Block {runtime = case_runtime}) - when runtime = Some case_runtime -> - Some action - | Lambda.Switch_int _ | Switch_constructor _ -> None) - in - action_or_switch action - | _ -> Lswitch (lam, lam_switch) - -let stringswitch (lam : t) cases default : t = - match lam with - | Lconst (Const_string {s; delim = None | Some DNoQuotes}) -> - Ext_list.assoc_by_string cases s default - | _ -> Lstringswitch (lam, cases, default) - -let true_ : t = Lconst Const_js_true -let false_ : t = Lconst Const_js_false -let unit : t = Lconst (Const_js_undefined {is_unit = true}) -let break : t = Lbreak -let continue : t = Lcontinue - -let rec seq (a : t) b : t = - match a with - | Lprim {primitive = Pmakeblock _; args = x :: xs} -> - seq (Ext_list.fold_left xs x seq) b - | Lprim {primitive = Pnull_to_opt | Pnull_undefined_to_opt; args = [a]} -> - seq a b - | _ -> Lsequence (a, b) - -let var id : t = Lvar id -let global_module id = Lglobal_module id -let const ct : t = Lconst ct - -let function_ ~loc ~attr ~arity ~params ~body : t = - Lfunction {arity; params; body; attr; loc} - -let let_ kind id e body : t = Llet (kind, id, e, body) -let letrec bindings body : t = Lletrec (bindings, body) -let while_ a b : t = Lwhile (a, b) -let try_ body id handler : t = Ltrywith (body, id, handler) -let for_ v e1 e2 dir e3 : t = Lfor (v, e1, e2, dir, e3) -let for_of v e1 e2 : t = Lfor_of (v, e1, e2) -let for_await_of v e1 e2 : t = Lfor_await_of (v, e1, e2) -let assign v l : t = Lassign (v, l) -let staticcatch a b c : t = Lstaticcatch (a, b, c) -let staticraise a b : t = Lstaticraise (a, b) - -module Lift = struct - let int i : t = Lconst (Const_int i) - - let bool b = if b then true_ else false_ - - let string s : t = Lconst (Const_string {s; delim = None}) - - let char b : t = Lconst (Const_char b) -end - -let prim ~primitive:(prim : Lam_primitive.t) ~args loc : t = - let default () : t = Lprim {primitive = prim; args; loc} in - match args with - | [Lconst a] -> ( - match (prim, a) with - | Pnegint, Const_int i -> Lift.int (Int32.neg i) - (* | Pfloatofint, ( (Const_int a)) *) - (* -> Lift.float (float_of_int a) *) - | Pintoffloat, Const_float a -> - Lift.int (Int32.of_float (float_of_string a)) - (* | Pnegfloat -> Lift.float (-. a) *) - | Pstringlength, Const_string {s; delim = None} -> - Lift.int (Int32.of_int (String.length s)) - (* | Pnegbint Pnativeint, ( (Const_nativeint i)) *) - (* -> *) - (* Lift.nativeint (Nativeint.neg i) *) - | Pnot, Const_js_true -> false_ - | Pnot, Const_js_false -> true_ - | _ -> default ()) - | [Lconst a; Lconst b] -> ( - match (prim, a, b) with - | Pintcomp cmp, Const_int a, Const_int b -> - Lift.bool (Lam_compat.cmp_int32 cmp a b) - | Pfloatcomp cmp, Const_float a, Const_float b -> - (* FIXME: could raise? *) - Lift.bool - (Lam_compat.cmp_float cmp (float_of_string a) (float_of_string b)) - | Pbigintcomp cmp, Const_bigint _, Const_bigint _ -> default () - | Pintcomp ((Ceq | Cneq) as op), Const_pointer a, Const_pointer b -> - Lift.bool - (match op with - | Ceq -> a = (b : string) - | Cneq -> a <> b - | _ -> assert false) - | ( Pintcomp ((Ceq | Cneq) as op), - Const_constructor {name = a; tag_type = None}, - Const_constructor {name = b; tag_type = None} ) -> - (* Both runtime representations are the constructor names *) - Lift.bool - (match op with - | Ceq -> a = b - | Cneq -> a <> b - | _ -> assert false) - | ( ( Paddint | Psubint | Pmulint | Pdivint | Pmodint | Pandint | Porint - | Pxorint | Plslint | Plsrint | Pasrint ), - Const_int aa, - Const_int bb ) -> ( - (* WE SHOULD keep it as [int], to preserve types *) - let int_ = Lift.int in - match prim with - | Paddint -> int_ (Int32.add aa bb) - | Psubint -> int_ (Int32.sub aa bb) - | Pmulint -> int_ (Int32.mul aa bb) - | Pdivint -> if bb = 0l then default () else int_ (Int32.div aa bb) - | Pmodint -> if bb = 0l then default () else int_ (Int32.rem aa bb) - | Pandint -> int_ (Int32.logand aa bb) - | Porint -> int_ (Int32.logor aa bb) - | Pxorint -> int_ (Int32.logxor aa bb) - | Plslint -> int_ (Int32.shift_left aa (Int32.to_int bb)) - | Plsrint -> int_ (Int32.shift_right_logical aa (Int32.to_int bb)) - | Pasrint -> int_ (Int32.shift_right aa (Int32.to_int bb)) - | _ -> default ()) - | Psequand, Const_js_false, (Const_js_true | Const_js_false) -> false_ - | Psequand, Const_js_true, Const_js_true -> true_ - | Psequand, Const_js_true, Const_js_false -> false_ - | Psequor, Const_js_true, (Const_js_true | Const_js_false) -> true_ - | Psequor, Const_js_false, Const_js_true -> true_ - | Psequor, Const_js_false, Const_js_false -> false_ - | ( Pstringadd, - Const_string {s = a; delim = None}, - Const_string {s = b; delim = None} ) -> - Lift.string (a ^ b) - | ( (Pstringrefs | Pstringrefu), - Const_string {s = a; delim = None}, - Const_int b ) -> ( - try Lift.char (Char.code (String.get a (Int32.to_int b))) - with _ -> default ()) - | _ -> default ()) - | _ -> ( - match prim with - | Pmakeblock (Blk_module fields, _) -> ( - let rec aux fields args (var : Ident.t) i = - match (fields, args) with - | [], [] -> true - | ( f :: fields, - Lprim - { - primitive = Pfield (pos, Fld_module {name = f1}); - args = [(Lglobal_module v1 | Lvar v1)]; - } - :: args ) -> - pos = i && f = f1 && Ident.same var v1 && aux fields args var (i + 1) - | _, _ -> false - in - match (fields, args) with - | ( field1 :: rest, - Lprim - { - primitive = Pfield (pos, Fld_module {name = f1}); - args = [((Lglobal_module v1 | Lvar v1) as lam)]; - } - :: args1 ) -> - if pos = 0 && field1 = f1 && aux rest args1 v1 1 then lam - else default () - | _ -> default ()) - (* In this level, include is already expanded, so that - {[ - { x0 : y0 ; x1 : y1 } - ]} - such module x can indeed be replaced by module y - *) - | _ -> default ()) - -let not_ loc x : t = - match x with - | Lprim ({primitive = Pintcomp Cneq} as prim) -> - Lprim {prim with primitive = Pintcomp Ceq} - | _ -> prim ~primitive:Pnot ~args:[x] loc - -let has_boolean_type (x : t) = - match x with - | Lprim - { - primitive = - ( Pnot | Psequand | Psequor | Pisout _ | Pis_not_none | Pobjcomp _ - | Pboolcomp _ | Pintcomp _ | Pfloatcomp _ | Pbigintcomp _ - | Pstringcomp _ ); - loc; - } -> - Some loc - | _ -> None - -(** [complete_range sw_consts 0 7] - is complete with [0,1,.. 7] -*) -let rec complete_range (sw_consts : (Lambda.switch_key * _) list) ~(start : int) - ~finish = - match sw_consts with - | [] -> finish < start - | (Switch_int i, _) :: rest -> - start <= finish && i = start - && complete_range rest ~start:(start + 1) ~finish - | (Switch_constructor _, _) :: _ -> false - -let rec eval_const_as_bool (v : Lam_constant.t) : bool option = - match v with - | Const_int x -> Some (x <> 0l) - | Const_assertfalse -> Some false - | Const_char x -> Some (x <> 0) - | Const_js_false | Const_js_null | Const_module_alias | Const_js_undefined _ - -> - Some false - | Const_js_true | Const_string _ | Const_pointer _ | Const_float _ - | Const_bigint _ | Const_block _ -> - Some true - | Const_some b -> eval_const_as_bool b - | Const_constructor {name; tag_type} -> ( - (* Truthiness of the canonical runtime representation *) - match tag_type with - | None -> Some (name <> "[]") (* the name string; [] is the number 0 *) - | Some (String s) -> Some (s <> "") - | Some (Int i) -> Some (i <> 0) - | Some (Bool b) -> Some b - | Some Null | Some Undefined -> Some false - | Some (Float _ | BigInt _ | Untagged _) -> None) - -let if_ (a : t) (b : t) (c : t) : t = - match a with - | Lconst v -> ( - match eval_const_as_bool v with - | Some v -> if v then b else c - | None -> Lifthenelse (a, b, c)) - | _ -> ( - match (b, c) with - | _, Lconst Const_assertfalse -> - seq a b (* TODO: we could customize more cases *) - | Lconst Const_assertfalse, _ -> seq a c - | Lconst Const_js_true, Lconst Const_js_false -> - if has_boolean_type a != None then a else Lifthenelse (a, b, c) - | Lconst Const_js_false, Lconst Const_js_true -> ( - match has_boolean_type a with - | Some loc -> not_ loc a - | None -> Lifthenelse (a, b, c)) - | Lprim {primitive = Praise}, _ -> ( - match c with - | Lconst _ -> Lifthenelse (a, b, c) - | _ -> seq (Lifthenelse (a, b, unit)) c) - | _ -> ( - match a with - | Lprim - {primitive = Pisout off; args = [Lconst (Const_int range); Lvar xx]} - -> ( - let range = Int32.to_int range in - match c with - | Lswitch - ( (Lvar yy as switch_arg), - ({ - sw_blocks = []; - sw_blocks_full = true; - sw_consts; - sw_consts_full = _; - sw_failaction = None; - } as body) ) - when Ident.same xx yy - && complete_range sw_consts ~start:(-off) ~finish:(range - off) - -> - Lswitch - ( switch_arg, - {body with sw_failaction = Some b; sw_consts_full = false} ) - | _ -> Lifthenelse (a, b, c)) - | Lprim {primitive = Pisint; args = [Lvar i]; _} -> ( - match b with - | Lifthenelse - (Lprim {primitive = Pintcomp Ceq; args = [Lvar j; Lconst _]}, _, b_f) - when Ident.same i j && eq_approx b_f c -> - b - | Lprim {primitive = Pintcomp Ceq; args = [Lvar j; Lconst _]} - when Ident.same i j && eq_approx false_ c -> - b - | Lifthenelse - ( Lprim - ({primitive = Pintcomp Cneq; args = [Lvar j; Lconst _]} as - b_pred), - b_t, - b_f ) - when Ident.same i j && eq_approx b_t c -> - Lifthenelse (Lprim {b_pred with primitive = Pintcomp Ceq}, b_f, b_t) - | Lprim - {primitive = Pintcomp Cneq; args = [Lvar j; Lconst _] as args; loc} - | Lprim - { - primitive = Pnot; - args = - [ - Lprim - { - primitive = Pintcomp Ceq; - args = [Lvar j; Lconst _] as args; - loc; - }; - ]; - } - when Ident.same i j && eq_approx true_ c -> - Lprim {primitive = Pintcomp Cneq; args; loc} - | _ -> Lifthenelse (a, b, c)) - | _ -> Lifthenelse (a, b, c))) - -(* TODO: the smart constructor is not exploited yet*) -(* [l || r ] *) -let sequor l r = if_ l true_ r - -(** [l && r ] *) -let sequand l r = if_ l r false_ diff --git a/compiler/core/lam.mli b/compiler/core/lam.mli deleted file mode 100644 index 82dbd1e0d6d..00000000000 --- a/compiler/core/lam.mli +++ /dev/null @@ -1,162 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type apply_status = App_na | App_infer_full | App_uncurry - -type ap_info = { - ap_loc: Location.t; - ap_inlined: Lambda.inline_attribute; - ap_status: apply_status; -} - -type ident = Ident.t - -type lambda_switch = t Lambda.switch - -and apply = private { - ap_func: t; - ap_args: t list; - ap_info: ap_info; - ap_transformed_jsx: bool; -} - -and lfunction = { - arity: int; - params: ident list; - body: t; - attr: Lambda.function_attribute; - loc: Location.t; -} - -and prim_info = private { - primitive: Lam_primitive.t; - args: t list; - loc: Location.t; -} - -and t = private - | Lvar of ident - | Lglobal_module of ident - | Lconst of Lam_constant.t - | Lapply of apply - | Lfunction of lfunction - | Llet of Lam_compat.let_kind * ident * t * t - | Lletrec of (ident * t) list * t - | Lprim of prim_info - | Lswitch of t * lambda_switch - | Lstringswitch of t * (string * t) list * t option - | Lstaticraise of int * t list - | Lstaticcatch of t * (int * ident list) * t - | Ltrywith of t * ident * t - | Lifthenelse of t * t * t - | Lsequence of t * t - | Lbreak - | Lcontinue - | Lwhile of t * t - | Lfor of ident * t * t * Asttypes.direction_flag * t - | Lfor_of of ident * t * t - | Lfor_await_of of ident * t * t - | Lassign of ident * t - -(* | Levent of t * Lambda.lambda_event - [Levent] in the branch hurt pattern match, - we should use record for trivial debugger info -*) - -(**************************************************************) - -val var : ident -> t -(** Smart constructors *) - -val global_module : ident -> t - -val const : Lam_constant.t -> t - -val apply : ?ap_transformed_jsx:bool -> t -> t list -> ap_info -> t - -val function_ : - loc:Location.t -> - attr:Lambda.function_attribute -> - arity:int -> - params:ident list -> - body:t -> - t - -val let_ : Lam_compat.let_kind -> ident -> t -> t -> t - -val letrec : (ident * t) list -> t -> t - -val if_ : t -> t -> t -> t -(** constant folding *) - -val switch : t -> lambda_switch -> t -(** constant folding*) - -val stringswitch : t -> (string * t) list -> t option -> t -(** constant folding*) - -(* val true_ : t *) -val false_ : t - -val unit : t - -val sequor : t -> t -> t -(** convert [l || r] to [if l then true else r]*) - -val sequand : t -> t -> t -(** convert [l && r] to [if l then r else false *) - -val not_ : Location.t -> t -> t -(** constant folding *) - -val seq : t -> t -> t -(** drop unused block *) - -val break : t - -val continue : t - -val while_ : t -> t -> t - -(* val event : t -> Lambda.lambda_event -> t *) -val try_ : t -> ident -> t -> t - -val assign : ident -> t -> t - -val prim : primitive:Lam_primitive.t -> args:t list -> Location.t -> t -(** constant folding *) - -val staticcatch : t -> int * ident list -> t -> t - -val staticraise : int -> t list -> t - -val for_ : ident -> t -> t -> Asttypes.direction_flag -> t -> t - -val for_of : ident -> t -> t -> t - -val for_await_of : ident -> t -> t -> t - -(**************************************************************) - -val eq_approx : t -> t -> bool diff --git a/compiler/core/lam_analysis.ml b/compiler/core/lam_analysis.ml index 5fd3f44efec..8b37b0e17bb 100644 --- a/compiler/core/lam_analysis.ml +++ b/compiler/core/lam_analysis.ml @@ -23,14 +23,14 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) (**used in effect analysis, it is sound but not-complete *) -let not_zero_constant (x : Lam_constant.t) = +let not_zero_constant (x : Lambda.structured_constant) = match x with | Const_int i -> i <> 0l | Const_assertfalse -> false | Const_bigint (_, i) -> i <> "0" | _ -> false -let rec no_side_effects (lam : Lam.t) : bool = +let rec no_side_effects (lam : Lambda.t) : bool = match lam with | Lvar _ | Lconst _ | Lfunction _ -> true | Lglobal_module _ -> true @@ -45,7 +45,6 @@ let rec no_side_effects (lam : Lam.t) : bool = match args with | [_; Lconst cst] -> not_zero_constant cst | _ -> false) - | Peliminated _ -> assert false | Pcreate_extension _ | Ptypeof | Pis_null | Pis_not_none | Psome | Psome_not_nest | Pis_undefined | Pis_null_undefined | Pnull_to_opt | Pnull_undefined_to_opt | Pjs_object_create _ | Pimport _ @@ -83,25 +82,23 @@ let rec no_side_effects (lam : Lam.t) : bool = (* Test if the argument is a block or an immediate integer *) | Pisint | Pis_poly_var_block (* Test if the (integer) argument is outside an interval *) - | Pisout _ (* Operations on big arrays: (unsafe, #dimensions, kind, layout) *) (* Compile time constants *) - | Poffsetint _ | Pstringadd | Pfn_arity | Phash | Phash_mixstring - | Phash_mixint | Phash_finalmix + | Pstringadd | Phash | Phash_mixstring | Phash_mixint | Phash_finalmix | Praw_js_code {code_info = Exp (Js_function _ | Js_literal _) | Stmt Js_stmt_comment} -> true (* A tagged template invokes its tag at runtime, so it always has side effects. *) - | Ptagged_template | Pjs_apply | Pjs_call _ | Pinit_mod | Pupdate_mod - | Pjs_object_get _ | Pjs_object_set _ | Pdebugger | Pjs_fn_method + | Ptagged_template | Pjs_call _ | Pinit_mod | Pupdate_mod | Pjs_object_get _ + | Pjs_object_set _ | Pdebugger | Pjs_fn_method (* Await promise *) | Pawait (* TODO *) | Praw_js_code _ (* byte swap *) - | Parraysets | Parraysetu | Poffsetref _ | Praise | Psetfield _ -> + | Parraysets | Parraysetu | Praise | Psetfield _ -> false) | Llet (_, _, arg, body) -> no_side_effects arg && no_side_effects body | Lswitch (_, _) -> false @@ -144,7 +141,7 @@ let really_big () = raise_notrace Too_big_to_inline (* let big_lambda = 1000 *) -let rec size (lam : Lam.t) = +let rec size (lam : Lambda.t) = try match lam with | Lvar _ -> 1 @@ -192,7 +189,7 @@ let rec size (lam : Lam.t) = and size_constant x = match x with | Const_int _ | Const_assertfalse | Const_constructor _ | Const_char _ - | Const_float _ | Const_bigint _ | Const_pointer _ | Const_js_null + | Const_float _ | Const_bigint _ | Const_polyvar _ | Const_js_null | Const_js_undefined _ | Const_module_alias | Const_js_true | Const_js_false -> 1 @@ -201,10 +198,10 @@ and size_constant x = | Const_block (_, str) -> Ext_list.fold_left str 0 (fun acc x -> acc + size_constant x) -and size_lams acc (lams : Lam.t list) = +and size_lams acc (lams : Lambda.t list) = Ext_list.fold_left lams acc (fun acc l -> acc + size l) -let args_all_const (args : Lam.t list) = +let args_all_const (args : Lambda.t list) = Ext_list.for_all args (fun x -> match x with | Lconst _ -> true @@ -223,7 +220,7 @@ let small_inline_size = 5 ideally we should also evaluate its size after inlining, since after partial evaluation, it might still be *very big* *) -let destruct_pattern (body : Lam.t) params args = +let destruct_pattern (body : Lambda.t) params args = let rec aux v params args = match (params, args) with | x :: xs, b :: bs -> if Ident.same x v then Some b else aux v xs bs @@ -233,23 +230,23 @@ let destruct_pattern (body : Lam.t) params args = match body with | Lswitch (Lvar v, switch) -> ( match aux v params args with - | Some (Lam.Lconst _ as lam) -> - size (Lam.switch lam switch) < small_inline_size + | Some (Lambda.Lconst _ as lam) -> + size (Lambda.switch lam switch) < small_inline_size | Some _ | None -> false) | Lifthenelse (Lvar v, then_, else_) -> ( (* -FIXME *) match aux v params args with | Some (Lconst _ as lam) -> - size (Lam.if_ lam then_ else_) < small_inline_size + size (Lambda.if_ lam then_ else_) < small_inline_size | Some _ | None -> false) | _ -> false (* Async functions cannot be beta reduced *) -let lfunction_can_be_inlined (lfunction : Lam.lfunction) = +let lfunction_can_be_inlined (lfunction : Lambda.lfunction) = (not lfunction.attr.async) && lfunction.attr.directive = None (** Hints to inlining *) -let ok_to_inline_fun_when_app (m : Lam.lfunction) (args : Lam.t list) = +let ok_to_inline_fun_when_app (m : Lambda.lfunction) (args : Lambda.t list) = match m.attr.inline with | Always_inline -> true | Never_inline -> false @@ -264,11 +261,11 @@ let ok_to_inline_fun_when_app (m : Lam.lfunction) (args : Lam.t list) = (* TODO: We can relax this a bit later, but decide whether to inline it later in the call site *) -let safe_to_inline (lam : Lam.t) = +let safe_to_inline (lam : Lambda.t) = match lam with | Lfunction _ -> true | Lconst - ( Const_pointer _ | Const_constructor _ | Const_js_true | Const_js_false + ( Const_polyvar _ | Const_constructor _ | Const_js_true | Const_js_false | Const_js_undefined _ ) -> true | _ -> false diff --git a/compiler/core/lam_analysis.mli b/compiler/core/lam_analysis.mli index 0451182da40..e42f736f14d 100644 --- a/compiler/core/lam_analysis.mli +++ b/compiler/core/lam_analysis.mli @@ -24,17 +24,17 @@ (** A module which provides some basic analysis over lambda expression *) -val no_side_effects : Lam.t -> bool +val no_side_effects : Lambda.t -> bool (** No side effect, but it might depend on data store *) -val size : Lam.t -> int +val size : Lambda.t -> int -val lfunction_can_be_inlined : Lam.lfunction -> bool +val lfunction_can_be_inlined : Lambda.lfunction -> bool -val ok_to_inline_fun_when_app : Lam.lfunction -> Lam.t list -> bool +val ok_to_inline_fun_when_app : Lambda.lfunction -> Lambda.t list -> bool val small_inline_size : int val exit_inline_size : int -val safe_to_inline : Lam.t -> bool +val safe_to_inline : Lambda.t -> bool diff --git a/compiler/core/lam_arity_analysis.ml b/compiler/core/lam_arity_analysis.ml index ea14efb5a98..cab4cef6569 100644 --- a/compiler/core/lam_arity_analysis.ml +++ b/compiler/core/lam_arity_analysis.ml @@ -35,7 +35,7 @@ let arity_of_var (meta : Lam_stats.t) (v : Ident.t) = We will keep iterating such environment If not found, we will return [NA] *) -let rec get_arity (meta : Lam_stats.t) (lam : Lam.t) : Lam_arity.t = +let rec get_arity (meta : Lam_stats.t) (lam : Lambda.t) : Lam_arity.t = match lam with | Lvar v -> arity_of_var meta v | Lconst _ -> Lam_arity.non_function_arity_info @@ -96,7 +96,8 @@ let rec get_arity (meta : Lam_stats.t) (lam : Lam.t) : Lam_arity.t = *) in take xs (List.length args)) - | Lfunction {arity; body} -> Lam_arity.merge arity (get_arity meta body) + | Lfunction {params; body} -> + Lam_arity.merge (List.length params) (get_arity meta body) | Lswitch ( _, { @@ -126,7 +127,7 @@ let rec get_arity (meta : Lam_stats.t) (lam : Lam.t) : Lam_arity.t = | Lwhile _ | Lfor _ | Lfor_of _ | Lfor_await_of _ | Lassign _ -> Lam_arity.non_function_arity_info -and all_lambdas meta (xs : Lam.t list) = +and all_lambdas meta (xs : Lambda.t list) = match xs with | y :: ys -> let arity = get_arity meta y in diff --git a/compiler/core/lam_arity_analysis.mli b/compiler/core/lam_arity_analysis.mli index ee148975ae3..004449a1f2b 100644 --- a/compiler/core/lam_arity_analysis.mli +++ b/compiler/core/lam_arity_analysis.mli @@ -24,4 +24,4 @@ (** Utilities for lambda analysis *) -val get_arity : Lam_stats.t -> Lam.t -> Lam_arity.t +val get_arity : Lam_stats.t -> Lambda.t -> Lam_arity.t diff --git a/compiler/core/lam_beta_reduce.ml b/compiler/core/lam_beta_reduce.ml index ed930c68eab..c8a4fef96dc 100644 --- a/compiler/core/lam_beta_reduce.ml +++ b/compiler/core/lam_beta_reduce.ml @@ -45,7 +45,7 @@ we can bound [x] to [100] in a single step *) let propagate_beta_reduce (meta : Lam_stats.t) (params : Ident.t list) - (body : Lam.t) (args : Lam.t list) = + (body : Lambda.t) (args : Lambda.t list) = match Lam_beta_reduce_util.simple_beta_reduce params body args with | Some x -> x | None -> @@ -56,7 +56,7 @@ let propagate_beta_reduce (meta : Lam_stats.t) (params : Ident.t list) | Lconst _ | Lvar _ -> (rest_bindings, arg :: acc) | _ -> let p = Ident.rename old_param in - ((p, arg) :: rest_bindings, Lam.var p :: acc)) + ((p, arg) :: rest_bindings, Lambda.var p :: acc)) in let new_body = Lam_bounded_vars.rewrite @@ -68,7 +68,8 @@ let propagate_beta_reduce (meta : Lam_stats.t) (params : Ident.t list) order. *) Ext_list.fold_left rest_bindings new_body (fun l (param, arg) -> (match arg with - | Lprim {primitive = Pmakeblock (_, Immutable); args; _} -> + | Lprim {primitive = Pmakeblock info; args; _} + when Lambda.is_immutable_block info -> Hash_ident.replace meta.ident_tbl param (Lam_util.kind_of_lambda_block args) | Lprim {primitive = Psome | Psome_not_nest; args = [v]; _} -> @@ -88,7 +89,7 @@ let propagate_beta_reduce_with_map (meta : Lam_stats.t) | Lconst _ | Lvar _ -> (rest_bindings, arg :: acc) | Lglobal_module _ -> let p = Ident.rename old_param in - ((p, arg) :: rest_bindings, Lam.var p :: acc) + ((p, arg) :: rest_bindings, Lambda.var p :: acc) | _ -> if Lam_analysis.no_side_effects arg then match Map_ident.find_exn map old_param with @@ -97,10 +98,10 @@ let propagate_beta_reduce_with_map (meta : Lam_stats.t) (rest_bindings, arg :: acc) else let p = Ident.rename old_param in - ((p, arg) :: rest_bindings, Lam.var p :: acc) + ((p, arg) :: rest_bindings, Lambda.var p :: acc) else let p = Ident.rename old_param in - ((p, arg) :: rest_bindings, Lam.var p :: acc)) + ((p, arg) :: rest_bindings, Lambda.var p :: acc)) in let new_body = Lam_bounded_vars.rewrite @@ -108,9 +109,11 @@ let propagate_beta_reduce_with_map (meta : Lam_stats.t) body in (* See above: fold left so arguments evaluate in call order. *) - Ext_list.fold_left rest_bindings new_body (fun l (param, (arg : Lam.t)) -> + Ext_list.fold_left rest_bindings new_body + (fun l (param, (arg : Lambda.t)) -> (match arg with - | Lprim {primitive = Pmakeblock (_, Immutable); args} -> + | Lprim {primitive = Pmakeblock info; args} + when Lambda.is_immutable_block info -> Hash_ident.replace meta.ident_tbl param (Lam_util.kind_of_lambda_block args) | Lprim {primitive = Psome | Psome_not_nest; args = [v]} -> diff --git a/compiler/core/lam_beta_reduce.mli b/compiler/core/lam_beta_reduce.mli index 8be5e2d49e8..9d6a4bc68e6 100644 --- a/compiler/core/lam_beta_reduce.mli +++ b/compiler/core/lam_beta_reduce.mli @@ -24,7 +24,7 @@ (** Beta reduction of lambda IR *) -val no_names_beta_reduce : Ident.t list -> Lam.t -> Lam.t list -> Lam.t +val no_names_beta_reduce : Ident.t list -> Lambda.t -> Lambda.t list -> Lambda.t (* Compile-time beta-reduction of functions immediately applied: Lapply(Lfunction(Curried, params, body), args, loc) -> let paramN = argN in ... let param1 = arg1 in body @@ -43,15 +43,15 @@ val no_names_beta_reduce : Ident.t list -> Lam.t -> Lam.t list -> Lam.t *) val propagate_beta_reduce : - Lam_stats.t -> Ident.t list -> Lam.t -> Lam.t list -> Lam.t + Lam_stats.t -> Ident.t list -> Lambda.t -> Lambda.t list -> Lambda.t val propagate_beta_reduce_with_map : Lam_stats.t -> Lam_var_stats.stats Map_ident.t -> Ident.t list -> - Lam.t -> - Lam.t list -> - Lam.t + Lambda.t -> + Lambda.t list -> + Lambda.t (** {[ Lam_beta_reduce.propogate_beta_reduce_with_map meta param_map diff --git a/compiler/core/lam_beta_reduce_util.ml b/compiler/core/lam_beta_reduce_util.ml index c1855dec203..00b70ce726c 100644 --- a/compiler/core/lam_beta_reduce_util.ml +++ b/compiler/core/lam_beta_reduce_util.ml @@ -31,7 +31,7 @@ other wise the evaluation order is tricky (make sure eval order is correct) *) -type value = {mutable used: bool; lambda: Lam.t} +type value = {mutable used: bool; lambda: Lambda.t} let param_hash : _ Hash_ident.t = Hash_ident.create 20 @@ -44,7 +44,7 @@ let param_hash : _ Hash_ident.t = Hash_ident.create 20 {[ when Ext_list.for_all2_no_exn (fun p a -> - match (a : Lam.t) with + match (a : Lambda.t) with | Lvar a -> Ident.same p a | _ -> false ) params args' ]} @@ -58,14 +58,14 @@ let simple_beta_reduce params body args = exp.lambda | None -> opt in - let rec aux_exn acc (us : Lam.t list) = + let rec aux_exn acc (us : Lambda.t list) = match us with | [] -> List.rev acc | (Lvar x as a) :: rest -> aux_exn (find_param_exn x a :: acc) rest | (Lconst _ as u) :: rest -> aux_exn (u :: acc) rest | _ :: _ -> raise_notrace Not_simple_apply in - match (body : Lam.t) with + match (body : Lambda.t) with | Lprim {primitive; args = ap_args; loc = ap_loc} (* There is no lambda in primitive *) -> ( (* catch a special case of primitives *) @@ -77,10 +77,11 @@ let simple_beta_reduce params body args = try let new_args = aux_exn [] ap_args in let result = - Hash_ident.fold param_hash (Lam.prim ~primitive ~args:new_args ap_loc) + Hash_ident.fold param_hash + (Lambda.prim ~primitive ~args:new_args ap_loc) (fun _param stats acc -> let {lambda; used} = stats in - if not used then Lam.seq lambda acc else acc) + if not used then Lambda.seq lambda acc else acc) in Hash_ident.clear param_hash; Some result @@ -113,10 +114,10 @@ let simple_beta_reduce params body args = | _ -> f in let result = - Hash_ident.fold param_hash (Lam.apply f new_args ap_info) + Hash_ident.fold param_hash (Lambda.apply f new_args ap_info) (fun _param stat acc -> let {lambda; used} = stat in - if not used then Lam.seq lambda acc else acc) + if not used then Lambda.seq lambda acc else acc) in Hash_ident.clear param_hash; Some result diff --git a/compiler/core/lam_beta_reduce_util.mli b/compiler/core/lam_beta_reduce_util.mli index 585611be7b5..335e9e0978f 100644 --- a/compiler/core/lam_beta_reduce_util.mli +++ b/compiler/core/lam_beta_reduce_util.mli @@ -22,4 +22,5 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val simple_beta_reduce : Ident.t list -> Lam.t -> Lam.t list -> Lam.t option +val simple_beta_reduce : + Ident.t list -> Lambda.t -> Lambda.t list -> Lambda.t option diff --git a/compiler/core/lam_bounded_vars.ml b/compiler/core/lam_bounded_vars.ml index 64aa2caf845..4737086a083 100644 --- a/compiler/core/lam_bounded_vars.ml +++ b/compiler/core/lam_bounded_vars.ml @@ -61,10 +61,10 @@ 2. number of invoked times 3. arguments are const or not *) -let rewrite (map : _ Hash_ident.t) (lam : Lam.t) : Lam.t = +let rewrite (map : _ Hash_ident.t) (lam : Lambda.t) : Lambda.t = let rebind i = let i' = Ident.rename i in - Hash_ident.add map i (Lam.var i'); + Hash_ident.add map i (Lambda.var i'); i' in (* order matters, especially for let bindings *) @@ -72,14 +72,14 @@ let rewrite (map : _ Hash_ident.t) (lam : Lam.t) : Lam.t = match op with | None -> None | Some x -> Some (aux x) - and aux (lam : Lam.t) : Lam.t = + and aux (lam : Lambda.t) : Lambda.t = match lam with | Lvar v -> Hash_ident.find_default map v lam | Llet (str, v, l1, l2) -> let v = rebind v in let l1 = aux l1 in let l2 = aux l2 in - Lam.let_ str v l1 l2 + Lambda.let_ str v l1 l2 | Lletrec (bindings, body) -> (*order matters see GPR #405*) let vars = Ext_list.map bindings (fun (k, _) -> rebind k) in @@ -87,41 +87,41 @@ let rewrite (map : _ Hash_ident.t) (lam : Lam.t) : Lam.t = Ext_list.map2 vars bindings (fun var (_, l) -> (var, aux l)) in let body = aux body in - Lam.letrec bindings body - | Lfunction {arity; params; body; attr; loc} -> + Lambda.letrec bindings body + | Lfunction {params; body; attr; loc} -> let params = Ext_list.map params rebind in let body = aux body in - Lam.function_ ~loc ~arity ~params ~body ~attr + Lambda.function_ ~loc ~params ~body ~attr | Lstaticcatch (l1, (i, xs), l2) -> let l1 = aux l1 in let xs = Ext_list.map xs rebind in let l2 = aux l2 in - Lam.staticcatch l1 (i, xs) l2 + Lambda.staticcatch l1 (i, xs) l2 | Lfor (ident, l1, l2, dir, l3) -> let ident = rebind ident in let l1 = aux l1 in let l2 = aux l2 in let l3 = aux l3 in - Lam.for_ ident (aux l1) l2 dir l3 + Lambda.for_ ident (aux l1) l2 dir l3 | Lfor_of (ident, l1, l2) -> let ident = rebind ident in let l1 = aux l1 in let l2 = aux l2 in - Lam.for_of ident l1 l2 + Lambda.for_of ident l1 l2 | Lfor_await_of (ident, l1, l2) -> let ident = rebind ident in let l1 = aux l1 in let l2 = aux l2 in - Lam.for_await_of ident l1 l2 + Lambda.for_await_of ident l1 l2 | Lconst _ -> lam | Lprim {primitive; args; loc} -> (* here it makes sure that global vars are not rebound *) - Lam.prim ~primitive ~args:(Ext_list.map args aux) loc + Lambda.prim ~primitive ~args:(Ext_list.map args aux) loc | Lglobal_module _ -> lam | Lapply {ap_func; ap_args; ap_info; ap_transformed_jsx} -> let fn = aux ap_func in let args = Ext_list.map ap_args aux in - Lam.apply ~ap_transformed_jsx fn args ap_info + Lambda.apply ~ap_transformed_jsx fn args ap_info | Lswitch ( l, { @@ -133,7 +133,7 @@ let rewrite (map : _ Hash_ident.t) (lam : Lam.t) : Lam.t = sw_dispatch; } ) -> let l = aux l in - Lam.switch l + Lambda.switch l { sw_consts = Ext_list.map_snd sw_consts aux; sw_blocks = Ext_list.map_snd sw_blocks aux; @@ -144,30 +144,30 @@ let rewrite (map : _ Hash_ident.t) (lam : Lam.t) : Lam.t = } | Lstringswitch (l, sw, d) -> let l = aux l in - Lam.stringswitch l (Ext_list.map_snd sw aux) (option_map d) - | Lstaticraise (i, ls) -> Lam.staticraise i (Ext_list.map ls aux) + Lambda.stringswitch l (Ext_list.map_snd sw aux) (option_map d) + | Lstaticraise (i, ls) -> Lambda.staticraise i (Ext_list.map ls aux) | Ltrywith (l1, v, l2) -> let l1 = aux l1 in let v = rebind v in let l2 = aux l2 in - Lam.try_ l1 v l2 + Lambda.try_ l1 v l2 | Lifthenelse (l1, l2, l3) -> let l1 = aux l1 in let l2 = aux l2 in let l3 = aux l3 in - Lam.if_ l1 l2 l3 + Lambda.if_ l1 l2 l3 | Lsequence (l1, l2) -> let l1 = aux l1 in let l2 = aux l2 in - Lam.seq l1 l2 - | Lbreak -> Lam.break - | Lcontinue -> Lam.continue + Lambda.seq l1 l2 + | Lbreak -> Lambda.break + | Lcontinue -> Lambda.continue | Lwhile (l1, l2) -> let l1 = aux l1 in let l2 = aux l2 in - Lam.while_ l1 l2 - | Lassign (v, l) -> Lam.assign v (aux l) + Lambda.while_ l1 l2 + | Lassign (v, l) -> Lambda.assign v (aux l) in aux lam -(* let refresh lam = rewrite (Hash_ident.create 17 : Lam.t Hash_ident.t ) lam *) +(* let refresh lam = rewrite (Hash_ident.create 17 : Lambda.t Hash_ident.t ) lam *) diff --git a/compiler/core/lam_bounded_vars.mli b/compiler/core/lam_bounded_vars.mli index 7969aaf78a2..2e9dffa0aa0 100644 --- a/compiler/core/lam_bounded_vars.mli +++ b/compiler/core/lam_bounded_vars.mli @@ -22,12 +22,12 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val rewrite : Lam.t Hash_ident.t -> Lam.t -> Lam.t +val rewrite : Lambda.t Hash_ident.t -> Lambda.t -> Lambda.t (** [rewrite tbl lam] Given a [tbl] to rewrite all bounded variables in [lam] *) (** refresh lambda to replace all bounded vars for new ones *) (* val refresh : - Lam.t -> - Lam.t *) + Lambda.t -> + Lambda.t *) diff --git a/compiler/core/lam_check.ml b/compiler/core/lam_check.ml index 3411c304736..91b71de50d8 100644 --- a/compiler/core/lam_check.ml +++ b/compiler/core/lam_check.ml @@ -47,9 +47,9 @@ let check ~file ~pass lam = in let rec check_list xs (cxt : Set_int.t) = Ext_list.iter xs (fun x -> check_staticfails x cxt) - and check_list_snd : 'a. ('a * Lam.t) list -> _ -> unit = + and check_list_snd : 'a. ('a * Lambda.t) list -> _ -> unit = fun xs cxt -> Ext_list.iter_snd xs (fun x -> check_staticfails x cxt) - and check_staticfails (l : Lam.t) (cxt : Set_int.t) = + and check_staticfails (l : Lambda.t) (cxt : Set_int.t) = match l with | Lvar _ | Lconst _ | Lglobal_module _ -> () | Lprim {args; _} -> check_list args cxt @@ -98,9 +98,9 @@ let check ~file ~pass lam = | Lassign (_id, e) -> check_staticfails e cxt in let rec iter_list xs = Ext_list.iter xs iter - and iter_list_snd : 'a. ('a * Lam.t) list -> unit = + and iter_list_snd : 'a. ('a * Lambda.t) list -> unit = fun xs -> Ext_list.iter_snd xs iter - and iter (l : Lam.t) = + and iter (l : Lambda.t) = match l with | Lvar id -> use id | Lglobal_module _ -> () diff --git a/compiler/core/lam_check.mli b/compiler/core/lam_check.mli index 2e4b08bc6e0..93bb81b74ce 100644 --- a/compiler/core/lam_check.mli +++ b/compiler/core/lam_check.mli @@ -22,4 +22,4 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val check : file:string -> pass:string -> Lam.t -> Lam.t +val check : file:string -> pass:string -> Lambda.t -> Lambda.t diff --git a/compiler/core/lam_closure.ml b/compiler/core/lam_closure.ml index 2092c92b9ff..5386d5ab252 100644 --- a/compiler/core/lam_closure.ml +++ b/compiler/core/lam_closure.ml @@ -52,7 +52,7 @@ let sink_pos = Lam_var_stats.sink An enriched version of [free_varaibles] in {!Lam_free_variables} *) let free_variables (export_idents : Set_ident.t) (params : stats Map_ident.t) - (lam : Lam.t) : stats Map_ident.t = + (lam : Lambda.t) : stats Map_ident.t = let fv = ref params in let local_set = ref export_idents in let local_add k = local_set := Set_ident.add !local_set k in @@ -65,7 +65,7 @@ let free_variables (export_idents : Set_ident.t) (params : stats Map_ident.t) if not (Set_ident.mem !local_set v) then fv := adjust !fv cur_pos v in - let rec iter (top : position) (lam : Lam.t) = + let rec iter (top : position) (lam : Lambda.t) = match lam with | Lvar v -> used top v | Lconst _ -> () @@ -150,7 +150,7 @@ let free_variables (export_idents : Set_ident.t) (params : stats Map_ident.t) iter Lam_var_stats.fresh_env lam; !fv -(* let is_closed_by (set : Set_ident.t) (lam : Lam.t) : bool = +(* let is_closed_by (set : Set_ident.t) (lam : Lambda.t) : bool = Map_ident.is_empty (free_variables set (Map_ident.empty ) lam ) *) (** A bit consverative , it should be empty *) @@ -159,7 +159,7 @@ let is_closed lam = (fun k _ -> Ident.global k) let is_closed_with_map (exports : Set_ident.t) (params : Ident.t list) - (body : Lam.t) : bool * stats Map_ident.t = + (body : Lambda.t) : bool * stats Map_ident.t = let param_map = free_variables exports (param_map_of_list params) body in let old_count = List.length params in let new_count = Map_ident.cardinal param_map in diff --git a/compiler/core/lam_closure.mli b/compiler/core/lam_closure.mli index 392cb5caa11..337bfc40e35 100644 --- a/compiler/core/lam_closure.mli +++ b/compiler/core/lam_closure.mli @@ -25,16 +25,19 @@ (** [is_closed_by map lam] return [true] if all unbound variables belongs to the given [map] *) -(* val is_closed_by : Set_ident.t -> Lam.t -> bool *) +(* val is_closed_by : Set_ident.t -> Lambda.t -> bool *) -val is_closed : Lam.t -> bool +val is_closed : Lambda.t -> bool val is_closed_with_map : - Set_ident.t -> Ident.t list -> Lam.t -> bool * Lam_var_stats.stats Map_ident.t + Set_ident.t -> + Ident.t list -> + Lambda.t -> + bool * Lam_var_stats.stats Map_ident.t (** The output is mostly used in betat reduction *) val free_variables : Set_ident.t -> Lam_var_stats.stats Map_ident.t -> - Lam.t -> + Lambda.t -> Lam_var_stats.stats Map_ident.t diff --git a/compiler/core/lam_coercion.ml b/compiler/core/lam_coercion.ml index 2ddddc7cfd0..4b11e845ca2 100644 --- a/compiler/core/lam_coercion.ml +++ b/compiler/core/lam_coercion.ml @@ -72,14 +72,14 @@ type t = { export_list: Ident.t list; export_set: Set_ident.t; - export_map: Lam.t Map_ident.t; + export_map: Lambda.t Map_ident.t; (** not used in code generation, mostly used for store some information in cmj files *) groups: Lam_group.t list; (* all code to be compiled later = original code + rebound coercions *) } -let handle_exports (meta : Lam_stats.t) (lambda_exports : Lam.t list) +let handle_exports (meta : Lam_stats.t) (lambda_exports : Lambda.t list) (reverse_input : Lam_group.t list) = let (original_exports : Ident.t list) = meta.exports in let (original_export_set : Set_ident.t) = meta.export_idents in @@ -92,7 +92,7 @@ let handle_exports (meta : Lam_stats.t) (lambda_exports : Lam.t list) export_set = original_export_set; export_map = Map_ident.empty; groups = []; - } (fun (original_export_id : Ident.t) (lam : Lam.t) (acc : t) -> + } (fun (original_export_id : Ident.t) (lam : Lambda.t) (acc : t) -> let original_name = original_export_id.name in if not @@ Hash_set_string.check_add tbl original_name then Bs_exception.error (Bs_duplicate_exports original_name); @@ -111,7 +111,7 @@ let handle_exports (meta : Lam_stats.t) (lambda_exports : Lam.t list) } else let newid = Ident.rename original_export_id in - let kind : Lam_compat.let_kind = Alias in + let kind : Lambda.let_kind = Alias in Lam_util.alias_ident_or_global meta newid id NA; { acc with @@ -176,8 +176,8 @@ let handle_exports (meta : Lam_stats.t) (lambda_exports : Lam.t list) - [compile_group] and [compile] become mutually recursive function *) -let rec flatten (acc : Lam_group.t list) (lam : Lam.t) : - Lam.t * Lam_group.t list = +let rec flatten (acc : Lam_group.t list) (lam : Lambda.t) : + Lambda.t * Lam_group.t list = match lam with | Llet (str, id, arg, body) -> let res, l = flatten acc arg in diff --git a/compiler/core/lam_coercion.mli b/compiler/core/lam_coercion.mli index e9163c9d6bd..bc123aa8dbd 100644 --- a/compiler/core/lam_coercion.mli +++ b/compiler/core/lam_coercion.mli @@ -25,8 +25,8 @@ type t = { export_list: Ident.t list; export_set: Set_ident.t; - export_map: Lam.t Map_ident.t; + export_map: Lambda.t Map_ident.t; groups: Lam_group.t list; } -val coerce_and_group_big_lambda : Lam_stats.t -> Lam.t -> t * Lam_stats.t +val coerce_and_group_big_lambda : Lam_stats.t -> Lambda.t -> t * Lam_stats.t diff --git a/compiler/core/lam_compat.ml b/compiler/core/lam_compat.ml deleted file mode 100644 index 7df7e27eed7..00000000000 --- a/compiler/core/lam_compat.ml +++ /dev/null @@ -1,82 +0,0 @@ -(* Copyright (C) 2018 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type comparison = Lambda.comparison = Ceq | Cneq | Clt | Cgt | Cle | Cge - -let eq_comparison (p : comparison) (p1 : comparison) = - match p with - | Cge -> p1 = Cge - | Cgt -> p1 = Cgt - | Cle -> p1 = Cle - | Clt -> p1 = Clt - | Ceq -> p1 = Ceq - | Cneq -> p1 = Cneq - -let cmp_int32 (cmp : comparison) (a : int32) b : bool = - match cmp with - | Ceq -> a = b - | Cneq -> a <> b - | Cgt -> a > b - | Cle -> a <= b - | Clt -> a < b - | Cge -> a >= b - -let cmp_float (cmp : comparison) (a : float) b : bool = - match cmp with - | Ceq -> a = b - | Cneq -> a <> b - | Cgt -> a > b - | Cle -> a <= b - | Clt -> a < b - | Cge -> a >= b - -type let_kind = Lambda.let_kind = Strict | Alias | StrictOpt | Variable - -type field_dbg_info = Lambda.field_dbg_info = - | Fld_record of {name: string} - | Fld_module of {name: string} - | Fld_record_inline of {name: string} - | Fld_record_extension of {name: string} - | Fld_tuple - | Fld_poly_var_tag - | Fld_poly_var_content - | Fld_extension - | Fld_variant - | Fld_cons - -let str_of_field_info (x : field_dbg_info) : string option = - match x with - | Fld_extension | Fld_variant | Fld_cons | Fld_poly_var_tag - | Fld_poly_var_content | Fld_tuple -> - None - | Fld_record {name; _} - | Fld_module {name; _} - | Fld_record_inline {name} - | Fld_record_extension {name} -> - Some name - -type set_field_dbg_info = Lambda.set_field_dbg_info = - | Fld_record_set of string - | Fld_record_inline_set of string - | Fld_record_extension_set of string diff --git a/compiler/core/lam_compat.mli b/compiler/core/lam_compat.mli deleted file mode 100644 index 00f15725e63..00000000000 --- a/compiler/core/lam_compat.mli +++ /dev/null @@ -1,52 +0,0 @@ -(* Copyright (C) 2018 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type comparison = Lambda.comparison = Ceq | Cneq | Clt | Cgt | Cle | Cge - -type let_kind = Lambda.let_kind = Strict | Alias | StrictOpt | Variable - -type field_dbg_info = Lambda.field_dbg_info = - | Fld_record of {name: string} - | Fld_module of {name: string} - | Fld_record_inline of {name: string} - | Fld_record_extension of {name: string} - | Fld_tuple - | Fld_poly_var_tag - | Fld_poly_var_content - | Fld_extension - | Fld_variant - | Fld_cons - -val str_of_field_info : field_dbg_info -> string option - -type set_field_dbg_info = Lambda.set_field_dbg_info = - | Fld_record_set of string - | Fld_record_inline_set of string - | Fld_record_extension_set of string - -val cmp_int32 : comparison -> int32 -> int32 -> bool - -val cmp_float : comparison -> float -> float -> bool - -val eq_comparison : comparison -> comparison -> bool diff --git a/compiler/core/lam_compile.ml b/compiler/core/lam_compile.ml index ffbdc779051..9d3663244f1 100644 --- a/compiler/core/lam_compile.ml +++ b/compiler/core/lam_compile.ml @@ -32,7 +32,7 @@ let with_source_loc loc (exp : J.expression) = | Some source_loc, None -> {exp with source_loc = Some source_loc} | _ -> exp -let rec source_loc_of_lam (lam : Lam.t) = +let rec source_loc_of_lam (lam : Lambda.t) = match lam with | Lapply {ap_info = {ap_loc}} -> Some ap_loc | Lprim {loc} | Lfunction {loc} -> Some loc @@ -83,57 +83,29 @@ let with_block_source_loc lam block = | stmt :: rest -> with_statement_source_loc (source_map_loc_of_lam lam) stmt :: rest -let args_either_function_or_const (args : Lam.t list) = +let args_either_function_or_const (args : Lambda.t list) = Ext_list.for_all args (fun x -> match x with | Lfunction _ | Lconst _ -> true | _ -> false) -let call_info_of_ap_status call_transformed_jsx (ap_status : Lam.apply_status) : - Js_call_info.t = - (* XXX *) - match ap_status with - | App_infer_full -> {arity = Full; call_info = Call_ml; call_transformed_jsx} - | App_uncurry -> {arity = Full; call_info = Call_na; call_transformed_jsx} - | App_na -> {arity = NA; call_info = Call_ml; call_transformed_jsx} - -let rec apply_with_arity_aux (fn : J.expression) (arity : int list) - (args : E.t list) (len : int) : E.t = - if len = 0 then fn (* All arguments consumed so far *) - else - match arity with - | x :: rest -> - let x = if x = 0 then 1 else x in - (* Relax when x = 0 *) - if len >= x then - let first_part, continue = Ext_list.split_at args x in - apply_with_arity_aux - (E.call ~info:Js_call_info.ml_full_call fn first_part) - rest continue (len - x) - else if - (* GPR #1423 *) - Ext_list.for_all args Js_analyzer.is_okay_to_duplicate - then - let params = - Ext_list.init (x - len) (fun _ -> Ext_ident.create "param") - in - E.ocaml_fun params ~return_unit:false (* unknown info *) - ~async:false ~one_unit_arg:false - [ - S.return_stmt - (E.call ~info:Js_call_info.ml_full_call fn - (Ext_list.append args @@ Ext_list.map params E.var)); - ] - else E.call ~info:Js_call_info.dummy fn args - (* alpha conversion now? -- - Since we did an alpha conversion before so it is not here - *) - | [] -> - (* can not happen, unless it's an exception ? *) - E.call ~info:Js_call_info.dummy fn args - -let apply_with_arity ~arity fn args = - apply_with_arity_aux fn arity args (List.length args) +(* Whether the callee's arity is known and this call saturates it. The printer + uses it to decide whether a wrapper around the call may be eta reduced, + which is only sound for a ReScript value of exactly that arity - never for + an FFI name, whose wrapper carries argument adaptation. Looked up here + rather than stamped on the application by an earlier pass. *) +let call_info_of_apply (meta : Lam_stats.t) call_transformed_jsx + (appinfo : Lambda.lambda_apply) : Js_call_info.t = + let saturated = + match + Lam_arity.extract_arity + (Lam_arity_analysis.get_arity meta appinfo.ap_func) + with + | x :: _ -> x = List.length appinfo.ap_args + | [] -> false + in + if saturated then {call_info = Call_ml; call_transformed_jsx} + else {call_info = Call_na; call_transformed_jsx} let change_tail_type_in_try (x : Lam_compile_context.tail_type) : Lam_compile_context.tail_type = @@ -159,8 +131,8 @@ let in_staticcatch (x : Lam_compile_context.tail_type) : -> x *) (* assume outer is [Lstaticcatch] *) -let rec flat_catches (acc : Lam_compile_context.handler list) (x : Lam.t) : - Lam_compile_context.handler list * Lam.t = +let rec flat_catches (acc : Lam_compile_context.handler list) (x : Lambda.t) : + Lam_compile_context.handler list * Lambda.t = match x with | Lstaticcatch (l, (label, bindings), handler) when acc = [] @@ -171,8 +143,8 @@ let rec flat_catches (acc : Lam_compile_context.handler list) (x : Lam.t) : flat_catches ({label; handler; bindings} :: acc) l | _ -> (acc, x) -let flatten_nested_caches (x : Lam.t) : Lam_compile_context.handler list * Lam.t - = +let flatten_nested_caches (x : Lambda.t) : + Lam_compile_context.handler list * Lambda.t = flat_catches [] x let morph_declare_to_assign (cxt : Lam_compile_context.t) k = @@ -184,7 +156,7 @@ let morph_declare_to_assign (cxt : Lam_compile_context.t) k = let group_apply ~merge_cases cases callback = Ext_list.flat_map (Ext_list.stable_group cases (fun (tag1, lam) (tag2, lam1) -> - merge_cases tag1 tag2 && Lam.eq_approx lam lam1)) + merge_cases tag1 tag2 && Lambda.eq_approx lam lam1)) (fun group -> Ext_list.map_last group callback) (* TODO: for expression generation, @@ -192,7 +164,7 @@ let group_apply ~merge_cases cases callback = only jmp_table and env needed *) -type default_case = Default of Lam.t | Complete | NonComplete +type default_case = Default of Lambda.t | Complete | NonComplete let default_action ~saturated failaction = match failaction with @@ -267,7 +239,7 @@ type initialization = J.block (* Semantic SCC already ran in [Lambda_scc.bind_rec]. JS still wants functions before values so dummy / updateDummy init is well-ordered. *) -let functions_before_values (group : (Ident.t * Lam.t) list) = +let functions_before_values (group : (Ident.t * Lambda.t) list) = if Ext_list.for_all group (fun (_, x) -> match x with @@ -277,7 +249,7 @@ let functions_before_values (group : (Ident.t * Lam.t) list) = else List.sort (fun (_, lama) (_, lamb) -> - match ((lama : Lam.t), (lamb : Lam.t)) with + match ((lama : Lambda.t), (lamb : Lambda.t)) with | Lfunction _, Lfunction _ -> 0 | Lfunction _, _ -> -1 | _, Lfunction _ -> 1 @@ -302,10 +274,10 @@ let compile output_prefix = table. *) let rec extract_field_path segments primitive args = match (primitive, args) with - | ( Lam_primitive.Pfield (_, Fld_module {name}), - [Lam.Lprim {primitive; args; _}] ) -> + | Lambda.Pfield (_, Fld_module {name}), [Lambda.Lprim {primitive; args; _}] + -> extract_field_path (name :: segments) primitive args - | Lam_primitive.Pfield (_, Fld_module {name}), [Lam.Lglobal_module id] -> + | Lambda.Pfield (_, Fld_module {name}), [Lambda.Lglobal_module id] -> Some (id, name :: segments) | _ -> None in @@ -351,8 +323,9 @@ let compile output_prefix = for the function, generative module or functor can be a function, however it can not be global -- global can only module *) - and compile_external_field_apply (appinfo : Lam.apply) (module_id : Ident.t) - (field_name : string) (lambda_cxt : Lam_compile_context.t) : Js_output.t = + and compile_external_field_apply (appinfo : Lambda.lambda_apply) + (module_id : Ident.t) (field_name : string) + (lambda_cxt : Lam_compile_context.t) : Js_output.t = let ident_info = Lam_compile_env.query_external_id_info module_id field_name in @@ -383,17 +356,11 @@ let compile output_prefix = let fn = E.ml_var_dot module_id ident_info.name in let expression = - match appinfo.ap_info.ap_status with - | (App_infer_full | App_uncurry) as ap_status -> - E.call - ~info:(call_info_of_ap_status appinfo.ap_transformed_jsx ap_status) - fn args - | App_na -> ( - match ident_info.arity with - | Submodule _ | Single Arity_na -> - E.call ~info:Js_call_info.dummy fn args - | Single x -> - apply_with_arity fn ~arity:(Lam_arity.extract_arity x) args) + E.call + ~info: + (call_info_of_apply lambda_cxt.meta appinfo.ap_transformed_jsx + appinfo) + fn args in let expression = with_source_loc appinfo.ap_info.ap_loc expression in Js_output.output_of_block_and_expression lambda_cxt.continuation args_code @@ -407,7 +374,7 @@ let compile output_prefix = *) and compile_recursive_let ~all_bindings (cxt : Lam_compile_context.t) - (id : Ident.t) (arg : Lam.t) : Js_output.t * initialization = + (id : Ident.t) (arg : Lambda.t) : Js_output.t * initialization = match arg with | Lfunction { @@ -478,7 +445,7 @@ let compile output_prefix = result ~no_effects:(lazy (Lam_analysis.no_side_effects arg)), [] ) - | Lprim {primitive = Pmakeblock (_, _); args} + | Lprim {primitive = Pmakeblock _; args} when args_either_function_or_const args -> (compile_lambda {cxt with continuation = Declare (Alias, id)} arg, []) (* case of lazy blocks, treat it as usual *) @@ -486,10 +453,9 @@ let compile output_prefix = { primitive = Pmakeblock - ( (( Blk_record _ - | Blk_constructor {num_nonconst = 1} - | Blk_record_inlined {num_nonconst = 1} ) as tag_info), - _ ); + (( Blk_record _ + | Blk_constructor {num_nonconst = 1} + | Blk_record_inlined {num_nonconst = 1} ) as tag_info); args = ls; } when Ext_list.for_all ls (fun x -> @@ -530,7 +496,7 @@ let compile output_prefix = | Lconst x -> Lam_compile_const.translate x | _ -> assert false)))), [] ) - | Lprim {primitive = Pmakeblock (tag_info, _)} -> ( + | Lprim {primitive = Pmakeblock tag_info} -> ( (* Lconst should not appear here if we do [scc] optimization, since it's faked recursive value, however it would affect scope issues, we have to declare it first @@ -572,7 +538,7 @@ let compile output_prefix = ]} *) (compile_lambda {cxt with continuation = Declare (Alias, id)} arg, []) - and compile_recursive_lets_aux cxt (id_args : (Ident.t * Lam.t) list) : + and compile_recursive_lets_aux cxt (id_args : (Ident.t * Lambda.t) list) : Js_output.t = (* #1716 *) let output_code, ids = @@ -598,14 +564,14 @@ let compile output_prefix = cxt:Lam_compile_context.t -> switch: (?default:J.block -> - ?declaration:Lam_compat.let_kind * Ident.t -> + ?declaration:Lambda.let_kind * Ident.t -> _ -> ('a * J.case_clause) list -> J.statement) -> switch_exp:J.expression -> default:default_case -> ?merge_cases:('a -> 'a -> bool) -> - ('a * Lam.t) list -> + ('a * Lambda.t) list -> J.block = fun (type a) ~(make_exp : a -> J.expression) ~(eq_exp : @@ -613,11 +579,11 @@ let compile output_prefix = ~(cxt : Lam_compile_context.t) ~(switch : ?default:J.block -> - ?declaration:Lam_compat.let_kind * Ident.t -> + ?declaration:Lambda.let_kind * Ident.t -> _ -> (a * J.case_clause) list -> J.statement) ~(switch_exp : J.expression) ~(default : default_case) - ?(merge_cases = fun _ _ -> true) (cases : (a * Lam.t) list) -> + ?(merge_cases = fun _ _ -> true) (cases : (a * Lambda.t) list) -> let output_block_with_source_loc cxt lam = compile_lambda cxt lam |> Js_output.output_as_block |> with_block_source_loc lam @@ -673,7 +639,9 @@ let compile output_prefix = let cases = match default with | Default lam -> - List.filter (fun (_, lam1) -> not (Lam.eq_approx lam lam1)) cases + List.filter + (fun (_, lam1) -> not (Lambda.eq_approx lam lam1)) + cases | _ -> cases in let switch_cxt = Lam_compile_context.enter_switch cxt in @@ -761,7 +729,7 @@ let compile output_prefix = | Switch_constructor _ -> assert false) clauses)) ~switch_exp ~default - and compile_switch (switch_arg : Lam.t) (sw : Lam.lambda_switch) + and compile_switch (switch_arg : Lambda.t) (sw : Lambda.lambda_switch) (lambda_cxt : Lam_compile_context.t) = (* TODO: if default is None, we can do some optimizations Use switch vs if/then/else @@ -778,7 +746,7 @@ let compile output_prefix = sw_failaction; sw_dispatch; } - : Lam.lambda_switch) = + : Lambda.lambda_switch) = sw in let sw_num_default = @@ -815,7 +783,7 @@ let compile output_prefix = in let eq_default d1 d2 = match (d1, d2) with - | Default lam1, Default lam2 -> Lam.eq_approx lam1 lam2 + | Default lam1, Default lam2 -> Lambda.eq_approx lam1 lam2 | Complete, Complete -> true | NonComplete, NonComplete -> true | _ -> false @@ -1006,7 +974,7 @@ let compile output_prefix = default: (exit 1)) with (1) 2)) *) - and compile_staticraise i (largs : Lam.t list) + and compile_staticraise i (largs : Lambda.t list) (lambda_cxt : Lam_compile_context.t) = (* [i] is the jump table, [largs] is the arguments passed to [Lstaticcatch]*) match Lam_compile_context.find_exn lambda_cxt i with @@ -1053,7 +1021,8 @@ let compile output_prefix = ]} *) - and compile_staticcatch (lam : Lam.t) (lambda_cxt : Lam_compile_context.t) = + and compile_staticcatch (lam : Lambda.t) (lambda_cxt : Lam_compile_context.t) + = let code_table, body = flatten_nested_caches lam in let exit_id = Ext_ident.create_tmp ~name:"exit" () in match (lambda_cxt.continuation, code_table) with @@ -1139,10 +1108,10 @@ let compile output_prefix = (Js_output.append_output lbody (Js_output.make (compile_cases ~cxt:new_cxt ~switch_exp:exit_expr handlers)))) - and compile_sequand (l : Lam.t) (r : Lam.t) + and compile_sequand (l : Lambda.t) (r : Lambda.t) (lambda_cxt : Lam_compile_context.t) = if Lam_compile_context.continuation_is_return lambda_cxt.continuation then - compile_lambda lambda_cxt (Lam.sequand l r) + compile_lambda lambda_cxt (Lambda.sequand l r) else let new_cxt = {lambda_cxt with continuation = NeedValue Not_tail} in match compile_lambda new_cxt l with @@ -1178,10 +1147,10 @@ let compile output_prefix = ((S.define_variable ~kind:Variable v E.false_ :: l_block) @ [S.if_ l_expr (r_block @ [S.assign v r_expr])]) ~value:(E.var v))) - and compile_sequor (l : Lam.t) (r : Lam.t) + and compile_sequor (l : Lambda.t) (r : Lambda.t) (lambda_cxt : Lam_compile_context.t) = if Lam_compile_context.continuation_is_return lambda_cxt.continuation then - compile_lambda lambda_cxt (Lam.sequor l r) + compile_lambda lambda_cxt (Lambda.sequor l r) else let new_cxt = {lambda_cxt with continuation = NeedValue Not_tail} in match compile_lambda new_cxt l with @@ -1225,7 +1194,7 @@ let compile output_prefix = while expression, here we generate for statement, leave optimization later. (Sine OCaml expression can be really complex..) *) - and compile_while (predicate : Lam.t) (body : Lam.t) + and compile_while (predicate : Lambda.t) (body : Lambda.t) (lambda_cxt : Lam_compile_context.t) = match compile_lambda @@ -1263,8 +1232,8 @@ let compile output_prefix = for(var i = 0 ; i < (console.log(i),10); ++i){console.log('hi')} print i each time, so they are different semantics... *) - and compile_for (id : J.for_ident) (start : Lam.t) (finish : Lam.t) - (direction : Js_op.direction_flag) (body : Lam.t) + and compile_for (id : J.for_ident) (start : Lambda.t) (finish : Lambda.t) + (direction : Js_op.direction_flag) (body : Lambda.t) (lambda_cxt : Lam_compile_context.t) = let new_cxt = {lambda_cxt with continuation = NeedValue Not_tail} in let block = @@ -1310,11 +1279,11 @@ let compile output_prefix = in Js_output.output_of_block_and_expression lambda_cxt.continuation block E.unit - and compile_for_of (id : J.for_ident) (iterable : Lam.t) (body : Lam.t) + and compile_for_of (id : J.for_ident) (iterable : Lambda.t) (body : Lambda.t) (lambda_cxt : Lam_compile_context.t) = let new_cxt = {lambda_cxt with continuation = NeedValue Not_tail} in let emitted_id = - if Set_ident.mem (Lam_free_variables.pass_free_variables body) id then id + if Set_ident.mem (Lambda.free_variables body) id then id else Ext_ident.create_tmp ~name:"_for_of" () in let block = @@ -1333,11 +1302,11 @@ let compile output_prefix = in Js_output.output_of_block_and_expression lambda_cxt.continuation block E.unit - and compile_for_await_of (id : J.for_ident) (iterable : Lam.t) (body : Lam.t) - (lambda_cxt : Lam_compile_context.t) = + and compile_for_await_of (id : J.for_ident) (iterable : Lambda.t) + (body : Lambda.t) (lambda_cxt : Lam_compile_context.t) = let new_cxt = {lambda_cxt with continuation = NeedValue Not_tail} in let emitted_id = - if Set_ident.mem (Lam_free_variables.pass_free_variables body) id then id + if Set_ident.mem (Lambda.free_variables body) id then id else Ext_ident.create_tmp ~name:"_for_await_of" () in let block = @@ -1356,12 +1325,10 @@ let compile output_prefix = in Js_output.output_of_block_and_expression lambda_cxt.continuation block E.unit - and compile_assign id (lambda : Lam.t) (lambda_cxt : Lam_compile_context.t) = + and compile_assign id (lambda : Lambda.t) (lambda_cxt : Lam_compile_context.t) + = let block = match lambda with - | Lprim {primitive = Poffsetint v; args = [Lvar bid]} - when Ident.same id bid -> - [S.exp (E.assign (E.var id) (E.int32_add (E.var id) (E.small_int v)))] | _ -> ( match compile_lambda @@ -1417,8 +1384,8 @@ let compile output_prefix = Js_output.make (aux lambda_cxt {lambda_cxt with continuation = EffectCall new_return_type}) - and compile_ifthenelse (predicate : Lam.t) (t_branch : Lam.t) - (f_branch : Lam.t) (lambda_cxt : Lam_compile_context.t) = + and compile_ifthenelse (predicate : Lambda.t) (t_branch : Lambda.t) + (f_branch : Lambda.t) (lambda_cxt : Lam_compile_context.t) = match compile_lambda {lambda_cxt with continuation = NeedValue Not_tail} @@ -1565,23 +1532,9 @@ let compile output_prefix = in Js_output.make (Ext_list.append_one b (S.if_ e then_output ~else_:else_output)))) - and compile_apply (appinfo : Lam.apply) (lambda_cxt : Lam_compile_context.t) = + and compile_apply (appinfo : Lambda.lambda_apply) + (lambda_cxt : Lam_compile_context.t) = match appinfo with - | { - ap_func = - Lapply {ap_func; ap_args; ap_info = {ap_status = App_na; ap_inlined}}; - ap_info = {ap_status = App_na} as outer_ap_info; - ap_transformed_jsx; - } -> - (* After inlining, we can generate such code, see {!Ari_regress_test}*) - let ap_info = - if outer_ap_info.ap_inlined = ap_inlined then outer_ap_info - else {outer_ap_info with ap_inlined} - in - compile_lambda lambda_cxt - (Lam.apply ap_func - (Ext_list.append ap_args appinfo.ap_args) - ap_info ~ap_transformed_jsx) (* External function call: it can not be tailcall in this case*) | { ap_func = @@ -1662,10 +1615,10 @@ let compile output_prefix = (with_source_loc appinfo.ap_info.ap_loc (E.call ~info: - (call_info_of_ap_status appinfo.ap_transformed_jsx - appinfo.ap_info.ap_status) + (call_info_of_apply lambda_cxt.meta appinfo.ap_transformed_jsx + appinfo) fn_code args))) - and compile_prim (prim_info : Lam.prim_info) + and compile_prim (prim_info : Lambda.prim_info) (lambda_cxt : Lam_compile_context.t) = let compile_primitive_default primitive args loc = let args_block, args_expr = @@ -1814,9 +1767,9 @@ let compile output_prefix = (Ext_list.concat_append args_block block) exp | {primitive; args; loc} -> compile_primitive_default primitive args loc - and collect_dup_overrides (copy_id : Ident.t) (lam : Lam.t) - (acc : (Lam_compat.set_field_dbg_info * Lam.t) list) : - (Lam_compat.set_field_dbg_info * Lam.t) list option = + and collect_dup_overrides (copy_id : Ident.t) (lam : Lambda.t) + (acc : (Lambda.set_field_dbg_info * Lambda.t) list) : + (Lambda.set_field_dbg_info * Lambda.t) list option = match lam with | Lsequence ( Lprim @@ -1827,7 +1780,7 @@ let compile output_prefix = | Lvar id' when Ident.same id' copy_id -> Some acc | _ -> None and try_compile_record_spread (lambda_cxt : Lam_compile_context.t) - (id : Ident.t) (arg : Lam.t) (body : Lam.t) : Js_output.t option = + (id : Ident.t) (arg : Lambda.t) (body : Lambda.t) : Js_output.t option = match arg with | Lprim {primitive = Pduprecord; args = [init]; loc} -> ( match collect_dup_overrides id body [] with @@ -1845,7 +1798,7 @@ let compile output_prefix = let blocks, props = List.fold_left (fun (blocks, props) - ((fld_info : Lam_compat.set_field_dbg_info), value_lam) -> + ((fld_info : Lambda.set_field_dbg_info), value_lam) -> let val_output = compile_lambda need_value_cxt value_lam in let val_val = match val_output.value with @@ -1867,7 +1820,7 @@ let compile output_prefix = blocks (with_source_loc loc (E.obj ~dup:init_val props)))) | _ -> None - and compile_lambda (lambda_cxt : Lam_compile_context.t) (cur_lam : Lam.t) : + and compile_lambda (lambda_cxt : Lam_compile_context.t) (cur_lam : Lambda.t) : Js_output.t = match cur_lam with | Lfunction @@ -1988,9 +1941,9 @@ let compile output_prefix = | Lfor (id, start, finish, direction, body) -> ( match (direction, finish) with | ( Upto, - ( Lprim - {primitive = Psubint; args = [new_finish; Lconst (Const_int 1l)]} - | Lprim {primitive = Poffsetint -1; args = [new_finish]} ) ) -> + Lprim + {primitive = Psubint; args = [new_finish; Lconst (Const_int 1l)]} ) + -> compile_for id start new_finish Up body lambda_cxt | _ -> compile_for id start finish diff --git a/compiler/core/lam_compile.mli b/compiler/core/lam_compile.mli index d5ed77b4040..56ff1d6f66a 100644 --- a/compiler/core/lam_compile.mli +++ b/compiler/core/lam_compile.mli @@ -27,8 +27,8 @@ val compile_recursive_lets : output_prefix:string -> Lam_compile_context.t -> - (Ident.t * Lam.t) list -> + (Ident.t * Lambda.t) list -> Js_output.t val compile_lambda : - output_prefix:string -> Lam_compile_context.t -> Lam.t -> Js_output.t + output_prefix:string -> Lam_compile_context.t -> Lambda.t -> Js_output.t diff --git a/compiler/core/lam_compile_const.ml b/compiler/core/lam_compile_const.ml index 46e0919c706..4cef7f14659 100644 --- a/compiler/core/lam_compile_const.ml +++ b/compiler/core/lam_compile_const.ml @@ -25,7 +25,7 @@ module E = Js_exp_make (** return [val < 0] if not nested [Some (Some (Some None))]*) -let rec is_some_none_aux (x : Lam_constant.t) acc = +let rec is_some_none_aux (x : Lambda.structured_constant) acc = match x with | Const_some v -> is_some_none_aux v (acc + 1) | Const_module_alias | Const_js_undefined _ -> acc @@ -34,14 +34,14 @@ let rec is_some_none_aux (x : Lam_constant.t) acc = let rec nested_some_none n none = if n = 0 then none else nested_some_none (n - 1) (E.optional_block none) -let rec translate_some (x : Lam_constant.t) : J.expression = +let rec translate_some (x : Lambda.structured_constant) : J.expression = let depth = is_some_none_aux x 0 in if depth < 0 then E.optional_not_nest_block (translate x) else nested_some_none depth (E.optional_block (translate (Const_js_undefined {is_unit = false}))) -and translate (x : Lam_constant.t) : J.expression = +and translate (x : Lambda.structured_constant) : J.expression = match x with | Const_module_alias -> E.undefined (* TODO *) | Const_some s -> translate_some s @@ -62,7 +62,7 @@ and translate (x : Lam_constant.t) : J.expression = | Const_float f -> E.float f (* TODO: preserve float *) | Const_string {s; delim = None | Some DNoQuotes} -> E.str s | Const_string {s; delim = Some delim} -> E.str ~delim s - | Const_pointer name -> E.str name + | Const_polyvar name -> E.str name | Const_block (tag_info, xs) -> Js_of_lam_block.make_block NA tag_info (Ext_list.map xs translate) diff --git a/compiler/core/lam_compile_const.mli b/compiler/core/lam_compile_const.mli index 2a97874bee3..30c22414ba5 100644 --- a/compiler/core/lam_compile_const.mli +++ b/compiler/core/lam_compile_const.mli @@ -24,6 +24,6 @@ (** Compile lambda constant to JS *) -val translate : Lam_constant.t -> J.expression +val translate : Lambda.structured_constant -> J.expression val translate_arg_cst : External_arg_spec.cst -> J.expression diff --git a/compiler/core/lam_compile_context.ml b/compiler/core/lam_compile_context.ml index 636f0a254bf..faab0d7545e 100644 --- a/compiler/core/lam_compile_context.ml +++ b/compiler/core/lam_compile_context.ml @@ -54,7 +54,7 @@ type tail_type = Not_tail | Maybe_tail_is_return of maybe_tail (* have a mutable field to notifiy it's actually triggered *) (* anonoymous function does not have identifier *) -type let_kind = Lam_compat.let_kind +type let_kind = Lambda.let_kind type loop_frame = {mutable label: J.label option} type continuation = @@ -100,7 +100,7 @@ let ensure_loop_label cxt frame = frame.label <- Some label; label -type handler = {label: jbl_label; handler: Lam.t; bindings: Ident.t list} +type handler = {label: jbl_label; handler: Lambda.t; bindings: Ident.t list} let no_static_raise_in_handler (x : handler) : bool = not (Lam_exit_code.has_exit_code x.handler (fun _code -> true)) @@ -112,7 +112,7 @@ let no_static_raise_in_handler (x : handler) : bool = [handlers] is used for compiling [staticcatch] *) let add_jmps (m : jmp_table) (exit_id : Ident.t) (code_table : handler list) : - jmp_table * (int * Lam.t) list = + jmp_table * (int * Lambda.t) list = let map, handlers = Ext_list.fold_left_with_offset code_table (m, []) (Handler_map.cardinal m + 1) @@ -124,7 +124,7 @@ let add_jmps (m : jmp_table) (exit_id : Ident.t) (code_table : handler list) : let add_pseudo_jmp (m : jmp_table) (exit_id : Ident.t) (* TODO not needed, remove it later *) - (code_table : handler) : jmp_table * Lam.t = + (code_table : handler) : jmp_table * Lambda.t = ( Handler_map.add m code_table.label {exit_id; bindings = code_table.bindings; order_id = -1}, code_table.handler ) diff --git a/compiler/core/lam_compile_context.mli b/compiler/core/lam_compile_context.mli index 6f4b4010cab..f19f9496f65 100644 --- a/compiler/core/lam_compile_context.mli +++ b/compiler/core/lam_compile_context.mli @@ -41,7 +41,7 @@ type return_label = { type value = {exit_id: Ident.t; bindings: Ident.t list; order_id: int} -type let_kind = Lam_compat.let_kind +type let_kind = Lambda.let_kind type loop_frame = {mutable label: J.label option} type tail = {label: return_label option; in_staticcatch: bool} @@ -82,13 +82,16 @@ val enter_switch : t -> t val push_loop : t -> t * loop_frame val ensure_loop_label : t -> loop_frame -> J.label -type handler = {label: jbl_label; handler: Lam.t; bindings: Ident.t list} +type handler = {label: jbl_label; handler: Lambda.t; bindings: Ident.t list} val no_static_raise_in_handler : handler -> bool val add_jmps : - jmp_table -> Ident.t -> handler list -> jmp_table * (jbl_label * Lam.t) list + jmp_table -> + Ident.t -> + handler list -> + jmp_table * (jbl_label * Lambda.t) list -val add_pseudo_jmp : jmp_table -> Ident.t -> handler -> jmp_table * Lam.t +val add_pseudo_jmp : jmp_table -> Ident.t -> handler -> jmp_table * Lambda.t val find_exn : t -> jbl_label -> value diff --git a/compiler/core/lam_compile_env.ml b/compiler/core/lam_compile_env.ml index a63388978f4..17a759da96e 100644 --- a/compiler/core/lam_compile_env.ml +++ b/compiler/core/lam_compile_env.ml @@ -32,7 +32,7 @@ type env_value = type ident_info = Js_cmj_format.keyed_cmj_value = { name: string; arity: Js_cmj_format.arity; - persistent_closed_lambda: Lam.t option; + persistent_closed_lambda: Lambda.t option; } (* diff --git a/compiler/core/lam_compile_external_call.ml b/compiler/core/lam_compile_external_call.ml index bfc4c24364c..751783d7366 100644 --- a/compiler/core/lam_compile_external_call.ml +++ b/compiler/core/lam_compile_external_call.ml @@ -98,7 +98,7 @@ let ocaml_to_js_eff ~(arg_label : External_arg_spec.label_noname) in match arg_type with | Arg_cst _ -> assert false - (* has to be preprocessed by {!Lam} module first *) + (* has to be preprocessed by {!Lambda} first *) | Extern_unit -> ( (if arg_label = Arg_empty then Splice0 else Splice1 E.unit), if Js_analyzer.no_side_effect_expression arg then [] else [arg] ) @@ -335,12 +335,7 @@ let translate_ffi ?(transformed_jsx = false) (cxt : Lam_compile_context.t) let args, eff = assemble_args_no_splice arg_types args in add_eff eff @@ E.call - ~info: - { - arity = Full; - call_info = Call_na; - call_transformed_jsx = transformed_jsx; - } + ~info:{call_info = Call_na; call_transformed_jsx = transformed_jsx} fn args | Decl_new {name = fn}, _ -> if splice then @@ -368,12 +363,7 @@ let translate_ffi ?(transformed_jsx = false) (cxt : Lam_compile_context.t) add_eff eff (let self = translate_scoped_access scopes self in E.call - ~info: - { - arity = Full; - call_info = Call_na; - call_transformed_jsx = transformed_jsx; - } + ~info:{call_info = Call_na; call_transformed_jsx = transformed_jsx} (E.dot self name) args) else let args, eff = assemble_args_no_splice arg_types args in diff --git a/compiler/core/lam_compile_main.ml b/compiler/core/lam_compile_main.ml index e68358bcccd..21b83d11403 100644 --- a/compiler/core/lam_compile_main.ml +++ b/compiler/core/lam_compile_main.ml @@ -128,28 +128,26 @@ let js_hoisted_aliases (export_ids : Ident.t list) | [] -> base | (pos, name) :: fields -> access loc - (Lam.prim - ~primitive: - (Lam_primitive.Pfield (pos, Lam_compat.Fld_module {name})) + (Lambda.prim + ~primitive:(Lambda.Pfield (pos, Lambda.Fld_module {name})) ~args:[base] loc) fields in let rec resolve_binding seen = function - | Lam.Lvar id as lam -> ( + | Lambda.Lvar id as lam -> ( if Set_ident.mem seen id then (lam, Some id) else match Map_ident.find_opt group_map id with | Some - ((Lam.Lvar _ | Lam.Lprim {primitive = Lam_primitive.Pfield _; _}) + ((Lambda.Lvar _ | Lambda.Lprim {primitive = Lambda.Pfield _; _}) as alias) -> resolve_binding (Set_ident.add seen id) alias | Some resolved -> (resolved, Some id) | None -> (lam, Some id)) - | Lam.Lprim {primitive = Lam_primitive.Pfield (pos, _); args = [base]} as - lam -> ( + | Lambda.Lprim {primitive = Lambda.Pfield (pos, _); args = [base]} as lam + -> ( match fst (resolve_binding seen base) with - | Lam.Lprim - {primitive = Lam_primitive.Pmakeblock (Blk_module _, _); args} -> ( + | Lambda.Lprim {primitive = Lambda.Pmakeblock (Blk_module _); args} -> ( match List.nth_opt args pos with | Some field -> resolve_binding seen field | None -> (lam, None)) @@ -171,8 +169,7 @@ let js_hoisted_aliases (export_ids : Ident.t list) Some (List.rev positions, binding_id, target) | field :: fields -> ( match resolve Set_ident.empty lam with - | Lam.Lprim - {primitive = Lam_primitive.Pmakeblock (Blk_module names, _); args} + | Lambda.Lprim {primitive = Lambda.Pmakeblock (Blk_module names); args} -> ( match find_field field 0 names args with | Some (pos, arg) -> find_path arg fields ((pos, field) :: positions) @@ -220,7 +217,7 @@ let js_hoisted_aliases (export_ids : Ident.t list) if Set_string.mem occupied_names js_name then let error_loc = match target with - | Lam.Lfunction {loc} -> loc + | Lambda.Lfunction {loc} -> loc | _ -> loc in Location.raise_errorf ~loc:error_loc @@ -229,7 +226,7 @@ let js_hoisted_aliases (export_ids : Ident.t list) name else let alias_id = Ident.create name in - let alias = access loc (Lam.var top_id) access_path in + let alias = access loc (Lambda.var top_id) access_path in ( ( Lam_group.Single (Alias, alias_id, alias), alias_id, alias, @@ -242,11 +239,28 @@ let js_hoisted_aliases (export_ids : Ident.t list) | None -> missing_path ()) | [] -> missing_path ())) +(* The other compilation units this one refers to. Conversion used to drop + [Lglobal_module] references and have module analysis add them back (see + #3852); they are read off the Lambda term instead. A reference the + optimizer deletes still has to be imported when the module it names is + impure. *) + (** Actually simplify_lets is kind of global optimization since it requires you to know whether it's used or not *) -let compile (output_prefix : string) export_idents hoisted (lam : Lambda.lambda) - = +let required_modules (lam : Lambda.t) : Lam_module_ident.Hash_set.t = + let required = Lam_module_ident.Hash_set.create 0 in + let rec collect (lam : Lambda.t) = + (match lam with + | Lglobal_module id -> + Lam_module_ident.Hash_set.add required (Lam_module_ident.of_ml id) + | _ -> ()); + Lambda.iter collect lam + in + collect lam; + required + +let compile (output_prefix : string) export_idents hoisted (lam : Lambda.t) = let debug_ir = !Js_config.debug_ir in let diagnostics = if debug_ir then Some (Ir_diagnostics.create ~output_prefix) else None @@ -275,7 +289,7 @@ let compile (output_prefix : string) export_idents hoisted (lam : Lambda.lambda) Ext_log.dwarn ~__POS__ "export idents: %s/%d" id.name id.stamp); Lam_compile_env.reset () in - let lam, may_required_modules = Lam_convert.convert lam in + let may_required_modules = required_modules lam in let lam = Lam_pass_collapse_var_aliases.collapse ~exports:export_ident_sets lam in @@ -284,7 +298,6 @@ let compile (output_prefix : string) export_idents hoisted (lam : Lambda.lambda) let lam = Lam_pass_deep_flatten.deep_flatten lam in let lam = d "flatten0" lam in let meta : Lam_stats.t = Lam_stats.make ~export_idents ~export_ident_sets in - let () = Lam_pass_collect.collect_info meta lam in let lam = let lam = lam |> d "flatten1" |> Lam_pass_exits.simplify_exits |> d "simplify_exits" @@ -303,18 +316,11 @@ let compile (output_prefix : string) export_idents hoisted (lam : Lambda.lambda) let () = Lam_pass_collect.collect_info meta lam in let lam = Lam_pass_remove_alias.simplify_alias meta lam in let lam = Lam_pass_deep_flatten.deep_flatten lam in - let () = Lam_pass_collect.collect_info meta lam in - let lam = - lam |> d "alpha_before" - |> Lam_pass_alpha_conversion.alpha_conversion meta - |> d "alpha_after" |> Lam_pass_exits.simplify_exits - in + let lam = lam |> Lam_pass_exits.simplify_exits in let () = Lam_pass_collect.collect_info meta lam in lam |> d "simplify_alias_before" |> Lam_pass_remove_alias.simplify_alias meta - |> d "alpha_conversion" - |> Lam_pass_alpha_conversion.alpha_conversion meta |> d "before-simplify_lets" (* we should investigate a better way to put different passes : )*) |> Lam_pass_lets_dce.simplify_lets @@ -324,7 +330,7 @@ let compile (output_prefix : string) export_idents hoisted (lam : Lambda.lambda) (* |> Lam_group_pass.scc_pass |> d "scc" *) |> Lam_pass_exits.simplify_exits - |> d "simplify_lets" + |> Lam_pass_guard_raises.guard_raises |> d "simplify_lets" |> fun lam -> if debug_ir then Ext_log.dwarn ~__POS__ "Before coercion: %a@." Lam_stats.print meta; diff --git a/compiler/core/lam_compile_main.mli b/compiler/core/lam_compile_main.mli index 2cfeef80019..c62ff0dca4e 100644 --- a/compiler/core/lam_compile_main.mli +++ b/compiler/core/lam_compile_main.mli @@ -31,7 +31,7 @@ val compile : string -> Ident.t list -> Lambda.hoisted_function list -> - Lambda.lambda -> + Lambda.t -> J.deps_program (** For toplevel, [filename] is [""] which is the same as {!Env.get_unit_name ()} diff --git a/compiler/core/lam_compile_primitive.ml b/compiler/core/lam_compile_primitive.ml index eb1540a5773..67fa13cefc3 100644 --- a/compiler/core/lam_compile_primitive.ml +++ b/compiler/core/lam_compile_primitive.ml @@ -48,8 +48,7 @@ let get_module_system () = | [module_system] -> module_system | _ -> Commonjs -let call_info = - {Js_call_info.arity = Full; call_info = Call_na; call_transformed_jsx = false} +let call_info = {Js_call_info.call_info = Call_na; call_transformed_jsx = false} let import_of_path path = E.call ~info:call_info (E.js_global "import") [E.str path] @@ -72,9 +71,8 @@ let wrap_then_path import (path : string list) = let wrap_then import value = wrap_then_path import [value] let translate output_prefix loc (cxt : Lam_compile_context.t) - (prim : Lam_primitive.t) (args : J.expression list) : J.expression = + (prim : Lambda.primitive) (args : J.expression list) : J.expression = match prim with - | Peliminated _ -> assert false | Pis_not_none -> Js_of_lam_option.is_not_none (Ext_list.singleton_exn args) | Pcreate_extension s -> E.make_exception s | Praw_js_code {code; code_info} -> E.raw_js_code code_info code @@ -82,10 +80,6 @@ let translate output_prefix loc (cxt : Lam_compile_context.t) trim can not be done before syntax checking otherwise location is incorrect *) - | Pjs_apply -> ( - match args with - | fn :: rest -> E.call ~info:call_info fn rest - | _ -> assert false) | Ptagged_template -> ( (* [tag; strings_array; values_array] -> tag`...` *) match args with @@ -165,7 +159,6 @@ let translate output_prefix loc (cxt : Lam_compile_context.t) match path with | [] -> import | _ :: _ -> wrap_then_path import path)) - | Pfn_arity -> E.function_length (Ext_list.singleton_exn args) | Pobjsize -> E.obj_length (Ext_list.singleton_exn args) | Pis_null -> E.is_null (Ext_list.singleton_exn args) | Pis_undefined -> E.is_undef (Ext_list.singleton_exn args) @@ -190,7 +183,8 @@ let translate output_prefix loc (cxt : Lam_compile_context.t) E.optional_not_nest_block arg | _ -> E.optional_block arg) | Psome_not_nest -> E.optional_not_nest_block (Ext_list.singleton_exn args) - | Pmakeblock (tag_info, mutable_flag) -> + | Pmakeblock tag_info -> + let mutable_flag = Lambda.mutable_flag_of_tag_info tag_info in (* RUNTIME *) Js_of_lam_block.make_block (Js_op_util.of_lam_mutable_flag mutable_flag) @@ -369,14 +363,6 @@ let translate output_prefix loc (cxt : Lam_compile_context.t) | _ -> assert false) | Pfloatofint -> Ext_list.singleton_exn args | Pnot -> E.not (Ext_list.singleton_exn args) - | Poffsetint n -> E.offset (Ext_list.singleton_exn args) n - | Poffsetref n -> - let v = - Js_of_lam_block.field Lambda.ref_field_info - (Ext_list.singleton_exn args) - 0l - in - E.seq (E.assign v (E.offset v n)) E.unit | Psequand -> ( (* TODO: rhs is possibly a tail call *) match args with @@ -387,20 +373,6 @@ let translate output_prefix loc (cxt : Lam_compile_context.t) match args with | [e1; e2] -> E.or_ e1 e2 | _ -> assert false) - | Pisout off -> ( - match args with - (* predicate: [x > range or x < 0 ] - can be simplified if x is positive , x > range - if x is negative, fine, its uint is for sure larger than range, - the output is not readable, we might change it back. - - Note that if range is small like [1], then the negative of - it can be more precise (given integer) - a normal case of the compiler is that it will do a shift - in the first step [ (x - 1) > 1 or ( x - 1 ) < 0 ] - *) - | [range; e] -> E.is_out (E.offset e off) range - | _ -> assert false) | Pstringlength -> E.string_length (Ext_list.singleton_exn args) | Pstringrefs | Pstringrefu -> ( match args with diff --git a/compiler/core/lam_compile_primitive.mli b/compiler/core/lam_compile_primitive.mli index b507f63b1cf..279a47242e6 100644 --- a/compiler/core/lam_compile_primitive.mli +++ b/compiler/core/lam_compile_primitive.mli @@ -32,6 +32,6 @@ val translate : string -> Location.t -> Lam_compile_context.t -> - Lam_primitive.t -> + Lambda.primitive -> J.expression list -> J.expression diff --git a/compiler/core/lam_compile_util.ml b/compiler/core/lam_compile_util.ml index a2c3a48437e..4b23e7715e2 100644 --- a/compiler/core/lam_compile_util.ml +++ b/compiler/core/lam_compile_util.ml @@ -22,7 +22,7 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -let jsop_of_comp (cmp : Lam_compat.comparison) : Js_op.binop = +let jsop_of_comp (cmp : Lambda.comparison) : Js_op.binop = match cmp with | Ceq -> EqEqEq (* comparison*) | Cneq -> NotEqEq @@ -31,7 +31,7 @@ let jsop_of_comp (cmp : Lam_compat.comparison) : Js_op.binop = | Cle -> Le | Cge -> Ge -let runtime_of_comp (cmp : Lam_compat.comparison) : string = +let runtime_of_comp (cmp : Lambda.comparison) : string = match cmp with | Ceq -> "equal" | Cneq -> "notequal" diff --git a/compiler/core/lam_compile_util.mli b/compiler/core/lam_compile_util.mli index 3b12a28ac9f..031bcbd748c 100644 --- a/compiler/core/lam_compile_util.mli +++ b/compiler/core/lam_compile_util.mli @@ -24,6 +24,6 @@ (** Some utilities for lambda compilation*) -val jsop_of_comp : Lam_compat.comparison -> Js_op.binop +val jsop_of_comp : Lambda.comparison -> Js_op.binop -val runtime_of_comp : Lam_compat.comparison -> string +val runtime_of_comp : Lambda.comparison -> string diff --git a/compiler/core/lam_constant_convert.ml b/compiler/core/lam_constant_convert.ml deleted file mode 100644 index 80fe10a0d87..00000000000 --- a/compiler/core/lam_constant_convert.ml +++ /dev/null @@ -1,68 +0,0 @@ -(* Copyright (C) 2018 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let rec convert_constant (const : Lambda.structured_constant) : Lam_constant.t = - match const with - | Const_int i -> Const_int i - | Const_char i -> Const_char i - | Const_string {s; delim} -> Const_string {s; delim} - | Const_float i -> Const_float i - | Const_bigint (sign, i) -> Const_bigint (sign, i) - | Const_pointer (Pt_constructor {name = "()"}) -> - Const_js_undefined {is_unit = true} - | Const_false -> Const_js_false - | Const_true -> Const_js_true - | Const_pointer p -> ( - match p with - | Pt_module_alias -> Const_module_alias - | Pt_shape_none -> Lam_constant.lam_none - | Pt_assertfalse -> Const_assertfalse - | Pt_constructor {tag_type = Some (Variant_runtime.Int v)} -> - (* A constructor represented as a number is a genuine number at - runtime; folding relies on it being an ordinary int constant *) - Const_int (Int32.of_int v) - | Pt_constructor runtime -> Const_constructor runtime - | Pt_variant {name} -> - if Ext_string.is_valid_hash_number name then - Const_int (Ext_string.hash_number_as_i32_exn name) - else Const_pointer name) - | Const_block (t, xs) -> ( - match t with - | Blk_some_not_nested -> - Const_some (convert_constant (Ext_list.singleton_exn xs)) - | Blk_some -> Const_some (convert_constant (Ext_list.singleton_exn xs)) - | Blk_constructor _ | Blk_tuple | Blk_record _ | Blk_module _ - | Blk_module_export _ | Blk_extension | Blk_record_inlined _ - | Blk_record_ext _ -> - Const_block (t, Ext_list.map xs convert_constant) - | Blk_poly_var s -> ( - match xs with - | [_; value] -> - let tag_val : Lam_constant.t = - if Ext_string.is_valid_hash_number s then - Const_int (Ext_string.hash_number_as_i32_exn s) - else Const_string {s; delim = None} - in - Const_block (t, [tag_val; convert_constant value]) - | _ -> assert false)) diff --git a/compiler/core/lam_constant_convert.mli b/compiler/core/lam_constant_convert.mli deleted file mode 100644 index d0bf02048fc..00000000000 --- a/compiler/core/lam_constant_convert.mli +++ /dev/null @@ -1,25 +0,0 @@ -(* Copyright (C) 2018 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val convert_constant : Lambda.structured_constant -> Lam_constant.t diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml deleted file mode 100644 index fe3c1dd052c..00000000000 --- a/compiler/core/lam_convert.ml +++ /dev/null @@ -1,268 +0,0 @@ -(* Copyright (C) 2018 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let prim = Lam.prim - -(* type required_modules = Lam_module_ident.Hash_set.t *) - -(** drop Lseq (List! ) etc - see #3852, we drop all these required global modules - but added it back based on our own module analysis -*) -let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = - match p with - | Peliminated e -> prim ~primitive:(Peliminated e) ~args loc - | Pnull -> Lam.const Const_js_null - | Pundefined -> Lam.const (Const_js_undefined {is_unit = false}) - | Pcreate_extension s -> prim ~primitive:(Pcreate_extension s) ~args loc - | Pgetglobal _ -> assert false - | Pmakeblock info -> ( - let mutable_flag = Lambda.mutable_flag_of_tag_info info in - match info with - | Blk_some_not_nested -> prim ~primitive:Psome_not_nest ~args loc - | Blk_some -> prim ~primitive:Psome ~args loc - | Blk_constructor _ | Blk_tuple | Blk_record _ | Blk_record_inlined _ - | Blk_module _ | Blk_module_export _ | Blk_extension | Blk_record_ext _ -> - prim ~primitive:(Pmakeblock (info, mutable_flag)) ~args loc - | Blk_poly_var s -> ( - match args with - | [_; value] -> - let tag_val : Lam_constant.t = - if Ext_string.is_valid_hash_number s then - Const_int (Ext_string.hash_number_as_i32_exn s) - else Const_string {s; delim = None} - in - prim - ~primitive:(Pmakeblock (info, mutable_flag)) - ~args:[Lam.const tag_val; value] - loc - | _ -> assert false)) - | Pfn_arity -> prim ~primitive:Pfn_arity ~args loc - | Pdebugger -> prim ~primitive:Pdebugger ~args loc - | Ptypeof -> prim ~primitive:Ptypeof ~args loc - | Pisnullable -> prim ~primitive:Pis_null_undefined ~args loc - | Pnull_to_opt -> prim ~primitive:Pnull_to_opt ~args loc - | Pnullable_to_opt -> prim ~primitive:Pnull_undefined_to_opt ~args loc - | Pis_not_none -> prim ~primitive:Pis_not_none ~args loc - | Pval_from_option -> prim ~primitive:Pval_from_option ~args loc - | Pval_from_option_not_nest -> - prim ~primitive:Pval_from_option_not_nest ~args loc - | Pjscomp x -> prim ~primitive:(Pjscomp x) ~args loc - | Pfield (id, info) -> prim ~primitive:(Pfield (id, info)) ~args loc - | Psetfield (id, info) -> prim ~primitive:(Psetfield (id, info)) ~args loc - | Pduprecord -> prim ~primitive:Pduprecord ~args loc - | Ptagged_template -> prim ~primitive:Ptagged_template ~args loc - | Precord_rest excluded -> prim ~primitive:(Precord_rest excluded) ~args loc - | Praise -> prim ~primitive:Praise ~args loc - | Pobjcomp x -> prim ~primitive:(Pobjcomp x) ~args loc - | Pobjorder -> prim ~primitive:Pobjorder ~args loc - | Pobjmin -> prim ~primitive:Pobjmin ~args loc - | Pobjmax -> prim ~primitive:Pobjmax ~args loc - | Pobjtag -> prim ~primitive:Pobjtag ~args loc - | Pobjsize -> prim ~primitive:Pobjsize ~args loc - | Psequand -> prim ~primitive:Psequand ~args loc - | Psequor -> prim ~primitive:Psequor ~args loc - | Pnot -> prim ~primitive:Pnot ~args loc - | Pboolcomp x -> prim ~primitive:(Pboolcomp x) ~args loc - | Pboolorder -> prim ~primitive:Pboolorder ~args loc - | Pboolmin -> prim ~primitive:Pboolmin ~args loc - | Pboolmax -> prim ~primitive:Pboolmax ~args loc - | Pnegint -> prim ~primitive:Pnegint ~args loc - | Paddint -> prim ~primitive:Paddint ~args loc - | Psubint -> prim ~primitive:Psubint ~args loc - | Pmulint -> prim ~primitive:Pmulint ~args loc - | Pdivint -> prim ~primitive:Pdivint ~args loc - | Pmodint -> prim ~primitive:Pmodint ~args loc - | Ppowint -> prim ~primitive:Ppowint ~args loc - | Pandint -> prim ~primitive:Pandint ~args loc - | Porint -> prim ~primitive:Porint ~args loc - | Pxorint -> prim ~primitive:Pxorint ~args loc - | Pnotint -> prim ~primitive:Pnotint ~args loc - | Plslint -> prim ~primitive:Plslint ~args loc - | Plsrint -> prim ~primitive:Plsrint ~args loc - | Pasrint -> prim ~primitive:Pasrint ~args loc - | Pintorder -> prim ~primitive:Pintorder ~args loc - | Pintmin -> prim ~primitive:Pintmin ~args loc - | Pintmax -> prim ~primitive:Pintmax ~args loc - | Pstringlength -> prim ~primitive:Pstringlength ~args loc - | Pstringrefu -> prim ~primitive:Pstringrefu ~args loc - | Pstringcomp x -> prim ~primitive:(Pstringcomp x) ~args loc - | Pstringorder -> prim ~primitive:Pstringorder ~args loc - | Pstringmin -> prim ~primitive:Pstringmin ~args loc - | Pstringmax -> prim ~primitive:Pstringmax ~args loc - | Pstringadd -> prim ~primitive:Pstringadd ~args loc - | Pstringrefs -> prim ~primitive:Pstringrefs ~args loc - | Pisint -> prim ~primitive:Pisint ~args loc - | Pisout -> ( - match args with - | [range; Lprim {primitive = Poffsetint i; args = [x]}] -> - prim ~primitive:(Pisout i) ~args:[range; x] loc - | _ -> prim ~primitive:(Pisout 0) ~args loc) - | Pintoffloat -> prim ~primitive:Pintoffloat ~args loc - | Pfloatofint -> prim ~primitive:Pfloatofint ~args loc - | Pnegfloat -> prim ~primitive:Pnegfloat ~args loc - | Paddfloat -> prim ~primitive:Paddfloat ~args loc - | Psubfloat -> prim ~primitive:Psubfloat ~args loc - | Pmulfloat -> prim ~primitive:Pmulfloat ~args loc - | Pdivfloat -> prim ~primitive:Pdivfloat ~args loc - | Pmodfloat -> prim ~primitive:Pmodfloat ~args loc - | Ppowfloat -> prim ~primitive:Ppowfloat ~args loc - | Pfloatorder -> prim ~primitive:Pfloatorder ~args loc - | Pfloatmin -> prim ~primitive:Pfloatmin ~args loc - | Pfloatmax -> prim ~primitive:Pfloatmax ~args loc - | Pnegbigint -> prim ~primitive:Pnegbigint ~args loc - | Paddbigint -> prim ~primitive:Paddbigint ~args loc - | Psubbigint -> prim ~primitive:Psubbigint ~args loc - | Pmulbigint -> prim ~primitive:Pmulbigint ~args loc - | Pdivbigint -> prim ~primitive:Pdivbigint ~args loc - | Pmodbigint -> prim ~primitive:Pmodbigint ~args loc - | Ppowbigint -> prim ~primitive:Ppowbigint ~args loc - | Pandbigint -> prim ~primitive:Pandbigint ~args loc - | Porbigint -> prim ~primitive:Porbigint ~args loc - | Pxorbigint -> prim ~primitive:Pxorbigint ~args loc - | Pnotbigint -> prim ~primitive:Pnotbigint ~args loc - | Plslbigint -> prim ~primitive:Plslbigint ~args loc - | Pasrbigint -> prim ~primitive:Pasrbigint ~args loc - | Pbigintcomp x -> prim ~primitive:(Pbigintcomp x) ~args loc - | Pbigintorder -> prim ~primitive:Pbigintorder ~args loc - | Pbigintmin -> prim ~primitive:Pbigintmin ~args loc - | Pbigintmax -> prim ~primitive:Pbigintmax ~args loc - | Pintcomp x -> prim ~primitive:(Pintcomp x) ~args loc - | Poffsetint x -> prim ~primitive:(Poffsetint x) ~args loc - | Poffsetref x -> prim ~primitive:(Poffsetref x) ~args loc - | Pfloatcomp x -> prim ~primitive:(Pfloatcomp x) ~args loc - | Pmakearray -> prim ~primitive:Pmakearray ~args loc - | Parraylength -> prim ~primitive:Parraylength ~args loc - | Parrayrefu -> prim ~primitive:Parrayrefu ~args loc - | Parraysetu -> prim ~primitive:Parraysetu ~args loc - | Parrayrefs -> prim ~primitive:Parrayrefs ~args loc - | Parraysets -> prim ~primitive:Parraysets ~args loc - | Pmakelist -> prim ~primitive:Pmakelist ~args loc - | Pmakedict -> prim ~primitive:Pmakedict ~args loc - | Pdict_has -> prim ~primitive:Pdict_has ~args loc - | Pawait -> prim ~primitive:Pawait ~args loc - | Pimport src -> prim ~primitive:(Pimport src) ~args loc - | Pinit_mod -> ( - match args with - | [_loc; Lconst (Const_block (_, [Const_block (_, [])]))] -> Lam.unit - | _ -> prim ~primitive:Pinit_mod ~args loc) - | Pupdate_mod -> ( - match args with - | [Lconst (Const_block (_, [Const_block (_, [])])); _; _] -> Lam.unit - | _ -> prim ~primitive:Pupdate_mod ~args loc) - | Phash -> prim ~primitive:Phash ~args loc - | Phash_mixint -> prim ~primitive:Phash_mixint ~args loc - | Phash_mixstring -> prim ~primitive:Phash_mixstring ~args loc - | Phash_finalmix -> prim ~primitive:Phash_finalmix ~args loc - | Pcurry_apply _ -> prim ~primitive:Pjs_apply ~args loc - | Pis_poly_var_block -> prim ~primitive:Pis_poly_var_block ~args loc - | Pjs_call {prim_name; arg_types; ffi; transformed_jsx} -> - prim - ~primitive:(Pjs_call {prim_name; arg_types; ffi; transformed_jsx}) - ~args loc - | Pjs_object_create labels -> - prim ~primitive:(Pjs_object_create labels) ~args loc - | Pjs_object_get name -> prim ~primitive:(Pjs_object_get name) ~args loc - | Pjs_object_set name -> prim ~primitive:(Pjs_object_set name) ~args loc - | Praw_js_code info -> prim ~primitive:(Praw_js_code info) ~args loc - | Pjs_fn_method -> prim ~primitive:Pjs_fn_method ~args loc - -(* Does not exist since we compile array in js backend unlike native backend *) - -let may_depend = Lam_module_ident.Hash_set.add - -let convert (lam : Lambda.lambda) : Lam.t * Lam_module_ident.Hash_set.t = - let may_depends = Lam_module_ident.Hash_set.create 0 in - - let rec convert_aux (lam : Lambda.lambda) : Lam.t = - match lam with - | Lvar x -> Lam.var x - | Lconst x -> Lam.const (Lam_constant_convert.convert_constant x) - | Lapply - { - ap_func = fn; - ap_args = args; - ap_loc = loc; - ap_inlined; - ap_transformed_jsx; - } -> - (* we need do this eargly in case [aux fn] add some wrapper *) - Lam.apply (convert_aux fn) - (Ext_list.map args convert_aux) - {ap_loc = loc; ap_inlined; ap_status = App_uncurry} - ~ap_transformed_jsx - | Lfunction {params; body; attr; loc} -> - Lam.function_ ~loc ~attr ~arity:(List.length params) ~params - ~body:(convert_aux body) - | Llet (kind, Pgenval, id, e, body) -> - Lam.let_ kind id (convert_aux e) (convert_aux body) - | Lletrec (bindings, body) -> - Lam.letrec (Ext_list.map_snd bindings convert_aux) (convert_aux body) - | Lprim (Pgetglobal id, args, _) -> - let args = Ext_list.map args convert_aux in - if Ident.is_predef_exn id then - Lam.const (Const_string {s = id.name; delim = None}) - else ( - may_depend may_depends (Lam_module_ident.of_ml id); - assert (args = []); - Lam.global_module id) - | Lprim (primitive, args, loc) -> - let args = Ext_list.map args convert_aux in - lam_prim ~primitive ~args loc - | Lswitch (e, s, _loc) -> convert_switch e s - | Lstringswitch (e, cases, default, _) -> - Lam.stringswitch (convert_aux e) - (Ext_list.map_snd cases convert_aux) - (Ext_option.map default convert_aux) - | Lstaticraise (id, args) -> - Lam.staticraise id (Ext_list.map args convert_aux) - | Lstaticcatch (b, (i, ids), handler) -> - Lam.staticcatch (convert_aux b) (i, ids) (convert_aux handler) - | Ltrywith (b, id, handler) -> - Lam.try_ (convert_aux b) id (convert_aux handler) - | Lifthenelse (b, then_, else_) -> - Lam.if_ (convert_aux b) (convert_aux then_) (convert_aux else_) - | Lsequence (a, b) -> Lam.seq (convert_aux a) (convert_aux b) - | Lbreak -> Lam.break - | Lcontinue -> Lam.continue - | Lwhile (b, body) -> Lam.while_ (convert_aux b) (convert_aux body) - | Lfor (id, from_, to_, dir, loop) -> - Lam.for_ id (convert_aux from_) (convert_aux to_) dir (convert_aux loop) - | Lfor_of (id, iterable, body) -> - Lam.for_of id (convert_aux iterable) (convert_aux body) - | Lfor_await_of (id, iterable, body) -> - Lam.for_await_of id (convert_aux iterable) (convert_aux body) - | Lassign (id, body) -> Lam.assign id (convert_aux body) - and convert_switch (e : Lambda.lambda) (s : Lambda.lambda_switch) = - Lam.switch (convert_aux e) - { - sw_consts_full = s.sw_consts_full; - sw_consts = Ext_list.map_snd s.sw_consts convert_aux; - sw_blocks_full = s.sw_blocks_full; - sw_blocks = Ext_list.map_snd s.sw_blocks convert_aux; - sw_failaction = Ext_option.map s.sw_failaction convert_aux; - sw_dispatch = s.sw_dispatch; - } - in - (convert_aux lam, may_depends) diff --git a/compiler/core/lam_convert.mli b/compiler/core/lam_convert.mli deleted file mode 100644 index dd3a3c74e6b..00000000000 --- a/compiler/core/lam_convert.mli +++ /dev/null @@ -1,29 +0,0 @@ -(* Copyright (C) 2018 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val convert : Lambda.lambda -> Lam.t * Lam_module_ident.Hash_set.t -(** [convert lam] translates Lambda to Lam and collects potential - depended modules. [let x = y] aliases are left for - {!Lam_pass_collapse_var_aliases}; unused lets are left for - {!Lam_pass_lets_dce}. *) diff --git a/compiler/core/lam_dce.ml b/compiler/core/lam_dce.ml index ee476b3da81..7b7a012da75 100644 --- a/compiler/core/lam_dce.ml +++ b/compiler/core/lam_dce.ml @@ -46,15 +46,13 @@ let remove export_idents (rest : Lam_group.t list) : Lam_group.t list = Ext_list.fold_left rest export_idents (fun acc x -> match x with | Single (kind, id, lam) -> ( - Hash_ident.add ident_free_vars id - (Lam_free_variables.pass_free_variables lam); + Hash_ident.add ident_free_vars id (Lambda.free_variables lam); match kind with | Alias | StrictOpt -> acc | Strict | Variable -> id :: acc) | Recursive bindings -> Ext_list.fold_left bindings acc (fun acc (id, lam) -> - Hash_ident.add ident_free_vars id - (Lam_free_variables.pass_free_variables lam); + Hash_ident.add ident_free_vars id (Lambda.free_variables lam); match lam with | Lfunction _ -> acc | _ -> id :: acc) @@ -62,8 +60,8 @@ let remove export_idents (rest : Lam_group.t list) : Lam_group.t list = if Lam_analysis.no_side_effects lam then acc else (* its free varaibles here will be defined above *) - Set_ident.fold (Lam_free_variables.pass_free_variables lam) acc - (fun x acc -> x :: acc)) + Set_ident.fold (Lambda.free_variables lam) acc (fun x acc -> + x :: acc)) in let visited = transitive_closure initial_idents ident_free_vars in Ext_list.fold_left rest [] (fun acc x -> diff --git a/compiler/core/lam_eta_conversion.ml b/compiler/core/lam_eta_conversion.ml deleted file mode 100644 index bd0f7decd14..00000000000 --- a/compiler/core/lam_eta_conversion.ml +++ /dev/null @@ -1,76 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* - let f x y = x + y - Invariant: there is no currying - here since f's arity is 2, no side effect - f 3 --> function(y) -> f 3 y -*) - -(** - [transform n loc status fn args] - n is the number of missing arguments required for [fn]. - Return a function of airty [n] -*) -let transform_under_supply n ap_info fn args = - let extra_args = Ext_list.init n (fun _ -> Ident.create Literals.param) in - let extra_lambdas = Ext_list.map extra_args Lam.var in - match - Ext_list.fold_right (fn :: args) ([], []) (fun (lam : Lam.t) (acc, bind) -> - match lam with - | Lvar _ - | Lconst - ( Const_int _ | Const_assertfalse | Const_constructor _ - | Const_char _ | Const_string _ | Const_float _ | Const_bigint _ - | Const_pointer _ | Const_js_true | Const_js_false - | Const_js_undefined _ ) - | Lprim {primitive = Pfield (_, Fld_module _); _} - | Lfunction _ -> - (lam :: acc, bind) - | _ -> - let v = Ident.create Literals.partial_arg in - (Lam.var v :: acc, (v, lam) :: bind)) - with - | fn :: args, [] -> - (* More than no side effect in the [args], - we try to avoid computation, so even if - [x + y] is side effect free, we need eval it only once - *) - (* TODO: Note we could adjust [fn] if [fn] is already a function - But it is dangerous to change the arity - of an existing function which may cause inconsistency - *) - Lam.function_ ~loc:Location.none ~arity:n ~params:extra_args - ~attr:Lambda.default_function_attribute - ~body:(Lam.apply fn (Ext_list.append args extra_lambdas) ap_info) - | fn :: args, bindings -> - let rest : Lam.t = - Lam.function_ ~loc:Location.none ~arity:n ~params:extra_args - ~attr:Lambda.default_function_attribute - ~body:(Lam.apply fn (Ext_list.append args extra_lambdas) ap_info) - in - Ext_list.fold_left bindings rest (fun lam (id, x) -> - Lam.let_ Strict id x lam) - | _, _ -> assert false diff --git a/compiler/core/lam_eta_conversion.mli b/compiler/core/lam_eta_conversion.mli deleted file mode 100644 index 9696587e2c6..00000000000 --- a/compiler/core/lam_eta_conversion.mli +++ /dev/null @@ -1,31 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** - [transform n loc status fn args] - n is the number of missing arguments required for [fn]. - Return a function of airty [n] -*) - -val transform_under_supply : int -> Lam.ap_info -> Lam.t -> Lam.t list -> Lam.t diff --git a/compiler/core/lam_exit_code.ml b/compiler/core/lam_exit_code.ml index 3f42e347427..79c1770b8e3 100644 --- a/compiler/core/lam_exit_code.ml +++ b/compiler/core/lam_exit_code.ml @@ -23,17 +23,17 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) let has_exit_code lam exits = - let rec aux (lam : Lam.t) = + let rec aux (lam : Lambda.t) = match lam with | Lfunction _ -> false (* static exit can not cross function boundary *) | Lstaticraise (p, _) when exits p -> true - | _ -> Lam_iter.inner_exists lam aux + | _ -> Lambda.shallow_exists aux lam in aux lam -let rec has_exit (lam : Lam.t) = +let rec has_exit (lam : Lambda.t) = match lam with | Lfunction _ -> false | Lstaticraise (_, _) -> true - | _ -> Lam_iter.inner_exists lam has_exit + | _ -> Lambda.shallow_exists has_exit lam diff --git a/compiler/core/lam_exit_code.mli b/compiler/core/lam_exit_code.mli index bd89d416545..105590425cb 100644 --- a/compiler/core/lam_exit_code.mli +++ b/compiler/core/lam_exit_code.mli @@ -22,6 +22,6 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val has_exit_code : Lam.t -> (int -> bool) -> bool +val has_exit_code : Lambda.t -> (int -> bool) -> bool -val has_exit : Lam.t -> bool +val has_exit : Lambda.t -> bool diff --git a/compiler/core/lam_exit_count.ml b/compiler/core/lam_exit_count.ml index 045435a44e8..17d07b8d901 100644 --- a/compiler/core/lam_exit_count.ml +++ b/compiler/core/lam_exit_count.ml @@ -48,9 +48,9 @@ let incr_exit (exits : collection) i = For Lswitch, if it is not exhuastive pattern match, default will be counted twice. Since for pattern match, we will test whether it is an integer or block, both have default cases predicate: [sw_consts_full] vs nconsts *) -let count_helper (lam : Lam.t) : collection = +let count_helper (lam : Lambda.t) : collection = let exits : collection = Hash_int.create 17 in - let rec count (lam : Lam.t) = + let rec count (lam : Lambda.t) = match lam with | Lstaticraise (i, ls) -> incr_exit exits i; diff --git a/compiler/core/lam_exit_count.mli b/compiler/core/lam_exit_count.mli index 9a621cf5ea1..71f632ca1cd 100644 --- a/compiler/core/lam_exit_count.mli +++ b/compiler/core/lam_exit_count.mli @@ -24,6 +24,6 @@ type collection -val count_helper : Lam.t -> collection +val count_helper : Lambda.t -> collection val count_exit : collection -> int -> int diff --git a/compiler/core/lam_free_variables.ml b/compiler/core/lam_free_variables.ml deleted file mode 100644 index d269c78c7cb..00000000000 --- a/compiler/core/lam_free_variables.ml +++ /dev/null @@ -1,111 +0,0 @@ -(* Copyright (C) 2018 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let pass_free_variables (l : Lam.t) : Set_ident.t = - let fv = ref Set_ident.empty in - let rec free_list xs = List.iter free xs - and free_list_snd : 'a. ('a * Lam.t) list -> unit = - fun xs -> Ext_list.iter_snd xs free - and free (l : Lam.t) = - match l with - | Lvar id -> fv := Set_ident.add !fv id - | Lassign (id, e) -> - free e; - fv := Set_ident.add !fv id - | Lstaticcatch (e1, (_, vars), e2) -> - free e1; - free e2; - Ext_list.iter vars (fun id -> fv := Set_ident.remove !fv id) - | Ltrywith (e1, exn, e2) -> - free e1; - free e2; - fv := Set_ident.remove !fv exn - | Lfunction {body; params} -> - free body; - Ext_list.iter params (fun param -> fv := Set_ident.remove !fv param) - | Llet (_str, id, arg, body) -> - free arg; - free body; - fv := Set_ident.remove !fv id - | Lletrec (decl, body) -> - free body; - free_list_snd decl; - Ext_list.iter decl (fun (id, _exp) -> fv := Set_ident.remove !fv id) - | Lfor (v, e1, e2, _dir, e3) -> - free e1; - free e2; - free e3; - fv := Set_ident.remove !fv v - | Lfor_of (v, e1, e2) -> - free e1; - free e2; - fv := Set_ident.remove !fv v - | Lfor_await_of (v, e1, e2) -> - free e1; - free e2; - fv := Set_ident.remove !fv v - | Lconst _ -> () - | Lapply {ap_func; ap_args; _} -> - free ap_func; - free_list ap_args - | Lglobal_module _ -> () - (* according to the existing semantics: - [primitive] is not counted - *) - | Lprim {args; _} -> free_list args - | Lswitch (arg, sw) -> - free arg; - free_list_snd sw.sw_consts; - free_list_snd sw.sw_blocks; - Ext_option.iter sw.sw_failaction free - | Lstringswitch (arg, cases, default) -> - free arg; - free_list_snd cases; - Ext_option.iter default free - | Lstaticraise (_, args) -> free_list args - | Lifthenelse (e1, e2, e3) -> - free e1; - free e2; - free e3 - | Lsequence (e1, e2) -> - free e1; - free e2 - | Lbreak | Lcontinue -> () - | Lwhile (e1, e2) -> - free e1; - free e2 - in - free l; - !fv - -(** - [hit_any_variables fv l] - check the lambda expression [l] if has some free - variables captured by [fv]. - Note it does not do any checking like below - [Llet(str,id,arg,body)] - it only check [arg] or [body] is hit or not, there - is a case that [id] is hit in [arg] but also exists - in [fv], this is ignored. -*) diff --git a/compiler/core/lam_free_variables.mli b/compiler/core/lam_free_variables.mli deleted file mode 100644 index 4126b4b857a..00000000000 --- a/compiler/core/lam_free_variables.mli +++ /dev/null @@ -1,25 +0,0 @@ -(* Copyright (C) 2018 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val pass_free_variables : Lam.t -> Set_ident.t diff --git a/compiler/core/lam_group.ml b/compiler/core/lam_group.ml index 357222cd641..216bec89551 100644 --- a/compiler/core/lam_group.ml +++ b/compiler/core/lam_group.ml @@ -24,23 +24,23 @@ (** This is not a recursive type definition *) type t = - | Single of Lam_compat.let_kind * Ident.t * Lam.t - | Recursive of (Ident.t * Lam.t) list - | Nop of Lam.t + | Single of Lambda.let_kind * Ident.t * Lambda.t + | Recursive of (Ident.t * Lambda.t) list + | Nop of Lambda.t -let single (kind : Lam_compat.let_kind) id (body : Lam.t) = +let single (kind : Lambda.let_kind) id (body : Lambda.t) = match (kind, body) with | (Strict | StrictOpt), (Lvar _ | Lconst _) -> Single (Alias, id, body) | _ -> Single (kind, id, body) -let nop_cons (x : Lam.t) acc = +let nop_cons (x : Lambda.t) acc = match x with | Lvar _ | Lconst _ | Lfunction _ -> acc | _ -> Nop x :: acc (* let pp = Format.fprintf *) -let str_of_kind (kind : Lam_compat.let_kind) = +let str_of_kind (kind : Lambda.let_kind) = match kind with | Alias -> "a" | Strict -> "" @@ -51,11 +51,11 @@ let pp_group fmt (x : t) = match x with | Single (kind, id, lam) -> Format.fprintf fmt "@[let@ %a@ =%s@ @[%a@]@ @]" Ident.print id - (str_of_kind kind) Lam_print.lambda lam + (str_of_kind kind) Printlambda.lambda lam | Recursive lst -> List.iter (fun (id, lam) -> Format.fprintf fmt "@[let %a@ =r@ %a@ @]" Ident.print id - Lam_print.lambda lam) + Printlambda.lambda lam) lst - | Nop lam -> Lam_print.lambda fmt lam + | Nop lam -> Printlambda.lambda fmt lam diff --git a/compiler/core/lam_group.mli b/compiler/core/lam_group.mli index c6325acc923..ba40b1b6a18 100644 --- a/compiler/core/lam_group.mli +++ b/compiler/core/lam_group.mli @@ -23,14 +23,14 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) type t = - | Single of Lam_compat.let_kind * Ident.t * Lam.t - | Recursive of (Ident.t * Lam.t) list - | Nop of Lam.t + | Single of Lambda.let_kind * Ident.t * Lambda.t + | Recursive of (Ident.t * Lambda.t) list + | Nop of Lambda.t (** Tricky to be complete *) val pp_group : Format.formatter -> t -> unit -val single : Lam_compat.let_kind -> Ident.t -> Lam.t -> t +val single : Lambda.let_kind -> Ident.t -> Lambda.t -> t -val nop_cons : Lam.t -> t list -> t list +val nop_cons : Lambda.t -> t list -> t list diff --git a/compiler/core/lam_hit.ml b/compiler/core/lam_hit.ml index fba5f7bdf74..dcd0dc97007 100644 --- a/compiler/core/lam_hit.ml +++ b/compiler/core/lam_hit.ml @@ -22,7 +22,7 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type t = Lam.t +type t = Lambda.t let hit_variables (fv : Set_ident.t) (l : t) : bool = let rec hit_opt (x : t option) = diff --git a/compiler/core/lam_hit.mli b/compiler/core/lam_hit.mli index be3199ea189..673ca072ff3 100644 --- a/compiler/core/lam_hit.mli +++ b/compiler/core/lam_hit.mli @@ -22,6 +22,6 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val hit_variables : Set_ident.t -> Lam.t -> bool +val hit_variables : Set_ident.t -> Lambda.t -> bool -val hit_variable : Ident.t -> Lam.t -> bool +val hit_variable : Ident.t -> Lambda.t -> bool diff --git a/compiler/core/lam_id_kind.ml b/compiler/core/lam_id_kind.ml index b7967fb15ff..667e3add6c4 100644 --- a/compiler/core/lam_id_kind.ml +++ b/compiler/core/lam_id_kind.ml @@ -31,23 +31,23 @@ type rec_flag = Lam_rec | Lam_non_rec | Lam_self_rec recursive function *) -type element = NA | SimpleForm of Lam.t +type element = NA | SimpleForm of Lambda.t type boxed_nullable = Undefined | Null | Null_undefined type t = - | Normal_optional of Lam.t (* Some [x] *) - | OptionalBlock of Lam.t * boxed_nullable + | Normal_optional of Lambda.t (* Some [x] *) + | OptionalBlock of Lambda.t * boxed_nullable | ImmutableBlock of element array | MutableBlock of element array - | Constant of Lam_constant.t + | Constant of Lambda.structured_constant | Module of Ident.t (** TODO: static module vs first class module *) | FunctionId of { mutable arity: Lam_arity.t; (* TODO: This may contain some closure environment, check how it will interact with dead code elimination *) - lambda: (Lam.t * rec_flag) option; + lambda: (Lambda.t * rec_flag) option; } | Exception | Parameter diff --git a/compiler/core/lam_id_kind.mli b/compiler/core/lam_id_kind.mli index 040a63a417e..707bde7e842 100644 --- a/compiler/core/lam_id_kind.mli +++ b/compiler/core/lam_id_kind.mli @@ -31,7 +31,7 @@ type rec_flag = | Lam_self_rec (* not inlining in this case *) -type element = NA | SimpleForm of Lam.t +type element = NA | SimpleForm of Lambda.t type boxed_nullable = Undefined | Null | Null_undefined @@ -48,15 +48,15 @@ type boxed_nullable = Undefined | Null | Null_undefined [Lif(v/1)] will be translated into [Lif (v/2 === undefined )] *) type t = - | Normal_optional of Lam.t - | OptionalBlock of Lam.t * boxed_nullable + | Normal_optional of Lambda.t + | OptionalBlock of Lambda.t * boxed_nullable | ImmutableBlock of element array | MutableBlock of element array - | Constant of Lam_constant.t + | Constant of Lambda.structured_constant | Module of Ident.t (** TODO: static module vs first class module *) | FunctionId of { mutable arity: Lam_arity.t; - lambda: (Lam.t * rec_flag) option; + lambda: (Lambda.t * rec_flag) option; } | Exception | Parameter diff --git a/compiler/core/lam_iter.ml b/compiler/core/lam_iter.ml deleted file mode 100644 index f5902d82faa..00000000000 --- a/compiler/core/lam_iter.ml +++ /dev/null @@ -1,62 +0,0 @@ -(* Copyright (C) 2018 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type t = Lam.t - -type ident = Ident.t - -let inner_exists (l : t) (f : t -> bool) : bool = - match l with - | Lvar (_ : ident) | Lglobal_module _ | Lconst (_ : Lam_constant.t) -> false - | Lapply {ap_func; ap_args; ap_info = _} -> - f ap_func || Ext_list.exists ap_args f - | Lfunction {body; arity = _; params = _} -> f body - | Llet (_str, _id, arg, body) -> f arg || f body - | Lletrec (decl, body) -> f body || Ext_list.exists_snd decl f - | Lswitch - ( arg, - { - sw_consts; - sw_consts_full = _; - sw_blocks; - sw_blocks_full = _; - sw_failaction; - } ) -> - f arg - || Ext_list.exists_snd sw_consts f - || Ext_list.exists_snd sw_blocks f - || Ext_option.exists sw_failaction f - | Lstringswitch (arg, cases, default) -> - f arg || Ext_list.exists_snd cases f || Ext_option.exists default f - | Lprim {args; primitive = _; loc = _} -> Ext_list.exists args f - | Lstaticraise (_id, args) -> Ext_list.exists args f - | Lstaticcatch (e1, _vars, e2) -> f e1 || f e2 - | Ltrywith (e1, _exn, e2) -> f e1 || f e2 - | Lifthenelse (e1, e2, e3) -> f e1 || f e2 || f e3 - | Lsequence (e1, e2) -> f e1 || f e2 - | Lbreak | Lcontinue -> false - | Lwhile (e1, e2) -> f e1 || f e2 - | Lfor (_v, e1, e2, _dir, e3) -> f e1 || f e2 || f e3 - | Lfor_of (_v, e1, e2) | Lfor_await_of (_v, e1, e2) -> f e1 || f e2 - | Lassign (_id, e) -> f e diff --git a/compiler/core/lam_iter.mli b/compiler/core/lam_iter.mli deleted file mode 100644 index 0077b5a860d..00000000000 --- a/compiler/core/lam_iter.mli +++ /dev/null @@ -1,25 +0,0 @@ -(* Copyright (C) 2018 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val inner_exists : Lam.t -> (Lam.t -> bool) -> bool diff --git a/compiler/core/lam_pass_alpha_conversion.ml b/compiler/core/lam_pass_alpha_conversion.ml deleted file mode 100644 index b83e930bb33..00000000000 --- a/compiler/core/lam_pass_alpha_conversion.ml +++ /dev/null @@ -1,114 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let alpha_conversion (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = - let rec populate_apply_info ?(ap_transformed_jsx = false) - (args_arity : int list) (len : int) (fn : Lam.t) (args : Lam.t list) - ap_info : Lam.t = - match args_arity with - | 0 :: _ | [] -> - Lam.apply (simpl fn) (Ext_list.map args simpl) ap_info ~ap_transformed_jsx - | x :: _ -> - if x = len then - Lam.apply (simpl fn) (Ext_list.map args simpl) - {ap_info with ap_status = App_infer_full} - ~ap_transformed_jsx - else if x > len then - let fn = simpl fn in - let args = Ext_list.map args simpl in - Lam_eta_conversion.transform_under_supply (x - len) - {ap_info with ap_status = App_infer_full} - fn args - else - let first, rest = Ext_list.split_at args x in - Lam.apply ~ap_transformed_jsx - (Lam.apply (simpl fn) (Ext_list.map first simpl) - {ap_info with ap_status = App_infer_full}) - (Ext_list.map rest simpl) ap_info - (* TODO refien *) - and simpl (lam : Lam.t) = - match lam with - | Lconst _ -> lam - | Lvar _ -> lam - | Lapply {ap_func; ap_args; ap_info; ap_transformed_jsx} -> - (* detect functor application *) - let args_arity = - Lam_arity.extract_arity (Lam_arity_analysis.get_arity meta ap_func) - in - let len = List.length ap_args in - populate_apply_info ~ap_transformed_jsx args_arity len ap_func ap_args - ap_info - | Llet (str, v, l1, l2) -> Lam.let_ str v (simpl l1) (simpl l2) - | Lletrec (bindings, body) -> - let bindings = Ext_list.map_snd bindings simpl in - Lam.letrec bindings (simpl body) - | Lglobal_module _ -> lam - | Lprim {primitive; args; loc} -> - Lam.prim ~primitive ~args:(Ext_list.map args simpl) loc - | Lfunction {arity; params; body; attr; loc} -> - (* Lam_mk.lfunction kind params (simpl l) *) - Lam.function_ ~loc ~arity ~params ~body:(simpl body) ~attr - | Lswitch - ( l, - { - sw_failaction; - sw_consts; - sw_blocks; - sw_blocks_full; - sw_consts_full; - sw_dispatch; - } ) -> - Lam.switch (simpl l) - { - sw_consts = Ext_list.map_snd sw_consts simpl; - sw_blocks = Ext_list.map_snd sw_blocks simpl; - sw_consts_full; - sw_blocks_full; - sw_failaction = Ext_option.map sw_failaction simpl; - sw_dispatch; - } - | Lstringswitch (l, sw, d) -> - Lam.stringswitch (simpl l) - (Ext_list.map_snd sw simpl) - (Ext_option.map d simpl) - | Lstaticraise (i, ls) -> Lam.staticraise i (Ext_list.map ls simpl) - | Lstaticcatch (l1, ids, l2) -> Lam.staticcatch (simpl l1) ids (simpl l2) - | Ltrywith (l1, v, l2) -> Lam.try_ (simpl l1) v (simpl l2) - | Lifthenelse (l1, l2, l3) -> Lam.if_ (simpl l1) (simpl l2) (simpl l3) - | Lsequence (l1, l2) -> Lam.seq (simpl l1) (simpl l2) - | Lbreak -> Lam.break - | Lcontinue -> Lam.continue - | Lwhile (l1, l2) -> Lam.while_ (simpl l1) (simpl l2) - | Lfor (flag, l1, l2, dir, l3) -> - Lam.for_ flag (simpl l1) (simpl l2) dir (simpl l3) - | Lfor_of (flag, l1, l2) -> Lam.for_of flag (simpl l1) (simpl l2) - | Lfor_await_of (flag, l1, l2) -> - Lam.for_await_of flag (simpl l1) (simpl l2) - | Lassign (v, l) -> - (* Lalias-bound variables are never assigned, so don't increase - v's refsimpl *) - Lam.assign v (simpl l) - in - - simpl lam diff --git a/compiler/core/lam_pass_alpha_conversion.mli b/compiler/core/lam_pass_alpha_conversion.mli deleted file mode 100644 index d32e3438ef6..00000000000 --- a/compiler/core/lam_pass_alpha_conversion.mli +++ /dev/null @@ -1,27 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** alpha conversion based on arity *) - -val alpha_conversion : Lam_stats.t -> Lam.t -> Lam.t diff --git a/compiler/core/lam_pass_collapse_var_aliases.ml b/compiler/core/lam_pass_collapse_var_aliases.ml index fe76ff17ac5..279a1d28424 100644 --- a/compiler/core/lam_pass_collapse_var_aliases.ml +++ b/compiler/core/lam_pass_collapse_var_aliases.ml @@ -10,29 +10,30 @@ let rec resolve tbl id = | None -> id | Some id' -> resolve tbl id' -let collapse ~exports (lam : Lam.t) : Lam.t = +let collapse ~exports (lam : Lambda.t) : Lambda.t = let tbl = Hash_ident.create 64 in - let rec go (lam : Lam.t) : Lam.t = + let rec go (lam : Lambda.t) : Lambda.t = match lam with - | Lvar x -> Lam.var (resolve tbl x) + | Lvar x -> Lambda.var (resolve tbl x) | Lglobal_module _ | Lconst _ | Lbreak | Lcontinue -> lam | Lapply {ap_func; ap_args; ap_info; ap_transformed_jsx} -> - Lam.apply (go ap_func) (Ext_list.map ap_args go) ap_info + Lambda.apply (go ap_func) (Ext_list.map ap_args go) ap_info ~ap_transformed_jsx - | Lfunction {arity; params; body; attr; loc} -> - Lam.function_ ~loc ~attr ~arity ~params ~body:(go body) + | Lfunction {params; body; attr; loc} -> + Lambda.function_ ~loc ~attr ~params ~body:(go body) | Llet (Alias, id, Lvar u, body) -> let u = resolve tbl u in Hash_ident.add tbl id u; - if Set_ident.mem exports id then Lam.let_ Alias id (Lam.var u) (go body) + if Set_ident.mem exports id then + Lambda.let_ Alias id (Lambda.var u) (go body) else go body - | Llet (kind, id, arg, body) -> Lam.let_ kind id (go arg) (go body) + | Llet (kind, id, arg, body) -> Lambda.let_ kind id (go arg) (go body) | Lletrec (bindings, body) -> - Lam.letrec (Ext_list.map_snd bindings go) (go body) + Lambda.letrec (Ext_list.map_snd bindings go) (go body) | Lprim {primitive; args; loc} -> - Lam.prim ~primitive ~args:(Ext_list.map args go) loc + Lambda.prim ~primitive ~args:(Ext_list.map args go) loc | Lswitch (arg, sw) -> - Lam.switch (go arg) + Lambda.switch (go arg) { sw with sw_consts = Ext_list.map_snd sw.sw_consts go; @@ -40,20 +41,21 @@ let collapse ~exports (lam : Lam.t) : Lam.t = sw_failaction = Ext_option.map sw.sw_failaction go; } | Lstringswitch (arg, cases, default) -> - Lam.stringswitch (go arg) + Lambda.stringswitch (go arg) (Ext_list.map_snd cases go) (Ext_option.map default go) - | Lstaticraise (i, args) -> Lam.staticraise i (Ext_list.map args go) + | Lstaticraise (i, args) -> Lambda.staticraise i (Ext_list.map args go) | Lstaticcatch (body, ids, handler) -> - Lam.staticcatch (go body) ids (go handler) - | Ltrywith (body, id, handler) -> Lam.try_ (go body) id (go handler) - | Lifthenelse (b, t, e) -> Lam.if_ (go b) (go t) (go e) - | Lsequence (a, b) -> Lam.seq (go a) (go b) - | Lwhile (b, body) -> Lam.while_ (go b) (go body) - | Lfor (id, lo, hi, dir, body) -> Lam.for_ id (go lo) (go hi) dir (go body) - | Lfor_of (id, iterable, body) -> Lam.for_of id (go iterable) (go body) + Lambda.staticcatch (go body) ids (go handler) + | Ltrywith (body, id, handler) -> Lambda.try_ (go body) id (go handler) + | Lifthenelse (b, t, e) -> Lambda.if_ (go b) (go t) (go e) + | Lsequence (a, b) -> Lambda.seq (go a) (go b) + | Lwhile (b, body) -> Lambda.while_ (go b) (go body) + | Lfor (id, lo, hi, dir, body) -> + Lambda.for_ id (go lo) (go hi) dir (go body) + | Lfor_of (id, iterable, body) -> Lambda.for_of id (go iterable) (go body) | Lfor_await_of (id, iterable, body) -> - Lam.for_await_of id (go iterable) (go body) - | Lassign (id, e) -> Lam.assign id (go e) + Lambda.for_await_of id (go iterable) (go body) + | Lassign (id, e) -> Lambda.assign id (go e) in go lam diff --git a/compiler/core/lam_pass_collapse_var_aliases.mli b/compiler/core/lam_pass_collapse_var_aliases.mli index 912515d2ff6..63263a80d69 100644 --- a/compiler/core/lam_pass_collapse_var_aliases.mli +++ b/compiler/core/lam_pass_collapse_var_aliases.mli @@ -10,4 +10,4 @@ before collect keeps [ident_tbl] from re-recording the same alias. Exported names are kept so coercion can still see them. *) -val collapse : exports:Set_ident.t -> Lam.t -> Lam.t +val collapse : exports:Set_ident.t -> Lambda.t -> Lambda.t diff --git a/compiler/core/lam_pass_collect.ml b/compiler/core/lam_pass_collect.ml index df60477a455..383a53f3055 100644 --- a/compiler/core/lam_pass_collect.ml +++ b/compiler/core/lam_pass_collect.ml @@ -27,38 +27,27 @@ how about guarantee that [Lassign] only check the local ref and we track which ids are [Lassign]ed *) -(** - might not be the same due to refinement - assert (old.arity = v) -*) +(* An update, not a new binding: the arity is refined on each collect round, + and the recorded lambda has to be replaced because an older one may mention + identifiers that later passes removed (see #3609). [add] would leave the + stale row underneath - invisible to [find_opt], which reads the newest, but + never reclaimed, since nothing removes from this table. *) let annotate (meta : Lam_stats.t) rec_flag (k : Ident.t) (arity : Lam_arity.t) lambda = - Hash_ident.add meta.ident_tbl k + Hash_ident.replace meta.ident_tbl k (FunctionId {arity; lambda = Some (lambda, rec_flag)}) -(* see #3609 - we have to update since bounded function lambda - may contain stale unbounded varaibles -*) -(* match Hash_ident.find_opt meta.ident_tbl k with - | None -> (** FIXME: need do a sanity check of arity is NA or Determin(_,[],_) *) - - | Some (FunctionId old) -> - Hash_ident.add meta.ident_tbl k - (FunctionId {arity; lambda = Some (lambda, rec_flag) }) - (* old.arity <- arity *) - (* due to we keep refining arity analysis after each round*) - | _ -> assert false *) (* TODO -- avoid exception *) (** it only make senses recording arities for function definition, alias propgation - and toplevel identifiers, this needs to be exported *) -let collect_info (meta : Lam_stats.t) (lam : Lam.t) = - let rec collect_bind rec_flag (ident : Ident.t) (lam : Lam.t) = +let collect_info (meta : Lam_stats.t) (lam : Lambda.t) = + let rec collect_bind rec_flag (ident : Ident.t) (lam : Lambda.t) = match lam with | Lconst v -> Hash_ident.replace meta.ident_tbl ident (Constant v) - | Lprim {primitive = Pmakeblock (_, Immutable); args = ls} -> + | Lprim {primitive = Pmakeblock info; args = ls} + when Lambda.is_immutable_block info -> Hash_ident.replace meta.ident_tbl ident (Lam_util.kind_of_lambda_block ls); List.iter collect ls | Lprim {primitive = Psome | Psome_not_nest; args = [v]} -> @@ -90,7 +79,7 @@ let collect_info (meta : Lam_stats.t) (lam : Lam.t) = collect x; if Set_ident.mem meta.export_idents ident then annotate meta rec_flag ident (Lam_arity_analysis.get_arity meta x) lam - and collect (lam : Lam.t) = + and collect (lam : Lambda.t) = match lam with | Lconst _ -> () | Lvar _ -> () diff --git a/compiler/core/lam_pass_collect.mli b/compiler/core/lam_pass_collect.mli index 4f7c45cd71b..23aa829f461 100644 --- a/compiler/core/lam_pass_collect.mli +++ b/compiler/core/lam_pass_collect.mli @@ -68,5 +68,5 @@ - *) -val collect_info : Lam_stats.t -> Lam.t -> unit +val collect_info : Lam_stats.t -> Lambda.t -> unit (** Modify existing [meta] *) diff --git a/compiler/core/lam_pass_count.ml b/compiler/core/lam_pass_count.ml index 5e3ee286f60..7f3ce84b1ec 100644 --- a/compiler/core/lam_pass_count.ml +++ b/compiler/core/lam_pass_count.ml @@ -92,7 +92,7 @@ let collect_occurs lam : occ_tbl = ()) in - let rec count (bv : local_tbl) (lam : Lam.t) = + let rec count (bv : local_tbl) (lam : Lambda.t) = match lam with | Lfunction {body = l} -> count Map_ident.empty l (* when entering a function local [bv] diff --git a/compiler/core/lam_pass_count.mli b/compiler/core/lam_pass_count.mli index 727aaa40cf5..9175e809e80 100644 --- a/compiler/core/lam_pass_count.mli +++ b/compiler/core/lam_pass_count.mli @@ -25,4 +25,4 @@ type occ_tbl = used_info Hash_ident.t val dummy_info : unit -> used_info -val collect_occurs : Lam.t -> occ_tbl +val collect_occurs : Lambda.t -> occ_tbl diff --git a/compiler/core/lam_pass_deep_flatten.ml b/compiler/core/lam_pass_deep_flatten.ml index bd630b7a956..d4bdab9e423 100644 --- a/compiler/core/lam_pass_deep_flatten.ml +++ b/compiler/core/lam_pass_deep_flatten.ml @@ -26,7 +26,7 @@ | Not_eliminatable | *) -let rec eliminate_tuple (id : Ident.t) (lam : Lam.t) acc = +let rec eliminate_tuple (id : Ident.t) (lam : Lambda.t) acc = match lam with | Llet (Alias, v, Lprim {primitive = Pfield (i, _); args = [Lvar tuple]}, e2) when Ident.same tuple id -> @@ -100,13 +100,13 @@ let rec eliminate_tuple (id : Ident.t) (lam : Lam.t) acc = - also for function compilation, flattening should be done first - [compile_group] and [compile] become mutually recursive function *) -let lambda_of_groups ~(rev_bindings : Lam_group.t list) (result : Lam.t) : Lam.t - = +let lambda_of_groups ~(rev_bindings : Lam_group.t list) (result : Lambda.t) : + Lambda.t = Ext_list.fold_left rev_bindings result (fun acc x -> match x with - | Nop l -> Lam.seq l acc + | Nop l -> Lambda.seq l acc | Single (kind, ident, lam) -> Lam_util.refine_let ~kind ident lam acc - | Recursive bindings -> Lam.letrec bindings acc) + | Recursive bindings -> Lambda.letrec bindings acc) (* TODO: refine effectful [ket_kind] to be pure or not @@ -114,20 +114,23 @@ let lambda_of_groups ~(rev_bindings : Lam_group.t list) (result : Lam.t) : Lam.t *) (* The shape [let x = in ... in apply f args]: the residue left by beta reduction of an immediately applied function. *) -let rec rhs_is_beta_residue (lam : Lam.t) = +let rec rhs_is_beta_residue (lam : Lambda.t) = match lam with | Llet ( (Alias | Strict | StrictOpt), _, - (Lprim {primitive = Pmakeblock (_, Immutable)} | Lvar _), - rest ) -> + Lprim {primitive = Pmakeblock info}, + rest ) + when Lambda.is_immutable_block info -> + rhs_is_beta_residue rest + | Llet ((Alias | Strict | StrictOpt), _, Lvar _, rest) -> rhs_is_beta_residue rest | Lapply _ -> true | _ -> false -let deep_flatten (lam : Lam.t) : Lam.t = - let rec flatten (acc : Lam_group.t list) (lam : Lam.t) : - Lam.t * Lam_group.t list = +let deep_flatten (lam : Lambda.t) : Lambda.t = + let rec flatten (acc : Lam_group.t list) (lam : Lambda.t) : + Lambda.t * Lam_group.t list = match lam with | Llet ( str, @@ -150,10 +153,10 @@ let deep_flatten (lam : Lam.t) : Lam.t = body ) -> let new_id = Ident.rename id in flatten acc - (Lam.let_ str new_id arg - (Lam.let_ Alias id - (Lam.prim ~primitive - ~args:[Lam.var new_id] + (Lambda.let_ str new_id arg + (Lambda.let_ Alias id + (Lambda.prim ~primitive + ~args:[Lambda.var new_id] Location.none (* FIXME*)) body)) | Llet (str, id, arg, body) when rhs_is_beta_residue arg -> @@ -175,7 +178,8 @@ let deep_flatten (lam : Lam.t) : Lam.t = match (id.name, str, res) with | ( ("match" | "include" | "param"), (Alias | Strict | StrictOpt), - Lprim {primitive = Pmakeblock (_, Immutable); args} ) -> ( + Lprim {primitive = Pmakeblock info; args} ) + when Lambda.is_immutable_block info -> ( match eliminate_tuple id body Map_int.empty with | Some (tuple_mapping, body) -> flatten @@ -192,7 +196,7 @@ let deep_flatten (lam : Lam.t) : Lam.t = let res, l = flatten acc l in flatten (Lam_group.nop_cons res l) r | x -> (aux x, acc) - and aux (lam : Lam.t) : Lam.t = + and aux (lam : Lambda.t) : Lambda.t = match lam with | Llet _ -> let res, groups = flatten [] lam in @@ -227,8 +231,8 @@ let deep_flatten (lam : Lam.t) : Lam.t = in lambda_of_groups ~rev_bindings:rev_wrap (* These bindings are extracted from [letrec] *) - (Lam.letrec (List.rev rev_bindings) (aux body)) - | Lsequence (l, r) -> Lam.seq (aux l) (aux r) + (Lambda.letrec (List.rev rev_bindings) (aux body)) + | Lsequence (l, r) -> Lambda.seq (aux l) (aux r) | Lconst _ -> lam | Lvar _ -> lam (* | Lapply(Lfunction(Curried, params, body), args, _) *) @@ -240,15 +244,15 @@ let deep_flatten (lam : Lam.t) : Lam.t = (* when List.length params = List.length args -> *) (* aux (beta_reduce params body args) *) | Lapply {ap_func = l1; ap_args = ll; ap_info; ap_transformed_jsx} -> - Lam.apply (aux l1) (Ext_list.map ll aux) ap_info ~ap_transformed_jsx + Lambda.apply (aux l1) (Ext_list.map ll aux) ap_info ~ap_transformed_jsx (* This kind of simple optimizations should be done each time and as early as possible *) | Lglobal_module _ -> lam | Lprim {primitive; args; loc} -> let args = Ext_list.map args aux in - Lam.prim ~primitive ~args loc - | Lfunction {arity; params; body; attr; loc} -> - Lam.function_ ~loc ~arity ~params ~body:(aux body) ~attr + Lambda.prim ~primitive ~args loc + | Lfunction {params; body; attr; loc} -> + Lambda.function_ ~loc ~params ~body:(aux body) ~attr | Lswitch ( l, { @@ -259,7 +263,7 @@ let deep_flatten (lam : Lam.t) : Lam.t = sw_consts_full; sw_dispatch; } ) -> - Lam.switch (aux l) + Lambda.switch (aux l) { sw_consts = Ext_list.map_snd sw_consts aux; sw_blocks = Ext_list.map_snd sw_blocks aux; @@ -269,21 +273,22 @@ let deep_flatten (lam : Lam.t) : Lam.t = sw_dispatch; } | Lstringswitch (l, sw, d) -> - Lam.stringswitch (aux l) (Ext_list.map_snd sw aux) (Ext_option.map d aux) - | Lstaticraise (i, ls) -> Lam.staticraise i (Ext_list.map ls aux) - | Lstaticcatch (l1, ids, l2) -> Lam.staticcatch (aux l1) ids (aux l2) - | Ltrywith (l1, v, l2) -> Lam.try_ (aux l1) v (aux l2) - | Lifthenelse (l1, l2, l3) -> Lam.if_ (aux l1) (aux l2) (aux l3) - | Lbreak -> Lam.break - | Lcontinue -> Lam.continue - | Lwhile (l1, l2) -> Lam.while_ (aux l1) (aux l2) + Lambda.stringswitch (aux l) (Ext_list.map_snd sw aux) + (Ext_option.map d aux) + | Lstaticraise (i, ls) -> Lambda.staticraise i (Ext_list.map ls aux) + | Lstaticcatch (l1, ids, l2) -> Lambda.staticcatch (aux l1) ids (aux l2) + | Ltrywith (l1, v, l2) -> Lambda.try_ (aux l1) v (aux l2) + | Lifthenelse (l1, l2, l3) -> Lambda.if_ (aux l1) (aux l2) (aux l3) + | Lbreak -> Lambda.break + | Lcontinue -> Lambda.continue + | Lwhile (l1, l2) -> Lambda.while_ (aux l1) (aux l2) | Lfor (flag, l1, l2, dir, l3) -> - Lam.for_ flag (aux l1) (aux l2) dir (aux l3) - | Lfor_of (flag, l1, l2) -> Lam.for_of flag (aux l1) (aux l2) - | Lfor_await_of (flag, l1, l2) -> Lam.for_await_of flag (aux l1) (aux l2) + Lambda.for_ flag (aux l1) (aux l2) dir (aux l3) + | Lfor_of (flag, l1, l2) -> Lambda.for_of flag (aux l1) (aux l2) + | Lfor_await_of (flag, l1, l2) -> Lambda.for_await_of flag (aux l1) (aux l2) | Lassign (v, l) -> (* Lalias-bound variables are never assigned, so don't increase v's refaux *) - Lam.assign v (aux l) + Lambda.assign v (aux l) in aux lam diff --git a/compiler/core/lam_pass_deep_flatten.mli b/compiler/core/lam_pass_deep_flatten.mli index 74e195fa874..8f88d8983e6 100644 --- a/compiler/core/lam_pass_deep_flatten.mli +++ b/compiler/core/lam_pass_deep_flatten.mli @@ -22,4 +22,4 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val deep_flatten : Lam.t -> Lam.t +val deep_flatten : Lambda.t -> Lambda.t diff --git a/compiler/core/lam_pass_eliminate_ref.ml b/compiler/core/lam_pass_eliminate_ref.ml index 3f1ef7d441a..3830c09072f 100644 --- a/compiler/core/lam_pass_eliminate_ref.ml +++ b/compiler/core/lam_pass_eliminate_ref.ml @@ -13,12 +13,12 @@ exception Real_reference -let rec eliminate_ref id (lam : Lam.t) = +let rec eliminate_ref id (lam : Lambda.t) = match lam with (* we can do better escape analysis in Javascript backend *) | Lvar v -> if Ident.same v id then raise_notrace Real_reference else lam | Lprim {primitive = Pfield (0, _); args = [Lvar v]} when Ident.same v id -> - Lam.var id + Lambda.var id | Lfunction _ -> if Lam_hit.hit_variable id lam then raise_notrace Real_reference else lam (* In Javascript backend, its okay, we can reify it later @@ -46,27 +46,23 @@ let rec eliminate_ref id (lam : Lam.t) = (* Lfunction(kind, params, eliminate_ref id body) *) | Lprim {primitive = Psetfield (0, _); args = [Lvar v; e]} when Ident.same v id -> - Lam.assign id (eliminate_ref id e) - | Lprim {primitive = Poffsetref delta; args = [Lvar v]; loc} - when Ident.same v id -> - Lam.assign id - (Lam.prim ~primitive:(Poffsetint delta) ~args:[Lam.var id] loc) + Lambda.assign id (eliminate_ref id e) | Lconst _ -> lam | Lapply {ap_func = e1; ap_args = el; ap_info; ap_transformed_jsx} -> - Lam.apply ~ap_transformed_jsx (eliminate_ref id e1) + Lambda.apply ~ap_transformed_jsx (eliminate_ref id e1) (Ext_list.map el (eliminate_ref id)) ap_info | Llet (str, v, e1, e2) -> - Lam.let_ str v (eliminate_ref id e1) (eliminate_ref id e2) + Lambda.let_ str v (eliminate_ref id e1) (eliminate_ref id e2) | Lletrec (idel, e2) -> - Lam.letrec + Lambda.letrec (Ext_list.map idel (fun (v, e) -> (v, eliminate_ref id e))) (eliminate_ref id e2) | Lglobal_module _ -> lam | Lprim {primitive; args; loc} -> - Lam.prim ~primitive ~args:(Ext_list.map args (eliminate_ref id)) loc + Lambda.prim ~primitive ~args:(Ext_list.map args (eliminate_ref id)) loc | Lswitch (e, sw) -> - Lam.switch (eliminate_ref id e) + Lambda.switch (eliminate_ref id e) { sw_consts_full = sw.sw_consts_full; sw_consts = @@ -81,28 +77,28 @@ let rec eliminate_ref id (lam : Lam.t) = sw_dispatch = sw.sw_dispatch; } | Lstringswitch (e, sw, default) -> - Lam.stringswitch (eliminate_ref id e) + Lambda.stringswitch (eliminate_ref id e) (Ext_list.map sw (fun (s, e) -> (s, eliminate_ref id e))) (match default with | None -> None | Some x -> Some (eliminate_ref id x)) | Lstaticraise (i, args) -> - Lam.staticraise i (Ext_list.map args (eliminate_ref id)) + Lambda.staticraise i (Ext_list.map args (eliminate_ref id)) | Lstaticcatch (e1, i, e2) -> - Lam.staticcatch (eliminate_ref id e1) i (eliminate_ref id e2) + Lambda.staticcatch (eliminate_ref id e1) i (eliminate_ref id e2) | Ltrywith (e1, v, e2) -> - Lam.try_ (eliminate_ref id e1) v (eliminate_ref id e2) + Lambda.try_ (eliminate_ref id e1) v (eliminate_ref id e2) | Lifthenelse (e1, e2, e3) -> - Lam.if_ (eliminate_ref id e1) (eliminate_ref id e2) (eliminate_ref id e3) - | Lsequence (e1, e2) -> Lam.seq (eliminate_ref id e1) (eliminate_ref id e2) - | Lbreak -> Lam.break - | Lcontinue -> Lam.continue - | Lwhile (e1, e2) -> Lam.while_ (eliminate_ref id e1) (eliminate_ref id e2) + Lambda.if_ (eliminate_ref id e1) (eliminate_ref id e2) (eliminate_ref id e3) + | Lsequence (e1, e2) -> Lambda.seq (eliminate_ref id e1) (eliminate_ref id e2) + | Lbreak -> Lambda.break + | Lcontinue -> Lambda.continue + | Lwhile (e1, e2) -> Lambda.while_ (eliminate_ref id e1) (eliminate_ref id e2) | Lfor (v, e1, e2, dir, e3) -> - Lam.for_ v (eliminate_ref id e1) (eliminate_ref id e2) dir + Lambda.for_ v (eliminate_ref id e1) (eliminate_ref id e2) dir (eliminate_ref id e3) | Lfor_of (v, e1, e2) -> - Lam.for_of v (eliminate_ref id e1) (eliminate_ref id e2) + Lambda.for_of v (eliminate_ref id e1) (eliminate_ref id e2) | Lfor_await_of (v, e1, e2) -> - Lam.for_await_of v (eliminate_ref id e1) (eliminate_ref id e2) - | Lassign (v, e) -> Lam.assign v (eliminate_ref id e) + Lambda.for_await_of v (eliminate_ref id e1) (eliminate_ref id e2) + | Lassign (v, e) -> Lambda.assign v (eliminate_ref id e) diff --git a/compiler/core/lam_pass_eliminate_ref.mli b/compiler/core/lam_pass_eliminate_ref.mli index e63428a0ef3..7051b64fd6a 100644 --- a/compiler/core/lam_pass_eliminate_ref.mli +++ b/compiler/core/lam_pass_eliminate_ref.mli @@ -24,4 +24,4 @@ exception Real_reference -val eliminate_ref : Ident.t -> Lam.t -> Lam.t +val eliminate_ref : Ident.t -> Lambda.t -> Lambda.t diff --git a/compiler/core/lam_pass_exits.ml b/compiler/core/lam_pass_exits.ml index 355ac011500..108588c9974 100644 --- a/compiler/core/lam_pass_exits.ml +++ b/compiler/core/lam_pass_exits.ml @@ -21,7 +21,7 @@ *) let rec no_list args = Ext_list.for_all args no_bounded_variables -and no_list_snd : 'a. ('a * Lam.t) list -> bool = +and no_list_snd : 'a. ('a * Lambda.t) list -> bool = fun args -> Ext_list.for_all_snd args no_bounded_variables and no_opt x = @@ -29,7 +29,7 @@ and no_opt x = | None -> true | Some a -> no_bounded_variables a -and no_bounded_variables (l : Lam.t) = +and no_bounded_variables (l : Lambda.t) = match l with | Lvar _ -> true | Lconst _ -> true @@ -82,8 +82,8 @@ and no_bounded_variables (l : Lam.t) = when do the substitution, if its occurence is > 1, we should refresh *) -type lam_subst = Id of Lam.t [@@unboxed] -(* | Refresh of Lam.t *) +type lam_subst = Id of Lambda.t [@@unboxed] +(* | Refresh of Lambda.t *) type subst_tbl = (Ident.t list * lam_subst) Hash_int.t @@ -152,9 +152,9 @@ let to_lam x = the j is not very indicative *) -let subst_helper (subst : subst_tbl) (query : int -> int) (lam : Lam.t) : Lam.t - = - let rec simplif (lam : Lam.t) = +let subst_helper (subst : subst_tbl) (query : int -> int) (lam : Lambda.t) : + Lambda.t = + let rec simplif (lam : Lambda.t) = match lam with | Lstaticcatch (l1, (i, xs), l2) -> ( let i_occur = query i in @@ -182,7 +182,7 @@ let subst_helper (subst : subst_tbl) (query : int -> int) (lam : Lam.t) : Lam.t if ok_to_inline then ( Hash_int.add subst i (xs, Id l2); simplif l1) - else Lam.staticcatch (simplif l1) (i, xs) l2) + else Lambda.staticcatch (simplif l1) (i, xs) l2) | Lstaticraise (i, []) -> ( match Hash_int.find_opt subst i with | Some (_, handler) -> to_lam handler @@ -194,32 +194,32 @@ let subst_helper (subst : subst_tbl) (query : int -> int) (lam : Lam.t) : Lam.t let handler = to_lam handler in let ys = Ext_list.map xs Ident.rename in let env = - Ext_list.fold_right2 xs ys Map_ident.empty (fun x y t -> - Map_ident.add t x (Lam.var y)) + Ext_list.fold_right2 xs ys Ident.empty (fun x y t -> + Ident.add x (Lambda.var y) t) in - Ext_list.fold_right2 ys ls (Lam_subst.subst env handler) (fun y l r -> - Lam.let_ Strict y l r) - | None -> Lam.staticraise i ls) + Ext_list.fold_right2 ys ls (Lambda.subst_lambda env handler) + (fun y l r -> Lambda.let_ Strict y l r) + | None -> Lambda.staticraise i ls) | Lvar _ | Lconst _ -> lam | Lapply {ap_func; ap_args; ap_info; ap_transformed_jsx} -> - Lam.apply (simplif ap_func) + Lambda.apply (simplif ap_func) (Ext_list.map ap_args simplif) ap_info ~ap_transformed_jsx - | Lfunction {arity; params; body; attr; loc} -> - Lam.function_ ~loc ~arity ~params ~body:(simplif body) ~attr - | Llet (kind, v, l1, l2) -> Lam.let_ kind v (simplif l1) (simplif l2) + | Lfunction {params; body; attr; loc} -> + Lambda.function_ ~loc ~params ~body:(simplif body) ~attr + | Llet (kind, v, l1, l2) -> Lambda.let_ kind v (simplif l1) (simplif l2) | Lletrec (bindings, body) -> - Lam.letrec (Ext_list.map_snd bindings simplif) (simplif body) + Lambda.letrec (Ext_list.map_snd bindings simplif) (simplif body) | Lglobal_module _ -> lam | Lprim {primitive; args; loc} -> let args = Ext_list.map args simplif in - Lam.prim ~primitive ~args loc + Lambda.prim ~primitive ~args loc | Lswitch (l, sw) -> let new_l = simplif l in let new_consts = Ext_list.map_snd sw.sw_consts simplif in let new_blocks = Ext_list.map_snd sw.sw_blocks simplif in let new_fail = Ext_option.map sw.sw_failaction simplif in - Lam.switch new_l + Lambda.switch new_l { sw with sw_consts = new_consts; @@ -227,24 +227,26 @@ let subst_helper (subst : subst_tbl) (query : int -> int) (lam : Lam.t) : Lam.t sw_failaction = new_fail; } | Lstringswitch (l, sw, d) -> - Lam.stringswitch (simplif l) + Lambda.stringswitch (simplif l) (Ext_list.map_snd sw simplif) (Ext_option.map d simplif) - | Ltrywith (l1, v, l2) -> Lam.try_ (simplif l1) v (simplif l2) - | Lifthenelse (l1, l2, l3) -> Lam.if_ (simplif l1) (simplif l2) (simplif l3) - | Lsequence (l1, l2) -> Lam.seq (simplif l1) (simplif l2) - | Lbreak -> Lam.break - | Lcontinue -> Lam.continue - | Lwhile (l1, l2) -> Lam.while_ (simplif l1) (simplif l2) + | Ltrywith (l1, v, l2) -> Lambda.try_ (simplif l1) v (simplif l2) + | Lifthenelse (l1, l2, l3) -> + Lambda.if_ (simplif l1) (simplif l2) (simplif l3) + | Lsequence (l1, l2) -> Lambda.seq (simplif l1) (simplif l2) + | Lbreak -> Lambda.break + | Lcontinue -> Lambda.continue + | Lwhile (l1, l2) -> Lambda.while_ (simplif l1) (simplif l2) | Lfor (v, l1, l2, dir, l3) -> - Lam.for_ v (simplif l1) (simplif l2) dir (simplif l3) - | Lfor_of (v, l1, l2) -> Lam.for_of v (simplif l1) (simplif l2) - | Lfor_await_of (v, l1, l2) -> Lam.for_await_of v (simplif l1) (simplif l2) - | Lassign (v, l) -> Lam.assign v (simplif l) + Lambda.for_ v (simplif l1) (simplif l2) dir (simplif l3) + | Lfor_of (v, l1, l2) -> Lambda.for_of v (simplif l1) (simplif l2) + | Lfor_await_of (v, l1, l2) -> + Lambda.for_await_of v (simplif l1) (simplif l2) + | Lassign (v, l) -> Lambda.assign v (simplif l) in simplif lam -let simplify_exits (lam : Lam.t) = +let simplify_exits (lam : Lambda.t) = let exits = Lam_exit_count.count_helper lam in subst_helper (Hash_int.create 17) (Lam_exit_count.count_exit exits) lam diff --git a/compiler/core/lam_pass_exits.mli b/compiler/core/lam_pass_exits.mli index a48c54d5a0f..68c6727454e 100644 --- a/compiler/core/lam_pass_exits.mli +++ b/compiler/core/lam_pass_exits.mli @@ -15,4 +15,4 @@ [simplif] module *) -val simplify_exits : Lam.t -> Lam.t +val simplify_exits : Lambda.t -> Lambda.t diff --git a/compiler/core/lam_pass_guard_raises.ml b/compiler/core/lam_pass_guard_raises.ml new file mode 100644 index 00000000000..1b6f4005f89 --- /dev/null +++ b/compiler/core/lam_pass_guard_raises.ml @@ -0,0 +1,11 @@ +let rec guard_raises (lam : Lambda.t) : Lambda.t = + match lam with + | Lifthenelse (a, (Lprim {primitive = Praise} as b), c) -> ( + match c with + (* A constant alternative is already as flat as it gets. *) + | Lconst _ -> Lambda.shallow_map_sharing guard_raises lam + | _ -> + Lambda.seq + (Lambda.if_ (guard_raises a) b Lambda.lambda_unit) + (guard_raises c)) + | _ -> Lambda.shallow_map_sharing guard_raises lam diff --git a/compiler/core/lam_pass_guard_raises.mli b/compiler/core/lam_pass_guard_raises.mli new file mode 100644 index 00000000000..f93b8652cb2 --- /dev/null +++ b/compiler/core/lam_pass_guard_raises.mli @@ -0,0 +1,14 @@ +val guard_raises : Lambda.t -> Lambda.t +(** Rewrite [if a then raise e else c] into [(if a then raise e else ()); c], + so the continuation stops being nested inside a branch - the guard clause + idiom in the emitted JavaScript. + + This is code motion rather than normalization: it changes the shape that + surrounding code matches on, so it cannot live in [Lambda.if_]. Matching + inspects the terms it has built after the fact, and rewriting them as they + are constructed leaves static raises without their catch. + + Run it late. The opportunities come from conversion and from four + different passes ([exits], [remove_alias], [lets_dce], [deep_flatten]), so + a traversal scheduled after all of them catches every case without having + to know which pass produced it. *) diff --git a/compiler/core/lam_pass_lets_dce.ml b/compiler/core/lam_pass_lets_dce.ml index 80956f4b9e6..0012153f06d 100644 --- a/compiler/core/lam_pass_lets_dce.ml +++ b/compiler/core/lam_pass_lets_dce.ml @@ -11,26 +11,23 @@ (***********************************************************************) (* Adapted for Javascript backend : Hongbo Zhang, *) -let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = - let subst : Lam.t Hash_ident.t = Hash_ident.create 32 in +let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lambda.t + = + let subst : Lambda.t Hash_ident.t = Hash_ident.create 32 in let string_table : string Hash_ident.t = Hash_ident.create 32 in let used v = (count_var v).times > 0 in - let rec simplif (lam : Lam.t) = + let rec simplif (lam : Lambda.t) = match lam with | Lvar v -> Hash_ident.find_default subst v lam | Llet ((Strict | Alias | StrictOpt), v, Lvar w, l2) -> - Hash_ident.add subst v (simplif (Lam.var w)); + Hash_ident.add subst v (simplif (Lambda.var w)); simplif l2 | Llet ( (Strict as kind), v, - Lprim - { - primitive = Pmakeblock (_, Mutable) as primitive; - args = [linit]; - loc; - }, - lbody ) -> ( + Lprim {primitive = Pmakeblock info as primitive; args = [linit]; loc}, + lbody ) + when not (Lambda.is_immutable_block info) -> ( let slinit = simplif linit in let slbody = simplif lbody in try @@ -39,7 +36,7 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = (Lam_pass_eliminate_ref.eliminate_ref v slbody) with Lam_pass_eliminate_ref.Real_reference -> Lam_util.refine_let ~kind v - (Lam.prim ~primitive ~args:[slinit] loc) + (Lambda.prim ~primitive ~args:[slinit] loc) slbody) | Llet (Alias, v, l1, l2) -> ( (* For alias, [l1] is pure, we can always inline, @@ -52,7 +49,7 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = | ( _, ( Lconst ( Const_int _ | Const_assertfalse | Const_constructor _ - | Const_char _ | Const_float _ | Const_bigint _ | Const_pointer _ + | Const_char _ | Const_float _ | Const_bigint _ | Const_polyvar _ | Const_js_true | Const_js_false | Const_js_undefined _ ) (* could be poly-variant [`A] -> [65a]*) | Lprim {primitive = Pfield _; args = [Lglobal_module _]} ) ) @@ -66,10 +63,10 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = | _, Lconst (Const_string {s; delim = None}) -> (* only "" added for later inlining *) Hash_ident.add string_table v s; - Lam.let_ Alias v l1 (simplif l2) + Lambda.let_ Alias v l1 (simplif l2) (* we need move [simplif l2] later, since adding Hash does have side effect *) | _ -> - Lam.let_ Alias v (simplif l1) (simplif l2) + Lambda.let_ Alias v (simplif l1) (simplif l2) (* for Alias, in most cases [l1] is already simplified *)) | Llet ((StrictOpt as kind), v, l1, lbody) -> ( if @@ -93,12 +90,8 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = then simplif lbody (* GPR #1476 *) else match l1 with - | Lprim - { - primitive = Pmakeblock (_, Mutable) as primitive; - args = [linit]; - loc; - } -> ( + | Lprim {primitive = Pmakeblock info as primitive; args = [linit]; loc} + when not (Lambda.is_immutable_block info) -> ( let slinit = simplif linit in let slbody = simplif lbody in try @@ -107,7 +100,7 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = (Lam_pass_eliminate_ref.eliminate_ref v slbody) with Lam_pass_eliminate_ref.Real_reference -> Lam_util.refine_let ~kind v - (Lam.prim ~primitive ~args:[slinit] loc) + (Lambda.prim ~primitive ~args:[slinit] loc) slbody) | _ -> ( let l1 = simplif l1 in @@ -115,23 +108,23 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = | Lconst (Const_string {s; delim = None}) -> Hash_ident.add string_table v s; (* we need move [simplif lbody] later, since adding Hash does have side effect *) - Lam.let_ Alias v l1 (simplif lbody) + Lambda.let_ Alias v l1 (simplif lbody) | _ -> Lam_util.refine_let ~kind v l1 (simplif lbody)) (* TODO: check if it is correct rollback to [StrictOpt]? *)) | Llet (((Strict | Variable) as kind), v, l1, l2) -> ( if not (used v) then let l1 = simplif l1 in let l2 = simplif l2 in - if Lam_analysis.no_side_effects l1 then l2 else Lam.seq l1 l2 + if Lam_analysis.no_side_effects l1 then l2 else Lambda.seq l1 l2 else let l1 = simplif l1 in match (kind, l1) with | Strict, Lconst (Const_string {s; delim = None}) -> Hash_ident.add string_table v s; - Lam.let_ Alias v l1 (simplif l2) + Lambda.let_ Alias v l1 (simplif l2) | _ -> Lam_util.refine_let ~kind v l1 (simplif l2)) - | Lsequence (l1, l2) -> Lam.seq (simplif l1) (simplif l2) + | Lsequence (l1, l2) -> Lambda.seq (simplif l1) (simplif l2) | Lapply {ap_func = Lfunction ({params; body} as lfunction); ap_args = args; _} when Ext_list.same_length params args @@ -145,13 +138,13 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = (* when Ext_list.same_length params args -> *) (* simplif (Lam_beta_reduce.beta_reduce params body args) *) | Lapply {ap_func = l1; ap_args = ll; ap_info; ap_transformed_jsx} -> - Lam.apply (simplif l1) (Ext_list.map ll simplif) ap_info + Lambda.apply (simplif l1) (Ext_list.map ll simplif) ap_info ~ap_transformed_jsx - | Lfunction {arity; params; body; attr; loc} -> - Lam.function_ ~loc ~arity ~params ~body:(simplif body) ~attr + | Lfunction {params; body; attr; loc} -> + Lambda.function_ ~loc ~params ~body:(simplif body) ~attr | Lconst _ -> lam | Lletrec (bindings, body) -> - Lam.letrec (Ext_list.map_snd bindings simplif) (simplif body) + Lambda.letrec (Ext_list.map_snd bindings simplif) (simplif body) | Lprim {primitive = Pstringadd; args = [l; r]; loc} -> ( let l' = simplif l in let r' = simplif r in @@ -162,7 +155,7 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = | _ -> None in match opt_l with - | None -> Lam.prim ~primitive:Pstringadd ~args:[l'; r'] loc + | None -> Lambda.prim ~primitive:Pstringadd ~args:[l'; r'] loc | Some l_s -> ( let opt_r = match r' with @@ -171,17 +164,18 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = | _ -> None in match opt_r with - | None -> Lam.prim ~primitive:Pstringadd ~args:[l'; r'] loc - | Some r_s -> Lam.const (Const_string {s = l_s ^ r_s; delim = None}))) + | None -> Lambda.prim ~primitive:Pstringadd ~args:[l'; r'] loc + | Some r_s -> Lambda.const (Const_string {s = l_s ^ r_s; delim = None})) + ) | Lglobal_module _ -> lam | Lprim {primitive; args; loc} -> - Lam.prim ~primitive ~args:(Ext_list.map args simplif) loc + Lambda.prim ~primitive ~args:(Ext_list.map args simplif) loc | Lswitch (l, sw) -> let new_l = simplif l and new_consts = Ext_list.map_snd sw.sw_consts simplif and new_blocks = Ext_list.map_snd sw.sw_blocks simplif and new_fail = Ext_option.map sw.sw_failaction simplif in - Lam.switch new_l + Lambda.switch new_l { sw with sw_consts = new_consts; @@ -189,22 +183,24 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = sw_failaction = new_fail; } | Lstringswitch (l, sw, d) -> - Lam.stringswitch (simplif l) + Lambda.stringswitch (simplif l) (Ext_list.map_snd sw simplif) (Ext_option.map d simplif) - | Lstaticraise (i, ls) -> Lam.staticraise i (Ext_list.map ls simplif) + | Lstaticraise (i, ls) -> Lambda.staticraise i (Ext_list.map ls simplif) | Lstaticcatch (l1, (i, args), l2) -> - Lam.staticcatch (simplif l1) (i, args) (simplif l2) - | Ltrywith (l1, v, l2) -> Lam.try_ (simplif l1) v (simplif l2) - | Lifthenelse (l1, l2, l3) -> Lam.if_ (simplif l1) (simplif l2) (simplif l3) - | Lbreak -> Lam.break - | Lcontinue -> Lam.continue - | Lwhile (l1, l2) -> Lam.while_ (simplif l1) (simplif l2) + Lambda.staticcatch (simplif l1) (i, args) (simplif l2) + | Ltrywith (l1, v, l2) -> Lambda.try_ (simplif l1) v (simplif l2) + | Lifthenelse (l1, l2, l3) -> + Lambda.if_ (simplif l1) (simplif l2) (simplif l3) + | Lbreak -> Lambda.break + | Lcontinue -> Lambda.continue + | Lwhile (l1, l2) -> Lambda.while_ (simplif l1) (simplif l2) | Lfor (v, l1, l2, dir, l3) -> - Lam.for_ v (simplif l1) (simplif l2) dir (simplif l3) - | Lfor_of (v, l1, l2) -> Lam.for_of v (simplif l1) (simplif l2) - | Lfor_await_of (v, l1, l2) -> Lam.for_await_of v (simplif l1) (simplif l2) - | Lassign (v, l) -> Lam.assign v (simplif l) + Lambda.for_ v (simplif l1) (simplif l2) dir (simplif l3) + | Lfor_of (v, l1, l2) -> Lambda.for_of v (simplif l1) (simplif l2) + | Lfor_await_of (v, l1, l2) -> + Lambda.for_await_of v (simplif l1) (simplif l2) + | Lassign (v, l) -> Lambda.assign v (simplif l) in simplif lam @@ -217,6 +213,6 @@ let apply_lets occ lambda = in lets_helper count_var lambda -let simplify_lets (lam : Lam.t) : Lam.t = +let simplify_lets (lam : Lambda.t) : Lambda.t = let occ = Lam_pass_count.collect_occurs lam in apply_lets occ lam diff --git a/compiler/core/lam_pass_lets_dce.mli b/compiler/core/lam_pass_lets_dce.mli index bad2bf97612..3ad0e5dc5c7 100644 --- a/compiler/core/lam_pass_lets_dce.mli +++ b/compiler/core/lam_pass_lets_dce.mli @@ -11,7 +11,7 @@ (***********************************************************************) (* Adapted for Javascript backend: Hongbo Zhang *) -val simplify_lets : Lam.t -> Lam.t +val simplify_lets : Lambda.t -> Lambda.t (** This pass would do beta reduction, and dead code elimination (adapted from compiler's built-in [Simplif] module ) diff --git a/compiler/core/lam_pass_remove_alias.ml b/compiler/core/lam_pass_remove_alias.ml index cdd31e5940e..4c4a77169ef 100644 --- a/compiler/core/lam_pass_remove_alias.ml +++ b/compiler/core/lam_pass_remove_alias.ml @@ -41,14 +41,13 @@ let id_is_for_sure_true_in_boolean (tbl : Lam_stats.ident_tbl) id = | None -> Eval_unknown -let is_const_some (cst : Lam_constant.t) : bool = +let is_const_some (cst : Lambda.structured_constant) : bool = match cst with | Const_some _ -> true - | Const_block ((Lambda.Blk_some | Lambda.Blk_some_not_nested), _) -> true | _ -> false -let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = - let rec simpl (lam : Lam.t) : Lam.t = +let simplify_alias (meta : Lam_stats.t) (lam : Lambda.t) : Lambda.t = + let rec simpl (lam : Lambda.t) : Lambda.t = match lam with | Lvar _ -> lam (* 7432: prevent optimization in JSX preserve mode *) @@ -59,16 +58,16 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = loc; } when !Js_config.jsx_preserve -> - Lam.prim ~primitive ~args:(field_arg :: Ext_list.map rest simpl) loc + Lambda.prim ~primitive ~args:(field_arg :: Ext_list.map rest simpl) loc | Lprim {primitive = Pfield (i, info) as primitive; args = [arg]; loc} -> ( (* ATTENTION: Main use case, we should detect inline all immutable block .. *) match simpl arg with | Lvar v as l -> Lam_util.field_flatten_get - (fun _ -> Lam.prim ~primitive ~args:[l] loc) + (fun _ -> Lambda.prim ~primitive ~args:[l] loc) v i info meta.ident_tbl - | l -> Lam.prim ~primitive ~args:[l] loc) + | l -> Lambda.prim ~primitive ~args:[l] loc) | Lprim { primitive = (Pval_from_option | Pval_from_option_not_nest) as p; @@ -79,7 +78,7 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = | _ -> if p = Pval_from_option_not_nest then lvar else x) | Lglobal_module _ -> lam | Lprim {primitive; args; loc} -> - Lam.prim ~primitive ~args:(Ext_list.map args simpl) loc + Lambda.prim ~primitive ~args:(Ext_list.map args simpl) loc | Lifthenelse ((Lprim {primitive = Pis_not_none; args = [Lvar id]} as l1), l2, l3) -> ( @@ -87,21 +86,21 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = | Some (Constant c) when is_const_some c -> simpl l2 | Some (ImmutableBlock _ | MutableBlock _ | Normal_optional _) -> simpl l2 | Some (OptionalBlock (l, Null)) -> - Lam.if_ - (Lam.not_ Location.none - (Lam.prim ~primitive:Pis_null ~args:[l] Location.none)) + Lambda.if_ + (Lambda.not_ Location.none + (Lambda.prim ~primitive:Pis_null ~args:[l] Location.none)) (simpl l2) (simpl l3) | Some (OptionalBlock (l, Undefined)) -> - Lam.if_ - (Lam.not_ Location.none - (Lam.prim ~primitive:Pis_undefined ~args:[l] Location.none)) + Lambda.if_ + (Lambda.not_ Location.none + (Lambda.prim ~primitive:Pis_undefined ~args:[l] Location.none)) (simpl l2) (simpl l3) | Some (OptionalBlock (l, Null_undefined)) -> - Lam.if_ - (Lam.not_ Location.none - (Lam.prim ~primitive:Pis_null_undefined ~args:[l] Location.none)) + Lambda.if_ + (Lambda.not_ Location.none + (Lambda.prim ~primitive:Pis_null_undefined ~args:[l] Location.none)) (simpl l2) (simpl l3) - | Some _ | None -> Lam.if_ l1 (simpl l2) (simpl l3)) + | Some _ | None -> Lambda.if_ l1 (simpl l2) (simpl l3)) (* could be the code path {[ match x with | h::hs -> @@ -113,13 +112,13 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = match id_is_for_sure_true_in_boolean meta.ident_tbl id with | Eval_true -> simpl l2 | Eval_false -> simpl l3 - | Eval_unknown -> Lam.if_ (simpl l1) (simpl l2) (simpl l3)) - | _ -> Lam.if_ (simpl l1) (simpl l2) (simpl l3)) + | Eval_unknown -> Lambda.if_ (simpl l1) (simpl l2) (simpl l3)) + | _ -> Lambda.if_ (simpl l1) (simpl l2) (simpl l3)) | Lconst _ -> lam - | Llet (str, v, l1, l2) -> Lam.let_ str v (simpl l1) (simpl l2) + | Llet (str, v, l1, l2) -> Lambda.let_ str v (simpl l1) (simpl l2) | Lletrec (bindings, body) -> let bindings = Ext_list.map_snd bindings simpl in - Lam.letrec bindings (simpl body) + Lambda.letrec bindings (simpl body) (* complicated 1. inline this function 2. ... @@ -156,7 +155,7 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = && Lam_analysis.lfunction_can_be_inlined lfunction -> simpl (Lam_beta_reduce.propagate_beta_reduce meta params body args) | _ -> - Lam.apply (simpl l1) (Ext_list.map args simpl) ap_info + Lambda.apply (simpl l1) (Ext_list.map args simpl) ap_info ?ap_transformed_jsx:None) (* Function inlining interact with other optimizations... @@ -170,7 +169,7 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = (* Ext_log.dwarn __LOC__ "%s/%d" v.name v.stamp; *) let ap_args = Ext_list.map ap_args simpl in let[@local] normal () = - Lam.apply (simpl fn) ap_args ap_info ~ap_transformed_jsx + Lambda.apply (simpl fn) ap_args ap_info ~ap_transformed_jsx in match Hash_ident.find_opt meta.ident_tbl v with | Some @@ -241,9 +240,10 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = (* when Ext_list.same_length params args -> *) (* simpl (Lam_beta_reduce.propogate_beta_reduce meta params body args) *) | Lapply {ap_func = l1; ap_args = ll; ap_info; ap_transformed_jsx} -> - Lam.apply (simpl l1) (Ext_list.map ll simpl) ap_info ~ap_transformed_jsx - | Lfunction {arity; params; body; attr; loc} -> - Lam.function_ ~loc ~arity ~params ~body:(simpl body) ~attr + Lambda.apply (simpl l1) (Ext_list.map ll simpl) ap_info + ~ap_transformed_jsx + | Lfunction {params; body; attr; loc} -> + Lambda.function_ ~loc ~params ~body:(simpl body) ~attr | Lswitch ( l, { @@ -254,7 +254,7 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = sw_consts_full; sw_dispatch; } ) -> - Lam.switch (simpl l) + Lambda.switch (simpl l) { sw_consts = Ext_list.map_snd sw_consts simpl; sw_blocks = Ext_list.map_snd sw_blocks simpl; @@ -268,26 +268,26 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = match l with | Lvar s -> ( match Hash_ident.find_opt meta.ident_tbl s with - | Some (Constant s) -> Lam.const s + | Some (Constant s) -> Lambda.const s | Some _ | None -> simpl l) | _ -> simpl l in - Lam.stringswitch l (Ext_list.map_snd sw simpl) (Ext_option.map d simpl) - | Lstaticraise (i, ls) -> Lam.staticraise i (Ext_list.map ls simpl) - | Lstaticcatch (l1, ids, l2) -> Lam.staticcatch (simpl l1) ids (simpl l2) - | Ltrywith (l1, v, l2) -> Lam.try_ (simpl l1) v (simpl l2) - | Lsequence (l1, l2) -> Lam.seq (simpl l1) (simpl l2) - | Lbreak -> Lam.break - | Lcontinue -> Lam.continue - | Lwhile (l1, l2) -> Lam.while_ (simpl l1) (simpl l2) + Lambda.stringswitch l (Ext_list.map_snd sw simpl) (Ext_option.map d simpl) + | Lstaticraise (i, ls) -> Lambda.staticraise i (Ext_list.map ls simpl) + | Lstaticcatch (l1, ids, l2) -> Lambda.staticcatch (simpl l1) ids (simpl l2) + | Ltrywith (l1, v, l2) -> Lambda.try_ (simpl l1) v (simpl l2) + | Lsequence (l1, l2) -> Lambda.seq (simpl l1) (simpl l2) + | Lbreak -> Lambda.break + | Lcontinue -> Lambda.continue + | Lwhile (l1, l2) -> Lambda.while_ (simpl l1) (simpl l2) | Lfor (flag, l1, l2, dir, l3) -> - Lam.for_ flag (simpl l1) (simpl l2) dir (simpl l3) - | Lfor_of (flag, l1, l2) -> Lam.for_of flag (simpl l1) (simpl l2) + Lambda.for_ flag (simpl l1) (simpl l2) dir (simpl l3) + | Lfor_of (flag, l1, l2) -> Lambda.for_of flag (simpl l1) (simpl l2) | Lfor_await_of (flag, l1, l2) -> - Lam.for_await_of flag (simpl l1) (simpl l2) + Lambda.for_await_of flag (simpl l1) (simpl l2) | Lassign (v, l) -> (* Lalias-bound variables are never assigned, so don't increase v's refsimpl *) - Lam.assign v (simpl l) + Lambda.assign v (simpl l) in simpl lam diff --git a/compiler/core/lam_pass_remove_alias.mli b/compiler/core/lam_pass_remove_alias.mli index 3d6b9159194..d74162dcb83 100644 --- a/compiler/core/lam_pass_remove_alias.mli +++ b/compiler/core/lam_pass_remove_alias.mli @@ -35,4 +35,4 @@ This pass does not change meta data *) -val simplify_alias : Lam_stats.t -> Lam.t -> Lam.t +val simplify_alias : Lam_stats.t -> Lambda.t -> Lambda.t diff --git a/compiler/core/lam_primitive.ml b/compiler/core/lam_primitive.ml deleted file mode 100644 index 4d5f64c7029..00000000000 --- a/compiler/core/lam_primitive.ml +++ /dev/null @@ -1,300 +0,0 @@ -(* Copyright (C) 2018 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -[@@@warning "+9"] - -type ident = Ident.t - -type t = - | Peliminated of Lambda.eliminated - (* Operations on heap blocks *) - | Pmakeblock of Lam_tag_info.t * Asttypes.mutable_flag - | Pfield of int * Lam_compat.field_dbg_info - | Psetfield of int * Lam_compat.set_field_dbg_info - (* could have field info at least for record *) - | Pduprecord - (* Tagged template literal: [tag; strings_array; values_array] *) - | Ptagged_template - | Precord_rest of string list - (* External call *) - | Pjs_call of { - prim_name: string; - arg_types: External_arg_spec.params; - ffi: External_ffi_types.external_decl; - transformed_jsx: bool; - } - | Pjs_object_create of External_arg_spec.obj_params - (* Exceptions *) - | Praise - (* object primitives *) - | Pobjcomp of Lam_compat.comparison - | Pobjorder - | Pobjmin - | Pobjmax - | Pobjtag - | Pobjsize - (* Boolean primitives *) - | Psequand - | Psequor - | Pnot - | Pboolcomp of Lam_compat.comparison - | Pboolorder - | Pboolmin - | Pboolmax - (* Integer primitives *) - | Pisint - | Pnegint - | Paddint - | Psubint - | Pmulint - | Pdivint - | Pmodint - | Ppowint - | Pandint - | Porint - | Pxorint - | Pnotint - | Plslint - | Plsrint - | Pasrint - | Poffsetint of int - | Poffsetref of int - | Pintcomp of Lam_compat.comparison - | Pintorder - | Pintmin - | Pintmax - (* Float primitives *) - | Pintoffloat - | Pfloatofint - | Pnegfloat - | Paddfloat - | Psubfloat - | Pmulfloat - | Pdivfloat - | Pmodfloat - | Ppowfloat - | Pfloatcomp of Lam_compat.comparison - | Pfloatorder - | Pfloatmin - | Pfloatmax - (* BigInt operations *) - | Pnegbigint - | Paddbigint - | Psubbigint - | Pmulbigint - | Pdivbigint - | Pmodbigint - | Ppowbigint - | Pandbigint - | Porbigint - | Pxorbigint - | Pnotbigint - | Plslbigint - | Pasrbigint - | Pbigintcomp of Lam_compat.comparison - | Pbigintorder - | Pbigintmin - | Pbigintmax - (* String primitives *) - | Pstringlength - | Pstringrefu - | Pstringrefs - | Pstringadd - | Pstringcomp of Lam_compat.comparison - | Pstringorder - | Pstringmin - | Pstringmax - (* Array primitives *) - | Pmakearray - | Parraylength - | Parrayrefu - | Parraysetu - | Parrayrefs - | Parraysets - (* List primitives *) - | Pmakelist - (* dict primitives *) - | Pmakedict - | Pdict_has - (* promise *) - | Pawait - (* etc or deprecated *) - | Pis_poly_var_block - | Pisout of int - | Pjscomp of Lam_compat.comparison - | Pjs_apply (*[f;arg0;arg1; arg2; ... argN]*) - | Pdebugger - | Pjs_object_get of string - | Pjs_object_set of string - | Pinit_mod - | Pupdate_mod - | Praw_js_code of Js_raw_info.t - (* we wrap it when do the conversion to prevent - accendential optimization - play safe first - *) - | Pjs_fn_method - | Pnull_to_opt - | Pnull_undefined_to_opt - | Pis_null - | Pis_undefined - | Pis_null_undefined - | Pimport of Lambda.import_source - | Ptypeof - | Pfn_arity - | Pcreate_extension of string - | Pis_not_none (* no info about its type *) - | Pval_from_option - | Pval_from_option_not_nest - | Psome - | Psome_not_nest - | Phash - | Phash_mixstring - | Phash_mixint - | Phash_finalmix - -let eq_field_dbg_info (x : Lam_compat.field_dbg_info) - (y : Lam_compat.field_dbg_info) = - x = y -(* save it to avoid conditional compilation, fix it later *) - -let eq_set_field_dbg_info (x : Lam_compat.set_field_dbg_info) - (y : Lam_compat.set_field_dbg_info) = - x = y -(* save it to avoid conditional compilation, fix it later *) - -let eq_tag_info (x : Lam_tag_info.t) y = x = y - -let eq_primitive_approx (lhs : t) (rhs : t) = - match lhs with - | Peliminated _ -> assert false - | Praise - (* generic comparison *) - | Pobjorder | Pobjmin | Pobjmax | Pobjtag | Pobjsize - (* bool primitives *) - | Psequand | Psequor | Pnot | Pboolcomp _ | Pboolorder | Pboolmin | Pboolmax - (* int primitives *) - | Pisint | Pnegint | Paddint | Psubint | Pmulint | Pdivint | Pmodint | Ppowint - | Pnotint | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint - | Pintorder | Pintmin | Pintmax - (* float primitives *) - | Pintoffloat | Pfloatofint | Pnegfloat | Paddfloat | Psubfloat | Pmulfloat - | Pdivfloat | Pmodfloat | Ppowfloat | Pfloatorder | Pfloatmin | Pfloatmax - (* bigint primitives *) - | Pnegbigint | Paddbigint | Psubbigint | Pmulbigint | Pdivbigint | Pmodbigint - | Ppowbigint | Pnotbigint | Pandbigint | Porbigint | Pxorbigint | Plslbigint - | Pasrbigint | Pbigintorder | Pbigintmin | Pbigintmax - (* string primitives *) - | Pstringlength | Pstringrefu | Pstringrefs | Pstringadd | Pstringcomp _ - | Pstringorder | Pstringmin | Pstringmax - (* List primitives *) - | Pmakelist - (* dict primitives *) - | Pmakedict | Pdict_has - (* promise *) - | Pawait - (* etc *) - | Pjs_apply | Pval_from_option | Pval_from_option_not_nest | Pnull_to_opt - | Pnull_undefined_to_opt | Pis_null | Pis_not_none | Psome | Psome_not_nest - | Pis_undefined | Pis_null_undefined | Ptypeof | Pfn_arity - | Pis_poly_var_block | Pdebugger | Pinit_mod | Pupdate_mod | Pduprecord - | Pmakearray | Parraylength | Parrayrefu | Parraysetu | Parrayrefs - | Parraysets | Pjs_fn_method | Phash | Phash_mixstring | Phash_mixint - | Phash_finalmix | Precord_rest _ -> - rhs = lhs - (* Reachable only via the optimizer's term-equality comparison, which the - test suite doesn't exercise for tagged templates. *) - | Ptagged_template -> ( ((rhs = lhs) [@coverage off])) - | Pcreate_extension a -> ( - match rhs with - | Pcreate_extension b -> a = (b : string) - | _ -> false) - | Pisout l -> ( - match rhs with - | Pisout r -> l = r - | _ -> false) - (* | Pcaml_obj_set_length -> rhs = Pcaml_obj_set_length *) - | Pfield (n0, info0) -> ( - match rhs with - | Pfield (n1, info1) -> n0 = n1 && eq_field_dbg_info info0 info1 - | _ -> false) - | Psetfield (i0, info0) -> ( - match rhs with - | Psetfield (i1, info1) -> i0 = i1 && eq_set_field_dbg_info info0 info1 - | _ -> false) - | Pmakeblock (info0, flag0) -> ( - match rhs with - | Pmakeblock (info1, flag1) -> flag0 = flag1 && eq_tag_info info0 info1 - | _ -> false) - | Pjs_call {prim_name; arg_types; ffi; _} -> ( - match rhs with - | Pjs_call rhs -> - prim_name = rhs.prim_name && arg_types = rhs.arg_types && ffi = rhs.ffi - | _ -> false) - | Pimport src -> ( - match rhs with - | Pimport src2 -> src = src2 - | _ -> false) - | Pjs_object_create obj_create -> ( - match rhs with - | Pjs_object_create obj_create1 -> obj_create = obj_create1 - | _ -> false) - | Pobjcomp comparison -> ( - match rhs with - | Pobjcomp comparison1 -> Lam_compat.eq_comparison comparison comparison1 - | _ -> false) - | Pintcomp comparison -> ( - match rhs with - | Pintcomp comparison1 -> Lam_compat.eq_comparison comparison comparison1 - | _ -> false) - | Pfloatcomp comparison -> ( - match rhs with - | Pfloatcomp comparison1 -> Lam_compat.eq_comparison comparison comparison1 - | _ -> false) - | Pbigintcomp comparison -> ( - match rhs with - | Pbigintcomp comparison1 -> Lam_compat.eq_comparison comparison comparison1 - | _ -> false) - | Pjscomp comparison -> ( - match rhs with - | Pjscomp comparison1 -> Lam_compat.eq_comparison comparison comparison1 - | _ -> false) - | Poffsetint i0 -> ( - match rhs with - | Poffsetint i1 -> i0 = i1 - | _ -> false) - | Poffsetref i0 -> ( - match rhs with - | Poffsetref i1 -> i0 = i1 - | _ -> false) - | Pjs_object_get name -> ( - match rhs with - | Pjs_object_get rhs_name -> name = rhs_name - | _ -> false) - | Pjs_object_set name -> ( - match rhs with - | Pjs_object_set rhs_name -> name = rhs_name - | _ -> false) - | Praw_js_code _ -> false -(* TOO lazy, here comparison is only approximation*) diff --git a/compiler/core/lam_primitive.mli b/compiler/core/lam_primitive.mli deleted file mode 100644 index 5b1114a978b..00000000000 --- a/compiler/core/lam_primitive.mli +++ /dev/null @@ -1,167 +0,0 @@ -(* Copyright (C) 2018 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type ident = Ident.t - -type t = - | Peliminated of Lambda.eliminated - | Pmakeblock of Lam_tag_info.t * Asttypes.mutable_flag - | Pfield of int * Lambda.field_dbg_info - | Psetfield of int * Lambda.set_field_dbg_info - | Pduprecord - | Ptagged_template - | Precord_rest of string list - | Pjs_call of { - (* Location.t * [loc] is passed down *) - prim_name: string; - arg_types: External_arg_spec.params; - ffi: External_ffi_types.external_decl; - transformed_jsx: bool; - } - | Pjs_object_create of External_arg_spec.obj_params - | Praise - (* object primitives *) - | Pobjcomp of Lam_compat.comparison - | Pobjorder - | Pobjmin - | Pobjmax - | Pobjtag - | Pobjsize - (* bool primitives *) - | Psequand - | Psequor - | Pnot - | Pboolcomp of Lam_compat.comparison - | Pboolorder - | Pboolmin - | Pboolmax - (* int primitives *) - | Pisint - | Pnegint - | Paddint - | Psubint - | Pmulint - | Pdivint - | Pmodint - | Ppowint - | Pandint - | Porint - | Pxorint - | Pnotint - | Plslint - | Plsrint - | Pasrint - | Poffsetint of int - | Poffsetref of int - | Pintcomp of Lam_compat.comparison - | Pintorder - | Pintmin - | Pintmax - (* float primitives *) - | Pintoffloat - | Pfloatofint - | Pnegfloat - | Paddfloat - | Psubfloat - | Pmulfloat - | Pdivfloat - | Pmodfloat - | Ppowfloat - | Pfloatcomp of Lam_compat.comparison - | Pfloatorder - | Pfloatmin - | Pfloatmax - (* bigint primitives *) - | Pnegbigint - | Paddbigint - | Psubbigint - | Pmulbigint - | Pdivbigint - | Pmodbigint - | Ppowbigint - | Pandbigint - | Porbigint - | Pxorbigint - | Pnotbigint - | Plslbigint - | Pasrbigint - | Pbigintcomp of Lam_compat.comparison - | Pbigintorder - | Pbigintmin - | Pbigintmax - (* string primitives *) - | Pstringlength - | Pstringrefu - | Pstringrefs - | Pstringadd - | Pstringcomp of Lam_compat.comparison - | Pstringorder - | Pstringmin - | Pstringmax - (* Array primitives *) - | Pmakearray - | Parraylength - | Parrayrefu - | Parraysetu - | Parrayrefs - | Parraysets - (* List primitives *) - | Pmakelist - (* dict primitives *) - | Pmakedict - | Pdict_has - (* promise *) - | Pawait - (* etc or deprecated *) - | Pis_poly_var_block - | Pisout of int - | Pjscomp of Lam_compat.comparison - | Pjs_apply (*[f;arg0;arg1; arg2; ... argN]*) - | Pdebugger - | Pjs_object_get of string - | Pjs_object_set of string - | Pinit_mod - | Pupdate_mod - | Praw_js_code of Js_raw_info.t - | Pjs_fn_method - | Pnull_to_opt - | Pnull_undefined_to_opt - | Pis_null - | Pis_undefined - | Pis_null_undefined - | Pimport of Lambda.import_source - | Ptypeof - | Pfn_arity - | Pcreate_extension of string - | Pis_not_none - | Pval_from_option - | Pval_from_option_not_nest - | Psome - | Psome_not_nest - | Phash - | Phash_mixstring - | Phash_mixint - | Phash_finalmix - -val eq_primitive_approx : t -> t -> bool diff --git a/compiler/core/lam_print.ml b/compiler/core/lam_print.ml deleted file mode 100644 index c9d837bfd98..00000000000 --- a/compiler/core/lam_print.ml +++ /dev/null @@ -1,462 +0,0 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -open Format -open Asttypes - -let rec struct_const ppf (cst : Lam_constant.t) = - match cst with - | Const_js_true -> fprintf ppf "#true" - | Const_js_false -> fprintf ppf "#false" - | Const_js_null -> fprintf ppf "#null" - | Const_module_alias -> fprintf ppf "#alias" - | Const_js_undefined _ -> fprintf ppf "#undefined" - | Const_int i -> fprintf ppf "%ld" i - | Const_assertfalse -> fprintf ppf "assertfalse" - | Const_char i -> fprintf ppf "%s" (Ext_util.string_of_int_as_char i) - | Const_string {s} -> fprintf ppf "%S" s - | Const_float f -> fprintf ppf "%s" f - | Const_bigint (sign, i) -> fprintf ppf "%sn" (Bigint_utils.to_string sign i) - | Const_pointer name -> fprintf ppf "`%s" name - | Const_constructor {name} -> fprintf ppf "`%s" name - | Const_some n -> fprintf ppf "[some-c]%a" struct_const n - | Const_block (i, []) -> fprintf ppf "[%s]" (Lambda.tag_label_of_tag_info i) - | Const_block (i, sc1 :: scl) -> - let sconsts ppf scl = - List.iter (fun sc -> fprintf ppf "@ %a" struct_const sc) scl - in - fprintf ppf "@[<1>[%s:@ @[%a%a@]]@]" - (Lambda.tag_label_of_tag_info i) - struct_const sc1 sconsts scl - -let primitive ppf (prim : Lam_primitive.t) = - match prim with - | Peliminated _ -> assert false - (* | Pcreate_exception s -> fprintf ppf "[exn-create]%S" s *) - | Pcreate_extension s -> fprintf ppf "[ext-create]%S" s - | Pinit_mod -> fprintf ppf "init_mod!" - | Pupdate_mod -> fprintf ppf "update_mod!" - | Pjs_apply -> fprintf ppf "#apply" - (* Debug-only dump, exercised solely under -drawlambda/-dlambda. *) - | Ptagged_template -> fprintf ppf "#tagged_template" [@coverage off] - | Pjs_object_get name -> fprintf ppf "js_object_get[%s]" name - | Pjs_object_set name -> fprintf ppf "js_object_set[%s]" name - | Pfn_arity -> fprintf ppf "fn.length" - | Pjs_fn_method -> fprintf ppf "js_fn_method" - | Pdebugger -> fprintf ppf "debugger" - | Praw_js_code _ -> fprintf ppf "[raw]" - | Ptypeof -> fprintf ppf "typeof" - | Pnull_to_opt -> fprintf ppf "[null->opt]" - | Pnull_undefined_to_opt -> fprintf ppf "[null/undefined->opt]" - | Pis_null -> fprintf ppf "[?null]" - | Pis_not_none -> fprintf ppf "[?is-not-none]" - | Psome -> fprintf ppf "[some]" - | Psome_not_nest -> fprintf ppf "[some-not-nest]" - | Pval_from_option -> fprintf ppf "[?unbox]" - | Pval_from_option_not_nest -> fprintf ppf "[?unbox-not-nest]" - | Pis_undefined -> fprintf ppf "[?undefined]" - | Pis_null_undefined -> fprintf ppf "[?null?undefined]" - | Pimport _ -> fprintf ppf "[import]" - | Pmakeblock (i, Immutable) -> - fprintf ppf "makeblock %s" (Lambda.tag_label_of_tag_info i) - | Pmakeblock (i, Mutable) -> - fprintf ppf "makemutable %s" (Lambda.tag_label_of_tag_info i) - | Pfield (n, field_info) -> ( - match Lam_compat.str_of_field_info field_info with - | None -> fprintf ppf "field %i" n - | Some s -> fprintf ppf "field %s/%i" s n) - | Psetfield (n, _) -> - let instr = "setfield " in - fprintf ppf "%s%i" instr n - | Pduprecord -> fprintf ppf "duprecord" - | Precord_rest excluded -> - fprintf ppf "record_rest(%s)" (String.concat ", " excluded) - | Pjs_call {prim_name} -> fprintf ppf "%s[js]" prim_name - | Pjs_object_create _ -> fprintf ppf "[js.obj]" - | Praise -> fprintf ppf "raise" - | Pobjcomp Ceq -> fprintf ppf "==" - | Pobjcomp Cneq -> fprintf ppf "!=" - | Pobjcomp Clt -> fprintf ppf "<" - | Pobjcomp Cle -> fprintf ppf "<=" - | Pobjcomp Cgt -> fprintf ppf ">" - | Pobjcomp Cge -> fprintf ppf ">=" - | Pobjorder -> fprintf ppf "compare" - | Pobjmin -> fprintf ppf "min" - | Pobjmax -> fprintf ppf "max" - | Pobjtag -> fprintf ppf "tag" - | Pobjsize -> fprintf ppf "length" - | Psequand -> fprintf ppf "&&" - | Psequor -> fprintf ppf "||" - | Pnot -> fprintf ppf "not" - | Pboolcomp Ceq -> fprintf ppf "==" - | Pboolcomp Cneq -> fprintf ppf "!=" - | Pboolcomp Clt -> fprintf ppf "<" - | Pboolcomp Cle -> fprintf ppf "<=" - | Pboolcomp Cgt -> fprintf ppf ">" - | Pboolcomp Cge -> fprintf ppf ">=" - | Pboolorder -> fprintf ppf "compare" - | Pboolmin -> fprintf ppf "min" - | Pboolmax -> fprintf ppf "max" - | Pnegint -> fprintf ppf "~-" - | Paddint -> fprintf ppf "+" - | Pstringadd -> fprintf ppf "+*" - | Psubint -> fprintf ppf "-" - | Pmulint -> fprintf ppf "*" - | Pdivint -> fprintf ppf "/" - | Pmodint -> fprintf ppf "mod" - | Ppowint -> fprintf ppf "**" - | Pandint -> fprintf ppf "and" - | Porint -> fprintf ppf "or" - | Pxorint -> fprintf ppf "xor" - | Pnotint -> fprintf ppf "~~" - | Plslint -> fprintf ppf "lsl" - | Plsrint -> fprintf ppf "lsr" - | Pasrint -> fprintf ppf "asr" - | Pintcomp Ceq -> fprintf ppf "==[int]" - | Pintcomp Cneq -> fprintf ppf "!=[int]" - | Pintcomp Clt -> fprintf ppf "<" - | Pintcomp Cle -> fprintf ppf "<=" - | Pintcomp Cgt -> fprintf ppf ">" - | Pintcomp Cge -> fprintf ppf ">=" - | Pintorder -> fprintf ppf "compare" - | Pintmin -> fprintf ppf "min" - | Pintmax -> fprintf ppf "max" - | Poffsetint n -> fprintf ppf "%i+" n - | Poffsetref n -> fprintf ppf "+:=%i" n - | Pintoffloat -> fprintf ppf "int_of_float" - | Pfloatofint -> fprintf ppf "float_of_int" - | Pnegfloat -> fprintf ppf "~." - | Paddfloat -> fprintf ppf "+." - | Psubfloat -> fprintf ppf "-." - | Pmulfloat -> fprintf ppf "*." - | Pdivfloat -> fprintf ppf "/." - | Pmodfloat -> fprintf ppf "mod" - | Ppowfloat -> fprintf ppf "**" - | Pfloatcomp Ceq -> fprintf ppf "==." - | Pfloatcomp Cneq -> fprintf ppf "!=." - | Pfloatcomp Clt -> fprintf ppf "<." - | Pfloatcomp Cle -> fprintf ppf "<=." - | Pfloatcomp Cgt -> fprintf ppf ">." - | Pfloatcomp Cge -> fprintf ppf ">=." - | Pfloatorder -> fprintf ppf "compare" - | Pfloatmin -> fprintf ppf "min" - | Pfloatmax -> fprintf ppf "max" - | Pnegbigint -> fprintf ppf "~-" - | Paddbigint -> fprintf ppf "+" - | Psubbigint -> fprintf ppf "-" - | Pmulbigint -> fprintf ppf "*" - | Pdivbigint -> fprintf ppf "/" - | Pmodbigint -> fprintf ppf "mod" - | Ppowbigint -> fprintf ppf "**" - | Pandbigint -> fprintf ppf "and" - | Porbigint -> fprintf ppf "or" - | Pxorbigint -> fprintf ppf "xor" - | Pnotbigint -> fprintf ppf "~~" - | Plslbigint -> fprintf ppf "lsl" - | Pasrbigint -> fprintf ppf "asr" - | Pbigintcomp Ceq -> fprintf ppf "==" - | Pbigintcomp Cneq -> fprintf ppf "!=" - | Pbigintcomp Clt -> fprintf ppf "<" - | Pbigintcomp Cle -> fprintf ppf "<=" - | Pbigintcomp Cgt -> fprintf ppf ">" - | Pbigintcomp Cge -> fprintf ppf ">=" - | Pbigintorder -> fprintf ppf "compare" - | Pbigintmin -> fprintf ppf "min" - | Pbigintmax -> fprintf ppf "max" - | Pjscomp Ceq -> fprintf ppf "#==" - | Pjscomp Cneq -> fprintf ppf "#!=" - | Pjscomp Clt -> fprintf ppf "#<" - | Pjscomp Cle -> fprintf ppf "#<=" - | Pjscomp Cgt -> fprintf ppf "#>" - | Pjscomp Cge -> fprintf ppf "#>=" - | Pstringlength -> fprintf ppf "string.length" - | Pstringrefu -> fprintf ppf "string.unsafe_get" - | Pstringrefs -> fprintf ppf "string.get" - | Pstringcomp Ceq -> fprintf ppf "==" - | Pstringcomp Cneq -> fprintf ppf "!=" - | Pstringcomp Clt -> fprintf ppf "<" - | Pstringcomp Cle -> fprintf ppf "<=" - | Pstringcomp Cgt -> fprintf ppf ">" - | Pstringcomp Cge -> fprintf ppf ">=" - | Pstringorder -> fprintf ppf "compare" - | Pstringmin -> fprintf ppf "min" - | Pstringmax -> fprintf ppf "max" - | Parraylength -> fprintf ppf "array.length" - | Pmakearray -> fprintf ppf "makearray" - | Pmakelist -> fprintf ppf "makelist" - | Pmakedict -> fprintf ppf "makedict" - | Pdict_has -> fprintf ppf "dict.has" - | Parrayrefu -> fprintf ppf "array.unsafe_get" - | Parraysetu -> fprintf ppf "array.unsafe_set" - | Parrayrefs -> fprintf ppf "array.get" - | Parraysets -> fprintf ppf "array.set" - | Pisint -> fprintf ppf "isint" - | Pis_poly_var_block -> fprintf ppf "#is_poly_var_block" - | Pisout i -> fprintf ppf "isout %d" i - | Pawait -> fprintf ppf "await" - | Phash -> fprintf ppf "hash" - | Phash_mixint -> fprintf ppf "hash_mix_int" - | Phash_mixstring -> fprintf ppf "hash_mix_string" - | Phash_finalmix -> fprintf ppf "hash_final_mix" - -type print_kind = Alias | Strict | StrictOpt | Variable | Recursive - -let kind = function - | Alias -> "a" - | Strict -> "" - | StrictOpt -> "o" - | Variable -> "v" - | Recursive -> "r" - -let to_print_kind (k : Lam_compat.let_kind) : print_kind = - match k with - | Alias -> Alias - | Strict -> Strict - | StrictOpt -> StrictOpt - | Variable -> Variable - -let rec aux (acc : (print_kind * Ident.t * Lam.t) list) (lam : Lam.t) = - match lam with - | Llet (str3, id3, arg3, body3) -> - aux ((to_print_kind str3, id3, arg3) :: acc) body3 - | Lletrec (bind_args, body) -> - aux - (Ext_list.map_append bind_args acc (fun (id, l) -> (Recursive, id, l))) - body - | e -> (acc, e) - -(* type left_var = - { - kind : print_kind ; - id : Ident.t - } *) - -(* type left = - | Id of left_var *) -(* | Nop *) - -let flatten (lam : 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 - | Lletrec (bind_args, body) -> - aux (Ext_list.map bind_args (fun (id, l) -> (Recursive, id, l))) body - | _ -> assert false - -let lambda ppf v = - let rec lam ppf (l : Lam.t) = - match l with - | Lvar id -> Ident.print ppf id - | Lglobal_module id -> fprintf ppf "global %a" Ident.print id - | Lconst cst -> struct_const ppf cst - | Lapply {ap_func; ap_args; ap_info = {ap_inlined}} -> - let lams ppf args = List.iter (fun l -> fprintf ppf "@ %a" lam l) args in - fprintf ppf "@[<2>(apply%s@ %a%a)@]" - (match ap_inlined with - | Always_inline -> "%inlned" - | _ -> "") - lam ap_func lams ap_args - | Lfunction {params; body; _} -> - let pr_params ppf params = - List.iter (fun param -> fprintf ppf "@ %a" Ident.print param) params - (* | Tupled -> *) - (* fprintf ppf " ("; *) - (* let first = ref true in *) - (* List.iter *) - (* (fun param -> *) - (* if !first then first := false else fprintf ppf ",@ "; *) - (* Ident.print ppf param) *) - (* params; *) - (* fprintf ppf ")" *) - in - fprintf ppf "@[<2>(function%a@ %a)@]" pr_params params lam body - | (Llet _ | Lletrec _) as x -> - let args, body = flatten x in - let bindings ppf id_arg_list = - let spc = ref false in - List.iter - (fun (k, id, l) -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[<2>%a =%s@ %a@]" Ident.print id (kind k) lam l) - id_arg_list - in - fprintf ppf "@[<2>(let@ (@[%a@]" bindings (List.rev args); - fprintf ppf ")@ %a)@]" lam body - | Lprim - { - primitive = Pfield (n, Fld_module {name = s}); - args = [Lglobal_module id]; - _; - } -> - fprintf ppf "%s.%s/%d" id.name s n - | Lprim {primitive = prim; args = largs; _} -> - let lams ppf largs = - List.iter (fun l -> fprintf ppf "@ %a" lam l) largs - in - fprintf ppf "@[<2>(%a%a)@]" primitive prim lams largs - | Lswitch (larg, sw) -> - let switch ppf (sw : Lam.lambda_switch) = - let spc = ref false in - List.iter - (fun (key, l) -> - if !spc then fprintf ppf "@ " else spc := true; - match key with - | Lambda.Switch_int ordinal -> - fprintf ppf "@[case int %i:@ %a@]" ordinal lam l - | Lambda.Switch_constructor (Constant {name}) -> - fprintf ppf "@[case constructor %S:@ %a@]" name lam l - | Lambda.Switch_constructor (Block _) -> assert false) - sw.sw_consts; - List.iter - (fun (key, l) -> - if !spc then fprintf ppf "@ " else spc := true; - match key with - | Lambda.Switch_int ordinal -> - fprintf ppf "@[case tag %i:@ %a@]" ordinal lam l - | Lambda.Switch_constructor (Block {runtime = {tag = {name}}}) -> - fprintf ppf "@[case constructor %S:@ %a@]" name lam l - | Lambda.Switch_constructor (Constant _) -> assert false) - sw.sw_blocks; - match sw.sw_failaction with - | None -> () - | Some l -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[default:@ %a@]" lam l - in - fprintf ppf "@[<1>(%s %a@ @[%a@])@]" - (match sw.sw_failaction with - | None -> "switch*" - | _ -> "switch") - lam larg switch sw - | Lstringswitch (arg, cases, default) -> - let switch ppf cases = - let spc = ref false in - List.iter - (fun (s, l) -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[case \"%s\":@ %a@]" (String.escaped s) lam l) - cases; - match default with - | Some default -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[default:@ %a@]" lam default - | None -> () - in - fprintf ppf "@[<1>(stringswitch %a@ @[%a@])@]" lam arg switch cases - | Lstaticraise (i, ls) -> - let lams ppf largs = - List.iter (fun l -> fprintf ppf "@ %a" lam l) largs - in - fprintf ppf "@[<2>(exit@ %d%a)@]" i lams ls - | Lstaticcatch (lbody, (i, vars), lhandler) -> - fprintf ppf "@[<2>(catch@ %a@;<1 -1>with (%d%a)@ %a)@]" lam lbody i - (fun ppf vars -> - match vars with - | [] -> () - | _ -> List.iter (fun x -> fprintf ppf " %a" Ident.print x) vars) - vars lam lhandler - | Ltrywith (lbody, param, lhandler) -> - fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]" lam lbody Ident.print - param lam lhandler - | Lifthenelse (lcond, lif, lelse) -> - fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" lam lcond lam lif lam lelse - | Lsequence (l1, l2) -> - fprintf ppf "@[<2>(seq@ %a@ %a)@]" lam l1 sequence l2 - | Lbreak -> fprintf ppf "break" - | Lcontinue -> fprintf ppf "continue" - | Lwhile (lcond, lbody) -> - fprintf ppf "@[<2>(while@ %a@ %a)@]" lam lcond lam lbody - | Lfor (param, lo, hi, dir, body) -> - fprintf ppf "@[<2>(for %a@ %a@ %s@ %a@ %a)@]" Ident.print param lam lo - (match dir with - | Upto -> "to" - | Downto -> "downto") - lam hi lam body - | Lfor_of (param, iterable, body) -> - fprintf ppf "@[<2>(for %a@ of@ %a@ %a)@]" Ident.print param lam iterable - lam body - | Lfor_await_of (param, iterable, body) -> - fprintf ppf "@[<2>(for await %a@ of@ %a@ %a)@]" Ident.print param lam - iterable lam body - | Lassign (id, expr) -> - fprintf ppf "@[<2>(assign@ %a@ %a)@]" Ident.print id lam expr - and sequence ppf = function - | Lsequence (l1, l2) -> fprintf ppf "%a@ %a" sequence l1 sequence l2 - | l -> lam ppf l - in - lam ppf v - -(* let structured_constant = struct_const *) - -(* let rec flatten_seq acc (lam : Lam.t) = - match lam with - | Lsequence(l1,l2) -> - flatten_seq (flatten_seq acc l1) l2 - | x -> x :: acc *) - -(* exception Not_a_module *) - -(* let rec flat (acc : (left * Lam.t) list ) (lam : Lam.t) = - match lam with - | Llet (str,id,arg,body) -> - flat ( (Id {kind = to_print_kind str; id}, arg) :: acc) body - | Lletrec (bind_args, body) -> - flat - (Ext_list.map_append bind_args acc - (fun (id, arg ) -> (Id {kind = Recursive; id}, arg)) ) - body - | Lsequence (l,r) -> - flat (flat acc l) r - | x -> (Nop, x) :: acc *) - -(* let lambda_as_module env ppf (lam : Lam.t) = - try - (* match lam with *) - (* | Lprim {primitive = Psetglobal id ; args = [biglambda]; _} *) - (* might be wrong in toplevel *) - (* -> *) - - begin match flat [] lam with - | (Nop, Lprim {primitive = Pmakeblock (_, _); args = toplevels; _}) - :: rest -> - (* let spc = ref false in *) - List.iter - (fun (left, l) -> - match left with - | Id { kind = k; id } -> - fprintf ppf "@[<2>%a =%s@ %a@]@." Ident.print id (kind k) lambda l - | Nop -> - - fprintf ppf "@[<2>%a@]@." lambda l - ) - - @@ List.rev rest - - - | _ -> raise Not_a_module - end - (* | _ -> raise Not_a_module *) - with _ -> - lambda ppf lam; - fprintf ppf "; lambda-failure" *) - -let serialize (filename : string) (lam : Lam.t) : unit = - let ou = open_out filename in - let old = Format.get_margin () in - let () = Format.set_margin 10000 in - let fmt = Format.formatter_of_out_channel ou in - (* lambda_as_module env fmt lambda; *) - lambda fmt lam; - Format.pp_print_flush fmt (); - close_out ou; - Format.set_margin old - -let lambda_to_string = Format.asprintf "%a" lambda diff --git a/compiler/core/lam_print.mli b/compiler/core/lam_print.mli deleted file mode 100644 index f8b6fda4975..00000000000 --- a/compiler/core/lam_print.mli +++ /dev/null @@ -1,31 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val lambda : Format.formatter -> Lam.t -> unit - -val primitive : Format.formatter -> Lam_primitive.t -> unit - -val serialize : string -> Lam.t -> unit - -val lambda_to_string : Lam.t -> string diff --git a/compiler/core/lam_stats_export.ml b/compiler/core/lam_stats_export.ml index 7bf33c0cefd..7f04c5abd18 100644 --- a/compiler/core/lam_stats_export.ml +++ b/compiler/core/lam_stats_export.ml @@ -26,7 +26,7 @@ let single_na = Js_cmj_format.single_na -let values_of_export (meta : Lam_stats.t) (export_map : Lam.t Map_ident.t) : +let values_of_export (meta : Lam_stats.t) (export_map : Lambda.t Map_ident.t) : Js_cmj_format.cmj_value Map_string.t = Ext_list.fold_left meta.exports Map_string.empty (fun acc x -> let arity : Js_cmj_format.arity = @@ -41,7 +41,8 @@ let values_of_export (meta : Lam_stats.t) (export_map : Lam.t Map_ident.t) : | SimpleForm lam -> Lam_arity_analysis.get_arity meta lam)) | Some _ | None -> ( match Map_ident.find_opt export_map x with - | Some (Lprim {primitive = Pmakeblock (_, Immutable); args}) -> + | Some (Lprim {primitive = Pmakeblock info; args}) + when Lambda.is_immutable_block info -> Submodule (Ext_array.of_list_map args (fun lam -> Lam_arity_analysis.get_arity meta lam)) diff --git a/compiler/core/lam_stats_export.mli b/compiler/core/lam_stats_export.mli index 9d8e814581f..ba0238adb5f 100644 --- a/compiler/core/lam_stats_export.mli +++ b/compiler/core/lam_stats_export.mli @@ -28,7 +28,7 @@ val get_dependent_module_effect : val export_to_cmj : Lam_stats.t -> Js_cmj_format.effect_ -> - Lam.t Map_ident.t -> + Lambda.t Map_ident.t -> Js_cmj_format.hoisted_export list -> Ext_js_file_kind.case -> Js_cmj_format.t diff --git a/compiler/core/lam_subst.ml b/compiler/core/lam_subst.ml deleted file mode 100644 index 3be69db85fb..00000000000 --- a/compiler/core/lam_subst.ml +++ /dev/null @@ -1,82 +0,0 @@ -(* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* Apply a substitution to a lambda-term. - Assumes that the bound variables of the lambda-term do not - belong to the domain of the substitution. - Assumes that the image of the substitution is out of reach - of the bound variables of the lambda-term (no capture). *) - -let subst (s : Lam.t Map_ident.t) lam = - let rec subst_aux (x : Lam.t) : Lam.t = - match x with - | Lvar id -> Map_ident.find_default s id x - | Lconst _ -> x - | Lapply {ap_func; ap_args; ap_info} -> - Lam.apply (subst_aux ap_func) (Ext_list.map ap_args subst_aux) ap_info - | Lfunction {arity; params; body; attr; loc} -> - Lam.function_ ~loc ~arity ~params ~body:(subst_aux body) ~attr - | Llet (str, id, arg, body) -> - Lam.let_ str id (subst_aux arg) (subst_aux body) - | Lletrec (decl, body) -> - Lam.letrec (Ext_list.map decl subst_decl) (subst_aux body) - | Lprim {primitive; args; loc} -> - Lam.prim ~primitive ~args:(Ext_list.map args subst_aux) loc - | Lglobal_module _ -> x - | Lswitch (arg, sw) -> - Lam.switch (subst_aux arg) - { - sw with - sw_consts = Ext_list.map sw.sw_consts subst_case; - sw_blocks = Ext_list.map sw.sw_blocks subst_case; - sw_failaction = subst_opt sw.sw_failaction; - } - | Lstringswitch (arg, cases, default) -> - Lam.stringswitch (subst_aux arg) - (Ext_list.map cases subst_strcase) - (subst_opt default) - | Lstaticraise (i, args) -> Lam.staticraise i (Ext_list.map args subst_aux) - | Lstaticcatch (e1, io, e2) -> - Lam.staticcatch (subst_aux e1) io (subst_aux e2) - | Ltrywith (e1, exn, e2) -> Lam.try_ (subst_aux e1) exn (subst_aux e2) - | Lifthenelse (e1, e2, e3) -> - Lam.if_ (subst_aux e1) (subst_aux e2) (subst_aux e3) - | Lsequence (e1, e2) -> Lam.seq (subst_aux e1) (subst_aux e2) - | Lbreak -> Lam.break - | Lcontinue -> Lam.continue - | Lwhile (e1, e2) -> Lam.while_ (subst_aux e1) (subst_aux e2) - | Lfor (v, e1, e2, dir, e3) -> - Lam.for_ v (subst_aux e1) (subst_aux e2) dir (subst_aux e3) - | Lfor_of (v, e1, e2) -> Lam.for_of v (subst_aux e1) (subst_aux e2) - | Lfor_await_of (v, e1, e2) -> - Lam.for_await_of v (subst_aux e1) (subst_aux e2) - | Lassign (id, e) -> Lam.assign id (subst_aux e) - and subst_decl (id, exp) = (id, subst_aux exp) - and subst_case (key, case) = (key, subst_aux case) - and subst_strcase (key, case) = (key, subst_aux case) - and subst_opt = function - | None -> None - | Some e -> Some (subst_aux e) - in - subst_aux lam diff --git a/compiler/core/lam_subst.mli b/compiler/core/lam_subst.mli deleted file mode 100644 index 00836dc8205..00000000000 --- a/compiler/core/lam_subst.mli +++ /dev/null @@ -1,31 +0,0 @@ -(* Copyright (C) 2017 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* Apply a substitution to a lambda-term. - Assumes that the bound variables of the lambda-term do not - belong to the domain of the substitution. - Assumes that the image of the substitution is out of reach - of the bound variables of the lambda-term (no capture). *) - -val subst : Lam.t Map_ident.t -> Lam.t -> Lam.t diff --git a/compiler/core/lam_tag_info.ml b/compiler/core/lam_tag_info.ml deleted file mode 100644 index dddd3d98503..00000000000 --- a/compiler/core/lam_tag_info.ml +++ /dev/null @@ -1,30 +0,0 @@ -(* Copyright (C) 2018-Present Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* Similiar to {!Lambda.tag_info} - In particular, - it reduces some branches e.g, - [Blk_some], [Blk_some_not_nested] -*) -type t = Lambda.tag_info diff --git a/compiler/core/lam_util.ml b/compiler/core/lam_util.ml index aba0e6ea212..56d22841725 100644 --- a/compiler/core/lam_util.ml +++ b/compiler/core/lam_util.ml @@ -55,9 +55,9 @@ let add_required_modules ( x : Ident.t list) (meta : Lam_stats.t) = Falling through keeps the original binding. Only the Alias clause changes evaluation strategy downstream, so we keep its predicate intentionally syntactic and narrow. *) -let refine_let ~kind param (arg : Lam.t) (l : Lam.t) : Lam.t = +let refine_let ~kind param (arg : Lambda.t) (l : Lambda.t) : Lambda.t = let is_block_constructor = function - | Lam_primitive.Pmakeblock _ -> true + | Lambda.Pmakeblock _ -> true | _ -> false in (* SafeAlias is the predicate that justifies the (Alias) rewrite @@ -66,7 +66,7 @@ let refine_let ~kind param (arg : Lam.t) (l : Lam.t) : Lam.t = to inline [e] at every use site or drop `const x = e` entirely, so every clause below must ensure that duplicate evaluation of [e] is equivalent to the single eager evaluation promised by [Strict]/[StrictOpt]. *) - let rec is_safe_to_alias (lam : Lam.t) = + let rec is_safe_to_alias (lam : Lambda.t) = match lam with | Lvar _ | Lconst _ -> (* var/const --> emitting multiple `const` reads is identical to the @@ -91,7 +91,7 @@ let refine_let ~kind param (arg : Lam.t) (l : Lam.t) : Lam.t = is_safe_to_alias inner | _ -> false in - match ((kind : Lam_compat.let_kind), arg, l) with + match ((kind : Lambda.let_kind), arg, l) with | _, _, Lvar w when Ident.same w param -> (* If the body immediately returns the binding (e.g. `{ let x = value; x }`), we skip creating `x` and keep `value`. There is no `rec`, so `value` @@ -103,33 +103,33 @@ let refine_let ~kind param (arg : Lam.t) (l : Lam.t) : Lam.t = `{ let x = value; Array.length(x) }`, we inline the primitive call with `value`. This only happens for primitives that are pure and do not allocate new blocks, so evaluation order and side effects stay the same. *) - Lam.prim ~primitive ~args:[arg] loc + Lambda.prim ~primitive ~args:[arg] loc | _, _, Lapply {ap_func = fn; ap_args = [Lvar w]; ap_info; ap_transformed_jsx} when Ident.same w param && not (Lam_hit.hit_variable param fn) -> (* For a function call such as `{ let x = value; someFn(x) }`, we can rewrite to `someFn(value)` as long as the callee does not capture `x`. This removes the temporary binding while preserving the call semantics. *) - Lam.apply fn [arg] ap_info ~ap_transformed_jsx + Lambda.apply fn [arg] ap_info ~ap_transformed_jsx | (Strict | StrictOpt), arg, _ when is_safe_to_alias arg -> (* `Strict` and `StrictOpt` bindings both evaluate the RHS immediately (with `StrictOpt` allowing later elimination if unused). When that RHS is pure — `{ let x = Some(value); ... }`, `{ let x = 3; ... }`, or a module field read — we mark it as an alias so downstream passes can inline the original expression and drop the temporary. *) - Lam.let_ Alias param arg l + Lambda.let_ Alias param arg l | Strict, Lfunction _, _ -> (* If we eagerly evaluate a function binding such as `{ let makeGreeting = () => "hi"; ... }`, we end up allocating the closure immediately. Downgrading `Strict` to `StrictOpt` preserves the original laziness while still letting later passes inline when safe. *) - Lam.let_ StrictOpt param arg l + Lambda.let_ StrictOpt param arg l | Strict, _, _ when Lam_analysis.no_side_effects arg -> (* A strict binding whose expression has no side effects — think `{ let x = computePure(); use(x); }` — can be relaxed to `StrictOpt`. This keeps the original semantics yet allows downstream passes to skip evaluating `x` when it turns out to be unused. *) - Lam.let_ StrictOpt param arg l - | kind, _, _ -> Lam.let_ kind param arg l + Lambda.let_ StrictOpt param arg l + | kind, _, _ -> Lambda.let_ kind param arg l let alias_ident_or_global (meta : Lam_stats.t) (k : Ident.t) (v : Ident.t) (v_kind : Lam_id_kind.t) = @@ -140,8 +140,8 @@ let alias_ident_or_global (meta : Lam_stats.t) (k : Ident.t) (v : Ident.t) | NA -> ( match Hash_ident.find_opt meta.ident_tbl v with | None -> () - | Some ident_info -> Hash_ident.add meta.ident_tbl k ident_info) - | ident_info -> Hash_ident.add meta.ident_tbl k ident_info + | Some ident_info -> Hash_ident.replace meta.ident_tbl k ident_info) + | ident_info -> Hash_ident.replace meta.ident_tbl k ident_info (* share -- it is safe to share most properties, for arity, we might be careful, only [Alias] can share, @@ -173,7 +173,7 @@ let alias_ident_or_global (meta : Lam_stats.t) (k : Ident.t) (v : Ident.t) mutable fields are explicit, since wen can not inline an mutable block access *) -let element_of_lambda (lam : Lam.t) : Lam_id_kind.element = +let element_of_lambda (lam : Lambda.t) : Lam_id_kind.element = match lam with | Lvar _ | Lconst _ | Lprim @@ -186,15 +186,16 @@ let element_of_lambda (lam : Lam.t) : Lam_id_kind.element = (* | Lfunction _ *) | _ -> NA -let kind_of_lambda_block (xs : Lam.t list) : Lam_id_kind.t = +let kind_of_lambda_block (xs : Lambda.t list) : Lam_id_kind.t = ImmutableBlock (Ext_array.of_list_map xs (fun x -> element_of_lambda x)) -let field_flatten_get lam v i info (tbl : Lam_id_kind.t Hash_ident.t) : Lam.t = +let field_flatten_get lam v i info (tbl : Lam_id_kind.t Hash_ident.t) : Lambda.t + = match Hash_ident.find_opt tbl v with | Some (Module g) -> - Lam.prim + Lambda.prim ~primitive:(Pfield (i, info)) - ~args:[Lam.global_module g] + ~args:[Lambda.global_module g] Location.none | Some (ImmutableBlock arr) -> ( match arr.(i) with @@ -209,27 +210,27 @@ let field_flatten_get lam v i info (tbl : Lam_id_kind.t Hash_ident.t) : Lam.t = if fst fields.(i) = name then found := Ext_list.nth_opt ls i done; match !found with - | Some c when not (Lam_constant.is_allocating c) -> Lam.const c + | Some c when not (Lambda.const_is_allocating c) -> Lambda.const c | _ -> lam ()) | _ -> lam ()) | Some (Constant (Const_block (_, ls))) -> ( match Ext_list.nth_opt ls i with | None -> lam () - | Some x when not (Lam_constant.is_allocating x) -> Lam.const x + | Some x when not (Lambda.const_is_allocating x) -> Lambda.const x | Some _ -> lam ()) | Some _ | None -> lam () -let is_function (lam : Lam.t) = +let is_function (lam : Lambda.t) = match lam with | Lfunction _ -> true | _ -> false -let not_function (lam : Lam.t) = +let not_function (lam : Lambda.t) = match lam with | Lfunction _ -> false | _ -> true (* -let is_var (lam : Lam.t) id = +let is_var (lam : Lambda.t) id = match lam with | Lvar id0 -> Ident.same id0 id | _ -> false *) diff --git a/compiler/core/lam_util.mli b/compiler/core/lam_util.mli index f9b845da901..690d6d35eb6 100644 --- a/compiler/core/lam_util.mli +++ b/compiler/core/lam_util.mli @@ -22,15 +22,15 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val kind_of_lambda_block : Lam.t list -> Lam_id_kind.t +val kind_of_lambda_block : Lambda.t list -> Lam_id_kind.t val field_flatten_get : - (unit -> Lam.t) -> + (unit -> Lambda.t) -> Ident.t -> int -> Lambda.field_dbg_info -> Lam_stats.ident_tbl -> - Lam.t + Lambda.t (** [field_flattern_get cb v i tbl] try to remove the indirection of [v.(i)] by inlining when [v] is a known block, @@ -52,8 +52,9 @@ val field_flatten_get : val alias_ident_or_global : Lam_stats.t -> Ident.t -> Ident.t -> Lam_id_kind.t -> unit -val refine_let : kind:Lam_compat.let_kind -> Ident.t -> Lam.t -> Lam.t -> Lam.t +val refine_let : + kind:Lambda.let_kind -> Ident.t -> Lambda.t -> Lambda.t -> Lambda.t -val not_function : Lam.t -> bool +val not_function : Lambda.t -> bool -val is_function : Lam.t -> bool +val is_function : Lambda.t -> bool diff --git a/compiler/core/lam_var_stats.mli b/compiler/core/lam_var_stats.mli index f4c5b800de6..3761d597d9b 100644 --- a/compiler/core/lam_var_stats.mli +++ b/compiler/core/lam_var_stats.mli @@ -34,7 +34,7 @@ val sink : position val fresh_env : position -val new_position_after_lam : Lam.t -> position -> position +val new_position_after_lam : Lambda.t -> position -> position val update : stats -> position -> stats (** The variable used stats update depend diff --git a/compiler/core/polyvar_pattern_match.ml b/compiler/core/polyvar_pattern_match.ml index d325fcacf51..9f342084671 100644 --- a/compiler/core/polyvar_pattern_match.ml +++ b/compiler/core/polyvar_pattern_match.ml @@ -22,7 +22,7 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type lam = Lambda.lambda +type lam = Lambda.t type hash_names = (int * string) list @@ -61,22 +61,20 @@ let or_list (arg : lam) (hash_names : (int * string) list) = match hash_names with | (hash, name) :: rest -> let init : lam = - Lprim - ( Pintcomp Ceq, - [arg; Lconst (Const_pointer (Pt_variant {name}))], - Location.none ) + Lambda.prim ~primitive:(Pintcomp Ceq) + ~args:[arg; Lambda.const (Lambda.const_polyvar name)] + Location.none in Ext_list.fold_left rest init (fun acc (hash, name) -> - Lambda.Lprim - ( Psequor, + Lambda.prim ~primitive:Psequor + ~args: [ acc; - Lprim - ( Pintcomp Ceq, - [arg; Lconst (Const_pointer (Pt_variant {name}))], - Location.none ); - ], - Location.none )) + Lambda.prim ~primitive:(Pintcomp Ceq) + ~args:[arg; Lambda.const (Lambda.const_polyvar name)] + Location.none; + ] + Location.none) | _ -> assert false let make_test_sequence_variant_constant (fail : lam option) (arg : lam) @@ -88,25 +86,22 @@ let make_test_sequence_variant_constant (fail : lam option) (arg : lam) | (_, act) :: rest, None | rest, Some act -> Ext_list.fold_right rest act (fun (hash_names, act1) acc -> let predicate : lam = or_list arg hash_names in - Lifthenelse (predicate, act1, acc)) + Lambda.if_ predicate act1 acc) | [], None -> assert false -let call_switcher_variant_constant (_loc : Location.t) (fail : lam option) - (arg : lam) (int_lambda_list : (int * (string * lam)) list) = +let call_switcher_variant_constant (fail : lam option) (arg : lam) + (int_lambda_list : (int * (string * lam)) list) = let int_lambda_list = convert int_lambda_list in match (int_lambda_list, fail) with | (_, act) :: rest, None | rest, Some act -> Ext_list.fold_right rest act (fun (hash_names, act1) acc -> let predicate = or_list arg hash_names in - Lifthenelse (predicate, act1, acc)) + Lambda.if_ predicate act1 acc) | [], None -> assert false let call_switcher_variant_constr (loc : Location.t) (fail : lam option) (arg : lam) int_lambda_list : lam = let v = Ident.create "variant" in - Llet - ( Alias, - Pgenval, - v, - Lprim (Pfield (0, Fld_poly_var_tag), [arg], loc), - call_switcher_variant_constant loc fail (Lvar v) int_lambda_list ) + Lambda.let_ Alias v + (Lambda.prim ~primitive:(Pfield (0, Fld_poly_var_tag)) ~args:[arg] loc) + (call_switcher_variant_constant fail (Lambda.var v) int_lambda_list) diff --git a/compiler/ext/ext_list.ml b/compiler/ext/ext_list.ml index 05d9826ab22..0217ed5c522 100644 --- a/compiler/ext/ext_list.ml +++ b/compiler/ext/ext_list.ml @@ -136,6 +136,22 @@ let rec map_snd l f = let y5 = f x5 in (v1, y1) :: (v2, y2) :: (v3, y3) :: (v4, y4) :: (v5, y5) :: map_snd tail f +let rec map_sharing l f = + match l with + | [] -> l + | x :: xs -> + let x' = f x in + let xs' = map_sharing xs f in + if x' == x && xs' == xs then l else x' :: xs' + +let rec map_snd_sharing l f = + match l with + | [] -> l + | (k, x) :: xs -> + let x' = f x in + let xs' = map_snd_sharing xs f in + if x' == x && xs' == xs then l else (k, x') :: xs' + let rec map_last l f = match l with | [] -> [] diff --git a/compiler/ext/ext_list.mli b/compiler/ext/ext_list.mli index add2b277351..0fe22de37a6 100644 --- a/compiler/ext/ext_list.mli +++ b/compiler/ext/ext_list.mli @@ -39,6 +39,13 @@ val mapi_append : 'a list -> (int -> 'a -> 'b) -> 'b list -> 'b list val map_snd : ('a * 'b) list -> ('b -> 'c) -> ('a * 'c) list +val map_sharing : 'a list -> ('a -> 'a) -> 'a list +(** [map_sharing l f] is [map l f], but returns [l] itself when every element + maps to a physically equal value, so an unchanged list allocates nothing. *) + +val map_snd_sharing : ('a * 'b) list -> ('b -> 'b) -> ('a * 'b) list +(** [map_snd] with the sharing of {!map_sharing}. *) + val map_last : 'a list -> (bool -> 'a -> 'b) -> 'b list (** [map_last f xs ] will pass [true] to [f] for the last element, diff --git a/compiler/ext/ext_option.ml b/compiler/ext/ext_option.ml index 92a2439a972..7e7e133a5ac 100644 --- a/compiler/ext/ext_option.ml +++ b/compiler/ext/ext_option.ml @@ -27,6 +27,13 @@ let map v f = | None -> None | Some x -> Some (f x) +let map_sharing v f = + match v with + | None -> v + | Some x -> + let x' = f x in + if x' == x then v else Some x' + let iter v f = match v with | None -> () diff --git a/compiler/ext/ext_option.mli b/compiler/ext/ext_option.mli index 41e0bb042df..d9860f97c64 100644 --- a/compiler/ext/ext_option.mli +++ b/compiler/ext/ext_option.mli @@ -26,6 +26,10 @@ val map : 'a option -> ('a -> 'b) -> 'b option +val map_sharing : 'a option -> ('a -> 'a) -> 'a option +(** [map] that returns the option itself when the value is physically + unchanged, so it allocates nothing. *) + val iter : 'a option -> ('a -> unit) -> unit val exists : 'a option -> ('a -> bool) -> bool diff --git a/compiler/ext/primitive_modules.ml b/compiler/ext/primitive_modules.ml index 3a567de5242..dc87480a872 100644 --- a/compiler/ext/primitive_modules.ml +++ b/compiler/ext/primitive_modules.ml @@ -50,8 +50,6 @@ let hash = "Primitive_hash" let exceptions = "Primitive_exceptions" -let curry = "Primitive_curry" - let util = "Primitive_util" let js_extern = "Primitive_js_extern" diff --git a/compiler/frontend/bs_ast_invariant.ml b/compiler/frontend/bs_ast_invariant.ml index 07accd4efef..6aaf07f2a74 100644 --- a/compiler/frontend/bs_ast_invariant.ml +++ b/compiler/frontend/bs_ast_invariant.ml @@ -91,12 +91,6 @@ let emit_external_warnings : iterator = (fun self ({pexp_loc = loc} as a) -> match a.pexp_desc with | Pexp_constant const -> check_constant loc const - | Pexp_variant (s, None) when Ext_string.is_valid_hash_number s -> ( - try ignore (Ext_string.hash_number_as_i32_exn s : int32) - with _ -> - Location.raise_errorf ~loc - "Integer literal exceeds int32 range. Use float or BigInt if \ - larger values are required.") | _ -> super.expr self a); label_declaration = (fun self lbl -> diff --git a/compiler/frontend/lam_constant.ml b/compiler/frontend/lam_constant.ml deleted file mode 100644 index 851a565f7ae..00000000000 --- a/compiler/frontend/lam_constant.ml +++ /dev/null @@ -1,103 +0,0 @@ -(* Copyright (C) 2018- Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type t = - | Const_js_null - | Const_js_undefined of {is_unit: bool} - | Const_js_true - | Const_js_false - | Const_int of int32 - | Const_assertfalse - | Const_constructor of Variant_runtime.tag - (* Constant constructor of a nominal variant, emitted from its - canonical runtime descriptor rather than an ordinal *) - | Const_char of int - | Const_string of {s: string; delim: External_arg_spec.delim option} - | Const_float of string - | Const_bigint of bool * string - | Const_pointer of string - | Const_block of Lambda.tag_info * t list - | Const_some of t - | Const_module_alias -(* eventually we can remove it, since we know - [constant] is [undefined] or not -*) - -let rec eq_approx (x : t) (y : t) = - match x with - | Const_module_alias -> y = Const_module_alias - | Const_js_null -> y = Const_js_null - | Const_js_undefined b -> y = Const_js_undefined b - | Const_js_true -> y = Const_js_true - | Const_js_false -> y = Const_js_false - | Const_int ix -> ( - match y with - | Const_int iy -> ix = iy - | _ -> false) - | Const_assertfalse -> y = Const_assertfalse - | Const_constructor ix -> ( - match y with - | Const_constructor iy -> ix = iy - | _ -> false) - | Const_char ix -> ( - match y with - | Const_char iy -> ix = iy - | _ -> false) - | Const_string {s = sx; delim = ux} -> ( - match y with - | Const_string {s = sy; delim = uy} -> sx = sy && ux = uy - | _ -> false) - | Const_float ix -> ( - match y with - | Const_float iy -> ix = iy - | _ -> false) - | Const_bigint (sx, ix) -> ( - match y with - | Const_bigint (sy, iy) -> sx = sy && ix = iy - | _ -> false) - | Const_pointer ix -> ( - match y with - | Const_pointer iy -> ix = iy - | _ -> false) - | Const_block (ix, ixs) -> ( - match y with - | Const_block (iy, iys) -> - ix = iy && Ext_list.for_all2_no_exn ixs iys eq_approx - | _ -> false) - | Const_some ix -> ( - match y with - | Const_some iy -> eq_approx ix iy - | _ -> false) - -let lam_none : t = Const_js_undefined {is_unit = false} - -let rec is_allocating (c : t) : bool = - match c with - | Const_some t -> is_allocating t - | Const_block _ -> true - | Const_js_null | Const_js_undefined _ | Const_js_true | Const_js_false - | Const_int _ | Const_assertfalse | Const_constructor _ | Const_char _ - | Const_string _ | Const_float _ | Const_bigint _ | Const_pointer _ - | Const_module_alias -> - false diff --git a/compiler/frontend/lam_constant.mli b/compiler/frontend/lam_constant.mli deleted file mode 100644 index 93096c98971..00000000000 --- a/compiler/frontend/lam_constant.mli +++ /dev/null @@ -1,51 +0,0 @@ -(* Copyright (C) 2018 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type t = - | Const_js_null - | Const_js_undefined of {is_unit: bool} - | Const_js_true - | Const_js_false - | Const_int of int32 - | Const_assertfalse - | Const_constructor of Variant_runtime.tag - (* Constant constructor of a nominal variant, emitted from its - canonical runtime descriptor rather than an ordinal *) - | Const_char of int - | Const_string of {s: string; delim: External_arg_spec.delim option} - | Const_float of string - | Const_bigint of bool * string - | Const_pointer of string - | Const_block of Lambda.tag_info * t list - | Const_some of t - (* eventually we can remove it, since we know - [constant] is [undefined] or not - *) - | Const_module_alias - -val eq_approx : t -> t -> bool - -val lam_none : t - -val is_allocating : t -> bool diff --git a/compiler/jsoo/jsoo_playground_main.ml b/compiler/jsoo/jsoo_playground_main.ml index 2e4536b6958..22a8ee36b48 100644 --- a/compiler/jsoo/jsoo_playground_main.ml +++ b/compiler/jsoo/jsoo_playground_main.ml @@ -547,8 +547,7 @@ module Compile = struct Printer.to_string Printtyped.implementation_with_coercion typed_tree in let lambda_output = Printer.to_string Printlambda.lambda lambda in - let lam, _ = Lam_convert.convert lambda in - let lam = Lam_print.lambda_to_string lam in + let lam = Printlambda.lambda_to_string lambda in let debug_attrs = Js.Unsafe. [| diff --git a/compiler/ml/dune b/compiler/ml/dune index 7a286e14044..98a6ccc065f 100644 --- a/compiler/ml/dune +++ b/compiler/ml/dune @@ -1,7 +1,7 @@ (env (_ (flags - (:standard -w +a-4-42-40-41-44-45-9-48-67-70)))) + (:standard -w +a-4-42-40-41-44-45-9-48-67-70-30)))) ; The browser profile builds the playground compiler; this rule pair generates a module from platform/{native,playground}. diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index b9f2243f2d1..9e045e99330 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -29,7 +29,7 @@ type tag_info = runtime: Variant_runtime.block_runtime; } | Blk_tuple - | Blk_poly_var of string + | Blk_poly_var | Blk_record of { fields: (string * bool (* optional *)) array; mutable_flag: Asttypes.mutable_flag; @@ -37,9 +37,6 @@ type tag_info = | Blk_module of string list | Blk_module_export of Ident.t list | Blk_extension - | Blk_some - | Blk_some_not_nested - (* ['a option] where ['a] can not inhabit a non-like value *) | Blk_record_ext of { fields: string array; mutable_flag: Asttypes.mutable_flag; @@ -50,9 +47,8 @@ type tag_info = let tag_label_of_tag_info (tag : tag_info) = match tag with | Blk_constructor {name} | Blk_record_inlined {name} -> name - | Blk_tuple | Blk_poly_var _ | Blk_record _ | Blk_module _ - | Blk_module_export _ | Blk_extension | Blk_some | Blk_some_not_nested - | Blk_record_ext _ -> + | Blk_tuple | Blk_poly_var | Blk_record _ | Blk_module _ | Blk_module_export _ + | Blk_extension | Blk_record_ext _ -> "0" let mutable_flag_of_tag_info (tag : tag_info) = @@ -61,8 +57,8 @@ let mutable_flag_of_tag_info (tag : tag_info) = | Blk_record {mutable_flag} | Blk_record_ext {mutable_flag} -> mutable_flag - | Blk_tuple | Blk_constructor _ | Blk_poly_var _ | Blk_module _ - | Blk_module_export _ | Blk_extension | Blk_some_not_nested | Blk_some -> + | Blk_tuple | Blk_constructor _ | Blk_poly_var | Blk_module _ + | Blk_module_export _ | Blk_extension -> Immutable type label = Types.label_description @@ -170,18 +166,17 @@ type import_source = name; [] means the external is the module itself *) } -(* Table keys for `%identity` / `%ignore` / unary `+`. [mk_prim] expands - these; they must not appear as [Lprim] nodes. *) +(* `%identity` / `%ignore` / unary `+`: builtins that erase at translation + rather than primitives. See [builtin]. *) type eliminated = Identity | Ignore type primitive = - | Peliminated of eliminated | Pdebugger | Ptypeof - | Pnull - | Pundefined - | Pfn_arity - | Pgetglobal of Ident.t + | Psome + | Psome_not_nest + (** [Some x] where [x] cannot itself be [undefined], so no wrapping is + needed. *) (* Operations on heap blocks *) | Pmakeblock of tag_info | Pfield of int * field_dbg_info @@ -234,8 +229,6 @@ type primitive = | Pintorder | Pintmin | Pintmax - | Poffsetint of int - | Poffsetref of int (* Float operations *) | Pintoffloat | Pfloatofint @@ -303,16 +296,17 @@ type primitive = (* Test if the argument is a block or an immediate integer *) | Pisint (* Test if the (integer) argument is outside an interval *) - | Pisout (* Test if the argument is null or undefined *) - | Pisnullable + | Pis_null_undefined (* exn *) | Pcreate_extension of string (* js *) - | Pcurry_apply of int | Pjscomp of comparison | Pnull_to_opt - | Pnullable_to_opt + | Pnull_undefined_to_opt + (* Produced by Lam_pass_remove_alias, not by translation *) + | Pis_null + | Pis_undefined | Pis_not_none | Pval_from_option | Pval_from_option_not_nest @@ -324,25 +318,39 @@ type primitive = and comparison = Ceq | Cneq | Clt | Cgt | Cle | Cge -and value_kind = Pgenval - -type pointer_info = - | Pt_constructor of Variant_runtime.tag - | Pt_variant of {name: string} - | Pt_module_alias - | Pt_shape_none - | Pt_assertfalse - type structured_constant = | Const_int of int32 | Const_char of int | Const_string of {s: string; delim: External_arg_spec.delim option} | Const_float of string | Const_bigint of bool * string - | Const_pointer of pointer_info | Const_block of tag_info * structured_constant list - | Const_false - | Const_true + | Const_constructor of Variant_runtime.tag + (** Constant constructor of a nominal variant, from its canonical + runtime descriptor. Integer-represented ones are [Const_int]. *) + | Const_polyvar of string + (** Tagless polymorphic variant; numeric-looking names are [Const_int]. *) + | Const_assertfalse + | Const_module_alias + | Const_js_false + | Const_js_true + | Const_js_null + | Const_some of structured_constant + | Const_js_undefined of {is_unit: bool} + (** [is_unit] tells the unit value apart from JS [undefined]; both emit + [undefined]. *) + +(* What a `%builtin` name in the primitive table means. Only [Primitive] + reaches the IR: [mk_builtin] erases the other cases at translation, so + they need no [primitive] constructor to stand in for them. *) +type builtin = + | Primitive of primitive + | Eliminated of eliminated + | Constant of structured_constant + | Offset_ref of int + (** [%incr] / [%decr]: an assignment through the reference, expanded here + so the caller's own IR carries the form its escape analysis reads. *) + type inline_attribute = | Always_inline (* [@inline] or [@inline always] *) | Never_inline (* [@inline never] *) @@ -359,42 +367,47 @@ type function_attribute = { one_unit_arg: bool; } -type lambda = +type t = | Lvar of Ident.t + | Lglobal_module of Ident.t + (** A reference to another compilation unit: a name the module system + resolves, not a value this one computes. *) | Lconst of structured_constant | Lapply of lambda_apply | Lfunction of lfunction - | Llet of let_kind * value_kind * Ident.t * lambda * lambda - | Lletrec of (Ident.t * lambda) list * lambda - | Lprim of primitive * lambda list * Location.t - | Lswitch of lambda * lambda_switch * Location.t - | Lstringswitch of - lambda * (string * lambda) list * lambda option * Location.t - | Lstaticraise of int * lambda list - | Lstaticcatch of lambda * (int * Ident.t list) * lambda - | Ltrywith of lambda * Ident.t * lambda - | Lifthenelse of lambda * lambda * lambda - | Lsequence of lambda * lambda + | Llet of let_kind * Ident.t * t * t + | Lletrec of (Ident.t * t) list * t + | Lprim of prim_info + | Lswitch of t * lambda_switch + | Lstringswitch of t * (string * t) list * t option + | Lstaticraise of int * t list + | Lstaticcatch of t * (int * Ident.t list) * t + | Ltrywith of t * Ident.t * t + | Lifthenelse of t * t * t + | Lsequence of t * t | Lbreak | Lcontinue - | Lwhile of lambda * lambda - | Lfor of Ident.t * lambda * lambda * Asttypes.direction_flag * lambda - | Lfor_of of Ident.t * lambda * lambda - | Lfor_await_of of Ident.t * lambda * lambda - | Lassign of Ident.t * lambda + | Lwhile of t * t + | Lfor of Ident.t * t * t * Asttypes.direction_flag * t + | Lfor_of of Ident.t * t * t + | Lfor_await_of of Ident.t * t * t + | Lassign of Ident.t * t and lfunction = { params: Ident.t list; - body: lambda; + body: t; attr: function_attribute; (* specified with [@inline] attribute *) loc: Location.t; } +and prim_info = {primitive: primitive; args: t list; loc: Location.t} + +and ap_info = {ap_loc: Location.t; ap_inlined: inline_attribute} + and lambda_apply = { - ap_func: lambda; - ap_args: lambda list; - ap_loc: Location.t; - ap_inlined: inline_attribute; + ap_func: t; + ap_args: t list; + ap_info: ap_info; ap_transformed_jsx: bool; } @@ -415,7 +428,7 @@ and 'a switch = { sw_dispatch: switch_dispatch; } -and lambda_switch = lambda switch +and lambda_switch = t switch (* This is actually a dummy value not necessary "()", it can be used as a place holder for module @@ -434,28 +447,841 @@ let const_of_typed (c : Asttypes.constant) : structured_constant = | Asttypes.Const_float f -> Const_float f | Asttypes.Const_bigint (sign, i) -> Const_bigint (sign, i) -let const_unit = - Const_pointer (Pt_constructor {Variant_runtime.name = "()"; tag_type = None}) +let const_unit = Const_js_undefined {is_unit = true} + +(* The JS value of a constant constructor: unit has its own constant, and a + constructor represented as a number is a genuine number at runtime, so + folding sees it as an ordinary integer. *) +let const_constructor (tag : Variant_runtime.tag) = + if tag.name = "()" then const_unit + else + match tag.tag_type with + | Some (Variant_runtime.Int v) -> Const_int (Int32.of_int v) + | _ -> Const_constructor tag -let lambda_assert_false = Lconst (Const_pointer Pt_assertfalse) +(* A constructor with an optional shape carries no payload when constant. *) +let const_shape_none = Const_js_undefined {is_unit = false} -let lambda_module_alias = Lconst (Const_pointer Pt_module_alias) +(* The JS value of a polymorphic variant's name: a numeric-looking name is a + number at runtime, anything else is a string. Used both for a tagless + variant and for the name field of one carrying a payload. *) +let const_polyvar name = + if Ext_string.is_valid_hash_number name then + Const_int (Ext_string.hash_number_as_i32_exn name) + else Const_polyvar name + +let const_polyvar_name name = + match const_polyvar name with + | Const_polyvar s -> Const_string {s; delim = None} + | c -> c + +let const_module_alias = Const_module_alias + +let lambda_assert_false = Lconst Const_assertfalse + +let lambda_module_alias = Lconst const_module_alias let lambda_unit = Lconst const_unit +let lambda_true = Lconst Const_js_true +let lambda_false = Lconst Const_js_false + +(* [r := r.contents + delta]. The reference is mentioned twice, so bind it + unless it is already a variable. *) +let offset_ref ~delta r loc = + let assign r = + Lprim + { + primitive = Psetfield (0, ref_field_set_info); + args = + [ + r; + Lprim + { + primitive = Paddint; + args = + [ + Lprim + {primitive = Pfield (0, ref_field_info); args = [r]; loc}; + Lconst (const_int delta); + ]; + loc; + }; + ]; + loc; + } + in + match r with + | Lvar _ -> assign r + | _ -> + let id = Ident.create "ref" in + Llet (Strict, id, r, assign (Lvar id)) + +let eq_comparison (p : comparison) (p1 : comparison) = p = p1 + +let eq_field_dbg_info (x : field_dbg_info) (y : field_dbg_info) = x = y +let eq_set_field_dbg_info (x : set_field_dbg_info) (y : set_field_dbg_info) = + x = y + +let eq_tag_info (x : tag_info) y = x = y + +let eq_primitive_approx (lhs : primitive) (rhs : primitive) = + match lhs with + | Praise + (* generic comparison *) + | Pobjorder | Pobjmin | Pobjmax | Pobjtag | Pobjsize + (* bool primitives *) + | Psequand | Psequor | Pnot | Pboolcomp _ | Pboolorder | Pboolmin | Pboolmax + (* int primitives *) + | Pisint | Pnegint | Paddint | Psubint | Pmulint | Pdivint | Pmodint | Ppowint + | Pnotint | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint + | Pintorder | Pintmin | Pintmax + (* float primitives *) + | Pintoffloat | Pfloatofint | Pnegfloat | Paddfloat | Psubfloat | Pmulfloat + | Pdivfloat | Pmodfloat | Ppowfloat | Pfloatorder | Pfloatmin | Pfloatmax + (* bigint primitives *) + | Pnegbigint | Paddbigint | Psubbigint | Pmulbigint | Pdivbigint | Pmodbigint + | Ppowbigint | Pnotbigint | Pandbigint | Porbigint | Pxorbigint | Plslbigint + | Pasrbigint | Pbigintorder | Pbigintmin | Pbigintmax + (* string primitives *) + | Pstringlength | Pstringrefu | Pstringrefs | Pstringadd | Pstringcomp _ + | Pstringorder | Pstringmin | Pstringmax + (* List primitives *) + | Pmakelist + (* dict primitives *) + | Pmakedict | Pdict_has + (* promise *) + | Pawait + (* etc *) + | Pval_from_option | Pval_from_option_not_nest | Pnull_to_opt + | Pnull_undefined_to_opt | Pis_null | Pis_not_none | Psome | Psome_not_nest + | Pis_undefined | Pis_null_undefined | Ptypeof | Pis_poly_var_block + | Pdebugger | Pinit_mod | Pupdate_mod | Pduprecord | Pmakearray | Parraylength + | Parrayrefu | Parraysetu | Parrayrefs | Parraysets | Pjs_fn_method | Phash + | Phash_mixstring | Phash_mixint | Phash_finalmix | Precord_rest _ -> + rhs = lhs + (* Reachable only via the optimizer's term-equality comparison, which the + test suite doesn't exercise for tagged templates. *) + | Ptagged_template -> ( ((rhs = lhs) [@coverage off])) + | Pcreate_extension a -> ( + match rhs with + | Pcreate_extension b -> a = (b : string) + | _ -> false) + (* | Pcaml_obj_set_length -> rhs = Pcaml_obj_set_length *) + | Pfield (n0, info0) -> ( + match rhs with + | Pfield (n1, info1) -> n0 = n1 && eq_field_dbg_info info0 info1 + | _ -> false) + | Psetfield (i0, info0) -> ( + match rhs with + | Psetfield (i1, info1) -> i0 = i1 && eq_set_field_dbg_info info0 info1 + | _ -> false) + | Pmakeblock info0 -> ( + match rhs with + | Pmakeblock info1 -> eq_tag_info info0 info1 + | _ -> false) + | Pjs_call {prim_name; arg_types; ffi; _} -> ( + match rhs with + | Pjs_call rhs -> + prim_name = rhs.prim_name && arg_types = rhs.arg_types && ffi = rhs.ffi + | _ -> false) + | Pimport src -> ( + match rhs with + | Pimport src2 -> src = src2 + | _ -> false) + | Pjs_object_create obj_create -> ( + match rhs with + | Pjs_object_create obj_create1 -> obj_create = obj_create1 + | _ -> false) + | Pobjcomp comparison -> ( + match rhs with + | Pobjcomp comparison1 -> eq_comparison comparison comparison1 + | _ -> false) + | Pintcomp comparison -> ( + match rhs with + | Pintcomp comparison1 -> eq_comparison comparison comparison1 + | _ -> false) + | Pfloatcomp comparison -> ( + match rhs with + | Pfloatcomp comparison1 -> eq_comparison comparison comparison1 + | _ -> false) + | Pbigintcomp comparison -> ( + match rhs with + | Pbigintcomp comparison1 -> eq_comparison comparison comparison1 + | _ -> false) + | Pjscomp comparison -> ( + match rhs with + | Pjscomp comparison1 -> eq_comparison comparison comparison1 + | _ -> false) + | Pjs_object_get name -> ( + match rhs with + | Pjs_object_get rhs_name -> name = rhs_name + | _ -> false) + | Pjs_object_set name -> ( + match rhs with + | Pjs_object_set rhs_name -> name = rhs_name + | _ -> false) + | Praw_js_code _ -> false +(* TOO lazy, here comparison is only approximation*) + +(* The source-level name a field access carries, when it has one. *) +let str_of_field_info (x : field_dbg_info) : string option = + match x with + | Fld_extension | Fld_variant | Fld_cons | Fld_poly_var_tag + | Fld_poly_var_content | Fld_tuple -> + None + | Fld_record {name} + | Fld_module {name} + | Fld_record_inline {name} + | Fld_record_extension {name} -> + Some name + +let is_immutable_block (info : tag_info) = + mutable_flag_of_tag_info info = Immutable + +(* A constant that has to be built at run time rather than shared. *) +let rec const_is_allocating (c : structured_constant) : bool = + match c with + | Const_some t -> const_is_allocating t + | Const_block _ -> true + | Const_js_null | Const_js_undefined _ | Const_js_true | Const_js_false + | Const_int _ | Const_assertfalse | Const_constructor _ | Const_char _ + | Const_string _ | Const_float _ | Const_bigint _ | Const_polyvar _ + | Const_module_alias -> + false + +let rec const_eq_approx (x : structured_constant) (y : structured_constant) = + match x with + | Const_module_alias -> y = Const_module_alias + | Const_js_null -> y = Const_js_null + | Const_js_undefined b -> y = Const_js_undefined b + | Const_js_true -> y = Const_js_true + | Const_js_false -> y = Const_js_false + | Const_int ix -> ( + match y with + | Const_int iy -> ix = iy + | _ -> false) + | Const_assertfalse -> y = Const_assertfalse + | Const_constructor ix -> ( + match y with + | Const_constructor iy -> ix = iy + | _ -> false) + | Const_char ix -> ( + match y with + | Const_char iy -> ix = iy + | _ -> false) + | Const_string {s = sx; delim = ux} -> ( + match y with + | Const_string {s = sy; delim = uy} -> sx = sy && ux = uy + | _ -> false) + | Const_float ix -> ( + match y with + | Const_float iy -> ix = iy + | _ -> false) + | Const_bigint (sx, ix) -> ( + match y with + | Const_bigint (sy, iy) -> sx = sy && ix = iy + | _ -> false) + | Const_polyvar ix -> ( + match y with + | Const_polyvar iy -> ix = iy + | _ -> false) + | Const_block (ix, ixs) -> ( + match y with + | Const_block (iy, iys) -> + ix = iy && Ext_list.for_all2_no_exn ixs iys const_eq_approx + | _ -> false) + | Const_some ix -> ( + match y with + | Const_some iy -> const_eq_approx ix iy + | _ -> false) + +let cmp_int32 (cmp : comparison) (a : int32) b : bool = + match cmp with + | Ceq -> a = b + | Cneq -> a <> b + | Cgt -> a > b + | Cle -> a <= b + | Clt -> a < b + | Cge -> a >= b + +let cmp_float (cmp : comparison) (a : float) b : bool = + match cmp with + | Ceq -> a = b + | Cneq -> a <> b + | Cgt -> a > b + | Cle -> a <= b + | Clt -> a < b + | Cge -> a >= b + +(* Constructors. The type is private outside this module, so every term is + built through one of these. They are plain for now; the normalizations that + Lambda.prim / Lambda.if_ / Lambda.switch perform will move here when the two layers + become one type. *) + +let var id : t = Lvar id +let global_module id : t = Lglobal_module id +let const ct : t = Lconst ct + +let function_ ~loc ~attr ~params ~body : t = Lfunction {params; body; attr; loc} + +let let_ kind id e body : t = Llet (kind, id, e, body) +let letrec bindings body : t = Lletrec (bindings, body) + +let staticraise i args : t = Lstaticraise (i, args) +let staticcatch body catch handler : t = Lstaticcatch (body, catch, handler) +let try_ body id handler : t = Ltrywith (body, id, handler) +let break : t = Lbreak +let continue : t = Lcontinue +let while_ cond body : t = Lwhile (cond, body) +let for_ id from_ to_ dir body : t = Lfor (id, from_, to_, dir, body) +let for_of id iterable body : t = Lfor_of (id, iterable, body) + +let for_await_of id iterable body : t = Lfor_await_of (id, iterable, body) + +let assign id body : t = Lassign (id, body) + +exception Not_simple_form + +(** + + + [is_eta_conversion_exn params inner_args outer_args] + case 1: + {{ + (fun params -> wrap (primitive (inner_args)) args + }} + when [inner_args] are the same as [params], it can be simplified as + [wrap (primitive args)] + + where [wrap] used to be simple instructions + Note that [external] functions are forced to do eta-conversion + when combined with [|>] operator, we need to make sure beta-reduction + is applied though since `[@variadic]` needs such guarantee. + Since `[@variadic] is the tail position +*) +let rec is_eta_conversion_exn params inner_args outer_args : t list = + match (params, inner_args, outer_args) with + | x :: xs, Lvar y :: ys, r :: rest when Ident.same x y -> + r :: is_eta_conversion_exn xs ys rest + | [], [], [] -> [] + | _, _, _ -> raise_notrace Not_simple_form + +let rec apply ?(ap_transformed_jsx = false) fn args (ap_info : ap_info) : t = + match fn with + | Lfunction + { + params; + body = + Lprim + { + primitive = + ( Pnull_to_opt | Pnull_undefined_to_opt | Pis_null + | Pis_null_undefined | Ptypeof ) as wrap; + args = + [Lprim ({primitive = _; args = inner_args} as primitive_call)]; + }; + } -> ( + match is_eta_conversion_exn params inner_args args with + | args -> + let loc = ap_info.ap_loc in + Lprim + {primitive = wrap; args = [Lprim {primitive_call with args; loc}]; loc} + | exception Not_simple_form -> + Lapply {ap_func = fn; ap_args = args; ap_info; ap_transformed_jsx}) + | Lfunction + { + params; + body = Lprim ({primitive = _; args = inner_args} as primitive_call); + } -> ( + match is_eta_conversion_exn params inner_args args with + | args -> Lprim {primitive_call with args; loc = ap_info.ap_loc} + | exception _ -> + Lapply {ap_func = fn; ap_args = args; ap_info; ap_transformed_jsx}) + | Lfunction + { + params; + body = + Lsequence + ( Lprim ({primitive = _; args = inner_args} as primitive_call), + (Lconst _ as const) ); + } -> ( + match is_eta_conversion_exn params inner_args args with + | args -> + Lsequence (Lprim {primitive_call with args; loc = ap_info.ap_loc}, const) + | exception _ -> + Lapply {ap_func = fn; ap_args = args; ap_info; ap_transformed_jsx} + (* | Lfunction {params;body} when Ext_list.same_length params args -> + Ext_list.fold_right2 (fun p arg acc -> + Llet(Strict,p,arg,acc) + ) params args body *) + (* TODO: more rigirous analysis on [let_kind] *)) + | Llet (kind, id, e, (Lfunction _ as fn)) -> + Llet (kind, id, e, apply fn args ap_info ~ap_transformed_jsx) + (* | Llet (kind0, id0, e0, Llet (kind,id, e, (Lfunction _ as fn))) -> + Llet(kind0,id0,e0,Llet (kind, id, e, apply fn args loc status)) *) + | _ -> Lapply {ap_func = fn; ap_args = args; ap_info; ap_transformed_jsx} + +let rec eq_approx (l1 : t) (l2 : t) = + match l1 with + | Lglobal_module i1 -> ( + match l2 with + | Lglobal_module i2 -> Ident.same i1 i2 + | _ -> false) + | Lvar i1 -> ( + match l2 with + | Lvar i2 -> Ident.same i1 i2 + | _ -> false) + | Lconst c1 -> ( + match l2 with + | Lconst c2 -> const_eq_approx c1 c2 + | _ -> false) + | Lapply app1 -> ( + match l2 with + | Lapply app2 -> + eq_approx app1.ap_func app2.ap_func + && eq_approx_list app1.ap_args app2.ap_args + | _ -> false) + | Lifthenelse (a, b, c) -> ( + match l2 with + | Lifthenelse (a0, b0, c0) -> + eq_approx a a0 && eq_approx b b0 && eq_approx c c0 + | _ -> false) + | Lsequence (a, b) -> ( + match l2 with + | Lsequence (a0, b0) -> eq_approx a a0 && eq_approx b b0 + | _ -> false) + | Lbreak -> l2 = Lbreak + | Lcontinue -> l2 = Lcontinue + | Lwhile (p, b) -> ( + match l2 with + | Lwhile (p0, b0) -> eq_approx p p0 && eq_approx b b0 + | _ -> false) + | Lassign (v0, l0) -> ( + match l2 with + | Lassign (v1, l1) -> Ident.same v0 v1 && eq_approx l0 l1 + | _ -> false) + | Lstaticraise (id, ls) -> ( + match l2 with + | Lstaticraise (id1, ls1) -> id = id1 && eq_approx_list ls ls1 + | _ -> false) + | Lprim info1 -> ( + match l2 with + | Lprim info2 -> + eq_primitive_approx info1.primitive info2.primitive + && eq_approx_list info1.args info2.args + | _ -> false) + | Lstringswitch (arg, patterns, default) -> ( + match l2 with + | Lstringswitch (arg2, patterns2, default2) -> + eq_approx arg arg2 && eq_option default default2 + && Ext_list.for_all2_no_exn patterns patterns2 + (fun ((k : string), v) (k2, v2) -> k = k2 && eq_approx v v2) + | _ -> false) + | Lfunction _ + | Llet (_, _, _, _) + | Lletrec _ | Lswitch _ | Lstaticcatch _ | Ltrywith _ + | Lfor (_, _, _, _, _) + | Lfor_of (_, _, _) + | Lfor_await_of (_, _, _) -> + false + +and eq_option l1 l2 = + match l1 with + | None -> l2 = None + | Some l1 -> ( + match l2 with + | Some l2 -> eq_approx l1 l2 + | None -> false) + +and eq_approx_list ls ls1 = Ext_list.for_all2_no_exn ls ls1 eq_approx + +let switch lam (lam_switch : lambda_switch) : t = + let action_or_switch = function + | Some action -> action + | None -> ( + match lam_switch.sw_failaction with + | Some action -> action + | None -> Lswitch (lam, lam_switch)) + in + match lam with + | Lconst (Const_constructor cstr_name) -> + let action = + Ext_list.find_opt lam_switch.sw_consts (fun (key, action) -> + match key with + | Switch_constructor (Constant tag) when cstr_name = tag -> + Some action + | Switch_int _ | Switch_constructor _ -> None) + in + action_or_switch action + | Lconst (Const_int i) -> + (* Because of inlining and dead code, we might be looking at a value of unexpected type + e.g. an integer, so the const case might not be found *) + let i = Int32.to_int i in + let action = + Ext_list.find_opt lam_switch.sw_consts (fun (key, action) -> + match key with + | Switch_int ordinal when ordinal = i -> Some action + | Switch_constructor + (Constant {tag_type = Some (Variant_runtime.Int value)}) + when value = i -> + Some action + | Switch_int _ | Switch_constructor _ -> None) + in + action_or_switch action + | Lconst (Const_block (tag_info, _)) -> + let runtime = + match tag_info with + | Blk_constructor {runtime} | Blk_record_inlined {runtime} -> Some runtime + | Blk_tuple | Blk_poly_var | Blk_record _ | Blk_record_ext _ + | Blk_module _ | Blk_module_export _ | Blk_extension -> + None + in + let action = + Ext_list.find_opt lam_switch.sw_blocks (fun (key, action) -> + match key with + | Switch_constructor (Block {runtime = case_runtime}) + when runtime = Some case_runtime -> + Some action + | Switch_int _ | Switch_constructor _ -> None) + in + action_or_switch action + | _ -> Lswitch (lam, lam_switch) + +let stringswitch (lam : t) cases default : t = + match lam with + | Lconst (Const_string {s; delim = None | Some DNoQuotes}) -> + Ext_list.assoc_by_string cases s default + | _ -> Lstringswitch (lam, cases, default) + +let rec seq (a : t) b : t = + match a with + | Lprim {primitive = Pmakeblock _; args = x :: xs} -> + seq (Ext_list.fold_left xs x seq) b + | Lprim {primitive = Pnull_to_opt | Pnull_undefined_to_opt; args = [a]} -> + seq a b + | _ -> Lsequence (a, b) + +module Lift = struct + let int i : t = Lconst (Const_int i) + + let bool b = if b then lambda_true else lambda_false + + let string s : t = Lconst (Const_string {s; delim = None}) + + let char b : t = Lconst (Const_char b) +end + +let prim ~primitive:(prim : primitive) ~args loc : t = + let default () : t = Lprim {primitive = prim; args; loc} in + match args with + | [Lconst a] -> ( + match (prim, a) with + | Pnegint, Const_int i -> Lift.int (Int32.neg i) + (* | Pfloatofint, ( (Const_int a)) *) + (* -> Lift.float (float_of_int a) *) + | Pintoffloat, Const_float a -> + Lift.int (Int32.of_float (float_of_string a)) + (* | Pnegfloat -> Lift.float (-. a) *) + | Pstringlength, Const_string {s; delim = None} -> + Lift.int (Int32.of_int (String.length s)) + (* | Pnegbint Pnativeint, ( (Const_nativeint i)) *) + (* -> *) + (* Lift.nativeint (Nativeint.neg i) *) + | Pnot, Const_js_true -> lambda_false + | Pnot, Const_js_false -> lambda_true + | _ -> default ()) + | [Lconst a; Lconst b] -> ( + match (prim, a, b) with + | Pintcomp cmp, Const_int a, Const_int b -> Lift.bool (cmp_int32 cmp a b) + | Pfloatcomp cmp, Const_float a, Const_float b -> + (* FIXME: could raise? *) + Lift.bool (cmp_float cmp (float_of_string a) (float_of_string b)) + | Pbigintcomp _, Const_bigint _, Const_bigint _ -> default () + | Pintcomp ((Ceq | Cneq) as op), Const_polyvar a, Const_polyvar b -> + Lift.bool + (match op with + | Ceq -> a = (b : string) + | Cneq -> a <> b + | _ -> assert false) + | ( Pintcomp ((Ceq | Cneq) as op), + Const_constructor {name = a; tag_type = None}, + Const_constructor {name = b; tag_type = None} ) -> + (* Both runtime representations are the constructor names *) + Lift.bool + (match op with + | Ceq -> a = b + | Cneq -> a <> b + | _ -> assert false) + | ( ( Paddint | Psubint | Pmulint | Pdivint | Pmodint | Pandint | Porint + | Pxorint | Plslint | Plsrint | Pasrint ), + Const_int aa, + Const_int bb ) -> ( + (* WE SHOULD keep it as [int], to preserve types *) + let int_ = Lift.int in + match prim with + | Paddint -> int_ (Int32.add aa bb) + | Psubint -> int_ (Int32.sub aa bb) + | Pmulint -> int_ (Int32.mul aa bb) + | Pdivint -> if bb = 0l then default () else int_ (Int32.div aa bb) + | Pmodint -> if bb = 0l then default () else int_ (Int32.rem aa bb) + | Pandint -> int_ (Int32.logand aa bb) + | Porint -> int_ (Int32.logor aa bb) + | Pxorint -> int_ (Int32.logxor aa bb) + | Plslint -> int_ (Int32.shift_left aa (Int32.to_int bb)) + | Plsrint -> int_ (Int32.shift_right_logical aa (Int32.to_int bb)) + | Pasrint -> int_ (Int32.shift_right aa (Int32.to_int bb)) + | _ -> default ()) + | Psequand, Const_js_false, (Const_js_true | Const_js_false) -> lambda_false + | Psequand, Const_js_true, Const_js_true -> lambda_true + | Psequand, Const_js_true, Const_js_false -> lambda_false + | Psequor, Const_js_true, (Const_js_true | Const_js_false) -> lambda_true + | Psequor, Const_js_false, Const_js_true -> lambda_true + | Psequor, Const_js_false, Const_js_false -> lambda_false + | ( Pstringadd, + Const_string {s = a; delim = None}, + Const_string {s = b; delim = None} ) -> + Lift.string (a ^ b) + | ( (Pstringrefs | Pstringrefu), + Const_string {s = a; delim = None}, + Const_int b ) -> ( + try Lift.char (Char.code (String.get a (Int32.to_int b))) + with _ -> default ()) + | _ -> default ()) + | _ -> ( + match prim with + | Pmakeblock (Blk_module fields) -> ( + let rec aux fields args (var : Ident.t) i = + match (fields, args) with + | [], [] -> true + | ( f :: fields, + Lprim + { + primitive = Pfield (pos, Fld_module {name = f1}); + args = [(Lglobal_module v1 | Lvar v1)]; + } + :: args ) -> + pos = i && f = f1 && Ident.same var v1 && aux fields args var (i + 1) + | _, _ -> false + in + match (fields, args) with + | ( field1 :: rest, + Lprim + { + primitive = Pfield (pos, Fld_module {name = f1}); + args = [((Lglobal_module v1 | Lvar v1) as lam)]; + } + :: args1 ) -> + if pos = 0 && field1 = f1 && aux rest args1 v1 1 then lam + else default () + | _ -> default ()) + (* In this level, include is already expanded, so that + {[ + { x0 : y0 ; x1 : y1 } + ]} + such module x can indeed be replaced by module y + *) + | _ -> default ()) + +let not_ loc x : t = + match x with + | Lprim ({primitive = Pintcomp Cneq} as prim) -> + Lprim {prim with primitive = Pintcomp Ceq} + | _ -> prim ~primitive:Pnot ~args:[x] loc + +let has_boolean_type (x : t) = + match x with + | Lprim + { + primitive = + ( Pnot | Psequand | Psequor | Pis_not_none | Pobjcomp _ | Pboolcomp _ + | Pintcomp _ | Pfloatcomp _ | Pbigintcomp _ | Pstringcomp _ ); + loc; + } -> + Some loc + | _ -> None -let mk_prim p args loc = - match p with - | Peliminated kind -> ( - match kind with - | Identity -> ( - match args with - | [arg] -> arg - | _ -> assert false) - | Ignore -> ( - match args with - | [arg] -> Lsequence (arg, lambda_unit) - | _ -> assert false)) - | _ -> Lprim (p, args, loc) +let rec eval_const_as_bool (v : structured_constant) : bool option = + match v with + | Const_int x -> Some (x <> 0l) + | Const_assertfalse -> Some false + | Const_char x -> Some (x <> 0) + | Const_js_false | Const_js_null | Const_module_alias | Const_js_undefined _ + -> + Some false + | Const_js_true | Const_string _ | Const_polyvar _ | Const_float _ + | Const_bigint _ | Const_block _ -> + Some true + | Const_some b -> eval_const_as_bool b + | Const_constructor {name; tag_type} -> ( + (* Truthiness of the canonical runtime representation *) + match tag_type with + | None -> Some (name <> "[]") (* the name string; [] is the number 0 *) + | Some (String s) -> Some (s <> "") + | Some (Int i) -> Some (i <> 0) + | Some (Bool b) -> Some b + | Some Null | Some Undefined -> Some false + | Some (Float _ | BigInt _ | Untagged _) -> None) + +let if_ (a : t) (b : t) (c : t) : t = + match a with + | Lconst v -> ( + match eval_const_as_bool v with + | Some v -> if v then b else c + | None -> Lifthenelse (a, b, c)) + | _ -> ( + match (b, c) with + | _, Lconst Const_assertfalse -> + seq a b (* TODO: we could customize more cases *) + | Lconst Const_assertfalse, _ -> seq a c + | Lconst Const_js_true, Lconst Const_js_false -> + if has_boolean_type a != None then a else Lifthenelse (a, b, c) + | Lconst Const_js_false, Lconst Const_js_true -> ( + match has_boolean_type a with + | Some loc -> not_ loc a + | None -> Lifthenelse (a, b, c)) + (* [if a then raise e else c] could become [(if a then raise e else ()); c], + but that is code motion, not normalization: it changes the shape that + matching's own exit bookkeeping inspects after the term is assembled, + and doing it here leaves static raises without their catch. It is + {!Lam_pass_guard_raises} instead. *) + | _ -> ( + match a with + | Lprim {primitive = Pisint; args = [Lvar i]; _} -> ( + match b with + | Lifthenelse + (Lprim {primitive = Pintcomp Ceq; args = [Lvar j; Lconst _]}, _, b_f) + when Ident.same i j && eq_approx b_f c -> + b + | Lprim {primitive = Pintcomp Ceq; args = [Lvar j; Lconst _]} + when Ident.same i j && eq_approx lambda_false c -> + b + | Lifthenelse + ( Lprim + ({primitive = Pintcomp Cneq; args = [Lvar j; Lconst _]} as + b_pred), + b_t, + b_f ) + when Ident.same i j && eq_approx b_t c -> + Lifthenelse (Lprim {b_pred with primitive = Pintcomp Ceq}, b_f, b_t) + | Lprim + {primitive = Pintcomp Cneq; args = [Lvar j; Lconst _] as args; loc} + | Lprim + { + primitive = Pnot; + args = + [ + Lprim + { + primitive = Pintcomp Ceq; + args = [Lvar j; Lconst _] as args; + loc; + }; + ]; + } + when Ident.same i j && eq_approx lambda_true c -> + Lprim {primitive = Pintcomp Cneq; args; loc} + | _ -> Lifthenelse (a, b, c)) + | _ -> Lifthenelse (a, b, c))) + +(** [shallow_map_sharing f lam] rewrites [lam]'s immediate children with [f] + and rebuilds the node through its smart constructor, so the result is + normalized. A node whose children all come back physically unchanged is + returned as-is, so a traversal that rewrites nothing allocates nothing. *) +let shallow_map_sharing (f : t -> t) (lam : t) : t = + match lam with + | Lvar _ | Lglobal_module _ | Lconst _ | Lbreak | Lcontinue -> lam + | Lapply ap -> + let fn = f ap.ap_func in + let args = Ext_list.map_sharing ap.ap_args f in + if fn == ap.ap_func && args == ap.ap_args then lam + else apply fn args ap.ap_info ~ap_transformed_jsx:ap.ap_transformed_jsx + | Lfunction {params; body; attr; loc} -> + let body' = f body in + if body' == body then lam else function_ ~loc ~attr ~params ~body:body' + | Llet (k, id, e, b) -> + let e' = f e and b' = f b in + if e' == e && b' == b then lam else let_ k id e' b' + | Lletrec (bs, b) -> + let bs' = Ext_list.map_snd_sharing bs f and b' = f b in + if bs' == bs && b' == b then lam else letrec bs' b' + | Lprim {primitive; args; loc} -> + let args' = Ext_list.map_sharing args f in + if args' == args then lam else prim ~primitive ~args:args' loc + | Lswitch (e, sw) -> + let e' = f e in + let consts = Ext_list.map_snd_sharing sw.sw_consts f in + let blocks = Ext_list.map_snd_sharing sw.sw_blocks f in + let fail = Ext_option.map_sharing sw.sw_failaction f in + if + e' == e && consts == sw.sw_consts && blocks == sw.sw_blocks + && fail == sw.sw_failaction + then lam + else + switch e' + {sw with sw_consts = consts; sw_blocks = blocks; sw_failaction = fail} + | Lstringswitch (e, cases, d) -> + let e' = f e in + let cases' = Ext_list.map_snd_sharing cases f in + let d' = Ext_option.map_sharing d f in + if e' == e && cases' == cases && d' == d then lam + else stringswitch e' cases' d' + | Lstaticraise (i, args) -> + let args' = Ext_list.map_sharing args f in + if args' == args then lam else staticraise i args' + | Lstaticcatch (b, h, hd) -> + let b' = f b and hd' = f hd in + if b' == b && hd' == hd then lam else staticcatch b' h hd' + | Ltrywith (b, id, h) -> + let b' = f b and h' = f h in + if b' == b && h' == h then lam else try_ b' id h' + | Lifthenelse (a, b, c) -> + let a' = f a and b' = f b and c' = f c in + if a' == a && b' == b && c' == c then lam else if_ a' b' c' + | Lsequence (a, b) -> + let a' = f a and b' = f b in + if a' == a && b' == b then lam else seq a' b' + | Lwhile (a, b) -> + let a' = f a and b' = f b in + if a' == a && b' == b then lam else while_ a' b' + | Lfor (id, a, b, d, c) -> + let a' = f a and b' = f b and c' = f c in + if a' == a && b' == b && c' == c then lam else for_ id a' b' d c' + | Lfor_of (id, a, b) -> + let a' = f a and b' = f b in + if a' == a && b' == b then lam else for_of id a' b' + | Lfor_await_of (id, a, b) -> + let a' = f a and b' = f b in + if a' == a && b' == b then lam else for_await_of id a' b' + | Lassign (id, b) -> + let b' = f b in + if b' == b then lam else assign id b' + +let sequor l r = if_ l lambda_true r + +(** [l && r] *) +let sequand l r = if_ l r lambda_false + +(** [l && r ] *) + +let mk_builtin b args loc = + match b with + | Primitive p -> Lprim {primitive = p; args; loc} + | Constant c -> ( + match args with + | [] -> Lconst c + | _ -> assert false) + | Offset_ref delta -> ( + match args with + | [r] -> offset_ref ~delta r loc + | _ -> assert false) + | Eliminated Identity -> ( + match args with + | [arg] -> arg + | _ -> assert false) + | Eliminated Ignore -> ( + match args with + | [arg] -> Lsequence (arg, lambda_unit) + | _ -> assert false) let default_function_attribute = { @@ -487,34 +1313,34 @@ let make_key e = (* Too big ! *) match e with | Lvar id -> ( try Ident.find_same id env with Not_found -> e) - | Lconst _ -> e + | Lglobal_module _ | Lconst _ -> e | Lapply ap -> Lapply { ap with ap_func = tr_rec env ap.ap_func; ap_args = tr_recs env ap.ap_args; - ap_loc = Location.none; + ap_info = {ap.ap_info with ap_loc = Location.none}; } - | Llet (Alias, _k, x, ex, e) -> + | Llet (Alias, x, ex, e) -> (* Ignore aliases -> substitute *) let ex = tr_rec env ex in tr_rec (Ident.add x ex env) e - | Llet ((Strict | StrictOpt), _k, x, ex, Lvar v) when Ident.same v x -> + | Llet ((Strict | StrictOpt), x, ex, Lvar v) when Ident.same v x -> tr_rec env ex - | Llet (str, k, x, ex, e) -> + | Llet (str, x, ex, e) -> (* Because of side effects, keep other lets with normalized names *) let ex = tr_rec env ex in let y = make_key x in - Llet (str, k, y, ex, tr_rec (Ident.add x (Lvar y) env) e) - | Lprim (p, es, _) -> mk_prim p (tr_recs env es) Location.none - | Lswitch (e, sw, loc) -> Lswitch (tr_rec env e, tr_sw env sw, loc) - | Lstringswitch (e, sw, d, _) -> + Llet (str, y, ex, tr_rec (Ident.add x (Lvar y) env) e) + | Lprim {primitive = p; args = es; loc = _} -> + Lprim {primitive = p; args = tr_recs env es; loc = Location.none} + | Lswitch (e, sw) -> Lswitch (tr_rec env e, tr_sw env sw) + | Lstringswitch (e, sw, d) -> Lstringswitch ( tr_rec env e, List.map (fun (s, e) -> (s, tr_rec env e)) sw, - tr_opt env d, - Location.none ) + tr_opt env d ) | Lstaticraise (i, es) -> Lstaticraise (i, tr_recs env es) | Lstaticcatch (e1, xs, e2) -> Lstaticcatch (tr_rec env e1, xs, tr_rec env e2) @@ -550,87 +1376,63 @@ let name_lambda strict arg fn = | Lvar id -> fn id | _ -> let id = Ident.create "let" in - Llet (strict, Pgenval, id, arg, fn id) + Llet (strict, id, arg, fn id) -let iter_opt f = function - | None -> () - | Some e -> f e - -let iter f = function - | Lvar _ | Lconst _ -> () - | Lapply {ap_func = fn; ap_args = args} -> - f fn; - List.iter f args +(* Does any immediate child satisfy [f]? Short-circuits. *) +let shallow_exists (f : t -> bool) (lam : t) : bool = + match lam with + | Lvar _ | Lglobal_module _ | Lconst _ | Lbreak | Lcontinue -> false + | Lapply {ap_func; ap_args} -> f ap_func || Ext_list.exists ap_args f | Lfunction {body} -> f body - | Llet (_str, _k, _id, arg, body) -> - f arg; - f body - | Lletrec (decl, body) -> - f body; - List.iter (fun (_id, exp) -> f exp) decl - | Lprim (_p, args, _loc) -> List.iter f args - | Lswitch (arg, sw, _) -> - f arg; - List.iter (fun (_key, case) -> f case) sw.sw_consts; - List.iter (fun (_key, case) -> f case) sw.sw_blocks; - iter_opt f sw.sw_failaction - | Lstringswitch (arg, cases, default, _) -> - f arg; - List.iter (fun (_, act) -> f act) cases; - iter_opt f default - | Lstaticraise (_, args) -> List.iter f args - | Lstaticcatch (e1, _, e2) -> - f e1; - f e2 - | Ltrywith (e1, _, e2) -> - f e1; - f e2 - | Lifthenelse (e1, e2, e3) -> - f e1; - f e2; - f e3 - | Lsequence (e1, e2) -> - f e1; - f e2 - | Lbreak | Lcontinue -> () - | Lwhile (e1, e2) -> - f e1; - f e2 - | Lfor (_v, e1, e2, _dir, e3) -> - f e1; - f e2; - f e3 - | Lfor_of (_v, e1, e2) -> - f e1; - f e2 - | Lfor_await_of (_v, e1, e2) -> - f e1; - f e2 + | Llet (_, _, arg, body) -> f arg || f body + | Lletrec (decl, body) -> f body || Ext_list.exists_snd decl f + | Lprim {args} -> Ext_list.exists args f + | Lswitch (arg, {sw_consts; sw_blocks; sw_failaction}) -> + f arg + || Ext_list.exists_snd sw_consts f + || Ext_list.exists_snd sw_blocks f + || Ext_option.exists sw_failaction f + | Lstringswitch (arg, cases, default) -> + f arg || Ext_list.exists_snd cases f || Ext_option.exists default f + | Lstaticraise (_, args) -> Ext_list.exists args f + | Lstaticcatch (e1, _, e2) -> f e1 || f e2 + | Ltrywith (e1, _, e2) -> f e1 || f e2 + | Lifthenelse (e1, e2, e3) -> f e1 || f e2 || f e3 + | Lsequence (e1, e2) -> f e1 || f e2 + | Lwhile (e1, e2) -> f e1 || f e2 + | Lfor (_, e1, e2, _, e3) -> f e1 || f e2 || f e3 + | Lfor_of (_, e1, e2) | Lfor_await_of (_, e1, e2) -> f e1 || f e2 | Lassign (_, e) -> f e -module Ident_set = Set.Make (Ident) +let iter f lam = + ignore + (shallow_exists + (fun x -> + f x; + false) + lam) let free_ids get l = - let fv = ref Ident_set.empty in + let fv = ref Set_ident.empty in let rec free l = iter free l; - fv := List.fold_right Ident_set.add (get l) !fv; + fv := List.fold_left Set_ident.add !fv (get l); match l with | Lfunction {params} -> - List.iter (fun param -> fv := Ident_set.remove param !fv) params - | Llet (_str, _k, id, _arg, _body) -> fv := Ident_set.remove id !fv + List.iter (fun param -> fv := Set_ident.remove !fv param) params + | Llet (_str, id, _arg, _body) -> fv := Set_ident.remove !fv id | Lletrec (decl, _body) -> - List.iter (fun (id, _exp) -> fv := Ident_set.remove id !fv) decl + List.iter (fun (id, _exp) -> fv := Set_ident.remove !fv id) decl | Lstaticcatch (_e1, (_, vars), _e2) -> - List.iter (fun id -> fv := Ident_set.remove id !fv) vars - | Ltrywith (_e1, exn, _e2) -> fv := Ident_set.remove exn !fv - | Lfor (v, _e1, _e2, _dir, _e3) -> fv := Ident_set.remove v !fv + List.iter (fun id -> fv := Set_ident.remove !fv id) vars + | Ltrywith (_e1, exn, _e2) -> fv := Set_ident.remove !fv exn + | Lfor (v, _e1, _e2, _dir, _e3) -> fv := Set_ident.remove !fv v | Lfor_of (v, _e1, _e2) | Lfor_await_of (v, _e1, _e2) -> - fv := Ident_set.remove v !fv - | Lassign (id, _e) -> fv := Ident_set.add id !fv - | Lvar _ | Lconst _ | Lapply _ | Lprim _ | Lswitch _ | Lstringswitch _ - | Lstaticraise _ | Lifthenelse _ | Lsequence _ | Lbreak | Lcontinue - | Lwhile _ -> + fv := Set_ident.remove !fv v + | Lassign (id, _e) -> fv := Set_ident.add !fv id + | Lvar _ | Lglobal_module _ | Lconst _ | Lapply _ | Lprim _ | Lswitch _ + | Lstringswitch _ | Lstaticraise _ | Lifthenelse _ | Lsequence _ | Lbreak + | Lcontinue | Lwhile _ -> () in free l; @@ -661,27 +1463,32 @@ let staticfail = Lstaticraise (0, []) let rec is_guarded = function | Lifthenelse (_cond, _body, Lstaticraise (0, [])) -> true - | Llet (_str, _k, _id, _lam, body) -> is_guarded body + | Llet (_str, _id, _lam, body) -> is_guarded body | _ -> false let rec patch_guarded patch = function | Lifthenelse (cond, body, Lstaticraise (0, [])) -> Lifthenelse (cond, body, patch) - | Llet (str, k, id, lam, body) -> - Llet (str, k, id, lam, patch_guarded patch body) + | Llet (str, id, lam, body) -> Llet (str, id, lam, patch_guarded patch body) | _ -> assert false (* Translate an access path *) let rec transl_normal_path = function | Path.Pident id -> - if Ident.global id then Lprim (Pgetglobal id, [], Location.none) + (* A predefined exception is its own name at runtime, so the reference is + that string rather than a module. *) + if Ident.is_predef_exn id then + Lconst (Const_string {s = id.name; delim = None}) + else if Ident.global id then Lglobal_module id else Lvar id | Pdot (p, s, pos) -> Lprim - ( Pfield (pos, Fld_module {name = s}), - [transl_normal_path p], - Location.none ) + { + primitive = Pfield (pos, Fld_module {name = s}); + args = [transl_normal_path p]; + loc = Location.none; + } | Papply _ -> assert false (* Translation of identifiers *) @@ -700,59 +1507,40 @@ let transl_extension_path = transl_value_path Assumes that the image of the substitution is out of reach of the bound variables of the lambda-term (no capture). *) +(* Substitution rebuilds through [shallow_map_sharing], so the result is + normalized and an untouched subterm is returned physically unchanged. *) let subst_lambda s lam = - let rec subst = function - | Lvar id as l -> ( try Ident.find_same id s with Not_found -> l) - | Lconst _ as l -> l - | Lapply ap -> - Lapply - { - ap with - ap_func = subst ap.ap_func; - ap_args = List.map subst ap.ap_args; - } - | Lfunction {params; body; attr; loc} -> - Lfunction {params; body = subst body; attr; loc} - | Llet (str, k, id, arg, body) -> Llet (str, k, id, subst arg, subst body) - | Lletrec (decl, body) -> Lletrec (List.map subst_decl decl, subst body) - | Lprim (p, args, loc) -> mk_prim p (List.map subst args) loc - | Lswitch (arg, sw, loc) -> - Lswitch - ( subst arg, - { - sw with - sw_consts = List.map subst_case sw.sw_consts; - sw_blocks = List.map subst_case sw.sw_blocks; - sw_failaction = subst_opt sw.sw_failaction; - }, - loc ) - | Lstringswitch (arg, cases, default, loc) -> - Lstringswitch - (subst arg, List.map subst_strcase cases, subst_opt default, loc) - | Lstaticraise (i, args) -> Lstaticraise (i, List.map subst args) - | Lstaticcatch (e1, io, e2) -> Lstaticcatch (subst e1, io, subst e2) - | Ltrywith (e1, exn, e2) -> Ltrywith (subst e1, exn, subst e2) - | Lifthenelse (e1, e2, e3) -> Lifthenelse (subst e1, subst e2, subst e3) - | Lsequence (e1, e2) -> Lsequence (subst e1, subst e2) - | Lbreak -> Lbreak - | Lcontinue -> Lcontinue - | Lwhile (e1, e2) -> Lwhile (subst e1, subst e2) - | Lfor (v, e1, e2, dir, e3) -> Lfor (v, subst e1, subst e2, dir, subst e3) - | Lfor_of (v, e1, e2) -> Lfor_of (v, subst e1, subst e2) - | Lfor_await_of (v, e1, e2) -> Lfor_await_of (v, subst e1, subst e2) - | Lassign (id, e) -> Lassign (id, subst e) - and subst_decl (id, exp) = (id, subst exp) - and subst_case (key, case) = (key, subst case) - and subst_strcase (key, case) = (key, subst case) - and subst_opt = function - | None -> None - | Some e -> Some (subst e) + let rec subst l = + match l with + | Lvar id -> ( try Ident.find_same id s with Not_found -> l) + | _ -> shallow_map_sharing subst l in subst lam +let make_exit i = Lstaticraise (i, []) + +let rec as_simple_exit = function + | Lstaticraise (i, []) -> Some i + | Llet (Alias, _, _, e) -> as_simple_exit e + | _ -> None + +(* Introduce a catch around [handler], if worth it. Returns the exit number to + raise to, and a function wrapping a body in the catch - a body that turns + out to be exactly that raise gets the handler itself instead. *) +let make_catch_delayed handler = + match as_simple_exit handler with + | Some i -> (i, fun act -> act) + | None -> ( + let i = next_raise_count () in + ( i, + fun body -> + match body with + | Lstaticraise (j, _) -> if i = j then handler else body + | _ -> Lstaticcatch (body, (i, []), handler) )) + (* To let-bind expressions to variables *) let bind str var exp body = match exp with | Lvar var' when Ident.same var var' -> body - | _ -> Llet (str, Pgenval, var, exp, body) + | _ -> Llet (str, var, exp, body) diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index 5f5bdb29a90..895faedfae1 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -33,7 +33,7 @@ type tag_info = runtime: Variant_runtime.block_runtime; } | Blk_tuple - | Blk_poly_var of string + | Blk_poly_var | Blk_record of { fields: (string * bool (* optional *)) array; mutable_flag: mutable_flag; @@ -50,9 +50,6 @@ type tag_info = [A, x, y] ]} *) - | Blk_some - | Blk_some_not_nested - (* ['a option] where ['a] can not inhabit a non-like value *) | Blk_record_ext of {fields: string array; mutable_flag: mutable_flag} val find_name : Parsetree.attribute -> Asttypes.label option @@ -114,13 +111,6 @@ val fld_record_extension_set : Types.label_description -> set_field_dbg_info type immediate_or_pointer = Immediate | Pointer -type pointer_info = - | Pt_constructor of Variant_runtime.tag - | Pt_variant of {name: string} - | Pt_module_alias - | Pt_shape_none - | Pt_assertfalse - (* The target of a dynamic [import], resolved at translation: the argument of the import primitive is a module reference, never an expression. *) type import_source = @@ -136,16 +126,17 @@ type import_source = name; [] means the external is the module itself *) } +(* `%identity` / `%ignore` / unary `+`: builtins that erase at translation + rather than primitives. See [builtin]. *) type eliminated = Identity | Ignore type primitive = - | Peliminated of eliminated | Pdebugger | Ptypeof - | Pnull - | Pundefined - | Pfn_arity - | Pgetglobal of Ident.t + | Psome + | Psome_not_nest + (** [Some x] where [x] cannot itself be [undefined], so no wrapping is + needed. *) (* Operations on heap blocks *) | Pmakeblock of tag_info | Pfield of int * field_dbg_info @@ -198,8 +189,6 @@ type primitive = | Pintorder | Pintmin | Pintmax - | Poffsetint of int - | Poffsetref of int (* Float operations *) | Pintoffloat | Pfloatofint @@ -267,16 +256,17 @@ type primitive = (* Test if the argument is a block or an immediate integer *) | Pisint (* Test if the (integer) argument is outside an interval *) - | Pisout (* Test if the argument is null or undefined *) - | Pisnullable + | Pis_null_undefined (* exn *) | Pcreate_extension of string (* js *) - | Pcurry_apply of int | Pjscomp of comparison | Pnull_to_opt - | Pnullable_to_opt + | Pnull_undefined_to_opt + (* Produced by Lam_pass_remove_alias, not by translation *) + | Pis_null + | Pis_undefined | Pis_not_none | Pval_from_option | Pval_from_option_not_nest @@ -287,18 +277,38 @@ type primitive = and comparison = Ceq | Cneq | Clt | Cgt | Cle | Cge -and value_kind = Pgenval - type structured_constant = | Const_int of int32 | Const_char of int | Const_string of {s: string; delim: External_arg_spec.delim option} | Const_float of string | Const_bigint of bool * string - | Const_pointer of pointer_info | Const_block of tag_info * structured_constant list - | Const_false - | Const_true + | Const_constructor of Variant_runtime.tag + (** Constant constructor of a nominal variant, from its canonical + runtime descriptor. Integer-represented ones are [Const_int]. *) + | Const_polyvar of string + (** Tagless polymorphic variant; numeric-looking names are [Const_int]. *) + | Const_assertfalse + | Const_module_alias + | Const_js_false + | Const_js_true + | Const_js_null + | Const_some of structured_constant + | Const_js_undefined of {is_unit: bool} + (** [is_unit] tells the unit value apart from JS [undefined]; both emit + [undefined]. *) + +(* What a `%builtin` name in the primitive table means. Only [Primitive] + reaches the IR: [mk_builtin] erases the other cases at translation, so + they need no [primitive] constructor to stand in for them. *) +type builtin = + | Primitive of primitive + | Eliminated of eliminated + | Constant of structured_constant + | Offset_ref of int + (** [%incr] / [%decr]: an assignment through the reference, expanded here + so the caller's own IR carries the form its escape analysis reads. *) type inline_attribute = | Always_inline (* [@inline] or [@inline always] *) @@ -327,44 +337,52 @@ type function_attribute = { one_unit_arg: bool; } -type lambda = +type t = private | Lvar of Ident.t + | Lglobal_module of Ident.t + (** A reference to another compilation unit: a name the module system + resolves, not a value this one computes. *) | Lconst of structured_constant | Lapply of lambda_apply | Lfunction of lfunction - | Llet of let_kind * value_kind * Ident.t * lambda * lambda - | Lletrec of (Ident.t * lambda) list * lambda - | Lprim of primitive * lambda list * Location.t - | Lswitch of lambda * lambda_switch * Location.t + | Llet of let_kind * Ident.t * t * t + | Lletrec of (Ident.t * t) list * t + | Lprim of prim_info + | Lswitch of t * lambda_switch (* switch on strings, clauses are sorted by string order, strings are pairwise distinct *) - | Lstringswitch of - lambda * (string * lambda) list * lambda option * Location.t - | Lstaticraise of int * lambda list - | Lstaticcatch of lambda * (int * Ident.t list) * lambda - | Ltrywith of lambda * Ident.t * lambda - | Lifthenelse of lambda * lambda * lambda - | Lsequence of lambda * lambda + | Lstringswitch of t * (string * t) list * t option + | Lstaticraise of int * t list + | Lstaticcatch of t * (int * Ident.t list) * t + | Ltrywith of t * Ident.t * t + | Lifthenelse of t * t * t + | Lsequence of t * t | Lbreak | Lcontinue - | Lwhile of lambda * lambda - | Lfor of Ident.t * lambda * lambda * direction_flag * lambda - | Lfor_of of Ident.t * lambda * lambda - | Lfor_await_of of Ident.t * lambda * lambda - | Lassign of Ident.t * lambda + | Lwhile of t * t + | Lfor of Ident.t * t * t * direction_flag * t + | Lfor_of of Ident.t * t * t + | Lfor_await_of of Ident.t * t * t + | Lassign of Ident.t * t and lfunction = { params: Ident.t list; - body: lambda; + body: t; attr: function_attribute; (* specified with [@inline] attribute *) loc: Location.t; } -and lambda_apply = { - ap_func: lambda; - ap_args: lambda list; +and prim_info = private {primitive: primitive; args: t list; loc: Location.t} + +and ap_info = { ap_loc: Location.t; ap_inlined: inline_attribute; (* specified with the [@inlined] attribute *) +} + +and lambda_apply = private { + ap_func: t; + ap_args: t list; + ap_info: ap_info; ap_transformed_jsx: bool; } @@ -385,7 +403,7 @@ and 'a switch = { sw_dispatch: switch_dispatch; } -and lambda_switch = lambda switch +and lambda_switch = t switch (* Lambda code for the middle-end. * In the closure case the code is a sequence of assignments to a @@ -400,33 +418,147 @@ and lambda_switch = lambda switch *) (* Sharing key *) -val make_key : lambda -> lambda option +val make_key : t -> t option val const_int : int -> structured_constant val const_string : string -> string option -> structured_constant val const_of_typed : constant -> structured_constant val const_unit : structured_constant -val lambda_assert_false : lambda -val lambda_unit : lambda +val const_constructor : Variant_runtime.tag -> structured_constant +val const_shape_none : structured_constant +val const_polyvar : string -> structured_constant +val const_polyvar_name : string -> structured_constant +val const_module_alias : structured_constant +val lambda_assert_false : t +val lambda_unit : t + +val eq_primitive_approx : primitive -> primitive -> bool + +val str_of_field_info : field_dbg_info -> string option + +val eq_comparison : comparison -> comparison -> bool + +val is_immutable_block : tag_info -> bool + +val const_is_allocating : structured_constant -> bool + +val const_eq_approx : structured_constant -> structured_constant -> bool + +val cmp_int32 : comparison -> int32 -> int32 -> bool + +val cmp_float : comparison -> float -> float -> bool + +(* Constructors. [t] is private, so every term outside this module is + built through one of these. + + Most are plain wrappers. Seven normalize as they build, and are the only + place that normalization happens - a pass cannot bypass it by writing a + constructor directly: + + - [prim] folds an operation whose arguments are already constants, and + collapses a module record rebuilt field-by-field from another module + back to that module. + - [if_] resolves a constant condition, collapses a branch that asserts + false, turns boolean branches into the condition or its negation, and + recognizes a few [Pisint] shapes. + - [switch] and [stringswitch] pick the matching case when the scrutinee + is constant. + - [not_] rewrites a negated inequality into an equality. + - [seq] drops a first operand that only allocates. + - [apply] eta-reduces a function whose body is a single primitive call on + its own parameters. + + These fire when a term is rebuilt with new children, which in practice + means during the optimizer's passes rather than at production: the + frontend has no constants in operand position yet. *) + +val var : Ident.t -> t + +val global_module : Ident.t -> t + +val const : structured_constant -> t + +val apply : ?ap_transformed_jsx:bool -> t -> t list -> ap_info -> t + +val function_ : + loc:Location.t -> + attr:function_attribute -> + params:Ident.t list -> + body:t -> + t + +val let_ : let_kind -> Ident.t -> t -> t -> t + +val letrec : (Ident.t * t) list -> t -> t + +val prim : primitive:primitive -> args:t list -> Location.t -> t -val mk_prim : primitive -> lambda list -> Location.t -> lambda -(** Expands [Peliminated] so it never appears as [Lprim]. *) +val switch : t -> lambda_switch -> t -val lambda_module_alias : lambda -val name_lambda : let_kind -> lambda -> (Ident.t -> lambda) -> lambda +val stringswitch : t -> (string * t) list -> t option -> t -val iter : (lambda -> unit) -> lambda -> unit -module Ident_set : Set.S with type elt = Ident.t -val free_variables : lambda -> Ident_set.t +val staticraise : int -> t list -> t -val transl_normal_path : Path.t -> lambda (* Path.t is already normal *) +val staticcatch : t -> int * Ident.t list -> t -> t -val transl_module_path : ?loc:Location.t -> Env.t -> Path.t -> lambda -val transl_value_path : ?loc:Location.t -> Env.t -> Path.t -> lambda -val transl_extension_path : ?loc:Location.t -> Env.t -> Path.t -> lambda +val try_ : t -> Ident.t -> t -> t -val subst_lambda : lambda Ident.tbl -> lambda -> lambda -val bind : let_kind -> Ident.t -> lambda -> lambda -> lambda +val if_ : t -> t -> t -> t + +val seq : t -> t -> t + +val break : t + +val continue : t + +val while_ : t -> t -> t + +val for_ : Ident.t -> t -> t -> direction_flag -> t -> t + +val for_of : Ident.t -> t -> t -> t + +val for_await_of : Ident.t -> t -> t -> t + +val assign : Ident.t -> t -> t + +val not_ : Location.t -> t -> t + +val sequor : t -> t -> t + +val sequand : t -> t -> t + +val lambda_true : t + +val lambda_false : t + +val shallow_map_sharing : (t -> t) -> t -> t +(** Rewrite a node's immediate children, rebuilding through the constructors + so the result is normalized. A node whose children are all physically + unchanged is returned as-is, so a traversal that rewrites nothing + allocates nothing. *) + +val eq_approx : t -> t -> bool + +val mk_builtin : builtin -> t list -> Location.t -> t +(** Expands the non-[Primitive] builtins, which have no IR form. *) + +val lambda_module_alias : t +val name_lambda : let_kind -> t -> (Ident.t -> t) -> t + +val shallow_exists : (t -> bool) -> t -> bool +(** Does any immediate child satisfy the predicate? Short-circuits. *) + +val iter : (t -> unit) -> t -> unit +val free_variables : t -> Set_ident.t + +val transl_normal_path : Path.t -> t (* Path.t is already normal *) + +val transl_module_path : ?loc:Location.t -> Env.t -> Path.t -> t +val transl_value_path : ?loc:Location.t -> Env.t -> Path.t -> t +val transl_extension_path : ?loc:Location.t -> Env.t -> Path.t -> t + +val subst_lambda : t Ident.tbl -> t -> t +val bind : let_kind -> Ident.t -> t -> t -> t val default_function_attribute : function_attribute @@ -436,14 +568,21 @@ val default_function_attribute : function_attribute (* Get a new static failure ident *) val next_raise_count : unit -> int + +val make_exit : int -> t + +val as_simple_exit : t -> int option + +(* Exit number to raise to, and a wrapper that puts the catch around a body. *) +val make_catch_delayed : t -> int * (t -> t) val next_negative_raise_count : unit -> int (* Negative raise counts are used to compile 'match ... with exception x -> ...'. This disabled some simplifications performed by the Simplif module that assume that static raises are in tail position in their handler. *) -val staticfail : lambda (* Anticipated static failure *) +val staticfail : t (* Anticipated static failure *) (* Check anticipated failure, substitute its final value *) -val is_guarded : lambda -> bool -val patch_guarded : lambda -> lambda -> lambda +val is_guarded : t -> bool +val patch_guarded : t -> t -> t diff --git a/compiler/ml/lambda_scc.ml b/compiler/ml/lambda_scc.ml index e216d5b092b..8050f6f90bf 100644 --- a/compiler/ml/lambda_scc.ml +++ b/compiler/ml/lambda_scc.ml @@ -24,17 +24,17 @@ open Lambda -type bindings = (Ident.t * lambda) list +type bindings = (Ident.t * Lambda.t) list (* [p] may have side effects (masking). Returning true stops the walk. *) -let exists_var (p : Ident.t -> bool) (l : lambda) : bool = +let exists_var (p : Ident.t -> bool) (l : Lambda.t) : bool = let rec hit_opt = function | None -> false | Some a -> hit a - and hit_list_snd : 'a. ('a * lambda) list -> bool = + and hit_list_snd : 'a. ('a * Lambda.t) list -> bool = fun x -> Ext_list.exists_snd x hit and hit_list xs = Ext_list.exists xs hit - and hit (l : lambda) = + and hit (l : Lambda.t) = match l with | Lvar id -> p id | Lassign (id, e) -> p id || hit e @@ -46,18 +46,20 @@ let exists_var (p : Ident.t -> bool) (l : lambda) : bool = | Lfor_await_of (_, e1, e2) -> hit e1 || hit e2 | Lfunction {body} -> hit body - | Llet (_, _, _, arg, body) -> hit arg || hit body + | Llet (_, _, arg, body) -> hit arg || hit body | Lletrec (decl, body) -> hit body || hit_list_snd decl | Lfor (_, e1, e2, _, e3) | Lifthenelse (e1, e2, e3) -> hit e1 || hit e2 || hit e3 | Lconst _ | Lbreak | Lcontinue -> false | Lapply {ap_func; ap_args} -> hit ap_func || hit_list ap_args - | Lprim (_, args, _) | Lstaticraise (_, args) -> hit_list args - | Lswitch (arg, sw, _) -> + | Lprim {primitive = _; args; loc = _} | Lstaticraise (_, args) -> + hit_list args + | Lswitch (arg, sw) -> hit arg || hit_list_snd sw.sw_consts || hit_list_snd sw.sw_blocks || hit_opt sw.sw_failaction - | Lstringswitch (arg, cases, default, _) -> + | Lstringswitch (arg, cases, default) -> hit arg || hit_list_snd cases || hit_opt default + | Lglobal_module _ -> false in hit l @@ -83,15 +85,15 @@ let preprocess_deps (groups : bindings) : _ * Ident.t array * Vec_int.t array = Vec_int.push base_key key)); (domain, int_mapping, node_vec) -let bind_rec (groups : bindings) (body : lambda) : lambda = +let bind_rec (groups : bindings) (body : Lambda.t) : Lambda.t = match groups with | [(id, bind)] -> - if exists_var (Ident.same id) bind then Lletrec (groups, body) - else Llet (Strict, Pgenval, id, bind, body) + if exists_var (Ident.same id) bind then letrec groups body + else let_ Strict id bind body | _ -> let domain, int_mapping, node_vec = preprocess_deps groups in let clusters = Ext_scc.graph node_vec in - if Int_vec_vec.length clusters <= 1 then Lletrec (groups, body) + if Int_vec_vec.length clusters <= 1 then letrec groups body else Int_vec_vec.fold_right (fun (v : Vec_int.t) acc -> @@ -107,7 +109,7 @@ let bind_rec (groups : bindings) (body : lambda) : lambda = | [(id, lam)] -> let base_key = Ordered_hash_map_local_ident.rank domain id in if Int_vec_util.mem base_key node_vec.(base_key) then - Lletrec (bindings, acc) - else Llet (Strict, Pgenval, id, lam, acc) - | _ -> Lletrec (bindings, acc)) + letrec bindings acc + else let_ Strict id lam acc + | _ -> letrec bindings acc) clusters body diff --git a/compiler/ml/lambda_scc.mli b/compiler/ml/lambda_scc.mli index b38dc9b6ae0..ed21031d55d 100644 --- a/compiler/ml/lambda_scc.mli +++ b/compiler/ml/lambda_scc.mli @@ -22,6 +22,6 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val bind_rec : (Ident.t * Lambda.lambda) list -> Lambda.lambda -> Lambda.lambda +val bind_rec : (Ident.t * Lambda.t) list -> Lambda.t -> Lambda.t (** Split a syntactic [let rec] group into the actual recursive clusters and demote bindings that are not recursive. *) diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index 83734fcc90f..324db00a6a8 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -346,8 +346,8 @@ let jumps_map f env = List.map (fun (i, pss) -> (i, f pss)) env (* Pattern matching before any compilation *) type pattern_matching = { - mutable cases: (pattern list * lambda) list; - args: (lambda * let_kind) list; + mutable cases: (pattern list * Lambda.t) list; + args: (Lambda.t * let_kind) list; default: (matrix * int) list; } @@ -365,7 +365,7 @@ type pm_half_compiled = | PmVar of pm_var_compiled | Pm of pattern_matching -and pm_var_compiled = {inside: pm_half_compiled; var_arg: lambda} +and pm_var_compiled = {inside: pm_half_compiled; var_arg: Lambda.t} type pm_half_compiled_info = { me: pm_half_compiled; @@ -440,34 +440,12 @@ let pretty_precompiled_res first nexts = *) module Store_exp = Switch.Store (struct - type t = lambda - type key = lambda + type t = Lambda.t + type key = Lambda.t let compare_key = compare let make_key = Lambda.make_key end) -let make_exit i = Lstaticraise (i, []) - -(* Introduce a catch, if worth it, delayed version *) -let rec as_simple_exit = function - | Lstaticraise (i, []) -> Some i - | Llet (Alias, _k, _, _, e) -> as_simple_exit e - | _ -> None - -let make_catch_delayed handler = - match as_simple_exit handler with - | Some i -> (i, fun act -> act) - | None -> ( - let i = next_raise_count () in - (* - Printf.eprintf "SHARE LAMBDA: %i\n%s\n" i (string_of_lam handler); -*) - ( i, - fun body -> - match body with - | Lstaticraise (j, _) -> if i = j then handler else body - | _ -> Lstaticcatch (body, (i, []), handler) )) - let raw_action l = match make_key l with | Some l -> l @@ -536,12 +514,9 @@ let simplify_or p = try simpl_rec p with Var p -> p let bind_record_rest loc arg rest action = - Llet - ( Strict, - Pgenval, - rest.rest_ident, - Lprim (Precord_rest rest.excluded_runtime_labels, [arg], loc), - action ) + let_ Strict rest.rest_ident + (prim ~primitive:(Precord_rest rest.excluded_runtime_labels) ~args:[arg] loc) + action let simplify_cases args cls = match args with @@ -625,14 +600,14 @@ let default_compat p def = (* Or-pattern expansion, variables are a complication w.r.t. the article *) let rec extract_vars r p = match p.pat_desc with - | Tpat_var (id, _) -> Ident_set.add id r - | Tpat_alias (p, id, _) -> extract_vars (Ident_set.add id r) p + | Tpat_var (id, _) -> Set_ident.add r id + | Tpat_alias (p, id, _) -> extract_vars (Set_ident.add r id) p | Tpat_tuple pats -> List.fold_left extract_vars r pats | Tpat_record (lpats, _, rest) -> ( let r = List.fold_left (fun r (_, _, p, _) -> extract_vars r p) r lpats in match rest with | None -> r - | Some rest -> Ident_set.add rest.rest_ident r) + | Some rest -> Set_ident.add r rest.rest_ident) | Tpat_construct (_, _, pats) -> List.fold_left extract_vars r pats | Tpat_array pats -> List.fold_left extract_vars r pats | Tpat_variant (_, Some p, _) -> extract_vars r p @@ -668,8 +643,8 @@ let rec explode_or_pat arg patl mk_action rem vars aliases = function let pm_free_variables {cases} = List.fold_right - (fun (_, act) r -> Ident_set.union (free_variables act) r) - cases Ident_set.empty + (fun (_, act) r -> Set_ident.union (free_variables act) r) + cases Set_ident.empty (* Basic grouping predicates *) let pat_as_constr = function @@ -751,8 +726,8 @@ let insert_or_append p ps act ors no = if is_or q then if may_compat p q then if - Ident_set.is_empty (extract_vars Ident_set.empty p) - && Ident_set.is_empty (extract_vars Ident_set.empty q) + Set_ident.is_empty (extract_vars Set_ident.empty p) + && Set_ident.is_empty (extract_vars Set_ident.empty q) && equiv_pat p q then (* attempt insert, for equivalent orpats with no variables *) @@ -1062,16 +1037,16 @@ and precompile_or argo cls ors args def k = } in let vars = - Ident_set.elements - (Ident_set.inter - (extract_vars Ident_set.empty orp) + Set_ident.elements + (Set_ident.inter + (extract_vars Set_ident.empty orp) (pm_free_variables orpm)) in let or_num = next_raise_count () in let new_patl = Parmatch.omega_list patl in let mk_new_action vs = - Lstaticraise (or_num, List.map (fun v -> Lvar v) vs) + staticraise or_num (List.map (fun v -> var v) vs) in let body, handlers = do_cases rem in @@ -1197,7 +1172,7 @@ let make_field_args ~fld_info loc binding_kind arg first_pos last_pos argl = let rec make_args pos = if pos > last_pos then argl else - (Lprim (Pfield (pos, fld_info), [arg], loc), binding_kind) + (prim ~primitive:(Pfield (pos, fld_info)) ~args:[arg] loc, binding_kind) :: make_args (pos + 1) in make_args first_pos @@ -1283,7 +1258,7 @@ let make_constr_matching p def ctx = function Pval_from_option_not_nest | _ -> Pval_from_option in - (Lprim (from_option, [arg], p.pat_loc), Alias) :: argl + (prim ~primitive:from_option ~args:[arg] p.pat_loc, Alias) :: argl | Ordinary_constructor _ -> make_field_args p.pat_loc Alias arg 0 (cstr.cstr_arity - 1) argl ~fld_info:(if cstr.cstr_name = "::" then Fld_cons else Fld_variant) @@ -1341,7 +1316,10 @@ let make_variant_matching_nonconst p lab def ctx = function { cases = []; args = - (Lprim (Pfield (1, Fld_poly_var_content), [arg], p.pat_loc), Alias) + ( prim + ~primitive:(Pfield (1, Fld_poly_var_content)) + ~args:[arg] p.pat_loc, + Alias ) :: argl; default = def; }; @@ -1414,7 +1392,7 @@ let make_tuple_matching loc arity def = function let rec make_args pos = if pos >= arity then argl else - (Lprim (Pfield (pos, Fld_tuple), [arg], loc), Alias) + (prim ~primitive:(Pfield (pos, Fld_tuple)) ~args:[arg] loc, Alias) :: make_args (pos + 1) in { @@ -1463,16 +1441,19 @@ let make_record_matching loc all_labels def = function match lbl.lbl_repres with | Record_float_unused -> assert false | Record_regular -> - Lprim (Pfield (lbl.lbl_pos, Lambda.fld_record lbl), [arg], loc) + prim + ~primitive:(Pfield (lbl.lbl_pos, Lambda.fld_record lbl)) + ~args:[arg] loc | Record_inlined _ -> - Lprim - (Pfield (lbl.lbl_pos, Lambda.fld_record_inline lbl), [arg], loc) + prim + ~primitive:(Pfield (lbl.lbl_pos, Lambda.fld_record_inline lbl)) + ~args:[arg] loc | Record_unboxed _ -> arg | Record_extension -> - Lprim - ( Pfield (lbl.lbl_pos + 1, Lambda.fld_record_extension lbl), - [arg], - loc ) + prim + ~primitive: + (Pfield (lbl.lbl_pos + 1, Lambda.fld_record_extension lbl)) + ~args:[arg] loc in let str = match lbl.lbl_mut with @@ -1516,7 +1497,8 @@ let make_array_matching p def ctx = function let rec make_args pos = if pos >= len then argl else - (Lprim (Parrayrefu, [arg; Lconst (const_int pos)], p.pat_loc), StrictOpt) + ( prim ~primitive:Parrayrefu ~args:[arg; const (const_int pos)] p.pat_loc, + StrictOpt ) :: make_args (pos + 1) in let def = make_default (matcher_array len) def and ctx = filter_ctx p ctx in @@ -1594,19 +1576,19 @@ let rec cut n l = let rec do_tests_fail loc fail tst arg = function | [] -> fail | (c, act) :: rem -> - Lifthenelse - ( Lprim (tst, [arg; Lconst (const_of_typed c)], loc), - do_tests_fail loc fail tst arg rem, - act ) + if_ + (prim ~primitive:tst ~args:[arg; const (const_of_typed c)] loc) + (do_tests_fail loc fail tst arg rem) + act let rec do_tests_nofail loc tst arg = function | [] -> fatal_error "Matching.do_tests_nofail" | [(_, act)] -> act | (c, act) :: rem -> - Lifthenelse - ( Lprim (tst, [arg; Lconst (const_of_typed c)], loc), - do_tests_nofail loc tst arg rem, - act ) + if_ + (prim ~primitive:tst ~args:[arg; const (const_of_typed c)] loc) + (do_tests_nofail loc tst arg rem) + act let make_test_sequence loc fail tst lt_tst arg const_lambda_list = let const_lambda_list = sort_lambda_list const_lambda_list in @@ -1622,64 +1604,14 @@ let make_test_sequence loc fail tst lt_tst arg const_lambda_list = let list1, list2 = cut (List.length const_lambda_list / 2) const_lambda_list in - Lifthenelse - ( Lprim (lt_tst, [arg; Lconst (const_of_typed (fst (List.hd list2)))], loc), - make_test_sequence list1, - make_test_sequence list2 ) + if_ + (prim ~primitive:lt_tst + ~args:[arg; const (const_of_typed (fst (List.hd list2)))] + loc) + (make_test_sequence list1) (make_test_sequence list2) in hs (make_test_sequence const_lambda_list) -module S_arg = struct - type primitive = Lambda.primitive - - let eqint = Pintcomp Ceq - let neint = Pintcomp Cneq - let leint = Pintcomp Cle - let ltint = Pintcomp Clt - let geint = Pintcomp Cge - let gtint = Pintcomp Cgt - - type act = Lambda.lambda - - let make_prim p args = mk_prim p args Location.none - let make_offset arg n = - match n with - | 0 -> arg - | _ -> Lprim (Poffsetint n, [arg], Location.none) - - let bind arg body = - let newvar, newarg = - match arg with - | Lvar v -> (v, arg) - | _ -> - let newvar = Ident.create "switcher" in - (newvar, Lvar newvar) - in - bind Alias newvar arg (body newarg) - let make_const i = Lconst (const_int i) - let make_isout h arg = Lprim (Pisout, [h; arg], Location.none) - let make_isin h arg = Lprim (Pnot, [make_isout h arg], Location.none) - let make_if cond ifso ifnot = Lifthenelse (cond, ifso, ifnot) - let make_switch loc arg cases acts ~offset = - let l = ref [] in - for i = Array.length cases - 1 downto 0 do - l := (Switch_int (offset + i), acts.(cases.(i))) :: !l - done; - Lswitch - ( arg, - { - sw_consts_full = true; - sw_consts = !l; - sw_blocks_full = true; - sw_blocks = []; - sw_failaction = None; - sw_dispatch = Switch_direct; - }, - loc ) - let make_catch = make_catch_delayed - let make_exit = make_exit -end - (* Action sharing for Lswitch argument *) let share_actions_sw sw = (* Attempt sharing on all actions *) @@ -1761,7 +1693,6 @@ let reintroduce_fail sw = else sw | Some _ -> sw -module Switcher = Switch.Make (S_arg) open Switch let rec last def = function @@ -1867,9 +1798,9 @@ let as_interval fail low high l = | None -> as_interval_nofail l | Some act -> as_interval_canfail act low high l ) -let call_switcher loc fail arg low high int_lambda_list = +let call_switcher fail arg low high int_lambda_list = let edges, (cases, actions) = as_interval fail low high int_lambda_list in - Switcher.zyva loc edges arg cases actions + Switch.zyva edges arg cases actions let rec list_as_pat = function | [] -> fatal_error "Matching.list_as_pat" @@ -1891,8 +1822,7 @@ let mk_failaction_neg partial ctx def = match partial with | Partial -> ( match def with - | (_, idef) :: _ -> - (Some (Lstaticraise (idef, [])), jumps_singleton idef ctx) + | (_, idef) :: _ -> (Some (staticraise idef []), jumps_singleton idef ctx) | [] -> (* Act as Total, this means If no appropriate default matrix exists, @@ -1911,7 +1841,7 @@ let mk_failaction_pos partial seen ctx defs = | [], _ | _, [] -> List.fold_left (fun (klist, jumps) (pats, i) -> - let action = Lstaticraise (i, []) in + let action = staticraise i [] in let klist = List.fold_right (fun pat r -> (get_key_constr pat, action) :: r) @@ -1961,7 +1891,7 @@ let combine_constant loc arg cst partial ctx def | _ -> assert false) const_lambda_list in - call_switcher loc fail arg min_int max_int int_lambda_list + call_switcher fail arg min_int max_int int_lambda_list | Const_char _ -> let int_lambda_list = List.map @@ -1970,7 +1900,7 @@ let combine_constant loc arg cst partial ctx def | _ -> assert false) const_lambda_list in - call_switcher loc fail arg 0 max_int int_lambda_list + call_switcher fail arg 0 max_int int_lambda_list | Const_string _ -> (* Note as the bytecode compiler may resort to dichotomic search, the clauses of stringswitch are sorted with duplicates removed. @@ -1986,7 +1916,7 @@ let combine_constant loc arg cst partial ctx def const_lambda_list in let hs, sw, fail = share_actions_tree sw fail in - hs (Lstringswitch (arg, sw, fail, loc)) + hs (stringswitch arg sw fail) | Const_float _ -> make_test_sequence loc fail (Pfloatcomp Cneq) (Pfloatcomp Clt) arg const_lambda_list @@ -2047,20 +1977,20 @@ let constructor_switch_key (cstr : Types.constructor_description) = (* An occurrence-specific plan for one constructor decision-tree node. It is deliberately local to pattern matching: [lower_constructor_matching_plan] immediately expresses the decision with existing Lambda control-flow - nodes, so Lambda and Lam do not acquire another expression language. *) + nodes, so Lambda does not acquire another expression language. *) type payload_presence_test = Is_present_option | Is_nonempty_list type constructor_matching_plan = - | Use_constructor_action of Lambda.lambda + | Use_constructor_action of Lambda.t (** Every possible constructor reaches the same action. *) | Test_payload_presence of { test: payload_presence_test; - absent: Lambda.lambda; - present: Lambda.lambda; + absent: Lambda.t; + present: Lambda.t; } (** A two-constructor representation whose runtime value directly reveals whether the payload constructor is present. *) - | Test_boolean_value of {if_false: Lambda.lambda; if_true: Lambda.lambda} + | Test_boolean_value of {if_false: Lambda.t; if_true: Lambda.t} (** The predefined boolean constructors are JavaScript booleans. *) | Switch_on_constructors of Lambda.lambda_switch (** General nominal and untagged variant matching. *) @@ -2070,17 +2000,16 @@ let lower_constructor_matching_plan ~loc ~arg = function | Test_payload_presence {test; absent; present} -> let condition = match test with - | Is_present_option -> Lprim (Pis_not_none, [arg], loc) + | Is_present_option -> prim ~primitive:Pis_not_none ~args:[arg] loc | Is_nonempty_list -> - Lprim (Pjscomp Cneq, [arg; Lconst (const_int 0)], loc) + prim ~primitive:(Pjscomp Cneq) ~args:[arg; const (const_int 0)] loc in - Lifthenelse (condition, present, absent) - | Test_boolean_value {if_false; if_true} -> - Lifthenelse (arg, if_true, if_false) + if_ condition present absent + | Test_boolean_value {if_false; if_true} -> if_ arg if_true if_false | Switch_on_constructors sw -> let hs, sw = share_actions_sw sw in let sw = reintroduce_fail sw in - hs (Lswitch (arg, sw, loc)) + hs (switch arg sw) let make_constructor_matching_plan ~cstr ~(layout : Variant_runtime.layout) ~fail_opt ~num_consts ~num_nonconsts ~tag_lambda_list ~consts ~nonconsts = @@ -2155,22 +2084,22 @@ let combine_constructor loc arg ex_pat cstr partial ctx def List.fold_right (fun (path, act) rem -> let ext = transl_extension_path ex_pat.pat_env path in - Lifthenelse - ( Lprim - ( Pstringcomp Ceq, - [ - Lprim - ( Pfield (0, Fld_record {name = Literals.exception_id}), - [Lvar tag], - loc ); - ext; - ], - loc ), - act, - rem )) + if_ + (prim ~primitive:(Pstringcomp Ceq) + ~args: + [ + prim + ~primitive: + (Pfield (0, Fld_record {name = Literals.exception_id})) + ~args:[var tag] + loc; + ext; + ] + loc) + act rem) extension_cases default in - Llet (Alias, Pgenval, tag, arg, tests) + let_ Alias tag arg tests in (lambda1, jumps_union local_jumps total1) else @@ -2201,45 +2130,41 @@ let make_test_sequence_variant_constant fail arg int_lambda_list = as_interval fail min_int max_int (List.map (fun (a, (_, c)) -> (a, c)) int_lambda_list) in - Switcher.test_sequence arg cases actions + Switch.test_sequence arg cases actions -let call_switcher_variant_constant loc fail arg int_lambda_list = - call_switcher loc fail arg min_int max_int +let call_switcher_variant_constant fail arg int_lambda_list = + call_switcher fail arg min_int max_int (List.map (fun (a, (_, c)) -> (a, c)) int_lambda_list) let call_switcher_variant_constr loc fail arg int_lambda_list = let v = Ident.create "variant" in - Llet - ( Alias, - Pgenval, - v, - Lprim (Pfield (0, Fld_poly_var_tag), [arg], loc), - call_switcher loc fail (Lvar v) min_int max_int - (List.map (fun (a, (_, c)) -> (a, c)) int_lambda_list) ) + let_ Alias v + (prim ~primitive:(Pfield (0, Fld_poly_var_tag)) ~args:[arg] loc) + (call_switcher fail (var v) min_int max_int + (List.map (fun (a, (_, c)) -> (a, c)) int_lambda_list)) let call_switcher_variant_constant : - (Location.t -> - Lambda.lambda option -> - Lambda.lambda -> - (int * (string * Lambda.lambda)) list -> - Lambda.lambda) + (Lambda.t option -> + Lambda.t -> + (int * (string * Lambda.t)) list -> + Lambda.t) ref = ref call_switcher_variant_constant let call_switcher_variant_constr : (Location.t -> - Lambda.lambda option -> - Lambda.lambda -> - (int * (string * Lambda.lambda)) list -> - Lambda.lambda) + Lambda.t option -> + Lambda.t -> + (int * (string * Lambda.t)) list -> + Lambda.t) ref = ref call_switcher_variant_constr let make_test_sequence_variant_constant : - (Lambda.lambda option -> - Lambda.lambda -> - (int * (string * Lambda.lambda)) list -> - Lambda.lambda) + (Lambda.t option -> + Lambda.t -> + (int * (string * Lambda.t)) list -> + Lambda.t) ref = ref make_test_sequence_variant_constant @@ -2256,7 +2181,7 @@ let combine_variant loc row arg partial ctx def (tag_lambda_list, total1, _pats) row.row_fields else num_constr := max_int; let test_int_or_block arg if_int if_block = - Lifthenelse (Lprim (Pis_poly_var_block, [arg], loc), if_block, if_int) + if_ (prim ~primitive:Pis_poly_var_block ~args:[arg] loc) if_block if_int in let sig_complete = List.length tag_lambda_list = !num_constr and one_action = same_actions tag_lambda_list in @@ -2289,7 +2214,7 @@ let combine_variant loc row arg partial ctx def (tag_lambda_list, total1, _pats) | None -> lam | Some fail -> test_int_or_block arg fail lam) | _, _ -> - let lam_const = !call_switcher_variant_constant loc fail arg consts + let lam_const = !call_switcher_variant_constant fail arg consts and lam_nonconst = !call_switcher_variant_constr loc fail arg nonconsts in @@ -2301,10 +2226,8 @@ let combine_array loc arg partial ctx def (len_lambda_list, total1, _pats) = let fail, local_jumps = mk_failaction_neg partial ctx def in let lambda1 = let newvar = Ident.create "len" in - let switch = - call_switcher loc fail (Lvar newvar) 0 max_int len_lambda_list - in - bind Alias newvar (Lprim (Parraylength, [arg], loc)) switch + let switch = call_switcher fail (var newvar) 0 max_int len_lambda_list in + bind Alias newvar (prim ~primitive:Parraylength ~args:[arg] loc) switch in (lambda1, jumps_union local_jumps total1) @@ -2360,12 +2283,11 @@ let compile_orhandlers compile_fun lambda1 total1 ctx to_catch = else do_rec r total_r rem | _ -> do_rec - (Lstaticcatch (r, (i, vars), handler_i)) + (staticcatch r (i, vars) handler_i) (jumps_union (jumps_remove i total_r) (jumps_map (ctx_rshift_num (ncols mat)) total_i)) rem - with Unused -> - do_rec (Lstaticcatch (r, (i, vars), lambda_unit)) total_r rem) + with Unused -> do_rec (staticcatch r (i, vars) lambda_unit) total_r rem) in do_rec lambda1 total1 to_catch @@ -2385,8 +2307,9 @@ let compile_test compile_fun partial divide combine ctx to_match = let rec approx_present v = function | Lconst _ -> false | Lstaticraise (_, args) -> List.exists (fun lam -> approx_present v lam) args - | Lprim (_, args, _) -> List.exists (fun lam -> approx_present v lam) args - | Llet (Alias, _k, _, l1, l2) -> approx_present v l1 || approx_present v l2 + | Lprim {primitive = _; args; loc = _} -> + List.exists (fun lam -> approx_present v lam) args + | Llet (Alias, _, l1, l2) -> approx_present v l1 || approx_present v l2 | Lvar vv -> Ident.same v vv | _ -> true @@ -2398,18 +2321,18 @@ let rec lower_bind v arg lam = and pnot = approx_present v ifnot in match (pcond, pso, pnot) with | false, false, false -> lam - | false, true, false -> Lifthenelse (cond, lower_bind v arg ifso, ifnot) - | false, false, true -> Lifthenelse (cond, ifso, lower_bind v arg ifnot) + | false, true, false -> if_ cond (lower_bind v arg ifso) ifnot + | false, false, true -> if_ cond ifso (lower_bind v arg ifnot) | _, _, _ -> bind Alias v arg lam) - | Lswitch (ls, ({sw_consts = [(i, act)]; sw_blocks = []} as sw), loc) + | Lswitch (ls, ({sw_consts = [(i, act)]; sw_blocks = []} as sw)) when not (approx_present v ls) -> - Lswitch (ls, {sw with sw_consts = [(i, lower_bind v arg act)]}, loc) - | Lswitch (ls, ({sw_consts = []; sw_blocks = [(i, act)]} as sw), loc) + switch ls {sw with sw_consts = [(i, lower_bind v arg act)]} + | Lswitch (ls, ({sw_consts = []; sw_blocks = [(i, act)]} as sw)) when not (approx_present v ls) -> - Lswitch (ls, {sw with sw_blocks = [(i, lower_bind v arg act)]}, loc) - | Llet (Alias, k, vv, lv, l) -> + switch ls {sw with sw_blocks = [(i, lower_bind v arg act)]} + | Llet (Alias, vv, lv, l) -> if approx_present v lv then bind Alias v arg lam - else Llet (Alias, k, vv, lv, lower_bind v arg l) + else let_ Alias vv lv (lower_bind v arg l) | Lvar u when Ident.same u v -> (* eliminate [let v = arg in v]; [lower_bind] is only used for alias bindings, so [arg] is pure *) @@ -2424,7 +2347,7 @@ let bind_check str v arg lam = let comp_exit ctx m = match m.default with - | (_, i) :: _ -> (Lstaticraise (i, []), jumps_singleton i ctx) + | (_, i) :: _ -> (staticraise i [], jumps_singleton i ctx) | _ -> fatal_error "Matching.comp_exit" let rec comp_match_handlers comp_fun partial ctx arg first_match next_matchs = @@ -2449,11 +2372,11 @@ let rec comp_match_handlers comp_fun partial ctx arg first_match next_matchs = ctx_i arg pm in c_rec - (Lstaticcatch (body, (i, []), li)) + (staticcatch body (i, []) li) (jumps_union total_i total_rem) rem with Unused -> - c_rec (Lstaticcatch (body, (i, []), lambda_unit)) total_rem rem)) + c_rec (staticcatch body (i, []) lambda_unit) total_rem rem)) in try let first_lam, total = comp_fun Partial ctx arg first_match in @@ -2477,7 +2400,7 @@ let arg_to_var arg cls = | Lvar v -> (v, arg) | _ -> let v = name_pattern "match" cls in - (v, Lvar v) + (v, var v) (* The main compilation function. @@ -2658,7 +2581,7 @@ let start_ctx n = [{left = []; right = omegas n}] let check_total total lambda i handler_fun = if jumps_is_empty total then lambda - else Lstaticcatch (lambda, (i, []), handler_fun ()) + else staticcatch lambda (i, []) (handler_fun ()) let compile_matching repr handler_fun arg pat_act_list partial = let partial = check_partial pat_act_list partial in @@ -2692,22 +2615,22 @@ let partial_function loc () = (* [Location.get_pos_info] is too expensive *) let fname, line, char = Location.get_pos_info loc.Location.loc_start in let fname = Filename.basename fname in - Lprim - ( Praise, + prim ~primitive:Praise + ~args: [ - Lprim - ( Pmakeblock Blk_extension, + prim ~primitive:(Pmakeblock Blk_extension) + ~args: [ transl_normal_path Predef.path_match_failure; - Lconst + const (Const_block ( Blk_tuple, [const_string fname None; const_int line; const_int char] )); - ], - loc ); - ], - loc ) + ] + loc; + ] + loc let for_function loc repr param pat_act_list partial = compile_matching repr (partial_function loc) param pat_act_list partial @@ -2715,7 +2638,7 @@ let for_function loc repr param pat_act_list partial = (* In the following two cases, exhaustiveness info is not available! *) let for_trywith param pat_act_list = compile_matching None - (fun () -> Lprim (Praise, [param], Location.none)) + (fun () -> prim ~primitive:Praise ~args:[param] Location.none) param pat_act_list Partial let simple_for_let loc param pat body = @@ -2774,10 +2697,10 @@ let for_let loc param pat body = | Tpat_any -> (* This eliminates a useless variable (and stack slot in bytecode) for "let _ = ...". See #6865. *) - Lsequence (param, body) + seq param body | Tpat_var (id, _) -> (* fast path, and keep track of simple bindings to unboxable numbers *) - Llet (Strict, Pgenval, id, param, body) + let_ Strict id param body | _ -> simple_for_let loc param pat body (* Handling of tupled functions and matchings *) @@ -2864,14 +2787,16 @@ let do_for_multiple_match loc paraml pat_act_list partial = ( raise_num, { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; - args = [(Lprim (Pmakeblock Blk_tuple, paraml, loc), Strict)]; + args = + [(prim ~primitive:(Pmakeblock Blk_tuple) ~args:paraml loc, Strict)]; default = [([[omega]], raise_num)]; } ) | _ -> ( -1, { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; - args = [(Lprim (Pmakeblock Blk_tuple, paraml, loc), Strict)]; + args = + [(prim ~primitive:(Pmakeblock Blk_tuple) ~args:paraml loc, Strict)]; default = []; } ) in @@ -2883,7 +2808,7 @@ let do_for_multiple_match loc paraml pat_act_list partial = let size = List.length paraml and idl = List.map (fun _ -> Ident.create "match") paraml in - let args = List.map (fun id -> (Lvar id, Alias)) idl in + let args = List.map (fun id -> (var id, Alias)) idl in let flat_next = flatten_precompiled size args next and flat_nexts = @@ -2924,6 +2849,6 @@ let bind_opt (v, eo) k = let for_multiple_match loc paraml pat_act_list partial = let v_paraml = List.map param_to_var paraml in - let paraml = List.map (fun (v, _) -> Lvar v) v_paraml in + let paraml = List.map (fun (v, _) -> var v) v_paraml in List.fold_right bind_opt v_paraml (do_for_multiple_match loc paraml pat_act_list partial) diff --git a/compiler/ml/matching.mli b/compiler/ml/matching.mli index 041eac3b9d1..0f34a422fb3 100644 --- a/compiler/ml/matching.mli +++ b/compiler/ml/matching.mli @@ -16,43 +16,39 @@ (* Compilation of pattern-matching *) open Typedtree -open Lambda val call_switcher_variant_constant : - (Location.t -> - Lambda.lambda option -> - Lambda.lambda -> - (int * (string * Lambda.lambda)) list -> - Lambda.lambda) + (Lambda.t option -> Lambda.t -> (int * (string * Lambda.t)) list -> Lambda.t) ref val call_switcher_variant_constr : (Location.t -> - Lambda.lambda option -> - Lambda.lambda -> - (int * (string * Lambda.lambda)) list -> - Lambda.lambda) + Lambda.t option -> + Lambda.t -> + (int * (string * Lambda.t)) list -> + Lambda.t) ref val make_test_sequence_variant_constant : - (Lambda.lambda option -> - Lambda.lambda -> - (int * (string * Lambda.lambda)) list -> - Lambda.lambda) + (Lambda.t option -> Lambda.t -> (int * (string * Lambda.t)) list -> Lambda.t) ref (* Entry points to match compiler *) val for_function : Location.t -> int ref option -> - lambda -> - (pattern * lambda) list -> + Lambda.t -> + (pattern * Lambda.t) list -> partial -> - lambda -val for_trywith : lambda -> (pattern * lambda) list -> lambda -val for_let : Location.t -> lambda -> pattern -> lambda -> lambda + Lambda.t +val for_trywith : Lambda.t -> (pattern * Lambda.t) list -> Lambda.t +val for_let : Location.t -> Lambda.t -> pattern -> Lambda.t -> Lambda.t val for_multiple_match : - Location.t -> lambda list -> (pattern * lambda) list -> partial -> lambda + Location.t -> + Lambda.t list -> + (pattern * Lambda.t) list -> + partial -> + Lambda.t exception Cannot_flatten diff --git a/compiler/ml/mtype.ml b/compiler/ml/mtype.ml index f6f243ade16..0f284fdaf7b 100644 --- a/compiler/ml/mtype.ml +++ b/compiler/ml/mtype.ml @@ -290,8 +290,6 @@ let contains_type env mty = module Path_set = Set.Make (Path) module Path_map = Map.Make (Path) -module Ident_set = Set.Make (Ident) - let rec get_prefixes = function | Pident _ -> Path_set.empty | Pdot (p, _, _) | Papply (p, _) -> Path_set.add p (get_prefixes p) @@ -318,10 +316,10 @@ let rec collect_ids subst bindings p = | Pident id -> let ids = try collect_ids subst bindings (Ident.find_same id bindings) - with Not_found -> Ident_set.empty + with Not_found -> Set_ident.empty in - Ident_set.add id ids - | _ -> Ident_set.empty + Set_ident.add ids id + | _ -> Set_ident.empty let collect_arg_paths mty = let open Btype in @@ -350,8 +348,8 @@ let collect_arg_paths mty = it.it_module_type it mty; it.it_module_type unmark_iterators mty; Path_set.fold - (fun p -> Ident_set.union (collect_ids !subst !bindings p)) - !paths Ident_set.empty + (fun p -> Set_ident.union (collect_ids !subst !bindings p)) + !paths Set_ident.empty let rec remove_aliases env excl mty = match mty with @@ -369,7 +367,7 @@ and remove_aliases_sig env excl sg = | Sig_module (id, md, rs) :: rem -> let mty = match md.md_type with - | Mty_alias _ when Ident_set.mem id excl -> md.md_type + | Mty_alias _ when Set_ident.mem excl id -> md.md_type | mty -> remove_aliases env excl mty in Sig_module (id, {md with md_type = mty}, rs) diff --git a/compiler/ml/parmatch.ml b/compiler/ml/parmatch.ml index a688e05e72f..297b68129af 100644 --- a/compiler/ml/parmatch.ml +++ b/compiler/ml/parmatch.ml @@ -2335,23 +2335,21 @@ let check_partial_gadt ?partial_match_warning_hint pred loc casel = to a specific guard. *) -module Id_set = Set.Make (Ident) - -let pattern_vars p = Id_set.of_list (Typedtree.pat_bound_idents p) +let pattern_vars p = Set_ident.of_list (Typedtree.pat_bound_idents p) (* Row for ambiguous variable search, unseen is the traditional pattern row, seen is a list of position bindings *) -type amb_row = {unseen: pattern list; seen: Id_set.t list} +type amb_row = {unseen: pattern list; seen: Set_ident.t list} (* Push binding variables now *) let rec do_push r p ps seen k = match p.pat_desc with - | Tpat_alias (p, x, _) -> do_push (Id_set.add x r) p ps seen k + | Tpat_alias (p, x, _) -> do_push (Set_ident.add r x) p ps seen k | Tpat_var (x, _) -> - (omega, {unseen = ps; seen = Id_set.add x r :: seen}) :: k + (omega, {unseen = ps; seen = Set_ident.add r x :: seen}) :: k | Tpat_or (p1, p2, _) -> do_push r p1 ps seen (do_push r p2 ps seen k) | _ -> (p, {unseen = ps; seen = r :: seen}) :: k @@ -2359,7 +2357,7 @@ let rec push_vars = function | [] -> [] | {unseen = []} :: _ -> assert false | {unseen = p :: ps; seen} :: rem -> - do_push Id_set.empty p ps seen (push_vars rem) + do_push Set_ident.empty p ps seen (push_vars rem) let collect_stable = function | [] -> assert false @@ -2367,11 +2365,11 @@ let collect_stable = function let rec c_rec xss = function | [] -> xss | {seen = yss; _} :: rem -> - let xss = List.map2 Id_set.inter xss yss in + let xss = List.map2 Set_ident.inter xss yss in c_rec xss rem in let inters = c_rec xss rem in - List.fold_left Id_set.union Id_set.empty inters + List.fold_left Set_ident.union Set_ident.empty inters (*********************************************) (* Filtering utilities for our specific rows *) @@ -2470,8 +2468,8 @@ let rec do_stable rs = (* If the first column is incoherent, then all the variables of this matrix are stable. *) List.fold_left - (fun acc (_, {seen; _}) -> List.fold_left Id_set.union acc seen) - Id_set.empty rs + (fun acc (_, {seen; _}) -> List.fold_left Set_ident.union acc seen) + Set_ident.empty rs else (* If the column is ill-typed but deemed coherent, we might spuriously warn about some variables being unstable. @@ -2481,7 +2479,7 @@ let rec do_stable rs = | [] -> do_stable (List.map snd rs) | (_, rs) :: env -> List.fold_left - (fun xs (_, rs) -> Id_set.inter xs (do_stable rs)) + (fun xs (_, rs) -> Set_ident.inter xs (do_stable rs)) (do_stable rs) env) let stable p = do_stable [{unseen = [p]; seen = []}] @@ -2505,13 +2503,13 @@ let stable p = do_stable [{unseen = [p]; seen = []}] *) let all_rhs_idents exp = - let ids = ref Id_set.empty in + let ids = ref Set_ident.empty in let module Iterator = Typedtree_iter.Make_iterator (struct include Typedtree_iter.Default_iterator_argument let enter_expression exp = match exp.exp_desc with | Texp_ident (path, _lid, _descr) -> - List.iter (fun id -> ids := Id_set.add id !ids) (Path.heads path) + List.iter (fun id -> ids := Set_ident.add !ids id) (Path.heads path) | _ -> () (* Very hackish, detect unpack pattern compilation @@ -2531,8 +2529,9 @@ let all_rhs_idents exp = ({exp_desc = Texp_ident (Path.Pident id_exp, _, _)}, _); }, _ ) -> - assert (Id_set.mem id_exp !ids); - if not (Id_set.mem id_mod !ids) then ids := Id_set.remove id_exp !ids + assert (Set_ident.mem !ids id_exp); + if not (Set_ident.mem !ids id_mod) then + ids := Set_ident.remove !ids id_exp | _ -> assert false end) in Iterator.iter_expression exp; @@ -2548,12 +2547,12 @@ let check_ambiguous_bindings = match case with | {c_guard = None; _} -> () | {c_lhs = p; c_guard = Some g; _} -> - let all = Id_set.inter (pattern_vars p) (all_rhs_idents g) in - if not (Id_set.is_empty all) then + let all = Set_ident.inter (pattern_vars p) (all_rhs_idents g) in + if not (Set_ident.is_empty all) then let st = stable p in - let ambiguous = Id_set.diff all st in - if not (Id_set.is_empty ambiguous) then - let pps = Id_set.elements ambiguous |> List.map Ident.name in + let ambiguous = Set_ident.diff all st in + if not (Set_ident.is_empty ambiguous) then + let pps = Set_ident.elements ambiguous |> List.map Ident.name in let warn = Ambiguous_pattern pps in Location.prerr_warning p.pat_loc warn) cases diff --git a/compiler/ml/printlambda.ml b/compiler/ml/printlambda.ml index e4740acbe40..dae4aa73e59 100644 --- a/compiler/ml/printlambda.ml +++ b/compiler/ml/printlambda.ml @@ -23,11 +23,14 @@ let rec struct_const ppf = function | Const_string {s} -> fprintf ppf "%S" s | Const_float f -> fprintf ppf "%s" f | Const_bigint (sign, n) -> fprintf ppf "%sn" (Bigint_utils.to_string sign n) - | Const_pointer (Pt_constructor {name}) -> fprintf ppf "`%s" name - | Const_pointer (Pt_variant {name}) -> fprintf ppf "`%s" name - | Const_pointer Pt_module_alias -> fprintf ppf "module_alias" - | Const_pointer Pt_shape_none -> fprintf ppf "shape_none" - | Const_pointer Pt_assertfalse -> fprintf ppf "assertfalse" + | Const_constructor {name} -> fprintf ppf "%s" name + | Const_polyvar name -> fprintf ppf "`%s" name + | Const_module_alias -> fprintf ppf "module_alias" + | Const_assertfalse -> fprintf ppf "assertfalse" + | Const_js_null -> fprintf ppf "null" + | Const_some c -> fprintf ppf "some(%a)" struct_const c + | Const_js_undefined {is_unit = true} -> fprintf ppf "unit" + | Const_js_undefined {is_unit = false} -> fprintf ppf "undefined" | Const_block (tag_info, []) -> let tag = Lambda.tag_label_of_tag_info tag_info in fprintf ppf "[%s]" tag @@ -37,11 +40,8 @@ let rec struct_const ppf = function List.iter (fun sc -> fprintf ppf "@ %a" struct_const sc) scl in fprintf ppf "@[<1>[%s:@ @[%a%a@]]@]" tag struct_const sc1 sconsts scl - | Const_false -> fprintf ppf "false" - | Const_true -> fprintf ppf "true" - -let value_kind = function - | Pgenval -> "" + | Const_js_false -> fprintf ppf "false" + | Const_js_true -> fprintf ppf "true" (* let field_kind = function | Pgenval -> "*" @@ -81,28 +81,39 @@ let print_taginfo ppf = function | Blk_tuple -> fprintf ppf "tuple" | Blk_constructor {name; num_nonconst} -> fprintf ppf "%s/%i" name num_nonconst - | Blk_poly_var name -> fprintf ppf "`%s" name + | Blk_poly_var -> fprintf ppf "polyvar" | Blk_record {fields = ss} -> fprintf ppf "[%s]" (String.concat ";" (List.map fst (Array.to_list ss))) | Blk_module ss -> fprintf ppf "[%s]" (String.concat ";" ss) - | Blk_some -> fprintf ppf "some" - | Blk_some_not_nested -> fprintf ppf "some_not_nested" | Blk_module_export _ -> fprintf ppf "module/exports" | Blk_record_inlined {fields = ss} -> fprintf ppf "[%s]" (String.concat ";" (List.map fst (Array.to_list ss))) +(* Every comparison prints its operand kind, so [Pintcomp], [Pjscomp], + [Pstringcomp] and friends stay distinguishable. *) +let comparison ppf kind (cmp : Lambda.comparison) = + let op = + match cmp with + | Ceq -> "==" + | Cneq -> "!=" + | Clt -> "<" + | Cle -> "<=" + | Cgt -> ">" + | Cge -> ">=" + in + fprintf ppf "%s[%s]" op kind + let primitive ppf = function - | Peliminated kind -> ( - match kind with - | Identity -> fprintf ppf "id" - | Ignore -> fprintf ppf "ignore") | Pdebugger -> fprintf ppf "debugger" | Ptypeof -> fprintf ppf "typeof" - | Pnull -> fprintf ppf "null" - | Pundefined -> fprintf ppf "undefined" - | Pfn_arity -> fprintf ppf "fn.length" - | Pgetglobal id -> fprintf ppf "global %a" Ident.print id - | Pmakeblock taginfo -> fprintf ppf "makeblock %a" print_taginfo taginfo + | Psome -> fprintf ppf "some" + | Psome_not_nest -> fprintf ppf "some_not_nest" + | Pmakeblock taginfo -> + let what = + if Lambda.mutable_flag_of_tag_info taginfo = Immutable then "makeblock" + else "makemutable" + in + fprintf ppf "%s %a" what print_taginfo taginfo | Pfield (n, fld) -> fprintf ppf "field:%s/%i" (str_of_field_info fld) n | Psetfield (n, _) -> fprintf ppf "setfield %i" n | Pduprecord -> fprintf ppf "duprecord" @@ -113,12 +124,7 @@ let primitive ppf = function | Pjs_object_get name -> fprintf ppf "js_object_get[%s]" name | Pjs_object_set name -> fprintf ppf "js_object_set[%s]" name | Praise -> fprintf ppf "raise" - | Pobjcomp Ceq -> fprintf ppf "==" - | Pobjcomp Cneq -> fprintf ppf "!=" - | Pobjcomp Clt -> fprintf ppf "<" - | Pobjcomp Cle -> fprintf ppf "<=" - | Pobjcomp Cgt -> fprintf ppf ">" - | Pobjcomp Cge -> fprintf ppf ">=" + | Pobjcomp cmp -> comparison ppf "obj" cmp | Pobjorder -> fprintf ppf "compare" | Pobjmin -> fprintf ppf "min" | Pobjmax -> fprintf ppf "max" @@ -127,12 +133,7 @@ let primitive ppf = function | Psequand -> fprintf ppf "&&" | Psequor -> fprintf ppf "||" | Pnot -> fprintf ppf "not" - | Pboolcomp Ceq -> fprintf ppf "==" - | Pboolcomp Cneq -> fprintf ppf "!=" - | Pboolcomp Clt -> fprintf ppf "<" - | Pboolcomp Cle -> fprintf ppf "<=" - | Pboolcomp Cgt -> fprintf ppf ">" - | Pboolcomp Cge -> fprintf ppf ">=" + | Pboolcomp cmp -> comparison ppf "bool" cmp | Pboolorder -> fprintf ppf "compare" | Pboolmin -> fprintf ppf "min" | Pboolmax -> fprintf ppf "max" @@ -150,17 +151,10 @@ let primitive ppf = function | Plslint -> fprintf ppf "lsl" | Plsrint -> fprintf ppf "lsr" | Pasrint -> fprintf ppf "asr" - | Pintcomp Ceq -> fprintf ppf "==" - | Pintcomp Cneq -> fprintf ppf "!=" - | Pintcomp Clt -> fprintf ppf "<" - | Pintcomp Cle -> fprintf ppf "<=" - | Pintcomp Cgt -> fprintf ppf ">" - | Pintcomp Cge -> fprintf ppf ">=" + | Pintcomp cmp -> comparison ppf "int" cmp | Pintorder -> fprintf ppf "compare" | Pintmin -> fprintf ppf "min" | Pintmax -> fprintf ppf "max" - | Poffsetint n -> fprintf ppf "%i+" n - | Poffsetref n -> fprintf ppf "+:=%i" n | Pintoffloat -> fprintf ppf "int_of_float" | Pfloatofint -> fprintf ppf "float_of_int" | Pnegfloat -> fprintf ppf "~-." @@ -170,12 +164,7 @@ let primitive ppf = function | Pdivfloat -> fprintf ppf "/." | Pmodfloat -> fprintf ppf "mod" | Ppowfloat -> fprintf ppf "**" - | Pfloatcomp Ceq -> fprintf ppf "==." - | Pfloatcomp Cneq -> fprintf ppf "!=." - | Pfloatcomp Clt -> fprintf ppf "<." - | Pfloatcomp Cle -> fprintf ppf "<=." - | Pfloatcomp Cgt -> fprintf ppf ">." - | Pfloatcomp Cge -> fprintf ppf ">=." + | Pfloatcomp cmp -> comparison ppf "float" cmp | Pfloatorder -> fprintf ppf "compare" | Pfloatmin -> fprintf ppf "min" | Pfloatmax -> fprintf ppf "max" @@ -192,24 +181,14 @@ let primitive ppf = function | Pasrbigint -> fprintf ppf "asr" | Pdivbigint -> fprintf ppf "/" | Pmodbigint -> fprintf ppf "mod" - | Pbigintcomp Ceq -> fprintf ppf "==," - | Pbigintcomp Cneq -> fprintf ppf "!=," - | Pbigintcomp Clt -> fprintf ppf "<," - | Pbigintcomp Cle -> fprintf ppf "<=," - | Pbigintcomp Cgt -> fprintf ppf ">," - | Pbigintcomp Cge -> fprintf ppf ">=," + | Pbigintcomp cmp -> comparison ppf "bigint" cmp | Pbigintorder -> fprintf ppf "compare" | Pbigintmin -> fprintf ppf "min" | Pbigintmax -> fprintf ppf "max" | Pstringlength -> fprintf ppf "string.length" | Pstringrefu -> fprintf ppf "string.unsafe_get" | Pstringrefs -> fprintf ppf "string.get" - | Pstringcomp Ceq -> fprintf ppf "==" - | Pstringcomp Cneq -> fprintf ppf "!=" - | Pstringcomp Clt -> fprintf ppf "<" - | Pstringcomp Cle -> fprintf ppf "<=" - | Pstringcomp Cgt -> fprintf ppf ">" - | Pstringcomp Cge -> fprintf ppf ">=" + | Pstringcomp cmp -> comparison ppf "string" cmp | Pstringorder -> fprintf ppf "compare" | Pstringmin -> fprintf ppf "min" | Pstringmax -> fprintf ppf "max" @@ -224,8 +203,9 @@ let primitive ppf = function | Pmakedict -> fprintf ppf "makedict" | Pdict_has -> fprintf ppf "dict.has" | Pisint -> fprintf ppf "isint" - | Pisout -> fprintf ppf "isout" - | Pisnullable -> fprintf ppf "isnullable" + | Pis_null -> fprintf ppf "is_null" + | Pis_undefined -> fprintf ppf "is_undefined" + | Pis_null_undefined -> fprintf ppf "isnullable" | Pcreate_extension s -> fprintf ppf "extension[%s]" s | Pawait -> fprintf ppf "await" | Pimport (Import_module {module_; path}) -> @@ -238,15 +218,9 @@ let primitive ppf = function | Phash_mixint -> fprintf ppf "hash_mix_int" | Phash_mixstring -> fprintf ppf "hash_mix_string" | Phash_finalmix -> fprintf ppf "hash_final_mix" - | Pcurry_apply i -> fprintf ppf "apply[%d]" i - | Pjscomp Ceq -> fprintf ppf "==" - | Pjscomp Cneq -> fprintf ppf "!=" - | Pjscomp Clt -> fprintf ppf "<" - | Pjscomp Cle -> fprintf ppf "<=" - | Pjscomp Cgt -> fprintf ppf ">" - | Pjscomp Cge -> fprintf ppf ">=" + | Pjscomp cmp -> comparison ppf "js" cmp | Pnull_to_opt -> fprintf ppf "null_to_opt" - | Pnullable_to_opt -> fprintf ppf "nullable_to_opt" + | Pnull_undefined_to_opt -> fprintf ppf "nullable_to_opt" | Pis_not_none -> fprintf ppf "#is_not_none" | Pval_from_option -> fprintf ppf "#val_from_option" | Pval_from_option_not_nest -> fprintf ppf "#val_from_option_not_nest" @@ -271,18 +245,19 @@ let apply_inlined_attribute ppf = function let rec lam ppf = function | Lvar id -> Ident.print ppf id + | Lglobal_module id -> fprintf ppf "global %a" Ident.print id | Lconst cst -> struct_const ppf cst | Lapply ap -> let lams ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in fprintf ppf "@[<2>(apply@ %a%a%a)@]" lam ap.ap_func lams ap.ap_args - apply_inlined_attribute ap.ap_inlined + apply_inlined_attribute ap.ap_info.ap_inlined | Lfunction {params; body; attr} -> let pr_params ppf params = List.iter (fun param -> fprintf ppf "@ %a" Ident.print param) params in fprintf ppf "@[<2>(function%a@ %a%a)@]" pr_params params function_attribute attr lam body - | Llet (str, k, id, arg, body) -> + | Llet (str, id, arg, body) -> let kind = function | Alias -> "a" | Strict -> "" @@ -290,14 +265,13 @@ let rec lam ppf = function | Variable -> "v" in let rec letbody = function - | Llet (str, k, id, arg, body) -> - fprintf ppf "@ @[<2>%a =%s%s@ %a@]" Ident.print id (kind str) - (value_kind k) lam arg; + | Llet (str, id, arg, body) -> + fprintf ppf "@ @[<2>%a =%s@ %a@]" Ident.print id (kind str) lam arg; letbody body | expr -> expr in - fprintf ppf "@[<2>(let@ @[(@[<2>%a =%s%s@ %a@]" Ident.print id - (kind str) (value_kind k) lam arg; + fprintf ppf "@[<2>(let@ @[(@[<2>%a =%s@ %a@]" Ident.print id + (kind str) lam arg; let expr = letbody body in fprintf ppf ")@]@ %a)@]" lam expr | Lletrec (id_arg_list, body) -> @@ -311,10 +285,10 @@ let rec lam ppf = function in fprintf ppf "@[<2>(letrec@ (@[%a@])@ %a)@]" bindings id_arg_list lam body - | Lprim (prim, largs, _) -> + | Lprim {primitive = prim; args = largs; loc = _} -> let lams ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in fprintf ppf "@[<2>(%a%a)@]" primitive prim lams largs - | Lswitch (larg, sw, _loc) -> + | Lswitch (larg, sw) -> let switch ppf sw = let spc = ref false in List.iter @@ -348,7 +322,7 @@ let rec lam ppf = function | None -> "switch*" | _ -> "switch") lam larg switch sw - | Lstringswitch (arg, cases, default, _) -> + | Lstringswitch (arg, cases, default) -> let switch ppf cases = let spc = ref false in List.iter @@ -405,3 +379,15 @@ and sequence ppf = function let structured_constant = struct_const let lambda = lam + +let serialize (filename : string) (l : Lambda.t) : unit = + let ou = open_out filename in + let old = Format.get_margin () in + Format.set_margin 10000; + let fmt = Format.formatter_of_out_channel ou in + lambda fmt l; + Format.pp_print_flush fmt (); + close_out ou; + Format.set_margin old + +let lambda_to_string = Format.asprintf "%a" lambda diff --git a/compiler/ml/printlambda.mli b/compiler/ml/printlambda.mli index d20fa3ece0f..d4e1dfbd09d 100644 --- a/compiler/ml/printlambda.mli +++ b/compiler/ml/printlambda.mli @@ -18,4 +18,11 @@ open Lambda open Format val structured_constant : formatter -> structured_constant -> unit -val lambda : formatter -> lambda -> unit +val lambda : formatter -> Lambda.t -> unit + +val primitive : formatter -> Lambda.primitive -> unit + +val serialize : string -> Lambda.t -> unit +(** Print a term to a file, unwrapped: used for the -debug-ir dumps. *) + +val lambda_to_string : Lambda.t -> string diff --git a/compiler/ml/switch.ml b/compiler/ml/switch.ml index 85d3b022471..714a030eb8d 100644 --- a/compiler/ml/switch.ml +++ b/compiler/ml/switch.ml @@ -13,6 +13,8 @@ (* *) (**************************************************************************) +open Lambda + type 'a shared = Shared of 'a | Single of 'a type 'a t_store = { @@ -21,8 +23,6 @@ type 'a t_store = { act_store_shared: 'a -> int; } -exception Not_simple - module type Stored = sig type t type key @@ -87,28 +87,74 @@ module Store (A : Stored) = struct } end -module type S = sig - type primitive - val eqint : primitive - val neint : primitive - val leint : primitive - val ltint : primitive - val geint : primitive - val gtint : primitive - type act - - val bind : act -> (act -> act) -> act - val make_const : int -> act - val make_offset : act -> int -> act - val make_prim : primitive -> act list -> act - val make_isout : act -> act -> act - val make_isin : act -> act -> act - val make_if : act -> act -> act -> act - val make_switch : - Location.t -> act -> int array -> act array -> offset:int -> act - val make_catch : act -> int * (act -> act) - val make_exit : int -> act -end +(* The algorithm below builds a decision structure over Lambda. It used to be a + functor so that upstream OCaml could share it between the bytecode and the + native backends; ReScript has only the one, so the operations it needs are + defined here directly. *) + +let eqint = Pintcomp Ceq +let neint = Pintcomp Cneq +let leint = Pintcomp Cle +let ltint = Pintcomp Clt +let geint = Pintcomp Cge +let gtint = Pintcomp Cgt + +let prim p args : Lambda.t = prim ~primitive:p ~args Location.none + +(* [covers_range cases ~start ~finish] holds when [cases] is exactly the + contiguous integer keys [start .. finish], in order. *) +let rec covers_range (cases : (switch_key * Lambda.t) list) ~start ~finish = + match cases with + | [] -> finish < start + | (Switch_int i, _) :: rest -> + start <= finish && i = start && covers_range rest ~start:(start + 1) ~finish + | (Switch_constructor _, _) :: _ -> false + +(* [arg] is outside [lo .. hi]. A two-value range reads better as a pair of + equality tests than as a pair of comparisons. *) +let out_of_range arg ~lo ~hi = + let test cmp k = prim (Pintcomp cmp) [arg; const (const_int k)] in + if hi = lo + 1 then prim Pnot [prim Psequor [test Ceq lo; test Ceq hi]] + else prim Psequor [test Cgt hi; test Clt lo] + +let emit_if_out ~offset ~range arg ifso ifno = + let lo = -offset and hi = range - offset in + match (arg, ifno) with + (* The switcher guards a jump table with a range test, because on a machine + target that beats a table carrying a default. A JS [switch] has a native + [default], so when the table already covers the whole guarded range the + guard is pure overhead: drop it and make its action the failaction. *) + | ( Lvar x, + Lswitch + ( (Lvar y as sarg), + ({ + sw_blocks = []; + sw_blocks_full = true; + sw_consts; + sw_failaction = None; + } as sw) ) ) + when Ident.same x y && covers_range sw_consts ~start:lo ~finish:hi -> + switch sarg {sw with sw_failaction = Some ifso; sw_consts_full = false} + | _ -> if_ (out_of_range arg ~lo ~hi) ifso ifno + +let emit_if_in ~offset ~range arg ifso ifno = + let lo = -offset and hi = range - offset in + if_ (prim Pnot [out_of_range arg ~lo ~hi]) ifso ifno + +let emit_switch arg cases acts ~offset : Lambda.t = + let l = ref [] in + for i = Array.length cases - 1 downto 0 do + l := (Switch_int (offset + i), acts.(cases.(i))) :: !l + done; + switch arg + { + sw_consts_full = true; + sw_consts = !l; + sw_blocks_full = true; + sw_blocks = []; + sw_failaction = None; + sw_dispatch = Switch_direct; + } (* The module will ``produce good code for the case statement'' *) (* @@ -125,21 +171,24 @@ end Technical Reports, James Cook University *) (* - Main adaptation is considering interval tests - (implemented as one addition + one unsigned test and branch) - which leads to exhaustive search for finding the optimal - test sequence in small cases and heuristics otherwise. + Main adaptation is considering interval tests, which leads to exhaustive + search for finding the optimal test sequence in small cases and heuristics + otherwise. Upstream costs an interval test as one addition plus one unsigned + test and branch; here it is a pair of comparisons, or a pair of equality + tests for a two-value range - see [out_of_range]. *) -module Make (Arg : S) = struct - type 'a inter = {cases: (int * int * int) array; actions: 'a array} - type 'a t_ctx = {off: int; arg: 'a} +(* [actions] is instantiated both at [lambda] (the original actions) and at + [t_ctx -> Lambda.t] (cluster actions, which still need a context). *) +type 'a inter = {cases: (int * int * int) array; actions: 'a array} - let cut = ref 8 +type t_ctx = {off: int; arg: Lambda.t} - and more_cut = ref 16 +let cut = ref 8 - (* +and more_cut = ref 16 + +(* let pint chan i = if i = min_int then Printf.fprintf chan "-oo" else if i=max_int then Printf.fprintf chan "oo" @@ -158,19 +207,19 @@ let prerr_inter i = Printf.fprintf stderr "cases=%a" pcases i.cases *) - let get_act cases i = - let _, _, r = cases.(i) in - r +let get_act cases i = + let _, _, r = cases.(i) in + r - and get_low cases i = - let r, _, _ = cases.(i) in - r +and get_low cases i = + let r, _, _ = cases.(i) in + r - type ctests = {mutable n: int; mutable ni: int} +type ctests = {mutable n: int; mutable ni: int} - let too_much = {n = max_int; ni = max_int} +let too_much = {n = max_int; ni = max_int} - (* +(* let ptests chan {n=n ; ni=ni} = Printf.fprintf chan "{n=%d ; ni=%d}" n ni @@ -180,96 +229,96 @@ let pta chan t = done *) - let less_tests c1 c2 = - if c1.n < c2.n then true - else if c1.n = c2.n then if c1.ni < c2.ni then true else false - else false +let less_tests c1 c2 = + if c1.n < c2.n then true + else if c1.n = c2.n then if c1.ni < c2.ni then true else false + else false - and eq_tests c1 c2 = c1.n = c2.n && c1.ni = c2.ni +and eq_tests c1 c2 = c1.n = c2.n && c1.ni = c2.ni - let less2tests (c1, d1) (c2, d2) = - if eq_tests c1 c2 then less_tests d1 d2 else less_tests c1 c2 +let less2tests (c1, d1) (c2, d2) = + if eq_tests c1 c2 then less_tests d1 d2 else less_tests c1 c2 - let add_test t1 t2 = - t1.n <- t1.n + t2.n; - t1.ni <- t1.ni + t2.ni +let add_test t1 t2 = + t1.n <- t1.n + t2.n; + t1.ni <- t1.ni + t2.ni - type t_ret = Inter of int * int | Sep of int | No +type t_ret = Inter of int * int | Sep of int | No - (* +(* let pret chan = function | Inter (i,j)-> Printf.fprintf chan "Inter %d %d" i j | Sep i -> Printf.fprintf chan "Sep %d" i | No -> Printf.fprintf chan "No" *) - let coupe cases i = - let l, _, _ = cases.(i) in - (l, Array.sub cases 0 i, Array.sub cases i (Array.length cases - i)) - - let case_append c1 c2 = - let len1 = Array.length c1 and len2 = Array.length c2 in - match (len1, len2) with - | 0, _ -> c2 - | _, 0 -> c1 - | _, _ -> - let l1, h1, act1 = c1.(Array.length c1 - 1) and l2, h2, act2 = c2.(0) in - if act1 = act2 then ( - let r = Array.make (len1 + len2 - 1) c1.(0) in - for i = 0 to len1 - 2 do - r.(i) <- c1.(i) - done; - - let l = - if len1 - 2 >= 0 then - let _, h, _ = r.(len1 - 2) in - if h + 1 < l1 then h + 1 else l1 - else l1 - and h = - if 1 < len2 - 1 then - let l, _, _ = c2.(1) in - if h2 + 1 < l then l - 1 else h2 - else h2 - in - r.(len1 - 1) <- (l, h, act1); - for i = 1 to len2 - 1 do - r.(len1 - 1 + i) <- c2.(i) - done; - r) - else if h1 > l1 then ( - let r = Array.make (len1 + len2) c1.(0) in - for i = 0 to len1 - 2 do - r.(i) <- c1.(i) - done; - r.(len1 - 1) <- (l1, l2 - 1, act1); - for i = 0 to len2 - 1 do - r.(len1 + i) <- c2.(i) - done; - r) - else if h2 > l2 then ( - let r = Array.make (len1 + len2) c1.(0) in - for i = 0 to len1 - 1 do - r.(i) <- c1.(i) - done; - r.(len1) <- (h1 + 1, h2, act2); - for i = 1 to len2 - 1 do - r.(len1 + i) <- c2.(i) - done; - r) - else Array.append c1 c2 - - let coupe_inter i j cases = - let lcases = Array.length cases in - let low, _, _ = cases.(i) and _, high, _ = cases.(j) in - ( low, - high, - Array.sub cases i (j - i + 1), - case_append (Array.sub cases 0 i) - (Array.sub cases (j + 1) (lcases - (j + 1))) ) - - type kind = Kvalue of int | Kinter of int | Kempty +let coupe cases i = + let l, _, _ = cases.(i) in + (l, Array.sub cases 0 i, Array.sub cases i (Array.length cases - i)) + +let case_append c1 c2 = + let len1 = Array.length c1 and len2 = Array.length c2 in + match (len1, len2) with + | 0, _ -> c2 + | _, 0 -> c1 + | _, _ -> + let l1, h1, act1 = c1.(Array.length c1 - 1) and l2, h2, act2 = c2.(0) in + if act1 = act2 then ( + let r = Array.make (len1 + len2 - 1) c1.(0) in + for i = 0 to len1 - 2 do + r.(i) <- c1.(i) + done; - (* + let l = + if len1 - 2 >= 0 then + let _, h, _ = r.(len1 - 2) in + if h + 1 < l1 then h + 1 else l1 + else l1 + and h = + if 1 < len2 - 1 then + let l, _, _ = c2.(1) in + if h2 + 1 < l then l - 1 else h2 + else h2 + in + r.(len1 - 1) <- (l, h, act1); + for i = 1 to len2 - 1 do + r.(len1 - 1 + i) <- c2.(i) + done; + r) + else if h1 > l1 then ( + let r = Array.make (len1 + len2) c1.(0) in + for i = 0 to len1 - 2 do + r.(i) <- c1.(i) + done; + r.(len1 - 1) <- (l1, l2 - 1, act1); + for i = 0 to len2 - 1 do + r.(len1 + i) <- c2.(i) + done; + r) + else if h2 > l2 then ( + let r = Array.make (len1 + len2) c1.(0) in + for i = 0 to len1 - 1 do + r.(i) <- c1.(i) + done; + r.(len1) <- (h1 + 1, h2, act2); + for i = 1 to len2 - 1 do + r.(len1 + i) <- c2.(i) + done; + r) + else Array.append c1 c2 + +let coupe_inter i j cases = + let lcases = Array.length cases in + let low, _, _ = cases.(i) and _, high, _ = cases.(j) in + ( low, + high, + Array.sub cases i (j - i + 1), + case_append (Array.sub cases 0 i) + (Array.sub cases (j + 1) (lcases - (j + 1))) ) + +type kind = Kvalue of int | Kinter of int | Kempty + +(* let pkind chan = function | Kvalue i ->Printf.fprintf chan "V%d" i | Kinter i -> Printf.fprintf chan "I%d" i @@ -282,46 +331,46 @@ let rec pkey chan = function Printf.fprintf chan "%a %a" pkey rem pkind k *) - let t = Hashtbl.create 17 - - let make_key cases = - let seen = ref [] and count = ref 0 in - let rec got_it act = function - | [] -> - seen := (act, !count) :: !seen; - let r = !count in - incr count; - r - | (act0, index) :: rem -> if act0 = act then index else got_it act rem - in - - let make_one (l : int) h act = - if l = h then Kvalue (got_it act !seen) else Kinter (got_it act !seen) - in +let t = Hashtbl.create 17 - let rec make_rec i pl = - if i < 0 then [] - else - let l, h, act = cases.(i) in - if pl = h + 1 then make_one l h act :: make_rec (i - 1) l - else Kempty :: make_one l h act :: make_rec (i - 1) l - in +let make_key cases = + let seen = ref [] and count = ref 0 in + let rec got_it act = function + | [] -> + seen := (act, !count) :: !seen; + let r = !count in + incr count; + r + | (act0, index) :: rem -> if act0 = act then index else got_it act rem + in - let l, h, act = cases.(Array.length cases - 1) in - make_one l h act :: make_rec (Array.length cases - 2) l + let make_one (l : int) h act = + if l = h then Kvalue (got_it act !seen) else Kinter (got_it act !seen) + in - let same_act t = - let len = Array.length t in - let a = get_act t (len - 1) in - let rec do_rec i = - if i < 0 then true - else - let b = get_act t i in - b = a && do_rec (i - 1) - in - do_rec (len - 2) + let rec make_rec i pl = + if i < 0 then [] + else + let l, h, act = cases.(i) in + if pl = h + 1 then make_one l h act :: make_rec (i - 1) l + else Kempty :: make_one l h act :: make_rec (i - 1) l + in + + let l, h, act = cases.(Array.length cases - 1) in + make_one l h act :: make_rec (Array.length cases - 2) l + +let same_act t = + let len = Array.length t in + let a = get_act t (len - 1) in + let rec do_rec i = + if i < 0 then true + else + let b = get_act t i in + b = a && do_rec (i - 1) + in + do_rec (len - 2) - (* +(* Interval test x in [l,h] works by checking x-l in [0,h-l] * This may be false for arithmetic modulo 2^31 * Subtracting l may change the relative ordering of values @@ -335,49 +384,113 @@ let rec pkey chan = function This condition is checked by zyva *) - let inter_limit = 1 lsl 16 - - let ok_inter = ref false - - let rec opt_count top cases = - let key = make_key cases in - try Hashtbl.find t key - with Not_found -> - let r = - let lcases = Array.length cases in - match lcases with - | 0 -> assert false - | _ when same_act cases -> (No, ({n = 0; ni = 0}, {n = 0; ni = 0})) - | _ -> - if lcases < !cut then enum top cases - else if lcases < !more_cut then heuristic cases - else divide cases - in - Hashtbl.add t key r; - r +let inter_limit = 1 lsl 16 + +let ok_inter = ref false + +let rec opt_count top cases = + let key = make_key cases in + try Hashtbl.find t key + with Not_found -> + let r = + let lcases = Array.length cases in + match lcases with + | 0 -> assert false + | _ when same_act cases -> (No, ({n = 0; ni = 0}, {n = 0; ni = 0})) + | _ -> + if lcases < !cut then enum top cases + else if lcases < !more_cut then heuristic cases + else divide cases + in + Hashtbl.add t key r; + r - and divide cases = - let lcases = Array.length cases in - let m = lcases / 2 in - let _, left, right = coupe cases m in - let ci = {n = 1; ni = 0} - and cm = {n = 1; ni = 0} - and _, (cml, cleft) = opt_count false left - and _, (cmr, cright) = opt_count false right in - add_test ci cleft; - add_test ci cright; - if less_tests cml cmr then add_test cm cmr else add_test cm cml; - (Sep m, (cm, ci)) - - and heuristic cases = - let lcases = Array.length cases in - - let sep, csep = divide cases - and inter, cinter = - if !ok_inter then - let _, _, act0 = cases.(0) and _, _, act1 = cases.(lcases - 1) in - if act0 = act1 then ( - let low, high, inside, outside = coupe_inter 1 (lcases - 2) cases in +and divide cases = + let lcases = Array.length cases in + let m = lcases / 2 in + let _, left, right = coupe cases m in + let ci = {n = 1; ni = 0} + and cm = {n = 1; ni = 0} + and _, (cml, cleft) = opt_count false left + and _, (cmr, cright) = opt_count false right in + add_test ci cleft; + add_test ci cright; + if less_tests cml cmr then add_test cm cmr else add_test cm cml; + (Sep m, (cm, ci)) + +and heuristic cases = + let lcases = Array.length cases in + + let sep, csep = divide cases + and inter, cinter = + if !ok_inter then + let _, _, act0 = cases.(0) and _, _, act1 = cases.(lcases - 1) in + if act0 = act1 then ( + let low, high, inside, outside = coupe_inter 1 (lcases - 2) cases in + let _, (cmi, cinside) = opt_count false inside + and _, (cmo, coutside) = opt_count false outside + and cmij = {n = 1; ni = (if low = high then 0 else 1)} + and cij = {n = 1; ni = (if low = high then 0 else 1)} in + add_test cij cinside; + add_test cij coutside; + if less_tests cmi cmo then add_test cmij cmo else add_test cmij cmi; + (Inter (1, lcases - 2), (cmij, cij))) + else (Inter (-1, -1), (too_much, too_much)) + else (Inter (-1, -1), (too_much, too_much)) + in + if less2tests csep cinter then (sep, csep) else (inter, cinter) + +and enum top cases = + let lcases = Array.length cases in + let lim, with_sep = + let best = ref (-1) and best_cost = ref (too_much, too_much) in + + for i = 1 to lcases - 1 do + let _, left, right = coupe cases i in + let ci = {n = 1; ni = 0} + and cm = {n = 1; ni = 0} + and _, (cml, cleft) = opt_count false left + and _, (cmr, cright) = opt_count false right in + add_test ci cleft; + add_test ci cright; + if less_tests cml cmr then add_test cm cmr else add_test cm cml; + + if less2tests (cm, ci) !best_cost then ( + if top then Printf.fprintf stderr "Get it: %d\n" i; + best := i; + best_cost := (cm, ci)) + done; + (!best, !best_cost) + in + + let ilow, ihigh, with_inter = + if not !ok_inter then ( + let rlow = ref (-1) + and rhigh = ref (-1) + and best_cost = ref (too_much, too_much) in + for i = 1 to lcases - 2 do + let low, high, inside, outside = coupe_inter i i cases in + if low = high then ( + let _, (cmi, cinside) = opt_count false inside + and _, (cmo, coutside) = opt_count false outside + and cmij = {n = 1; ni = 0} + and cij = {n = 1; ni = 0} in + add_test cij cinside; + add_test cij coutside; + if less_tests cmi cmo then add_test cmij cmo else add_test cmij cmi; + if less2tests (cmij, cij) !best_cost then ( + rlow := i; + rhigh := i; + best_cost := (cmij, cij))) + done; + (!rlow, !rhigh, !best_cost)) + else + let rlow = ref (-1) + and rhigh = ref (-1) + and best_cost = ref (too_much, too_much) in + for i = 1 to lcases - 2 do + for j = i to lcases - 2 do + let low, high, inside, outside = coupe_inter i j cases in let _, (cmi, cinside) = opt_count false inside and _, (cmo, coutside) = opt_count false outside and cmij = {n = 1; ni = (if low = high then 0 else 1)} @@ -385,348 +498,265 @@ let rec pkey chan = function add_test cij cinside; add_test cij coutside; if less_tests cmi cmo then add_test cmij cmo else add_test cmij cmi; - (Inter (1, lcases - 2), (cmij, cij))) - else (Inter (-1, -1), (too_much, too_much)) - else (Inter (-1, -1), (too_much, too_much)) - in - if less2tests csep cinter then (sep, csep) else (inter, cinter) - - and enum top cases = - let lcases = Array.length cases in - let lim, with_sep = - let best = ref (-1) and best_cost = ref (too_much, too_much) in - - for i = 1 to lcases - 1 do - let _, left, right = coupe cases i in - let ci = {n = 1; ni = 0} - and cm = {n = 1; ni = 0} - and _, (cml, cleft) = opt_count false left - and _, (cmr, cright) = opt_count false right in - add_test ci cleft; - add_test ci cright; - if less_tests cml cmr then add_test cm cmr else add_test cm cml; - - if less2tests (cm, ci) !best_cost then ( - if top then Printf.fprintf stderr "Get it: %d\n" i; - best := i; - best_cost := (cm, ci)) + if less2tests (cmij, cij) !best_cost then ( + rlow := i; + rhigh := j; + best_cost := (cmij, cij)) + done done; - (!best, !best_cost) - in - - let ilow, ihigh, with_inter = - if not !ok_inter then ( - let rlow = ref (-1) - and rhigh = ref (-1) - and best_cost = ref (too_much, too_much) in - for i = 1 to lcases - 2 do - let low, high, inside, outside = coupe_inter i i cases in - if low = high then ( - let _, (cmi, cinside) = opt_count false inside - and _, (cmo, coutside) = opt_count false outside - and cmij = {n = 1; ni = 0} - and cij = {n = 1; ni = 0} in - add_test cij cinside; - add_test cij coutside; - if less_tests cmi cmo then add_test cmij cmo else add_test cmij cmi; - if less2tests (cmij, cij) !best_cost then ( - rlow := i; - rhigh := i; - best_cost := (cmij, cij))) - done; - (!rlow, !rhigh, !best_cost)) - else - let rlow = ref (-1) - and rhigh = ref (-1) - and best_cost = ref (too_much, too_much) in - for i = 1 to lcases - 2 do - for j = i to lcases - 2 do - let low, high, inside, outside = coupe_inter i j cases in - let _, (cmi, cinside) = opt_count false inside - and _, (cmo, coutside) = opt_count false outside - and cmij = {n = 1; ni = (if low = high then 0 else 1)} - and cij = {n = 1; ni = (if low = high then 0 else 1)} in - add_test cij cinside; - add_test cij coutside; - if less_tests cmi cmo then add_test cmij cmo else add_test cmij cmi; - if less2tests (cmij, cij) !best_cost then ( - rlow := i; - rhigh := j; - best_cost := (cmij, cij)) - done - done; - (!rlow, !rhigh, !best_cost) - in - let r = ref (Inter (ilow, ihigh)) and rc = ref with_inter in - if less2tests with_sep !rc then ( - r := Sep lim; - rc := with_sep); - (!r, !rc) - - let make_if_test test arg i ifso ifnot = - Arg.make_if (Arg.make_prim test [arg; Arg.make_const i]) ifso ifnot - - let make_if_lt arg i ifso ifnot = - match i with - | 1 -> make_if_test Arg.leint arg 0 ifso ifnot - | _ -> make_if_test Arg.ltint arg i ifso ifnot - - and make_if_ge arg i ifso ifnot = - match i with - | 1 -> make_if_test Arg.gtint arg 0 ifso ifnot - | _ -> make_if_test Arg.geint arg i ifso ifnot - - and make_if_eq arg i ifso ifnot = make_if_test Arg.eqint arg i ifso ifnot - - and make_if_ne arg i ifso ifnot = make_if_test Arg.neint arg i ifso ifnot - - let do_make_if_out h arg ifso ifno = - Arg.make_if (Arg.make_isout h arg) ifso ifno - - let make_if_out ctx l d mk_ifso mk_ifno = - match l with - | 0 -> do_make_if_out (Arg.make_const d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) - | _ -> - do_make_if_out (Arg.make_const d) - (Arg.make_offset ctx.arg (-l)) - (mk_ifso ctx) (mk_ifno ctx) - - let do_make_if_in h arg ifso ifno = - Arg.make_if (Arg.make_isin h arg) ifso ifno - - let make_if_in ctx l d mk_ifso mk_ifno = - match l with - | 0 -> do_make_if_in (Arg.make_const d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) - | _ -> - do_make_if_in (Arg.make_const d) - (Arg.make_offset ctx.arg (-l)) - (mk_ifso ctx) (mk_ifno ctx) - - let rec c_test ctx ({cases; actions} as s) = - let lcases = Array.length cases in - assert (lcases > 0); - if lcases = 1 then actions.(get_act cases 0) ctx - else - let w, _c = opt_count false cases in - (* + (!rlow, !rhigh, !best_cost) + in + let r = ref (Inter (ilow, ihigh)) and rc = ref with_inter in + if less2tests with_sep !rc then ( + r := Sep lim; + rc := with_sep); + (!r, !rc) + +let make_if_test test arg i ifso ifnot = + if_ (prim test [arg; const (const_int i)]) ifso ifnot + +let make_if_lt arg i ifso ifnot = + match i with + | 1 -> make_if_test leint arg 0 ifso ifnot + | _ -> make_if_test ltint arg i ifso ifnot + +and make_if_ge arg i ifso ifnot = + match i with + | 1 -> make_if_test gtint arg 0 ifso ifnot + | _ -> make_if_test geint arg i ifso ifnot + +and make_if_eq arg i ifso ifnot = make_if_test eqint arg i ifso ifnot + +and make_if_ne arg i ifso ifnot = make_if_test neint arg i ifso ifnot + +let make_if_out ctx l d mk_ifso mk_ifno = + emit_if_out ~offset:(-l) ~range:d ctx.arg (mk_ifso ctx) (mk_ifno ctx) + +let make_if_in ctx l d mk_ifso mk_ifno = + emit_if_in ~offset:(-l) ~range:d ctx.arg (mk_ifso ctx) (mk_ifno ctx) + +let rec c_test ctx ({cases; actions} as s) = + let lcases = Array.length cases in + assert (lcases > 0); + if lcases = 1 then actions.(get_act cases 0) ctx + else + let w, _c = opt_count false cases in + (* Printf.fprintf stderr "off=%d tactic=%a for %a\n" ctx.off pret w pcases cases ; *) - match w with - | No -> actions.(get_act cases 0) ctx - | Inter (i, j) -> - let low, high, inside, outside = coupe_inter i j cases in - let _, (cinside, _) = opt_count false inside - and _, (coutside, _) = opt_count false outside in - (* Costs are retrieved to put the code with more remaining tests + match w with + | No -> actions.(get_act cases 0) ctx + | Inter (i, j) -> + let low, high, inside, outside = coupe_inter i j cases in + let _, (cinside, _) = opt_count false inside + and _, (coutside, _) = opt_count false outside in + (* Costs are retrieved to put the code with more remaining tests in the privileged (positive) branch of ``if'' *) - if low = high then - if less_tests coutside cinside then - make_if_eq ctx.arg (low + ctx.off) - (c_test ctx {s with cases = inside}) - (c_test ctx {s with cases = outside}) - else - make_if_ne ctx.arg (low + ctx.off) - (c_test ctx {s with cases = outside}) - (c_test ctx {s with cases = inside}) - else if less_tests coutside cinside then - make_if_in ctx (low + ctx.off) (high - low) - (fun ctx -> c_test ctx {s with cases = inside}) - (fun ctx -> c_test ctx {s with cases = outside}) + if low = high then + if less_tests coutside cinside then + make_if_eq ctx.arg (low + ctx.off) + (c_test ctx {s with cases = inside}) + (c_test ctx {s with cases = outside}) else - make_if_out ctx (low + ctx.off) (high - low) - (fun ctx -> c_test ctx {s with cases = outside}) - (fun ctx -> c_test ctx {s with cases = inside}) - | Sep i -> - let lim, left, right = coupe cases i in - let _, (cleft, _) = opt_count false left - and _, (cright, _) = opt_count false right in - let left = {s with cases = left} and right = {s with cases = right} in - - if i = 1 && lim + ctx.off = 1 && get_low cases 0 + ctx.off = 0 then - make_if_ne ctx.arg 0 (c_test ctx right) (c_test ctx left) - else if less_tests cright cleft then - make_if_lt ctx.arg (lim + ctx.off) (c_test ctx left) - (c_test ctx right) - else - make_if_ge ctx.arg (lim + ctx.off) (c_test ctx right) - (c_test ctx left) - - (* Minimal density of switches *) - let theta = ref 0.33333 - - (* Minimal number of tests to make a switch *) - let switch_min = ref 3 - - (* Particular case 0, 1, 2 *) - let particular_case cases i j = - j - i = 2 - && - let l1, _h1, act1 = cases.(i) - and l2, _h2, _act2 = cases.(i + 1) - and l3, h3, act3 = cases.(i + 2) in - l1 + 1 = l2 && l2 + 1 = l3 && l3 = h3 && act1 <> act3 - - let approx_count cases i j = - let l = j - i + 1 in - if l < !cut then - let _, (_, {n = ntests}) = opt_count false (Array.sub cases i l) in - ntests - else l - 1 - - (* Sends back a boolean that says whether is switch is worth or not *) - - let dense {cases} i j = - if i = j then true - else - let l, _, _ = cases.(i) and _, h, _ = cases.(j) in - let ntests = approx_count cases i j in - (* + make_if_ne ctx.arg (low + ctx.off) + (c_test ctx {s with cases = outside}) + (c_test ctx {s with cases = inside}) + else if less_tests coutside cinside then + make_if_in ctx (low + ctx.off) (high - low) + (fun ctx -> c_test ctx {s with cases = inside}) + (fun ctx -> c_test ctx {s with cases = outside}) + else + make_if_out ctx (low + ctx.off) (high - low) + (fun ctx -> c_test ctx {s with cases = outside}) + (fun ctx -> c_test ctx {s with cases = inside}) + | Sep i -> + let lim, left, right = coupe cases i in + let _, (cleft, _) = opt_count false left + and _, (cright, _) = opt_count false right in + let left = {s with cases = left} and right = {s with cases = right} in + + if i = 1 && lim + ctx.off = 1 && get_low cases 0 + ctx.off = 0 then + make_if_ne ctx.arg 0 (c_test ctx right) (c_test ctx left) + else if less_tests cright cleft then + make_if_lt ctx.arg (lim + ctx.off) (c_test ctx left) (c_test ctx right) + else + make_if_ge ctx.arg (lim + ctx.off) (c_test ctx right) (c_test ctx left) + +(* Minimal density of switches *) +let theta = ref 0.33333 + +(* Minimal number of tests to make a switch *) +let switch_min = ref 3 + +(* Particular case 0, 1, 2 *) +let particular_case cases i j = + j - i = 2 + && + let l1, _h1, act1 = cases.(i) + and l2, _h2, _act2 = cases.(i + 1) + and l3, h3, act3 = cases.(i + 2) in + l1 + 1 = l2 && l2 + 1 = l3 && l3 = h3 && act1 <> act3 + +let approx_count cases i j = + let l = j - i + 1 in + if l < !cut then + let _, (_, {n = ntests}) = opt_count false (Array.sub cases i l) in + ntests + else l - 1 + +(* Sends back a boolean that says whether is switch is worth or not *) + +let dense {cases} i j = + if i = j then true + else + let l, _, _ = cases.(i) and _, h, _ = cases.(j) in + let ntests = approx_count cases i j in + (* (ntests+1) >= theta * (h-l+1) *) - particular_case cases i j - || ntests >= !switch_min - && float_of_int ntests +. 1.0 - >= !theta *. (float_of_int h -. float_of_int l +. 1.0) + particular_case cases i j + || ntests >= !switch_min + && float_of_int ntests +. 1.0 + >= !theta *. (float_of_int h -. float_of_int l +. 1.0) - (* Compute clusters by dynamic programming +(* Compute clusters by dynamic programming Adaptation of the correction to Bernstein ``Correction to `Producing Good Code for the Case Statement' '' S.K. Kannan and T.A. Proebsting Software Practice and Experience Vol. 24(2) 233 (Feb 1994) *) - let comp_clusters s = - let len = Array.length s.cases in - let min_clusters = Array.make len max_int and k = Array.make len 0 in - let get_min i = if i < 0 then 0 else min_clusters.(i) in - - for i = 0 to len - 1 do - for j = 0 to i do - if dense s j i && get_min (j - 1) + 1 < min_clusters.(i) then ( - k.(i) <- j; - min_clusters.(i) <- get_min (j - 1) + 1) - done - done; - (min_clusters.(len - 1), k) - - (* Assume j > i *) - let make_switch loc {cases; actions} i j = - let ll, _, _ = cases.(i) and _, hh, _ = cases.(j) in - let tbl = Array.make (hh - ll + 1) 0 - and t = Hashtbl.create 17 - and index = ref 0 in - let get_index act = - try Hashtbl.find t act - with Not_found -> - let i = !index in - incr index; - Hashtbl.add t act i; - i - in - - for k = i to j do - let l, h, act = cases.(k) in - let index = get_index act in - for kk = l - ll to h - ll do - tbl.(kk) <- index - done - done; - let acts = Array.make !index actions.(0) in - Hashtbl.iter (fun act i -> acts.(i) <- actions.(act)) t; - fun ctx -> Arg.make_switch ~offset:(ll + ctx.off) loc ctx.arg tbl acts - - let make_clusters loc ({cases; actions} as s) n_clusters k = - let len = Array.length cases in - let r = Array.make n_clusters (0, 0, 0) - and t = Hashtbl.create 17 - and index = ref 0 - and bidon = ref (Array.length actions) in - let get_index act = - try - let i, _ = Hashtbl.find t act in - i - with Not_found -> - let i = !index in - incr index; - Hashtbl.add t act (i, fun _ -> actions.(act)); - i - and add_index act = +let comp_clusters s = + let len = Array.length s.cases in + let min_clusters = Array.make len max_int and k = Array.make len 0 in + let get_min i = if i < 0 then 0 else min_clusters.(i) in + + for i = 0 to len - 1 do + for j = 0 to i do + if dense s j i && get_min (j - 1) + 1 < min_clusters.(i) then ( + k.(i) <- j; + min_clusters.(i) <- get_min (j - 1) + 1) + done + done; + (min_clusters.(len - 1), k) + +(* Assume j > i *) +let make_switch {cases; actions} i j = + let ll, _, _ = cases.(i) and _, hh, _ = cases.(j) in + let tbl = Array.make (hh - ll + 1) 0 + and t = Hashtbl.create 17 + and index = ref 0 in + let get_index act = + try Hashtbl.find t act + with Not_found -> let i = !index in incr index; - incr bidon; - Hashtbl.add t !bidon (i, act); + Hashtbl.add t act i; i - in - - let rec zyva j ir = - let i = k.(j) in - (if i = j then - let l, h, act = cases.(i) in - r.(ir) <- (l, h, get_index act) - else - (* assert i < j *) - let l, _, _ = cases.(i) and _, h, _ = cases.(j) in - r.(ir) <- (l, h, add_index (make_switch loc s i j))); - if i > 0 then zyva (i - 1) (ir - 1) - in - - zyva (len - 1) (n_clusters - 1); - let acts = Array.make !index (fun _ -> assert false) in - Hashtbl.iter (fun _ (i, act) -> acts.(i) <- act) t; - {cases = r; actions = acts} - - let do_zyva loc (low, high) arg cases actions = - let old_ok = !ok_inter in - ok_inter := abs low <= inter_limit && abs high <= inter_limit; - if !ok_inter <> old_ok then Hashtbl.clear t; - - let s = {cases; actions} in + in + + for k = i to j do + let l, h, act = cases.(k) in + let index = get_index act in + for kk = l - ll to h - ll do + tbl.(kk) <- index + done + done; + let acts = Array.make !index actions.(0) in + Hashtbl.iter (fun act i -> acts.(i) <- actions.(act)) t; + fun ctx -> emit_switch ~offset:(ll + ctx.off) ctx.arg tbl acts + +let make_clusters ({cases; actions} as s) n_clusters k = + let len = Array.length cases in + let r = Array.make n_clusters (0, 0, 0) + and t = Hashtbl.create 17 + and index = ref 0 + and bidon = ref (Array.length actions) in + let get_index act = + try + let i, _ = Hashtbl.find t act in + i + with Not_found -> + let i = !index in + incr index; + Hashtbl.add t act (i, fun _ -> actions.(act)); + i + and add_index act = + let i = !index in + incr index; + incr bidon; + Hashtbl.add t !bidon (i, act); + i + in + + let rec zyva j ir = + let i = k.(j) in + (if i = j then + let l, h, act = cases.(i) in + r.(ir) <- (l, h, get_index act) + else + (* assert i < j *) + let l, _, _ = cases.(i) and _, h, _ = cases.(j) in + r.(ir) <- (l, h, add_index (make_switch s i j))); + if i > 0 then zyva (i - 1) (ir - 1) + in + + zyva (len - 1) (n_clusters - 1); + let acts = Array.make !index (fun _ -> assert false) in + Hashtbl.iter (fun _ (i, act) -> acts.(i) <- act) t; + {cases = r; actions = acts} + +let do_zyva (low, high) arg cases actions = + let old_ok = !ok_inter in + ok_inter := abs low <= inter_limit && abs high <= inter_limit; + if !ok_inter <> old_ok then Hashtbl.clear t; + + let s = {cases; actions} in - (* + (* Printf.eprintf "ZYVA: %B [low=%i,high=%i]\n" !ok_inter low high ; pcases stderr cases ; prerr_endline "" ; *) - let n_clusters, k = comp_clusters s in - let clusters = make_clusters loc s n_clusters k in - c_test {arg; off = 0} clusters - - let abstract_shared actions = - let handlers = ref (fun x -> x) in - let actions = - Array.map - (fun act -> - match act with - | Single act -> act - | Shared act -> - let i, h = Arg.make_catch act in - let oh = !handlers in - (handlers := fun act -> h (oh act)); - Arg.make_exit i) - actions - in - (!handlers, actions) - - let zyva loc lh arg cases actions = - assert (Array.length cases > 0); - let actions = actions.act_get_shared () in - let hs, actions = abstract_shared actions in - hs (do_zyva loc lh arg cases actions) - - and test_sequence arg cases actions = - assert (Array.length cases > 0); - let actions = actions.act_get_shared () in - let hs, actions = abstract_shared actions in - let old_ok = !ok_inter in - ok_inter := false; - if !ok_inter <> old_ok then Hashtbl.clear t; - let s = {cases; actions = Array.map (fun act _ -> act) actions} in - (* + let n_clusters, k = comp_clusters s in + let clusters = make_clusters s n_clusters k in + c_test {arg; off = 0} clusters + +let abstract_shared actions = + let handlers = ref (fun x -> x) in + let actions = + Array.map + (fun act -> + match act with + | Single act -> act + | Shared act -> + let i, h = make_catch_delayed act in + let oh = !handlers in + (handlers := fun act -> h (oh act)); + make_exit i) + actions + in + (!handlers, actions) + +let zyva lh arg cases actions = + assert (Array.length cases > 0); + let actions = actions.act_get_shared () in + let hs, actions = abstract_shared actions in + hs (do_zyva lh arg cases actions) + +and test_sequence arg cases actions = + assert (Array.length cases > 0); + let actions = actions.act_get_shared () in + let hs, actions = abstract_shared actions in + let old_ok = !ok_inter in + ok_inter := false; + if !ok_inter <> old_ok then Hashtbl.clear t; + let s = {cases; actions = Array.map (fun act _ -> act) actions} in + (* Printf.eprintf "SEQUENCE: %B\n" !ok_inter ; pcases stderr cases ; prerr_endline "" ; *) - hs (c_test {arg; off = 0} s) -end + hs (c_test {arg; off = 0} s) diff --git a/compiler/ml/switch.mli b/compiler/ml/switch.mli index 2b3b5e7c178..3bac8c7eaef 100644 --- a/compiler/ml/switch.mli +++ b/compiler/ml/switch.mli @@ -37,8 +37,6 @@ type 'a t_store = { act_store_shared: 'a -> int; } -exception Not_simple - module type Stored = sig type t type key @@ -50,45 +48,8 @@ module Store (A : Stored) : sig val mk_store : unit -> A.t t_store end -(* Arguments to the Make functor *) -module type S = sig - (* type of basic tests *) - type primitive - - (* basic tests themselves *) - val eqint : primitive - val neint : primitive - val leint : primitive - val ltint : primitive - val geint : primitive - val gtint : primitive - - (* type of actions *) - type act - - (* Various constructors, for making a binder, - adding one integer, etc. *) - val bind : act -> (act -> act) -> act - val make_const : int -> act - val make_offset : act -> int -> act - val make_prim : primitive -> act list -> act - val make_isout : act -> act -> act - val make_isin : act -> act -> act - val make_if : act -> act -> act -> act - - (* construct an actual switch : - make_switch arg cases acts - NB: cases is in the value form *) - val make_switch : - Location.t -> act -> int array -> act array -> offset:int -> act - - (* Build last minute sharing of action stuff *) - val make_catch : act -> int * (act -> act) - val make_exit : int -> act -end - (* - Make.zyva arg low high cases actions where + zyva (low, high) arg cases actions where - arg is the argument of the switch. - low, high are the interval limits. - cases is a list of sub-interval and action indices @@ -97,17 +58,12 @@ end All these arguments specify a switch construct and zyva returns an action that performs the switch. *) -module Make : functor (Arg : S) -> sig - (* Standard entry point, sharing is tracked *) - val zyva : - Location.t -> - int * int -> - Arg.act -> - (int * int * int) array -> - Arg.act t_store -> - Arg.act - - (* Output test sequence, sharing tracked *) - val test_sequence : - Arg.act -> (int * int * int) array -> Arg.act t_store -> Arg.act -end +val zyva : + int * int -> + Lambda.t -> + (int * int * int) array -> + Lambda.t t_store -> + Lambda.t + +val test_sequence : + Lambda.t -> (int * int * int) array -> Lambda.t t_store -> Lambda.t diff --git a/compiler/ml/transl_recmodule.ml b/compiler/ml/transl_recmodule.ml index ead654d2709..436fb419a27 100644 --- a/compiler/ml/transl_recmodule.ml +++ b/compiler/ml/transl_recmodule.ml @@ -12,7 +12,7 @@ exception Error of Location.t * error let undefined_location loc = let fname, line, char = Location.get_pos_info loc.Location.loc_start in let fname = Filename.basename fname in - Lconst + const (Const_block ( Lambda.Blk_tuple, [const_string fname None; const_int line; const_int char] )) @@ -40,8 +40,7 @@ let init_shape modl = let rec init_shape_mod env mty = match Mtype.scrape env mty with | Mty_ident _ -> raise Not_found - | Mty_alias _ -> - Const_block (value_tag_info, [Const_pointer Pt_module_alias]) + | Mty_alias _ -> Const_block (value_tag_info, [const_module_alias]) | Mty_signature sg -> Const_block (module_tag_info, [Const_block (Blk_tuple, init_shape_struct env sg)]) @@ -59,9 +58,8 @@ let init_shape modl = let init_v = match Ctype.expand_head env ty with | t when is_function t -> - Const_pointer - (Pt_constructor - (Ast_untagged_variants.constructor_tag ~name:"Function" [])) + const_constructor + (Ast_untagged_variants.constructor_tag ~name:"Function" []) | _ -> raise Not_found in add_name init_v id :: init_shape_struct env rem @@ -80,7 +78,7 @@ let init_shape modl = try Some ( undefined_location modl.mod_loc, - Lconst (init_shape_mod modl.mod_env modl.mod_type) ) + const (init_shape_mod modl.mod_env modl.mod_type) ) with Not_found -> None type binding_status = Undefined | Inprogress | Defined @@ -102,7 +100,7 @@ let reorder_rec_bindings bindings = if init.(i) = None then ( status.(i) <- Inprogress; for j = 0 to num_bindings - 1 do - if Ident_set.mem id.(j) fv.(i) then emit_binding j + if Set_ident.mem fv.(i) id.(j) then emit_binding j done); res := (id.(i), init.(i), rhs.(i)) :: !res; status.(i) <- Defined @@ -115,7 +113,7 @@ let reorder_rec_bindings bindings = done; List.rev !res -type t = Lambda.lambda +type t = Lambda.t (* Utilities for compiling "module rec" definitions *) @@ -125,24 +123,30 @@ type shape = t type binding = Ident.t * (loc * shape) option * t +(* A shape with no fields: the module has nothing to initialize and nothing to + patch, so the runtime dummy and its update are both pointless. The right + hand side still has to run for its effects. *) +let shape_is_empty (shape : Lambda.t) = + match shape with + | Lambda.Lconst (Const_block (_, [Const_block (_, [])])) -> true + | _ -> false + let eval_rec_bindings_aux (bindings : binding list) (cont : t) : t = let rec bind_inits args acc = match args with | [] -> acc | (_id, None, _rhs) :: rem -> bind_inits rem acc | (id, Some (loc, shape), _rhs) :: rem -> - Lambda.Llet - ( Strict, - Pgenval, - id, - Lprim (Pinit_mod, [loc; shape], Location.none), - bind_inits rem acc ) + let init = + if shape_is_empty shape then Lambda.lambda_unit + else Lambda.prim ~primitive:Pinit_mod ~args:[loc; shape] Location.none + in + Lambda.let_ Strict id init (bind_inits rem acc) in let rec bind_strict args acc = match args with | [] -> acc - | (id, None, rhs) :: rem -> - Lambda.Llet (Strict, Pgenval, id, rhs, bind_strict rem acc) + | (id, None, rhs) :: rem -> Lambda.let_ Strict id rhs (bind_strict rem acc) | (_id, Some _, _rhs) :: rem -> bind_strict rem acc in let rec patch_forwards args = @@ -150,9 +154,14 @@ let eval_rec_bindings_aux (bindings : binding list) (cont : t) : t = | [] -> cont | (_id, None, _rhs) :: rem -> patch_forwards rem | (id, Some (_loc, shape), rhs) :: rem -> - Lsequence - ( Lprim (Pupdate_mod, [shape; Lvar id; rhs], Location.none), - patch_forwards rem ) + let patch = + if shape_is_empty shape then rhs + else + Lambda.prim ~primitive:Pupdate_mod + ~args:[shape; var id; rhs] + Location.none + in + seq patch (patch_forwards rem) in bind_inits bindings (bind_strict bindings (patch_forwards bindings)) @@ -160,15 +169,15 @@ let eval_rec_bindings_aux (bindings : binding list) (cont : t) : t = if the module creation is just a set of function declarations and consts, it is good *) -let rec is_function_or_const_block (lam : Lambda.lambda) acc = +let rec is_function_or_const_block (lam : Lambda.t) acc = match lam with - | Lprim (Pmakeblock _, args, _) -> + | Lprim {primitive = Pmakeblock _; args; loc = _} -> Ext_list.for_all args (fun x -> match x with | 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 = @@ -181,8 +190,8 @@ let rec is_function_or_const_block (lam : Lambda.lambda) acc = match aux_bindings bindings acc with | None -> false | Some acc -> is_function_or_const_block cont acc) - | Llet (_, _, _, Lconst _, cont) -> is_function_or_const_block cont acc - | Llet (_, _, id1, Lvar id2, cont) when Set_ident.mem acc id2 -> + | Llet (_, _, Lconst _, cont) -> is_function_or_const_block cont acc + | Llet (_, id1, Lvar id2, cont) when Set_ident.mem acc id2 -> is_function_or_const_block cont (Set_ident.add acc id1) | _ -> false diff --git a/compiler/ml/transl_recmodule.mli b/compiler/ml/transl_recmodule.mli index 82611084451..db2d3cbf1ca 100644 --- a/compiler/ml/transl_recmodule.mli +++ b/compiler/ml/transl_recmodule.mli @@ -22,7 +22,7 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) val compile_recmodule : - (Ident.t -> Typedtree.module_expr -> Location.t -> Lambda.lambda) -> + (Ident.t -> Typedtree.module_expr -> Location.t -> Lambda.t) -> Typedtree.module_binding list -> - Lambda.lambda -> - Lambda.lambda + Lambda.t -> + Lambda.t diff --git a/compiler/ml/translattribute.ml b/compiler/ml/translattribute.ml index 91314cfdcf3..b4efb4c301f 100644 --- a/compiler/ml/translattribute.ml +++ b/compiler/ml/translattribute.ml @@ -81,7 +81,7 @@ let get_inline_attribute l = let attr, _ = find_attribute is_inline_attribute l in parse_inline_attribute attr -let add_inline_attribute (expr : Lambda.lambda) loc attributes = +let add_inline_attribute (expr : Lambda.t) loc attributes = match (expr, get_inline_attribute attributes) with | expr, Default_inline -> expr | Lfunction ({attr} as funct), inline -> @@ -90,7 +90,7 @@ let add_inline_attribute (expr : Lambda.lambda) loc attributes = | Always_inline | Never_inline -> Location.prerr_warning loc (Warnings.Duplicated_attribute "inline")); let attr = {attr with inline} in - Lfunction {funct with attr} + Lambda.function_ ~loc:funct.loc ~attr ~params:funct.params ~body:funct.body | expr, Always_inline -> Location.prerr_warning loc (Warnings.Misplaced_attribute "inline"); expr diff --git a/compiler/ml/translattribute.mli b/compiler/ml/translattribute.mli index bac456ba8d8..6570ef8f25b 100644 --- a/compiler/ml/translattribute.mli +++ b/compiler/ml/translattribute.mli @@ -19,7 +19,7 @@ val check_attribute_on_module : Typedtree.module_expr -> Parsetree.attribute -> unit val add_inline_attribute : - Lambda.lambda -> Location.t -> Parsetree.attributes -> Lambda.lambda + Lambda.t -> Location.t -> Parsetree.attributes -> Lambda.t val get_inline_attribute : Parsetree.attributes -> Lambda.inline_attribute diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index da17510c5dc..d8097648f29 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -32,7 +32,7 @@ exception Error of Location.t * error let transl_module = ref (fun _cc _rootpath _modl -> assert false - : module_coercion -> Path.t option -> module_expr -> lambda) + : module_coercion -> Path.t option -> module_expr -> Lambda.t) (* Number of payload-carrying constructors of the variant declaring [cstr]; part of the runtime representation of its blocks *) @@ -49,37 +49,45 @@ let transl_extension_constructor env path ext = in let loc = ext.ext_loc in match ext.ext_kind with - | Text_decl _ -> Lprim (Pcreate_extension name, [], loc) + | Text_decl _ -> prim ~primitive:(Pcreate_extension name) ~args:[] loc | Text_rebind (path, _lid) -> transl_extension_path ~loc env path (* Translation of primitives *) +let builtin_of_lowering (l : Unified_ops.lowering) : Lambda.builtin = + match l with + | Lower p -> Primitive p + | Pass_through -> Eliminated Identity + (** This is ad-hoc translation for unifying specific primitive operations See [Unified_ops] module for detailed explanation. *) let translate_unified_ops (prim : Primitive.description) (env : Env.t) - (lhs_type : type_expr) : Lambda.primitive option = + (lhs_type : type_expr) : Lambda.builtin option = (* lhs_type is already unified in type-level *) let entry = Hashtbl.find_opt Unified_ops.index_by_name prim.prim_name in - match entry with - | Some {specialization} -> ( - match specialization with - | {int} - when is_base_type env lhs_type Predef.path_int - || maybe_pointer_type env lhs_type = Immediate -> - Some int - | {float = Some float} when is_base_type env lhs_type Predef.path_float -> - Some float - | {bigint = Some bigint} when is_base_type env lhs_type Predef.path_bigint - -> - Some bigint - | {string = Some string} when is_base_type env lhs_type Predef.path_string - -> - Some string - | {bool = Some bool} when is_base_type env lhs_type Predef.path_bool -> - Some bool - | {int} -> Some int) - | _ -> None + let lowering = + match entry with + | Some {specialization} -> ( + match specialization with + | {int} + when is_base_type env lhs_type Predef.path_int + || maybe_pointer_type env lhs_type = Immediate -> + Some int + | {float = Some float} when is_base_type env lhs_type Predef.path_float -> + Some float + | {bigint = Some bigint} when is_base_type env lhs_type Predef.path_bigint + -> + Some bigint + | {string = Some string} when is_base_type env lhs_type Predef.path_string + -> + Some string + | {bool = Some bool} when is_base_type env lhs_type Predef.path_bool -> + Some bool + | {int} -> Some int) + | _ -> None + in + Option.map builtin_of_lowering lowering type specialized = { objcomp: Lambda.primitive; @@ -237,18 +245,30 @@ let comparisons_table = } ); |] -let primitives_table = - create_hashtable +(* Builtins with no primitive form: [Lambda.mk_builtin] erases them at + translation. *) +let erased_builtins : (string * Lambda.builtin) array = + [| + ("%identity", Eliminated Identity); + ("%component_identity", Eliminated Identity); + ("%ignore", Eliminated Ignore); + ("%incr", Offset_ref 1); + ("%decr", Offset_ref (-1)); + ("%null", Constant Const_js_null); + ("%undefined", Constant (Const_js_undefined {is_unit = false})); + (* FIXME: Core compatibility *) + ("#null", Constant Const_js_null); + ("#undefined", Constant (Const_js_undefined {is_unit = false})); + |] + +let primitive_builtins : (string * Lambda.builtin) array = + Array.map + (fun (name, p) -> (name, Lambda.Primitive p)) [| - ("%identity", Peliminated Identity); - ("%component_identity", Peliminated Identity); - ("%ignore", Peliminated Ignore); (* BEGIN Triples for ref data type *) ("%makeref", Pmakeblock Lambda.ref_tag_info); ("%refset", Psetfield (0, Lambda.ref_field_set_info)); ("%refget", Pfield (0, Lambda.ref_field_info)); - ("%incr", Poffsetref 1); - ("%decr", Poffsetref (-1)); (* Finish Triples for ref data type *) ("%field0", Pfield (0, Fld_tuple)); ("%field1", Pfield (1, Fld_tuple)); @@ -268,8 +288,6 @@ let primitives_table = (* int primitives *) ("%obj_is_int", Pisint); ("%negint", Pnegint); - ("%succint", Poffsetint 1); - ("%predint", Poffsetint (-1)); ("%addint", Paddint); ("%subint", Psubint); ("%mulint", Pmulint); @@ -366,36 +384,26 @@ let primitives_table = ("%unsafe_le", Pjscomp Cle); ("%unsafe_gt", Pjscomp Cgt); ("%unsafe_ge", Pjscomp Cge); - ("%null", Pnull); - ("%undefined", Pundefined); - ("%is_nullable", Pisnullable); + ("%is_nullable", Pis_null_undefined); ("%null_to_opt", Pnull_to_opt); - ("%nullable_to_opt", Pnullable_to_opt); - ("%function_arity", Pfn_arity); - ("%curry_apply1", Pcurry_apply 1); - ("%curry_apply2", Pcurry_apply 2); - ("%curry_apply3", Pcurry_apply 3); - ("%curry_apply4", Pcurry_apply 4); - ("%curry_apply5", Pcurry_apply 5); - ("%curry_apply6", Pcurry_apply 6); - ("%curry_apply7", Pcurry_apply 7); - ("%curry_apply8", Pcurry_apply 8); + ("%nullable_to_opt", Pnull_undefined_to_opt); ("%makemutablelist", Pmakelist); ("%unsafe_to_method", Pjs_fn_method); (* Compiler internals, never expose to ReScript files *) (* FIXME: Core compatibility *) - ("#null", Pnull); - ("#undefined", Pundefined); ("#typeof", Ptypeof); - ("#is_nullable", Pisnullable); + ("#is_nullable", Pis_null_undefined); ("#null_to_opt", Pnull_to_opt); - ("#nullable_to_opt", Pnullable_to_opt); + ("#nullable_to_opt", Pnull_undefined_to_opt); ("#makemutablelist", Pmakelist); (* FIXME: Deprecated *) ("%obj_field", Parrayrefu); |] -let find_primitive prim_name = Hashtbl.find primitives_table prim_name +let builtins_table : (string, Lambda.builtin) Hashtbl.t = + create_hashtable (Array.append erased_builtins primitive_builtins) + +let find_builtin prim_name = Hashtbl.find builtins_table prim_name let specialize_comparison ({objcomp; intcomp; floatcomp; stringcomp; bigintcomp; boolcomp} : @@ -423,25 +431,28 @@ let specialize_primitive p env ty (* ~has_constant_constructor *) = | None -> None in match unified with - | Some primitive -> primitive + | Some builtin -> builtin | None -> ( try let table = Hashtbl.find comparisons_table p.prim_name in match fn_expr with - | Some (lhs, _rhs) -> specialize_comparison table env lhs - | None -> table.objcomp - with Not_found -> find_primitive p.prim_name) + | Some (lhs, _rhs) -> Primitive (specialize_comparison table env lhs) + | None -> Primitive table.objcomp + with Not_found -> find_builtin p.prim_name) +(* [is_unit] excluded: unit shares the undefined constant but is not a + [%null] / [%undefined] literal, and comparing it never suppressed the + warning. *) let is_null_undefined_constant = function - | Lprim ((Pnull | Pundefined), [], _) -> true + | Lconst (Const_js_null | Const_js_undefined {is_unit = false}) -> true | _ -> false -let warn_polymorphic_comparison loc prim args = - match (prim, args) with - | Pobjcomp (Ceq | Cneq), [arg1; arg2] +let warn_polymorphic_comparison loc (builtin : Lambda.builtin) args = + match (builtin, args) with + | Primitive (Pobjcomp (Ceq | Cneq)), [arg1; arg2] when is_null_undefined_constant arg1 || is_null_undefined_constant arg2 -> () - | (Pobjcomp _ | Pobjorder | Pobjmin | Pobjmax), _ -> + | Primitive (Pobjcomp _ | Pobjorder | Pobjmin | Pobjmax), _ -> Location.prerr_warning loc Warnings.Bs_polymorphic_comparison | _ -> () @@ -452,8 +463,8 @@ let lambda_of_inline_const (c : External_ffi_types.inline_const) : Lambda.structured_constant = match c with | Const_str {s; delim} -> Const_string {s; delim} - | Const_bool true -> Const_true - | Const_bool false -> Const_false + | Const_bool true -> Const_js_true + | Const_bool false -> Const_js_false | Const_int i -> Const_int i | Const_bigint {negative; digits} -> Const_bigint (negative, digits) | Const_float f -> Const_float f @@ -545,9 +556,10 @@ let external_returns_unit env (p : Primitive.description) (val_type : type_expr) let external_result_wrap loc (result_type : External_ffi_types.return_wrapper) ~returns_unit result = match result_type with - | Return_unset when returns_unit -> Lsequence (result, Lconst const_unit) - | Return_null_to_opt -> Lprim (Pnull_to_opt, [result], loc) - | Return_null_undefined_to_opt -> Lprim (Pnullable_to_opt, [result], loc) + | Return_unset when returns_unit -> seq result (const const_unit) + | Return_null_to_opt -> prim ~primitive:Pnull_to_opt ~args:[result] loc + | Return_null_undefined_to_opt -> + prim ~primitive:Pnull_undefined_to_opt ~args:[result] loc | Return_unset | Return_identity -> result (* Does importing this external as a value require the FFI adaptation a @@ -583,80 +595,74 @@ let external_import_needs_adaptation (arg_types : External_arg_spec.params) let transl_adapted_external_import loc env ~(emn : External_ffi_types.external_module_name) ~name ~scopes ~variadic ~(arg_types : External_arg_spec.params) ~return_wrapper - (p : Primitive.description) (val_type : type_expr) : Lambda.lambda = + (p : Primitive.description) (val_type : type_expr) : Lambda.t = let returns_unit = external_returns_unit env p val_type in let send_call receiver args (kind : External_ffi_types.decl_kind) = - Lprim - ( Pjs_call - { - prim_name = name; - arg_types = External_arg_spec.dummy :: arg_types; - ffi = - { - kind; - module_ = None; - scopes; - variadic; - effective_arity = List.length arg_types + 1; - }; - transformed_jsx = false; - }, - receiver :: args, - loc ) + prim + ~primitive: + (Pjs_call + { + prim_name = name; + arg_types = External_arg_spec.dummy :: arg_types; + ffi = + { + kind; + module_ = None; + scopes; + variadic; + effective_arity = List.length arg_types + 1; + }; + transformed_jsx = false; + }) + ~args:(receiver :: args) loc in let m = Ident.create "m" in let adapted_value = if p.prim_arity = 0 then external_result_wrap loc return_wrapper ~returns_unit - (send_call (Lvar m) [] (Decl_get {name})) + (send_call (var m) [] (Decl_get {name})) else let params = List.init p.prim_arity (fun i -> Ident.create ("prim" ^ string_of_int i)) in - Lfunction - { - params; - attr = default_function_attribute; - loc; - body = - external_result_wrap loc return_wrapper ~returns_unit - (send_call (Lvar m) - (List.map (fun i -> Lvar i) params) - (Decl_send {name})); - } + function_ ~loc ~attr:default_function_attribute ~params + ~body: + (external_result_wrap loc return_wrapper ~returns_unit + (send_call (var m) + (List.map (fun i -> var i) params) + (Decl_send {name}))) in let callback = - Lfunction - { - params = [m]; - attr = default_function_attribute; - loc; - body = adapted_value; - } + function_ ~loc ~attr:default_function_attribute ~params:[m] + ~body:adapted_value in - Lprim - ( Pjs_call - { - prim_name = "then"; - arg_types = [External_arg_spec.dummy; External_arg_spec.dummy]; - ffi = - { - kind = Decl_send {name = "then"}; - module_ = None; - scopes = []; - variadic = false; - effective_arity = 2; - }; - transformed_jsx = false; - }, + prim + ~primitive: + (Pjs_call + { + prim_name = "then"; + arg_types = [External_arg_spec.dummy; External_arg_spec.dummy]; + ffi = + { + kind = Decl_send {name = "then"}; + module_ = None; + scopes = []; + variadic = false; + effective_arity = 2; + }; + transformed_jsx = false; + }) + ~args: [ - Lprim (Pimport (Import_external {module_ = emn; path = []}), [], loc); + prim + ~primitive:(Pimport (Import_external {module_ = emn; path = []})) + ~args:[] loc; callback; - ], - loc ) + ] + loc -let transl_dynamic_import loc (arg : Typedtree.expression) : Lambda.lambda = +let transl_dynamic_import loc (arg : Typedtree.expression) : Lambda.t = match arg.exp_desc with | Texp_ident ( _, @@ -683,22 +689,22 @@ let transl_dynamic_import loc (arg : Typedtree.expression) : Lambda.lambda = when external_import_needs_adaptation arg_types decl return_wrapper -> transl_adapted_external_import loc arg.exp_env ~emn ~name ~scopes ~variadic ~arg_types ~return_wrapper p val_type - | _ -> Lprim (Pimport (import_source_of_arg arg), [], loc) + | _ -> prim ~primitive:(Pimport (import_source_of_arg arg)) ~args:[] loc let transl_external_application loc env (p : Primitive.description) - ~(val_type : type_expr) argl ~transformed_jsx : Lambda.lambda = + ~(val_type : type_expr) argl ~transformed_jsx : Lambda.t = match p.prim_kind with - | Kind_inline_const c -> Lconst (lambda_of_inline_const c) + | Kind_inline_const c -> const (lambda_of_inline_const c) | Kind_external (Ffi_obj_create labels) -> - Lprim (Pjs_object_create labels, argl, loc) + prim ~primitive:(Pjs_object_create labels) ~args:argl loc | Kind_external (Ffi_bs (arg_types, result_type, decl)) -> external_result_wrap loc result_type ~returns_unit:(external_returns_unit env p val_type) - (Lprim - ( Pjs_call - {prim_name = p.prim_name; arg_types; ffi = decl; transformed_jsx}, - argl, - loc )) + (prim + ~primitive: + (Pjs_call + {prim_name = p.prim_name; arg_types; ffi = decl; transformed_jsx}) + ~args:argl loc) | Kind_intrinsic -> Location.raise_errorf ~loc "@{Error:@} internal error, using unrecognized primitive %s" @@ -725,7 +731,7 @@ let lam_of_loc kind loc = in match kind with | Loc_POS -> - Lconst + const (Const_block ( Blk_tuple, [ @@ -734,18 +740,18 @@ let lam_of_loc kind loc = const_int cnum; const_int enum; ] )) - | Loc_FILE -> Lconst (const_string file None) + | Loc_FILE -> const (const_string file None) | Loc_MODULE -> let filename = Filename.basename file in let name = Env.get_unit_name () in let module_name = if name = "" then "//" ^ filename ^ "//" else name in - Lconst (const_string module_name None) + const (const_string module_name None) | Loc_LOC -> let loc = Printf.sprintf "File %S, line %d, characters %d-%d" file lnum cnum enum in - Lconst (const_string loc None) - | Loc_LINE -> Lconst (const_int lnum) + const (const_string loc None) + | Loc_LINE -> const (const_int lnum) (* Eta-expand a primitive *) @@ -758,13 +764,9 @@ let transl_primitive loc p env ty ~val_type = | 0 -> lam | 1 -> let param = Ident.create "prim" in - Lfunction - { - params = [param]; - attr = default_function_attribute; - loc; - body = Lprim (Pmakeblock Blk_tuple, [lam; Lvar param], loc); - } + function_ ~loc ~attr:default_function_attribute ~params:[param] + ~body: + (prim ~primitive:(Pmakeblock Blk_tuple) ~args:[lam; var param] loc) | _ -> assert false) | None -> ( let prim = @@ -787,18 +789,13 @@ let transl_primitive loc p env ty ~val_type = List.init p.prim_arity (fun i -> Ident.create ("prim" ^ string_of_int i)) in - Lfunction - { - params; - attr = default_function_attribute; - loc; - body = - transl_external_application loc env p ~val_type - (List.map (fun id -> Lvar id) params) - ~transformed_jsx:false; - } - | Some prim -> - warn_polymorphic_comparison loc prim []; + function_ ~loc ~attr:default_function_attribute ~params + ~body: + (transl_external_application loc env p ~val_type + (List.map (fun id -> var id) params) + ~transformed_jsx:false) + | Some builtin -> + warn_polymorphic_comparison loc builtin []; let rec make_params n total = if n <= 0 then [] else @@ -806,24 +803,19 @@ let transl_primitive loc p env ty ~val_type = :: make_params (n - 1) total in let prim_arity = p.prim_arity in - if p.prim_from_constructor || prim_arity = 0 then mk_prim prim [] loc + if p.prim_from_constructor || prim_arity = 0 then + mk_builtin builtin [] loc else let params = if prim_arity = 1 then [Ident.create "prim"] else make_params prim_arity prim_arity in - Lfunction - { - params; - attr = default_function_attribute; - loc; - body = mk_prim prim (List.map (fun id -> Lvar id) params) loc; - }) + function_ ~loc ~attr:default_function_attribute ~params + ~body:(mk_builtin builtin (List.map (fun id -> var id) params) loc)) (* [None] means the primitive is an external whose application must be expanded from its FFI spec *) -let transl_primitive_application loc prim env ty args : Lambda.primitive option - = +let transl_primitive_application loc prim env ty args : Lambda.builtin option = let prim_name = prim.prim_name in let unified = match args with @@ -831,14 +823,14 @@ let transl_primitive_application loc prim env ty args : Lambda.primitive option | _ -> None in match unified with - | Some primitive -> Some primitive + | Some builtin -> Some builtin | None -> ( try match args with | [arg1; _] when is_base_type env arg1.exp_type Predef.path_bool && Hashtbl.mem comparisons_table prim_name -> - Some (Hashtbl.find comparisons_table prim_name).boolcomp + Some (Primitive (Hashtbl.find comparisons_table prim_name).boolcomp) | _ -> let has_constant_constructor = match args with @@ -866,7 +858,7 @@ let transl_primitive_application loc prim env ty args : Lambda.primitive option if has_constant_constructor then match Hashtbl.find_opt comparisons_table prim_name with | Some table when table.simplify_constant_constructor -> - Some table.intcomp + Some (Primitive table.intcomp) | Some _ | None -> Some (specialize_primitive prim env ty) (* ~has_constant_constructor*) else Some (specialize_primitive prim env ty) @@ -893,22 +885,22 @@ let assert_failed exp = Location.get_pos_info exp.exp_loc.Location.loc_start in let fname = Filename.basename fname in - Lprim - ( Praise, + prim ~primitive:Praise + ~args: [ - Lprim - ( Pmakeblock Blk_extension, + prim ~primitive:(Pmakeblock Blk_extension) + ~args: [ transl_normal_path Predef.path_assert_failure; - Lconst + const (Const_block ( Blk_tuple, [const_string fname None; const_int line; const_int char] )); - ], - exp.exp_loc ); - ], - exp.exp_loc ) + ] + exp.exp_loc; + ] + exp.exp_loc let rec cut n l = if n = 0 then ([], l) @@ -926,50 +918,40 @@ let rec cut n l = so matching sees a ReScript value. Pure [throw v] is not an inspect: rethrow the raw JS value. *) let wrap_exn loc arg = - Lapply - { - ap_func = - Lprim - ( Pfield (0, Fld_module {name = "internalToException"}), - [ - Lprim - ( Pgetglobal - (Ident.create_persistent Primitive_modules.exceptions), - [], - loc ); - ], - loc ); - ap_args = [arg]; - ap_loc = loc; - ap_inlined = Default_inline; - ap_transformed_jsx = false; - } -let exception_id_destructed (l : lambda) (fv : Ident.t) : bool = + apply ~ap_transformed_jsx:false + (prim + ~primitive:(Pfield (0, Fld_module {name = "internalToException"})) + ~args: + [global_module (Ident.create_persistent Primitive_modules.exceptions)] + loc) + [arg] + {ap_loc = loc; ap_inlined = Default_inline} +let exception_id_destructed (l : Lambda.t) (fv : Ident.t) : bool = let rec hit_opt = function | None -> false | Some a -> hit a and hit_list_snd : 'a. ('a * _) list -> bool = fun x -> Ext_list.exists_snd x hit and hit_list xs = Ext_list.exists xs hit - and hit (l : lambda) = + and hit (l : Lambda.t) = match l with - | Lprim (Praise, [Lvar _], _) -> false - | Lprim (_, args, _) -> hit_list args + | Lprim {primitive = Praise; args = [Lvar _]; loc = _} -> false + | Lprim {primitive = _; args; loc = _} -> hit_list args | Lvar id -> Ident.same id fv | Lassign (id, e) -> Ident.same id fv || hit e | Lstaticcatch (e1, _, e2) -> hit e1 || hit e2 | Ltrywith (e1, _, e2) -> hit e1 || hit e2 | Lfunction {body} -> hit body - | Llet (_, _, _, arg, body) -> hit arg || hit body + | Llet (_, _, arg, body) -> hit arg || hit body | Lletrec (decl, body) -> hit body || hit_list_snd decl | Lfor (_, e1, e2, _, e3) -> hit e1 || hit e2 || hit e3 | Lfor_of (_, e1, e2) | Lfor_await_of (_, e1, e2) -> hit e1 || hit e2 - | Lconst _ -> false + | Lglobal_module _ | Lconst _ -> false | Lapply {ap_func; ap_args} -> hit ap_func || hit_list ap_args - | Lswitch (arg, sw, _) -> + | Lswitch (arg, sw) -> hit arg || hit_list_snd sw.sw_consts || hit_list_snd sw.sw_blocks || hit_opt sw.sw_failaction - | Lstringswitch (arg, cases, default, _) -> + | Lstringswitch (arg, cases, default) -> hit arg || hit_list_snd cases || hit_opt default | Lstaticraise (_, args) -> hit_list args | Lifthenelse (e1, e2, e3) -> hit e1 || hit e2 || hit e3 @@ -982,10 +964,7 @@ let exception_id_destructed (l : lambda) (fv : Ident.t) : bool = let pack_trywith_exn id handler = if exception_id_destructed handler id then let raw_id = Ident.create ("raw_" ^ id.name) in - ( raw_id, - Llet - (StrictOpt, Pgenval, id, wrap_exn Location.none (Lvar raw_id), handler) - ) + (raw_id, let_ StrictOpt id (wrap_exn Location.none (var raw_id)) handler) else (id, handler) let extract_directive_for_fn exp = @@ -1026,13 +1005,13 @@ let rec transl_exp e = List.iter (Translattribute.check_attribute e) e.exp_attributes; transl_exp0 e) -and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = +and transl_exp0 (e : Typedtree.expression) : Lambda.t = match e.exp_desc with | Texp_ident (_, _, ({val_kind = Val_prim p} as vd)) -> transl_primitive e.exp_loc p e.exp_env e.exp_type ~val_type:vd.val_type | Texp_ident (path, _, {val_kind = Val_reg}) -> transl_value_path ~loc:e.exp_loc e.exp_env path - | Texp_constant cst -> Lconst (const_of_typed cst) + | Texp_constant cst -> const (const_of_typed cst) | Texp_let (rec_flag, pat_expr_list, body) -> transl_let ~js_hoist:None rec_flag pat_expr_list (transl_exp body) | Texp_function {params = fparams; body; async} -> @@ -1062,7 +1041,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = } in let loc = e.exp_loc in - Lfunction {params; body = lbody; attr; loc} + function_ ~loc ~attr ~params ~body:lbody | Texp_apply {funct; args = oargs} when List.exists (fun (attr, _) -> attr.txt = "res.taggedTemplate") @@ -1077,10 +1056,9 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = | [(_, Some strings); (_, Some values)] -> (strings, values) | _ -> assert false in - Lprim - ( Ptagged_template, - [transl_exp funct; transl_exp strings; transl_exp values], - e.exp_loc ) + prim ~primitive:Ptagged_template + ~args:[transl_exp funct; transl_exp strings; transl_exp values] + e.exp_loc | Texp_apply { funct = @@ -1120,7 +1098,9 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = | [] -> wrap (lam_of_loc kind e.exp_loc) | [arg1] -> let lam = lam_of_loc kind arg1.exp_loc in - wrap (Lprim (Pmakeblock Blk_tuple, lam :: argl, e.exp_loc)) + wrap + (prim ~primitive:(Pmakeblock Blk_tuple) ~args:(lam :: argl) + e.exp_loc) | _ -> assert false) | None -> ( match @@ -1133,19 +1113,23 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = | "#raw_expr", [Lconst (Const_string {s = code})] -> let kind = Classify_function.classify code in wrap - (Lprim (Praw_js_code {code; code_info = Exp kind}, [], e.exp_loc)) + (prim + ~primitive:(Praw_js_code {code; code_info = Exp kind}) + ~args:[] e.exp_loc) | "#raw_stmt", [Lconst (Const_string {s = code})] -> let kind = Classify_function.classify_stmt code in wrap - (Lprim (Praw_js_code {code; code_info = Stmt kind}, [], e.exp_loc)) + (prim + ~primitive:(Praw_js_code {code; code_info = Stmt kind}) + ~args:[] e.exp_loc) | ("#raw_expr" | "#raw_stmt"), _ -> assert false | _ -> wrap (transl_external_application e.exp_loc e.exp_env p ~val_type:prim_vd.val_type argl ~transformed_jsx)) - | Some prim -> - warn_polymorphic_comparison e.exp_loc prim argl; - wrap (mk_prim prim argl e.exp_loc)))) + | Some builtin -> + warn_polymorphic_comparison e.exp_loc builtin argl; + wrap (mk_builtin builtin argl e.exp_loc)))) | Texp_apply {funct; args = oargs; partial; transformed_jsx} -> let inlined, funct = Translattribute.get_and_remove_inlined_attribute funct @@ -1168,15 +1152,16 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = transl_match e arg pat_expr_list exn_pat_expr_list partial | Texp_try (body, pat_expr_list) -> let id = Typecore.name_pattern "exn" pat_expr_list in - let handler = Matching.for_trywith (Lvar id) (transl_cases pat_expr_list) in + let handler = Matching.for_trywith (var id) (transl_cases pat_expr_list) in let id, handler = pack_trywith_exn id handler in - Ltrywith (transl_exp body, id, handler) + try_ (transl_exp body) id handler | Texp_tuple el -> ( let ll = transl_list el in - try Lconst (Const_block (Blk_tuple, List.map extract_constant ll)) - with Not_constant -> Lprim (Pmakeblock Blk_tuple, ll, e.exp_loc)) - | Texp_construct ({txt = Lident "false"}, _, []) -> Lconst Const_false - | Texp_construct ({txt = Lident "true"}, _, []) -> Lconst Const_true + try const (Const_block (Blk_tuple, List.map extract_constant ll)) + with Not_constant -> + prim ~primitive:(Pmakeblock Blk_tuple) ~args:ll e.exp_loc) + | Texp_construct ({txt = Lident "false"}, _, []) -> const Const_js_false + | Texp_construct ({txt = Lident "true"}, _, []) -> const Const_js_true | Texp_construct (_, cstr, args) -> ( let ll = transl_list args in if cstr.cstr_inlined <> None then @@ -1186,14 +1171,13 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = else match cstr.cstr_kind with | Ordinary_constructor _ when cstr.cstr_args = [] -> - Lconst - (Const_pointer - (if Datarepr.constructor_has_optional_shape cstr then Pt_shape_none - else - Pt_constructor - (match Datarepr.constructor_case cstr with - | Constant tag -> tag - | Block _ -> assert false))) + const + (if Datarepr.constructor_has_optional_shape cstr then const_shape_none + else + const_constructor + (match Datarepr.constructor_case cstr with + | Constant tag -> tag + | Block _ -> assert false)) | Ordinary_constructor _ -> ( let runtime = match Datarepr.constructor_case cstr with @@ -1204,42 +1188,50 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = match ll with | [value] -> value | _ -> assert false + else if Datarepr.constructor_has_optional_shape cstr then + let value = + match ll with + | [value] -> value + | _ -> assert false + in + let primitive : Lambda.primitive = + match args with + | [arg] + when Typeopt.type_cannot_contain_undefined arg.exp_type + arg.exp_env -> + Psome_not_nest + | _ -> Psome + in + try const (Const_some (extract_constant value)) + with Not_constant -> prim ~primitive ~args:ll e.exp_loc else let tag_info : Lambda.tag_info = - if Datarepr.constructor_has_optional_shape cstr then - match args with - | [arg] - when Typeopt.type_cannot_contain_undefined arg.exp_type - arg.exp_env -> - (* Format.fprintf Format.err_formatter "@[special boxingl@]@."; *) - Blk_some_not_nested - | _ -> Blk_some - else - Blk_constructor - { - name = cstr.cstr_name; - num_nonconst = num_nonconst_constructors cstr; - runtime; - } + Blk_constructor + { + name = cstr.cstr_name; + num_nonconst = num_nonconst_constructors cstr; + runtime; + } in - try Lconst (Const_block (tag_info, List.map extract_constant ll)) - with Not_constant -> Lprim (Pmakeblock tag_info, ll, e.exp_loc)) + try const (Const_block (tag_info, List.map extract_constant ll)) + with Not_constant -> + prim ~primitive:(Pmakeblock tag_info) ~args:ll e.exp_loc) | Extension_constructor path -> - Lprim - ( Pmakeblock Blk_extension, - transl_extension_path e.exp_env path :: ll, - e.exp_loc )) + prim ~primitive:(Pmakeblock Blk_extension) + ~args:(transl_extension_path e.exp_env path :: ll) + e.exp_loc) | Texp_extension_constructor (_, path) -> transl_extension_path e.exp_env path | Texp_variant (l, arg) -> ( - let tag = Btype.hash_variant l in match arg with - | None -> Lconst (Const_pointer (Pt_variant {name = l})) + | None -> const (const_polyvar l) | Some arg -> ( let lam = transl_exp arg in - let tag_info = Blk_poly_var l in - try Lconst (Const_block (tag_info, [const_int tag; extract_constant lam])) + let name = const_polyvar_name l in + try const (Const_block (Blk_poly_var, [name; extract_constant lam])) with Not_constant -> - Lprim (Pmakeblock tag_info, [Lconst (const_int tag); lam], e.exp_loc))) + prim ~primitive:(Pmakeblock Blk_poly_var) + ~args:[const name; lam] + e.exp_loc)) | Texp_record {fields; representation; extended_expression} -> transl_record e.exp_loc e.exp_env fields representation extended_expression | Texp_field (arg, _, lbl) -> ( @@ -1247,16 +1239,18 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = match lbl.lbl_repres with | Record_float_unused -> assert false | Record_regular -> - Lprim (Pfield (lbl.lbl_pos, Lambda.fld_record lbl), [targ], e.exp_loc) + prim + ~primitive:(Pfield (lbl.lbl_pos, Lambda.fld_record lbl)) + ~args:[targ] e.exp_loc | Record_inlined _ -> - Lprim - (Pfield (lbl.lbl_pos, Lambda.fld_record_inline lbl), [targ], e.exp_loc) + prim + ~primitive:(Pfield (lbl.lbl_pos, Lambda.fld_record_inline lbl)) + ~args:[targ] e.exp_loc | Record_unboxed _ -> targ | Record_extension -> - Lprim - ( Pfield (lbl.lbl_pos + 1, Lambda.fld_record_extension lbl), - [targ], - e.exp_loc )) + prim + ~primitive:(Pfield (lbl.lbl_pos + 1, Lambda.fld_record_extension lbl)) + ~args:[targ] e.exp_loc) | Texp_setfield (arg, _, lbl, newval) -> let access = match lbl.lbl_repres with @@ -1268,25 +1262,24 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = | Record_extension -> Psetfield (lbl.lbl_pos + 1, Lambda.fld_record_extension_set lbl) in - Lprim (access, [transl_exp arg; transl_exp newval], e.exp_loc) + prim ~primitive:access ~args:[transl_exp arg; transl_exp newval] e.exp_loc | Texp_array expr_list -> let ll = transl_list expr_list in - Lprim (Pmakearray, ll, e.exp_loc) + prim ~primitive:Pmakearray ~args:ll e.exp_loc | Texp_ifthenelse (cond, ifso, Some ifnot) -> - Lifthenelse (transl_exp cond, transl_exp ifso, transl_exp ifnot) + if_ (transl_exp cond) (transl_exp ifso) (transl_exp ifnot) | Texp_ifthenelse (cond, ifso, None) -> - Lifthenelse (transl_exp cond, transl_exp ifso, lambda_unit) - | Texp_sequence (expr1, expr2) -> - Lsequence (transl_exp expr1, transl_exp expr2) - | Texp_break -> Lbreak - | Texp_continue -> Lcontinue - | Texp_while (cond, body) -> Lwhile (transl_exp cond, transl_exp body) + if_ (transl_exp cond) (transl_exp ifso) lambda_unit + | Texp_sequence (expr1, expr2) -> seq (transl_exp expr1) (transl_exp expr2) + | Texp_break -> break + | Texp_continue -> continue + | Texp_while (cond, body) -> while_ (transl_exp cond) (transl_exp body) | Texp_for (param, _, low, high, dir, body) -> - Lfor (param, transl_exp low, transl_exp high, dir, transl_exp body) + for_ param (transl_exp low) (transl_exp high) dir (transl_exp body) | Texp_for_of (param, _, iterable, body) -> - Lfor_of (param, transl_exp iterable, transl_exp body) + for_of param (transl_exp iterable) (transl_exp body) | Texp_for_await_of (param, _, iterable, body) -> - Lfor_await_of (param, transl_exp iterable, transl_exp body) + for_await_of param (transl_exp iterable) (transl_exp body) | Texp_object_literal fields -> let labels = List.map @@ -1297,31 +1290,29 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = }) fields in - Lprim - ( Pjs_object_create labels, - List.map (fun (_, field) -> transl_exp field) fields, - e.exp_loc ) + prim ~primitive:(Pjs_object_create labels) + ~args:(List.map (fun (_, field) -> transl_exp field) fields) + e.exp_loc | Texp_object_get (expr, nm) -> - Lprim (Pjs_object_get nm.txt, [transl_exp expr], e.exp_loc) + prim ~primitive:(Pjs_object_get nm.txt) ~args:[transl_exp expr] e.exp_loc | Texp_object_set (expr, nm, value) -> - Lprim (Pjs_object_set nm.txt, [transl_exp expr; transl_exp value], e.exp_loc) + prim ~primitive:(Pjs_object_set nm.txt) + ~args:[transl_exp expr; transl_exp value] + e.exp_loc | Texp_letmodule (id, _loc, modl, body) -> let defining_expr = !transl_module Tcoerce_none None modl in - Llet (Strict, Pgenval, id, defining_expr, transl_exp body) + let_ Strict id defining_expr (transl_exp body) | Texp_letexception (cd, body) -> - Llet - ( Strict, - Pgenval, - cd.ext_id, - transl_extension_constructor e.exp_env None cd, - transl_exp body ) + let_ Strict cd.ext_id + (transl_extension_constructor e.exp_env None cd) + (transl_exp body) | Texp_pack modl -> !transl_module Tcoerce_none None modl | Texp_assert {exp_desc = Texp_construct (_, {cstr_name = "false"}, _)} -> if !Clflags.no_assert_false then Lambda.lambda_assert_false else assert_failed e | Texp_assert cond -> if !Clflags.noassert then lambda_unit - else Lifthenelse (transl_exp cond, lambda_unit, assert_failed e) + else if_ (transl_exp cond) lambda_unit (assert_failed e) and transl_list expr_list = List.map transl_exp expr_list @@ -1329,7 +1320,7 @@ and transl_guard guard rhs = let expr = transl_exp rhs in match guard with | None -> expr - | Some cond -> Lifthenelse (transl_exp cond, expr, staticfail) + | Some cond -> if_ (transl_exp cond) expr staticfail and transl_case {c_lhs; c_guard; c_rhs} = (c_lhs, transl_guard c_guard c_rhs) @@ -1339,14 +1330,8 @@ and transl_apply ?(inlined = Default_inline) ?(uncurried_partial_application = None) ?(transformed_jsx = false) lam sargs loc = let lapply ap_func ap_args = - Lapply - { - ap_loc = loc; - ap_func; - ap_args; - ap_inlined = inlined; - ap_transformed_jsx = transformed_jsx; - } + apply ~ap_transformed_jsx:transformed_jsx ap_func ap_args + {ap_loc = loc; ap_inlined = inlined} in let rec build_apply lam args = function | (None, optional) :: l -> @@ -1357,7 +1342,7 @@ and transl_apply ?(inlined = Default_inline) | _ -> let id = Ident.create name in defs := (id, lam) :: !defs; - Lvar id + var id in let args, args' = if List.for_all (fun (_, opt) -> opt) args then ([], args) @@ -1368,21 +1353,14 @@ and transl_apply ?(inlined = Default_inline) and l = List.map (fun (arg, opt) -> (may_map (protect "arg") arg, opt)) l and id_arg = Ident.create "param" in let body = - match build_apply handle ((Lvar id_arg, optional) :: args') l with + match build_apply handle ((var id_arg, optional) :: args') l with | Lfunction {params = ids; body = lam; attr; loc} -> - Lfunction {params = id_arg :: ids; body = lam; attr; loc} + function_ ~loc ~attr ~params:(id_arg :: ids) ~body:lam | lam -> - Lfunction - { - params = [id_arg]; - body = lam; - attr = default_function_attribute; - loc; - } + function_ ~loc ~attr:default_function_attribute ~params:[id_arg] + ~body:lam in - List.fold_left - (fun body (id, lam) -> Llet (Strict, Pgenval, id, lam, body)) - body !defs + List.fold_left (fun body (id, lam) -> let_ Strict id lam body) body !defs | (Some arg, optional) :: l -> build_apply lam ((arg, optional) :: args) l | [] -> lapply lam (List.rev_map fst args) in @@ -1396,52 +1374,40 @@ and transl_apply ?(inlined = Default_inline) | _, None -> let id_arg = Ident.create "none" in none_ids := id_arg :: !none_ids; - Some (Lvar id_arg)) + Some (var id_arg)) in let extra_ids = Array.init extra_arity (fun _ -> Ident.create "extra") |> Array.to_list in - let extra_args = Ext_list.map extra_ids (fun id -> Lvar id) in + let extra_args = Ext_list.map extra_ids (fun id -> var id) in let ap_args = args @ extra_args in let l0 = - Lapply - { - ap_func = lam; - ap_args; - ap_inlined = inlined; - ap_loc = loc; - ap_transformed_jsx = transformed_jsx; - } + apply ~ap_transformed_jsx:transformed_jsx lam ap_args + {ap_loc = loc; ap_inlined = inlined} in - Lfunction - { - params = List.rev_append !none_ids extra_ids; - body = l0; - attr = default_function_attribute; - loc; - } + function_ ~loc ~attr:default_function_attribute + ~params:(List.rev_append !none_ids extra_ids) + ~body:l0 | _ -> (build_apply lam [] (List.map (fun (l, x) -> (may_map transl_exp x, Btype.is_optional l)) sargs) - : Lambda.lambda) + : Lambda.t) and transl_function loc (params : function_param list) body = match params with | [] -> assert false | [{fp_param; fp_pat; fp_partial}] -> ( [fp_param], - Matching.for_function loc None (Lvar fp_param) + Matching.for_function loc None (var fp_param) [(fp_pat, transl_exp body)] fp_partial, is_base_type body.exp_env body.exp_type Predef.path_unit ) | {fp_param; fp_pat; fp_partial} :: rest -> let lparams, lbody, return_unit = transl_function loc rest body in ( fp_param :: lparams, - Matching.for_function loc None (Lvar fp_param) - [(fp_pat, lbody)] - fp_partial, + Matching.for_function loc None (var fp_param) [(fp_pat, lbody)] fp_partial, return_unit ) and transl_let ~js_hoist rec_flag pat_expr_list body = @@ -1517,7 +1483,7 @@ and transl_record loc env fields repres opt_init_expr = | Record_extension -> Pfield (i + 1, Lambda.fld_record_extension lbl) in - Lprim (access, [Lvar init_id], loc) + prim ~primitive:access ~args:[var init_id] loc | Overridden (_lid, expr) -> transl_exp expr) fields in @@ -1534,7 +1500,7 @@ and transl_record loc env fields repres opt_init_expr = match repres with | Record_float_unused -> assert false | Record_regular -> - Lconst (Const_block (Lambda.blk_record fields mut, cl)) + const (Const_block (Lambda.blk_record fields mut, cl)) | Record_inlined {name; representation} -> let runtime = match Variant_runtime.representation representation with @@ -1545,13 +1511,13 @@ and transl_record loc env fields repres opt_init_expr = Variant_runtime.num_blocks (Variant_runtime.get_layout representation.variant) in - Lconst + const (Const_block ( Lambda.blk_record_inlined fields name num_nonconsts ~runtime mut, cl )) | Record_unboxed _ -> - Lconst + const (match cl with | [v] -> v | _ -> assert false) @@ -1559,7 +1525,9 @@ and transl_record loc env fields repres opt_init_expr = with Not_constant -> ( match repres with | Record_regular -> - Lprim (Pmakeblock (Lambda.blk_record fields mut), ll, loc) + prim + ~primitive:(Pmakeblock (Lambda.blk_record fields mut)) + ~args:ll loc | Record_float_unused -> assert false | Record_inlined {name; representation} -> let runtime = @@ -1571,12 +1539,12 @@ and transl_record loc env fields repres opt_init_expr = Variant_runtime.num_blocks (Variant_runtime.get_layout representation.variant) in - Lprim - ( Pmakeblock - (Lambda.blk_record_inlined fields name num_nonconsts ~runtime - mut), - ll, - loc ) + prim + ~primitive: + (Pmakeblock + (Lambda.blk_record_inlined fields name num_nonconsts ~runtime + mut)) + ~args:ll loc | Record_unboxed _ -> ( match ll with | [v] -> v @@ -1589,13 +1557,13 @@ and transl_record loc env fields repres opt_init_expr = | _ -> assert false in let slot = transl_extension_path env path in - Lprim - (Pmakeblock (Lambda.blk_record_ext fields mut), slot :: ll, loc)) + prim + ~primitive:(Pmakeblock (Lambda.blk_record_ext fields mut)) + ~args:(slot :: ll) loc) in match opt_init_expr with | None -> lam - | Some init_expr -> - Llet (Strict, Pgenval, init_id, transl_exp init_expr, lam) + | Some init_expr -> let_ Strict init_id (transl_exp init_expr) lam else (* Take a shallow copy of the init record, then mutate the fields of the copy *) @@ -1615,17 +1583,16 @@ and transl_record loc env fields repres opt_init_expr = | Record_extension -> Psetfield (lbl.lbl_pos + 1, Lambda.fld_record_extension_set lbl) in - Lsequence (Lprim (upd, [Lvar copy_id; transl_exp expr], loc), cont) + seq + (prim ~primitive:upd ~args:[var copy_id; transl_exp expr] loc) + cont in match opt_init_expr with | None -> assert false | Some init_expr -> - Llet - ( Strict, - Pgenval, - copy_id, - Lprim (Pduprecord, [transl_exp init_expr], loc), - Array.fold_left update_field (Lvar copy_id) fields )) + let_ Strict copy_id + (prim ~primitive:Pduprecord ~args:[transl_exp init_expr] loc) + (Array.fold_left update_field (var copy_id) fields)) and transl_match e arg pat_expr_list exn_pat_expr_list partial = let id = Typecore.name_pattern "exn" exn_pat_expr_list @@ -1633,19 +1600,19 @@ and transl_match e arg pat_expr_list exn_pat_expr_list partial = and exn_cases = transl_cases exn_pat_expr_list in let static_catch body val_ids handler = let static_exception_id = next_negative_raise_count () in - let exn_handler = Matching.for_trywith (Lvar id) exn_cases in + let exn_handler = Matching.for_trywith (var id) exn_cases in let id, exn_handler = pack_trywith_exn id exn_handler in - Lstaticcatch - ( Ltrywith (Lstaticraise (static_exception_id, body), id, exn_handler), - (static_exception_id, val_ids), - handler ) + staticcatch + (try_ (staticraise static_exception_id body) id exn_handler) + (static_exception_id, val_ids) + handler in match (arg, exn_cases) with | {exp_desc = Texp_tuple argl}, [] -> Matching.for_multiple_match e.exp_loc (transl_list argl) cases partial | {exp_desc = Texp_tuple argl}, _ :: _ -> let val_ids = List.map (fun _ -> Typecore.name_pattern "val" []) argl in - let lvars = List.map (fun id -> Lvar id) val_ids in + let lvars = List.map (fun id -> var id) val_ids in static_catch (transl_list argl) val_ids (Matching.for_multiple_match e.exp_loc lvars cases partial) | arg, [] -> @@ -1655,7 +1622,7 @@ and transl_match e arg pat_expr_list exn_pat_expr_list partial = static_catch [transl_exp arg] [val_id] - (Matching.for_function e.exp_loc None (Lvar val_id) cases partial) + (Matching.for_function e.exp_loc None (var val_id) cases partial) open Format diff --git a/compiler/ml/translcore.mli b/compiler/ml/translcore.mli index 98ea3758700..000953852fb 100644 --- a/compiler/ml/translcore.mli +++ b/compiler/ml/translcore.mli @@ -16,14 +16,14 @@ (* Translation from typed abstract syntax to lambda terms, for the core language *) -val transl_exp : Typedtree.expression -> Lambda.lambda +val transl_exp : Typedtree.expression -> Lambda.t val transl_let : js_hoist:(Ident.t -> Location.t -> unit) option -> Asttypes.rec_flag -> Typedtree.value_binding list -> - Lambda.lambda -> - Lambda.lambda + Lambda.t -> + Lambda.t val transl_primitive : Location.t -> @@ -31,15 +31,15 @@ val transl_primitive : Env.t -> Types.type_expr -> val_type:Types.type_expr -> - Lambda.lambda + Lambda.t val transl_extension_constructor : - Env.t -> Path.t option -> Typedtree.extension_constructor -> Lambda.lambda + Env.t -> Path.t option -> Typedtree.extension_constructor -> Lambda.t (* Forward declaration -- to be filled in by Translmod.transl_module *) val transl_module : (Typedtree.module_coercion -> Path.t option -> Typedtree.module_expr -> - Lambda.lambda) + Lambda.t) ref diff --git a/compiler/ml/translmod.ml b/compiler/ml/translmod.ml index e75ca3fe277..cd8125fc221 100644 --- a/compiler/ml/translmod.ml +++ b/compiler/ml/translmod.ml @@ -57,7 +57,7 @@ let field_path path field : Path.t option = (* Compile type extensions *) let transl_type_extension env rootpath (tyext : Typedtree.type_extension) body : - Lambda.lambda = + Lambda.t = List.fold_right (fun ext body -> let lam = @@ -65,7 +65,7 @@ let transl_type_extension env rootpath (tyext : Typedtree.type_extension) body : (field_path rootpath ext.ext_id) ext in - Lambda.Llet (Strict, Pgenval, ext.ext_id, lam, body)) + Lambda.let_ Strict ext.ext_id lam body) tyext.tyext_constructors body (* Compile a coercion *) @@ -76,20 +76,26 @@ let rec apply_coercion loc strict (restr : Typedtree.module_coercion) arg = | Tcoerce_structure (pos_cc_list, id_pos_list, runtime_fields) -> Lambda.name_lambda strict arg (fun id -> let get_field_name name pos = - Lambda.Lprim (Pfield (pos, Fld_module {name}), [Lvar id], loc) + Lambda.prim + ~primitive:(Pfield (pos, Fld_module {name})) + ~args:[Lambda.var id] + loc in let lam = - Lambda.Lprim - ( Pmakeblock (Blk_module runtime_fields), - Ext_list.map2 pos_cc_list runtime_fields (fun (pos, cc) name -> - apply_coercion loc Alias cc - (Lprim (Pfield (pos, Fld_module {name}), [Lvar id], loc))), - loc ) + Lambda.prim ~primitive:(Pmakeblock (Blk_module runtime_fields)) + ~args: + (Ext_list.map2 pos_cc_list runtime_fields (fun (pos, cc) name -> + apply_coercion loc Alias cc + (Lambda.prim + ~primitive:(Pfield (pos, Fld_module {name})) + ~args:[Lambda.var id] + loc))) + loc in wrap_id_pos_list loc id_pos_list get_field_name lam) | Tcoerce_functor (cc_arg, cc_res) -> let param = Ident.create "funarg" in - let carg = apply_coercion loc Alias cc_arg (Lvar param) in + let carg = apply_coercion loc Alias cc_arg (Lambda.var param) in apply_coercion_result loc strict arg param carg cc_res | Tcoerce_primitive {pc_loc; pc_desc; pc_env; pc_type} -> Translcore.transl_primitive pc_loc pc_desc pc_env pc_type ~val_type:pc_type @@ -99,22 +105,13 @@ let rec apply_coercion loc strict (restr : Typedtree.module_coercion) arg = and apply_coercion_result loc strict funct param arg cc_res = Lambda.name_lambda strict funct (fun id -> - Lfunction - { - params = [param]; - attr = {Lambda.default_function_attribute with is_a_functor = true}; - loc; - body = - apply_coercion loc Strict cc_res - (Lapply - { - ap_loc = loc; - ap_func = Lvar id; - ap_args = [arg]; - ap_inlined = Default_inline; - ap_transformed_jsx = false; - }); - }) + Lambda.function_ ~loc + ~attr:{Lambda.default_function_attribute with is_a_functor = true} + ~params:[param] + ~body: + (apply_coercion loc Strict cc_res + (Lambda.apply ~ap_transformed_jsx:false (Lambda.var id) [arg] + {ap_loc = loc; ap_inlined = Default_inline}))) and wrap_id_pos_list loc id_pos_list get_field lam = let fv = Lambda.free_variables lam in @@ -124,15 +121,12 @@ and wrap_id_pos_list loc id_pos_list get_field lam = let lam, s = List.fold_left (fun (lam, s) (id', pos, c) -> - if Lambda.Ident_set.mem id' fv then + if Set_ident.mem fv id' then let id'' = Ident.create (Ident.name id') in - ( Lambda.Llet - ( Alias, - Pgenval, - id'', - apply_coercion loc Alias c (get_field (Ident.name id') pos), - lam ), - Ident.add id' (Lambda.Lvar id'') s ) + ( Lambda.let_ Alias id'' + (apply_coercion loc Alias c (get_field (Ident.name id') pos)) + lam, + Ident.add id' (Lambda.var id'') s ) else (lam, s)) (lam, Ident.empty) id_pos_list in @@ -253,26 +247,21 @@ let rec compile_functor mexp coercion root_path loc = (* cf. [transl_module] *) let param, loc_, arg_coercion = functor_param in let param' = Ident.rename param in - let arg = apply_coercion loc_ Alias arg_coercion (Lvar param') in + let arg = apply_coercion loc_ Alias arg_coercion (Lambda.var param') in let body = - Lambda.Llet - (Alias, Pgenval, param, arg, transl_module res_coercion body_path body) + Lambda.let_ Alias param arg (transl_module res_coercion body_path body) in - Lambda.Lfunction - { - params = [param']; - attr = - { - inline = inline_attribute; - is_a_functor = true; - return_unit = false; - async = false; - one_unit_arg = false; - directive = None; - }; - loc; - body; - } + Lambda.function_ ~loc + ~attr: + { + inline = inline_attribute; + is_a_functor = true; + return_unit = false; + async = false; + one_unit_arg = false; + directive = None; + } + ~params:[param'] ~body (* Compile a module expression *) and transl_module cc rootpath mexp = @@ -293,14 +282,10 @@ and transl_module cc rootpath mexp = Translattribute.get_and_remove_inlined_attribute_on_module funct in apply_coercion loc Strict cc - (Lapply - { - ap_loc = loc; - ap_func = transl_module Tcoerce_none None funct; - ap_args = [transl_module ccarg None arg]; - ap_inlined = inlined_attribute; - ap_transformed_jsx = false; - }) + (Lambda.apply ~ap_transformed_jsx:false + (transl_module Tcoerce_none None funct) + [transl_module ccarg None arg] + {ap_loc = loc; ap_inlined = inlined_attribute}) | Tmod_constraint (arg, _, _, ccarg) -> transl_module (compose_coercions cc ccarg) rootpath arg | Tmod_unpack (arg, _) -> @@ -320,15 +305,15 @@ and transl_structure loc fields cc rootpath final_env = function (fun acc id -> if is_top_root_path then export_identifiers := id :: !export_identifiers; - Lambda.Lvar id :: acc) + Lambda.var id :: acc) [] fields in - ( Lambda.Lprim - ( Pmakeblock - (if is_top_root_path then Blk_module_export !export_identifiers - else Blk_module (List.rev_map (fun id -> id.Ident.name) fields)), - block_fields, - loc ), + ( Lambda.prim + ~primitive: + (Pmakeblock + (if is_top_root_path then Blk_module_export !export_identifiers + else Blk_module (List.rev_map (fun id -> id.Ident.name) fields))) + ~args:block_fields loc, List.length fields ) | Tcoerce_structure (pos_cc_list, id_pos_list, runtime_fields) -> (* Do not ignore id_pos_list ! *) @@ -338,10 +323,8 @@ and transl_structure loc fields cc rootpath final_env = function Format.eprintf "@]@.";*) assert (List.length runtime_fields = List.length pos_cc_list); let v = Ext_array.reverse_of_list fields in - let get_field pos = Lambda.Lvar v.(pos) - and ids = - List.fold_right Lambda.Ident_set.add fields Lambda.Ident_set.empty - in + let get_field pos = Lambda.var v.(pos) + and ids = List.fold_left Set_ident.add Set_ident.empty fields in let get_field_name _name = get_field in let result = List.fold_right @@ -360,15 +343,15 @@ and transl_structure loc fields cc rootpath final_env = function pos_cc_list [] in let lam = - Lambda.Lprim - ( Pmakeblock - (if is_top_root_path then Blk_module_export !export_identifiers - else Blk_module runtime_fields), - result, - loc ) + Lambda.prim + ~primitive: + (Pmakeblock + (if is_top_root_path then Blk_module_export !export_identifiers + else Blk_module runtime_fields)) + ~args:result loc and id_pos_list = Ext_list.filter id_pos_list (fun (id, _, _) -> - not (Lambda.Ident_set.mem id ids)) + not (Set_ident.mem ids id)) in ( wrap_id_pos_list loc id_pos_list get_field_name lam, List.length pos_cc_list ) @@ -377,7 +360,7 @@ and transl_structure loc fields cc rootpath final_env = function match item.str_desc with | Tstr_eval (expr, _) -> let body, size = transl_structure loc fields cc rootpath final_env rem in - (Lsequence (Translcore.transl_exp expr, body), size) + (Lambda.seq (Translcore.transl_exp expr) body, size) | Tstr_value (rec_flag, pat_expr_list) -> let ext_fields = rev_let_bound_idents pat_expr_list @ fields in let body, size = @@ -409,12 +392,9 @@ and transl_structure loc fields cc rootpath final_env = function let body, size = transl_structure loc (id :: fields) cc rootpath final_env rem in - ( Llet - ( Strict, - Pgenval, - id, - Translcore.transl_extension_constructor item.str_env path ext, - body ), + ( Lambda.let_ Strict id + (Translcore.transl_extension_constructor item.str_env path ext) + body, size ) | Tstr_module mb as s -> let id = mb.mb_id in @@ -431,7 +411,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) + (Lambda.let_ (pure_module mb.mb_expr) id module_body body, size) | Tstr_recmodule bindings -> let ext_fields = List.rev_append (List.map (fun mb -> mb.mb_id) bindings) fields @@ -454,24 +434,18 @@ and transl_structure loc fields cc rootpath final_env = function | [] -> transl_structure loc newfields cc rootpath final_env rem | id :: ids -> let body, size = rebind_idents (pos + 1) (id :: newfields) ids in - ( Llet - ( Alias, - Pgenval, - id, - Lprim - ( Pfield (pos, Fld_module {name = Ident.name id}), - [Lvar mid], - incl.incl_loc ), - body ), + ( Lambda.let_ Alias id + (Lambda.prim + ~primitive:(Pfield (pos, Fld_module {name = Ident.name id})) + ~args:[Lambda.var mid] + incl.incl_loc) + body, size ) in let body, size = rebind_idents 0 fields ids in - ( Llet - ( pure_module modl, - Pgenval, - mid, - transl_module Tcoerce_none None modl, - body ), + ( Lambda.let_ (pure_module modl) mid + (transl_module Tcoerce_none None modl) + body, size ) | Tstr_primitive _ | Tstr_type _ | Tstr_modtype _ | Tstr_open _ | Tstr_attribute _ -> @@ -485,7 +459,7 @@ let _ = Translcore.transl_module := transl_module (* Compile an implementation *) type implementation = { - lambda: Lambda.lambda; + lambda: Lambda.t; exports: Ident.t list; hoisted_functions: Lambda.hoisted_function list; } diff --git a/compiler/ml/translmod.mli b/compiler/ml/translmod.mli index 5da4808c1fa..efd18ad9c83 100644 --- a/compiler/ml/translmod.mli +++ b/compiler/ml/translmod.mli @@ -17,7 +17,7 @@ for the module language *) type implementation = { - lambda: Lambda.lambda; + lambda: Lambda.t; exports: Ident.t list; hoisted_functions: Lambda.hoisted_function list; } diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 1dd091d0f65..2d2e1c180d3 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -80,6 +80,7 @@ type error = | Break_outside_loop | Continue_outside_loop | Literal_overflow of string + | Polyvar_literal_overflow | Unknown_literal of string * char | Illegal_letrec_pat | Empty_record_literal @@ -286,6 +287,15 @@ let constant_or_raise env loc cst = | Ok c -> c | Error err -> raise (Error (loc, env, err)) +(* A numeric polymorphic variant name is its own runtime value, so it has to + fit the int32 range the name is emitted in. Checked here, where every label + position is typed, so that decoding it downstream cannot fail. *) +let check_polyvar_name env loc name = + if Ext_string.is_valid_hash_number name then + match Int32.of_string_opt name with + | Some _ -> () + | None -> raise (Error (loc, env, Polyvar_literal_overflow)) + (* Specific version of type_option, using newty rather than newgenty *) let type_option ty = newty (Tconstr (Predef.path_option, [ty], ref Mnil)) @@ -1465,6 +1475,7 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp pat_env = !env; }) | Ppat_variant (l, sarg) -> ( + check_polyvar_name !env loc l; let arg_type = match sarg with | None -> [] @@ -2713,6 +2724,7 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp | Pexp_construct (lid, sarg) -> type_construct ~context env loc lid sarg ty_expected sexp.pexp_attributes | Pexp_variant (l, sarg) -> ( + check_polyvar_name env loc l; (* Keep sharing *) let ty_expected0 = instance env ty_expected in try @@ -5230,6 +5242,10 @@ let report_error env loc ppf error = fprintf ppf "Integer literal exceeds the range of representable integers of type %s" ty + | Polyvar_literal_overflow -> + fprintf ppf + "Integer literal exceeds int32 range. Use float or BigInt if larger \ + values are required." | Unknown_literal (n, m) -> fprintf ppf "Unknown modifier '%c' for literal %s%c" m n m | Illegal_letrec_pat -> diff --git a/compiler/ml/typecore.mli b/compiler/ml/typecore.mli index 42b5d4ce685..432f9c45df7 100644 --- a/compiler/ml/typecore.mli +++ b/compiler/ml/typecore.mli @@ -113,6 +113,7 @@ type error = | Break_outside_loop | Continue_outside_loop | Literal_overflow of string + | Polyvar_literal_overflow | Unknown_literal of string * char | Illegal_letrec_pat | Empty_record_literal diff --git a/compiler/ml/unified_ops.ml b/compiler/ml/unified_ops.ml index 4debc8b1e40..6cce6c65577 100644 --- a/compiler/ml/unified_ops.ml +++ b/compiler/ml/unified_ops.ml @@ -36,13 +36,20 @@ open Misc type form = Unary | Binary -(* Note: unified op must support int type *) +(* How an operator lowers for one operand type. *) +type lowering = + | Lower of Lambda.primitive + | Pass_through (** the operand is already the result: unary [+] *) + +(* [None] means the operand type is not supported by the operator; the payload + says how the supported ones lower. + Note: unified op must support int type *) type specialization = { - int: Lambda.primitive; - bool: Lambda.primitive option; - float: Lambda.primitive option; - bigint: Lambda.primitive option; - string: Lambda.primitive option; + int: lowering; + bool: lowering option; + float: lowering option; + bigint: lowering option; + string: lowering option; } type entry = { @@ -53,209 +60,215 @@ type entry = { specialization: specialization; } -let builtin x = Primitive_modules.pervasives ^ "." ^ x +let pervasives_path x = Primitive_modules.pervasives ^ "." ^ x let entries = [| { - path = builtin "~+"; + path = pervasives_path "~+"; name = "%plus"; form = Unary; specialization = { - int = Peliminated Identity; + int = Pass_through; bool = None; - float = Some (Peliminated Identity); - bigint = Some (Peliminated Identity); + float = Some Pass_through; + bigint = Some Pass_through; string = None; }; }; { - path = builtin "~-"; + path = pervasives_path "~-"; name = "%neg"; form = Unary; specialization = { - int = Pnegint; + int = Lower Pnegint; bool = None; - float = Some Pnegfloat; - bigint = Some Pnegbigint; + float = Some (Lower Pnegfloat); + bigint = Some (Lower Pnegbigint); string = None; }; }; { - path = builtin "+"; + path = pervasives_path "+"; name = "%add"; form = Binary; specialization = { - int = Paddint; + int = Lower Paddint; bool = None; - float = Some Paddfloat; - bigint = Some Paddbigint; - string = Some Pstringadd; + float = Some (Lower Paddfloat); + bigint = Some (Lower Paddbigint); + string = Some (Lower Pstringadd); }; }; { - path = builtin "-"; + path = pervasives_path "-"; name = "%sub"; form = Binary; specialization = { - int = Psubint; + int = Lower Psubint; bool = None; - float = Some Psubfloat; - bigint = Some Psubbigint; + float = Some (Lower Psubfloat); + bigint = Some (Lower Psubbigint); string = None; }; }; { - path = builtin "*"; + path = pervasives_path "*"; name = "%mul"; form = Binary; specialization = { - int = Pmulint; + int = Lower Pmulint; bool = None; - float = Some Pmulfloat; - bigint = Some Pmulbigint; + float = Some (Lower Pmulfloat); + bigint = Some (Lower Pmulbigint); string = None; }; }; { - path = builtin "/"; + path = pervasives_path "/"; name = "%div"; form = Binary; specialization = { - int = Pdivint; + int = Lower Pdivint; bool = None; - float = Some Pdivfloat; - bigint = Some Pdivbigint; + float = Some (Lower Pdivfloat); + bigint = Some (Lower Pdivbigint); string = None; }; }; { - path = builtin "%"; + path = pervasives_path "%"; name = "%mod"; form = Binary; specialization = { - int = Pmodint; + int = Lower Pmodint; bool = None; - float = Some Pmodfloat; - bigint = Some Pmodbigint; + float = Some (Lower Pmodfloat); + bigint = Some (Lower Pmodbigint); string = None; }; }; { - path = builtin "<<"; + path = pervasives_path "<<"; name = "%lsl"; form = Binary; specialization = { - int = Plslint; + int = Lower Plslint; bool = None; float = None; - bigint = Some Plslbigint; + bigint = Some (Lower Plslbigint); string = None; }; }; { - path = builtin ">>"; + path = pervasives_path ">>"; name = "%asr"; form = Binary; specialization = { - int = Pasrint; + int = Lower Pasrint; bool = None; float = None; - bigint = Some Pasrbigint; + bigint = Some (Lower Pasrbigint); string = None; }; }; { - path = builtin ">>>"; + path = pervasives_path ">>>"; name = "%lsr"; form = Binary; specialization = - {int = Plsrint; bool = None; float = None; bigint = None; string = None}; + { + int = Lower Plsrint; + bool = None; + float = None; + bigint = None; + string = None; + }; }; { - path = builtin "mod"; + path = pervasives_path "mod"; name = "%mod"; form = Binary; specialization = { - int = Pmodint; + int = Lower Pmodint; bool = None; - float = Some Pmodfloat; - bigint = Some Pmodbigint; + float = Some (Lower Pmodfloat); + bigint = Some (Lower Pmodbigint); string = None; }; }; { - path = builtin "**"; + path = pervasives_path "**"; name = "%pow"; form = Binary; specialization = { - int = Ppowint; + int = Lower Ppowint; bool = None; - float = Some Ppowfloat; - bigint = Some Ppowbigint; + float = Some (Lower Ppowfloat); + bigint = Some (Lower Ppowbigint); string = None; }; }; { - path = builtin "~~~"; + path = pervasives_path "~~~"; name = "%bitnot"; form = Unary; specialization = { - int = Pnotint; + int = Lower Pnotint; bool = None; float = None; - bigint = Some Pnotbigint; + bigint = Some (Lower Pnotbigint); string = None; }; }; { - path = builtin "|||"; + path = pervasives_path "|||"; name = "%bitor"; form = Binary; specialization = { - int = Porint; + int = Lower Porint; bool = None; float = None; - bigint = Some Porbigint; + bigint = Some (Lower Porbigint); string = None; }; }; { - path = builtin "^^^"; + path = pervasives_path "^^^"; name = "%bitxor"; form = Binary; specialization = { - int = Pxorint; + int = Lower Pxorint; bool = None; float = None; - bigint = Some Pxorbigint; + bigint = Some (Lower Pxorbigint); string = None; }; }; { - path = builtin "&&&"; + path = pervasives_path "&&&"; name = "%bitand"; form = Binary; specialization = { - int = Pandint; + int = Lower Pandint; bool = None; float = None; - bigint = Some Pandbigint; + bigint = Some (Lower Pandbigint); string = None; }; }; diff --git a/compiler/ml/unified_ops.mli b/compiler/ml/unified_ops.mli index b52e052a559..2cf4440f0a3 100644 --- a/compiler/ml/unified_ops.mli +++ b/compiler/ml/unified_ops.mli @@ -1,11 +1,15 @@ type form = Unary | Binary +type lowering = + | Lower of Lambda.primitive + | Pass_through (** the operand is already the result: unary [+] *) + type specialization = { - int: Lambda.primitive; - bool: Lambda.primitive option; - float: Lambda.primitive option; - bigint: Lambda.primitive option; - string: Lambda.primitive option; + int: lowering; + bool: lowering option; + float: lowering option; + bigint: lowering option; + string: lowering option; } type entry = { diff --git a/packages/@rescript/runtime/Primitive_curry.res b/packages/@rescript/runtime/Primitive_curry.res deleted file mode 100644 index 9bf7acb6fb2..00000000000 --- a/packages/@rescript/runtime/Primitive_curry.res +++ /dev/null @@ -1,336 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017- Hongbo Zhang, Authors of ReScript - * - * SPDX-License-Identifier: MIT - */ - -module Array = Primitive_array_extern -module Obj = Primitive_object_extern - -@@uncurried - -external function_arity: 'a => int = "%function_arity" - -@send external apply_args: ('a => 'b, Primitive_js_extern.null<_>, array<_>) => 'b = "apply" -let apply_args = (f, args) => apply_args(f, Primitive_js_extern.null, args) - -/* Public */ -let rec app = (f, args) => { - let init_arity = function_arity(f) - let arity = if init_arity == 0 { - 1 - } else { - init_arity - } /* arity fixing */ - let len = Array.length(args) - let d = arity - len - if d == 0 { - apply_args(f, args) /* f.apply (null,args) */ - } else if d < 0 { - /* TODO: could avoid copy by tracking the index */ - app(Obj.magic(apply_args(f, Array.slice(args, 0, arity))), Array.slice(args, arity, len)) - } else { - Obj.magic(x => app(f, Array.concat(args, [x]))) - } -} - -external apply1: ('a0 => 'a1, 'a0) => 'a1 = "%curry_apply1" -external apply2: (('a0, 'a1) => 'a2, 'a0, 'a1) => 'a2 = "%curry_apply2" -external apply3: (('a0, 'a1, 'a2) => 'a3, 'a0, 'a1, 'a2) => 'a3 = "%curry_apply3" -external apply4: (('a0, 'a1, 'a2, 'a3) => 'a4, 'a0, 'a1, 'a2, 'a3) => 'a4 = "%curry_apply4" -external apply5: (('a0, 'a1, 'a2, 'a3, 'a4) => 'a5, 'a0, 'a1, 'a2, 'a3, 'a4) => 'a5 = - "%curry_apply5" -external apply6: (('a0, 'a1, 'a2, 'a3, 'a4, 'a5) => 'a6, 'a0, 'a1, 'a2, 'a3, 'a4, 'a5) => 'a6 = - "%curry_apply6" -external apply7: ( - ('a0, 'a1, 'a2, 'a3, 'a4, 'a5, 'a6) => 'a7, - 'a0, - 'a1, - 'a2, - 'a3, - 'a4, - 'a5, - 'a6, -) => 'a7 = "%curry_apply7" -external apply8: ( - ('a0, 'a1, 'a2, 'a3, 'a4, 'a5, 'a6, 'a7) => 'a8, - 'a0, - 'a1, - 'a2, - 'a3, - 'a4, - 'a5, - 'a6, - 'a7, -) => 'a8 = "%curry_apply8" - -let curry_1 = (o, a0, arity) => - switch arity { - | 1 => apply1(Obj.magic(o), a0) - | 2 => param => apply2(Obj.magic(o), a0, param) - | 3 => Obj.magic((param, \"param$1") => apply3(Obj.magic(o), a0, param, \"param$1")) - | 4 => - Obj.magic((param, \"param$1", \"param$2") => - apply4(Obj.magic(o), a0, param, \"param$1", \"param$2") - ) - | 5 => - Obj.magic((param, \"param$1", \"param$2", \"param$3") => - apply5(Obj.magic(o), a0, param, \"param$1", \"param$2", \"param$3") - ) - | 6 => - Obj.magic((param, \"param$1", \"param$2", \"param$3", \"param$4") => - apply6(Obj.magic(o), a0, param, \"param$1", \"param$2", \"param$3", \"param$4") - ) - | 7 => - Obj.magic((param, \"param$1", \"param$2", \"param$3", \"param$4", \"param$5") => - apply7(Obj.magic(o), a0, param, \"param$1", \"param$2", \"param$3", \"param$4", \"param$5") - ) - | _ => Obj.magic(app(o, [a0])) - } - -let _1 = (o, a0) => { - let arity = function_arity(o) - if arity == 1 { - apply1(o, a0) - } else { - curry_1(o, a0, arity) - } -} - -let __1 = o => { - let arity = function_arity(o) - if arity == 1 { - o - } else { - a0 => _1(o, a0) - } -} - -let curry_2 = (o, a0, a1, arity) => - switch arity { - | 1 => app(apply1(Obj.magic(o), a0), [a1]) - | 2 => apply2(Obj.magic(o), a0, a1) - | 3 => param => apply3(Obj.magic(o), a0, a1, param) - | 4 => Obj.magic((param, \"param$1") => apply4(Obj.magic(o), a0, a1, param, \"param$1")) - | 5 => - Obj.magic((param, \"param$1", \"param$2") => - apply5(Obj.magic(o), a0, a1, param, \"param$1", \"param$2") - ) - | 6 => - Obj.magic((param, \"param$1", \"param$2", \"param$3") => - apply6(Obj.magic(o), a0, a1, param, \"param$1", \"param$2", \"param$3") - ) - | 7 => - Obj.magic((param, \"param$1", \"param$2", \"param$3", \"param$4") => - apply7(Obj.magic(o), a0, a1, param, \"param$1", \"param$2", \"param$3", \"param$4") - ) - | _ => Obj.magic(app(o, [a0, a1])) - } - -let _2 = (o, a0, a1) => { - let arity = function_arity(o) - if arity == 2 { - apply2(o, a0, a1) - } else { - curry_2(Obj.magic(o), a0, a1, arity) - } -} - -let __2 = o => { - let arity = function_arity(o) - if arity == 2 { - o - } else { - (a0, a1) => _2(o, a0, a1) - } -} - -let curry_3 = (o, a0, a1, a2, arity) => - switch arity { - | 1 => app(apply1(Obj.magic(o), a0), [a1, a2]) - | 2 => app(apply2(Obj.magic(o), a0, a1), [a2]) - | 3 => apply3(Obj.magic(o), a0, a1, a2) - | 4 => param => apply4(Obj.magic(o), a0, a1, a2, param) - | 5 => Obj.magic((param, \"param$1") => apply5(Obj.magic(o), a0, a1, a2, param, \"param$1")) - | 6 => - Obj.magic((param, \"param$1", \"param$2") => - apply6(Obj.magic(o), a0, a1, a2, param, \"param$1", \"param$2") - ) - | 7 => - Obj.magic((param, \"param$1", \"param$2", \"param$3") => - apply7(Obj.magic(o), a0, a1, a2, param, \"param$1", \"param$2", \"param$3") - ) - | _ => Obj.magic(app(o, [a0, a1, a2])) - } - -let _3 = (o, a0, a1, a2) => { - let arity = function_arity(o) - if arity == 3 { - apply3(o, a0, a1, a2) - } else { - curry_3(Obj.magic(o), a0, a1, a2, arity) - } -} - -let __3 = o => { - let arity = function_arity(o) - if arity == 3 { - o - } else { - (a0, a1, a2) => _3(o, a0, a1, a2) - } -} - -let curry_4 = (o, a0, a1, a2, a3, arity) => - switch arity { - | 1 => app(apply1(Obj.magic(o), a0), [a1, a2, a3]) - | 2 => app(apply2(Obj.magic(o), a0, a1), [a2, a3]) - | 3 => app(apply3(Obj.magic(o), a0, a1, a2), [a3]) - | 4 => apply4(Obj.magic(o), a0, a1, a2, a3) - | 5 => param => apply5(Obj.magic(o), a0, a1, a2, a3, param) - | 6 => Obj.magic((param, \"param$1") => apply6(Obj.magic(o), a0, a1, a2, a3, param, \"param$1")) - | 7 => - Obj.magic((param, \"param$1", \"param$2") => - apply7(Obj.magic(o), a0, a1, a2, a3, param, \"param$1", \"param$2") - ) - | _ => Obj.magic(app(o, [a0, a1, a2, a3])) - } - -let _4 = (o, a0, a1, a2, a3) => { - let arity = function_arity(o) - if arity == 4 { - apply4(o, a0, a1, a2, a3) - } else { - curry_4(Obj.magic(o), a0, a1, a2, a3, arity) - } -} - -let __4 = o => { - let arity = function_arity(o) - if arity == 4 { - o - } else { - (a0, a1, a2, a3) => _4(o, a0, a1, a2, a3) - } -} - -let curry_5 = (o, a0, a1, a2, a3, a4, arity) => - switch arity { - | 1 => app(apply1(Obj.magic(o), a0), [a1, a2, a3, a4]) - | 2 => app(apply2(Obj.magic(o), a0, a1), [a2, a3, a4]) - | 3 => app(apply3(Obj.magic(o), a0, a1, a2), [a3, a4]) - | 4 => app(apply4(Obj.magic(o), a0, a1, a2, a3), [a4]) - | 5 => apply5(Obj.magic(o), a0, a1, a2, a3, a4) - | 6 => param => apply6(Obj.magic(o), a0, a1, a2, a3, a4, param) - | 7 => - Obj.magic((param, \"param$1") => apply7(Obj.magic(o), a0, a1, a2, a3, a4, param, \"param$1")) - | _ => Obj.magic(app(o, [a0, a1, a2, a3, a4])) - } - -let _5 = (o, a0, a1, a2, a3, a4) => { - let arity = function_arity(o) - if arity == 5 { - apply5(o, a0, a1, a2, a3, a4) - } else { - curry_5(Obj.magic(o), a0, a1, a2, a3, a4, arity) - } -} - -let __5 = o => { - let arity = function_arity(o) - if arity == 5 { - o - } else { - (a0, a1, a2, a3, a4) => _5(o, a0, a1, a2, a3, a4) - } -} - -let curry_6 = (o, a0, a1, a2, a3, a4, a5, arity) => - switch arity { - | 1 => app(apply1(Obj.magic(o), a0), [a1, a2, a3, a4, a5]) - | 2 => app(apply2(Obj.magic(o), a0, a1), [a2, a3, a4, a5]) - | 3 => app(apply3(Obj.magic(o), a0, a1, a2), [a3, a4, a5]) - | 4 => app(apply4(Obj.magic(o), a0, a1, a2, a3), [a4, a5]) - | 5 => app(apply5(Obj.magic(o), a0, a1, a2, a3, a4), [a5]) - | 6 => apply6(Obj.magic(o), a0, a1, a2, a3, a4, a5) - | 7 => param => apply7(Obj.magic(o), a0, a1, a2, a3, a4, a5, param) - | _ => Obj.magic(app(o, [a0, a1, a2, a3, a4, a5])) - } - -let _6 = (o, a0, a1, a2, a3, a4, a5) => { - let arity = function_arity(o) - if arity == 6 { - apply6(o, a0, a1, a2, a3, a4, a5) - } else { - curry_6(Obj.magic(o), a0, a1, a2, a3, a4, a5, arity) - } -} - -let __6 = o => { - let arity = function_arity(o) - if arity == 6 { - o - } else { - (a0, a1, a2, a3, a4, a5) => _6(o, a0, a1, a2, a3, a4, a5) - } -} - -let curry_7 = (o, a0, a1, a2, a3, a4, a5, a6, arity) => - switch arity { - | 1 => app(apply1(Obj.magic(o), a0), [a1, a2, a3, a4, a5, a6]) - | 2 => app(apply2(Obj.magic(o), a0, a1), [a2, a3, a4, a5, a6]) - | 3 => app(apply3(Obj.magic(o), a0, a1, a2), [a3, a4, a5, a6]) - | 4 => app(apply4(Obj.magic(o), a0, a1, a2, a3), [a4, a5, a6]) - | 5 => app(apply5(Obj.magic(o), a0, a1, a2, a3, a4), [a5, a6]) - | 6 => app(apply6(Obj.magic(o), a0, a1, a2, a3, a4, a5), [a6]) - | 7 => apply7(Obj.magic(o), a0, a1, a2, a3, a4, a5, a6) - | _ => Obj.magic(app(o, [a0, a1, a2, a3, a4, a5, a6])) - } - -let _7 = (o, a0, a1, a2, a3, a4, a5, a6) => { - let arity = function_arity(o) - if arity == 7 { - apply7(o, a0, a1, a2, a3, a4, a5, a6) - } else { - curry_7(Obj.magic(o), a0, a1, a2, a3, a4, a5, a6, arity) - } -} - -let __7 = o => { - let arity = function_arity(o) - if arity == 7 { - o - } else { - (a0, a1, a2, a3, a4, a5, a6) => _7(o, a0, a1, a2, a3, a4, a5, a6) - } -} - -let curry_8 = (o, a0, a1, a2, a3, a4, a5, a6, a7, arity) => - switch arity { - | 1 => app(apply1(Obj.magic(o), a0), [a1, a2, a3, a4, a5, a6, a7]) - | 2 => app(apply2(Obj.magic(o), a0, a1), [a2, a3, a4, a5, a6, a7]) - | 3 => app(apply3(Obj.magic(o), a0, a1, a2), [a3, a4, a5, a6, a7]) - | 4 => app(apply4(Obj.magic(o), a0, a1, a2, a3), [a4, a5, a6, a7]) - | 5 => app(apply5(Obj.magic(o), a0, a1, a2, a3, a4), [a5, a6, a7]) - | 6 => app(apply6(Obj.magic(o), a0, a1, a2, a3, a4, a5), [a6, a7]) - | 7 => app(apply7(Obj.magic(o), a0, a1, a2, a3, a4, a5, a6), [a7]) - | _ => Obj.magic(app(o, [a0, a1, a2, a3, a4, a5, a6, a7])) - } - -let _8 = (o, a0, a1, a2, a3, a4, a5, a6, a7) => { - let arity = function_arity(o) - if arity == 8 { - apply8(o, a0, a1, a2, a3, a4, a5, a6, a7) - } else { - curry_8(Obj.magic(o), a0, a1, a2, a3, a4, a5, a6, a7, arity) - } -} - -let __8 = o => { - let arity = function_arity(o) - if arity == 8 { - o - } else { - (a0, a1, a2, a3, a4, a5, a6, a7) => _8(o, a0, a1, a2, a3, a4, a5, a6, a7) - } -} diff --git a/packages/@rescript/runtime/Primitive_curry.resi b/packages/@rescript/runtime/Primitive_curry.resi deleted file mode 100644 index 753d6bb3980..00000000000 --- a/packages/@rescript/runtime/Primitive_curry.resi +++ /dev/null @@ -1,32 +0,0 @@ -// let _1: ('a => 'b => 'c, 'a) => 'b => 'c -let __1: ('a => 'b => 'c) => 'a => 'b => 'c - -// let _2: (('a, 'a) => 'b => 'c, 'a, 'a) => 'b => 'c -let __2: (('a, 'a) => 'b => 'c) => ('a, 'a) => 'b => 'c - -// let _3: (('a, 'a, 'a) => 'b => 'c, 'a, 'a, 'a) => 'b => 'c -let __3: (('a, 'a, 'a) => 'b => 'c) => ('a, 'a, 'a) => 'b => 'c - -// let _4: (('a, 'a, 'a, 'a) => 'b => 'c, 'a, 'a, 'a, 'a) => 'b => 'c -let __4: (('a, 'a, 'a, 'a) => 'b => 'c) => ('a, 'a, 'a, 'a) => 'b => 'c - -// let _5: (('a, 'a, 'a, 'a, 'a) => 'b => 'c, 'a, 'a, 'a, 'a, 'a) => 'b => 'c -let __5: (('a, 'a, 'a, 'a, 'a) => 'b => 'c) => ('a, 'a, 'a, 'a, 'a) => 'b => 'c - -// let _6: (('a, 'a, 'a, 'a, 'a, 'a) => 'b => 'c, 'a, 'a, 'a, 'a, 'a, 'a) => 'b => 'c -let __6: (('a, 'a, 'a, 'a, 'a, 'a) => 'b => 'c) => ('a, 'a, 'a, 'a, 'a, 'a) => 'b => 'c - -// let _7: (('a, 'a, 'a, 'a, 'a, 'a, 'a) => 'b => 'c, 'a, 'a, 'a, 'a, 'a, 'a, 'a) => 'b => 'c -let __7: (('a, 'a, 'a, 'a, 'a, 'a, 'a) => 'b => 'c) => ('a, 'a, 'a, 'a, 'a, 'a, 'a) => 'b => 'c - -// let _8: (('a, 'a, 'a, 'a, 'a, 'a, 'a, 'a) => 'b => 'c, 'a, 'a, 'a, 'a, 'a, 'a, 'a, 'a) => 'b => 'c -let __8: (('a, 'a, 'a, 'a, 'a, 'a, 'a, 'a) => 'b => 'c) => ( - 'a, - 'a, - 'a, - 'a, - 'a, - 'a, - 'a, - 'a, -) => 'b => 'c diff --git a/packages/@rescript/runtime/lib/es6/Primitive_curry.mjs b/packages/@rescript/runtime/lib/es6/Primitive_curry.mjs deleted file mode 100644 index dc32d8492c2..00000000000 --- a/packages/@rescript/runtime/lib/es6/Primitive_curry.mjs +++ /dev/null @@ -1,438 +0,0 @@ - - - -function app(_f, _args) { - while (true) { - let args = _args; - let f = _f; - let init_arity = f.length; - let arity = init_arity === 0 ? 1 : init_arity; - let len = args.length; - let d = arity - len | 0; - if (d === 0) { - return f.apply(null, args); - } - if (d >= 0) { - return x => app(f, args.concat([x])); - } - _args = args.slice(arity, len); - _f = f.apply(null, args.slice(0, arity)); - continue; - }; -} - -function __1(o) { - let arity = o.length; - if (arity === 1) { - return o; - } else { - return a0 => { - let arity = o.length; - if (arity === 1) { - return o(a0); - } else { - switch (arity) { - case 1 : - return o(a0); - case 2 : - return param => o(a0, param); - case 3 : - return (param, param$1) => o(a0, param, param$1); - case 4 : - return (param, param$1, param$2) => o(a0, param, param$1, param$2); - case 5 : - return (param, param$1, param$2, param$3) => o(a0, param, param$1, param$2, param$3); - case 6 : - return (param, param$1, param$2, param$3, param$4) => o(a0, param, param$1, param$2, param$3, param$4); - case 7 : - return (param, param$1, param$2, param$3, param$4, param$5) => o(a0, param, param$1, param$2, param$3, param$4, param$5); - default: - return app(o, [a0]); - } - } - }; - } -} - -function __2(o) { - let arity = o.length; - if (arity === 2) { - return o; - } else { - return (a0, a1) => { - let arity = o.length; - if (arity === 2) { - return o(a0, a1); - } else { - switch (arity) { - case 1 : - return app(o(a0), [a1]); - case 2 : - return o(a0, a1); - case 3 : - return param => o(a0, a1, param); - case 4 : - return (param, param$1) => o(a0, a1, param, param$1); - case 5 : - return (param, param$1, param$2) => o(a0, a1, param, param$1, param$2); - case 6 : - return (param, param$1, param$2, param$3) => o(a0, a1, param, param$1, param$2, param$3); - case 7 : - return (param, param$1, param$2, param$3, param$4) => o(a0, a1, param, param$1, param$2, param$3, param$4); - default: - return app(o, [ - a0, - a1 - ]); - } - } - }; - } -} - -function __3(o) { - let arity = o.length; - if (arity === 3) { - return o; - } else { - return (a0, a1, a2) => { - let arity = o.length; - if (arity === 3) { - return o(a0, a1, a2); - } else { - switch (arity) { - case 1 : - return app(o(a0), [ - a1, - a2 - ]); - case 2 : - return app(o(a0, a1), [a2]); - case 3 : - return o(a0, a1, a2); - case 4 : - return param => o(a0, a1, a2, param); - case 5 : - return (param, param$1) => o(a0, a1, a2, param, param$1); - case 6 : - return (param, param$1, param$2) => o(a0, a1, a2, param, param$1, param$2); - case 7 : - return (param, param$1, param$2, param$3) => o(a0, a1, a2, param, param$1, param$2, param$3); - default: - return app(o, [ - a0, - a1, - a2 - ]); - } - } - }; - } -} - -function __4(o) { - let arity = o.length; - if (arity === 4) { - return o; - } else { - return (a0, a1, a2, a3) => { - let arity = o.length; - if (arity === 4) { - return o(a0, a1, a2, a3); - } else { - switch (arity) { - case 1 : - return app(o(a0), [ - a1, - a2, - a3 - ]); - case 2 : - return app(o(a0, a1), [ - a2, - a3 - ]); - case 3 : - return app(o(a0, a1, a2), [a3]); - case 4 : - return o(a0, a1, a2, a3); - case 5 : - return param => o(a0, a1, a2, a3, param); - case 6 : - return (param, param$1) => o(a0, a1, a2, a3, param, param$1); - case 7 : - return (param, param$1, param$2) => o(a0, a1, a2, a3, param, param$1, param$2); - default: - return app(o, [ - a0, - a1, - a2, - a3 - ]); - } - } - }; - } -} - -function __5(o) { - let arity = o.length; - if (arity === 5) { - return o; - } else { - return (a0, a1, a2, a3, a4) => { - let arity = o.length; - if (arity === 5) { - return o(a0, a1, a2, a3, a4); - } else { - switch (arity) { - case 1 : - return app(o(a0), [ - a1, - a2, - a3, - a4 - ]); - case 2 : - return app(o(a0, a1), [ - a2, - a3, - a4 - ]); - case 3 : - return app(o(a0, a1, a2), [ - a3, - a4 - ]); - case 4 : - return app(o(a0, a1, a2, a3), [a4]); - case 5 : - return o(a0, a1, a2, a3, a4); - case 6 : - return param => o(a0, a1, a2, a3, a4, param); - case 7 : - return (param, param$1) => o(a0, a1, a2, a3, a4, param, param$1); - default: - return app(o, [ - a0, - a1, - a2, - a3, - a4 - ]); - } - } - }; - } -} - -function __6(o) { - let arity = o.length; - if (arity === 6) { - return o; - } else { - return (a0, a1, a2, a3, a4, a5) => { - let arity = o.length; - if (arity === 6) { - return o(a0, a1, a2, a3, a4, a5); - } else { - switch (arity) { - case 1 : - return app(o(a0), [ - a1, - a2, - a3, - a4, - a5 - ]); - case 2 : - return app(o(a0, a1), [ - a2, - a3, - a4, - a5 - ]); - case 3 : - return app(o(a0, a1, a2), [ - a3, - a4, - a5 - ]); - case 4 : - return app(o(a0, a1, a2, a3), [ - a4, - a5 - ]); - case 5 : - return app(o(a0, a1, a2, a3, a4), [a5]); - case 6 : - return o(a0, a1, a2, a3, a4, a5); - case 7 : - return param => o(a0, a1, a2, a3, a4, a5, param); - default: - return app(o, [ - a0, - a1, - a2, - a3, - a4, - a5 - ]); - } - } - }; - } -} - -function __7(o) { - let arity = o.length; - if (arity === 7) { - return o; - } else { - return (a0, a1, a2, a3, a4, a5, a6) => { - let arity = o.length; - if (arity === 7) { - return o(a0, a1, a2, a3, a4, a5, a6); - } else { - switch (arity) { - case 1 : - return app(o(a0), [ - a1, - a2, - a3, - a4, - a5, - a6 - ]); - case 2 : - return app(o(a0, a1), [ - a2, - a3, - a4, - a5, - a6 - ]); - case 3 : - return app(o(a0, a1, a2), [ - a3, - a4, - a5, - a6 - ]); - case 4 : - return app(o(a0, a1, a2, a3), [ - a4, - a5, - a6 - ]); - case 5 : - return app(o(a0, a1, a2, a3, a4), [ - a5, - a6 - ]); - case 6 : - return app(o(a0, a1, a2, a3, a4, a5), [a6]); - case 7 : - return o(a0, a1, a2, a3, a4, a5, a6); - default: - return app(o, [ - a0, - a1, - a2, - a3, - a4, - a5, - a6 - ]); - } - } - }; - } -} - -function __8(o) { - let arity = o.length; - if (arity === 8) { - return o; - } else { - return (a0, a1, a2, a3, a4, a5, a6, a7) => { - let arity = o.length; - if (arity === 8) { - return o(a0, a1, a2, a3, a4, a5, a6, a7); - } else { - switch (arity) { - case 1 : - return app(o(a0), [ - a1, - a2, - a3, - a4, - a5, - a6, - a7 - ]); - case 2 : - return app(o(a0, a1), [ - a2, - a3, - a4, - a5, - a6, - a7 - ]); - case 3 : - return app(o(a0, a1, a2), [ - a3, - a4, - a5, - a6, - a7 - ]); - case 4 : - return app(o(a0, a1, a2, a3), [ - a4, - a5, - a6, - a7 - ]); - case 5 : - return app(o(a0, a1, a2, a3, a4), [ - a5, - a6, - a7 - ]); - case 6 : - return app(o(a0, a1, a2, a3, a4, a5), [ - a6, - a7 - ]); - case 7 : - return app(o(a0, a1, a2, a3, a4, a5, a6), [a7]); - default: - return app(o, [ - a0, - a1, - a2, - a3, - a4, - a5, - a6, - a7 - ]); - } - } - }; - } -} - -export { - __1, - __2, - __3, - __4, - __5, - __6, - __7, - __8, -} -/* No side effect */ diff --git a/packages/@rescript/runtime/lib/js/Primitive_curry.cjs b/packages/@rescript/runtime/lib/js/Primitive_curry.cjs deleted file mode 100644 index 755967faf1e..00000000000 --- a/packages/@rescript/runtime/lib/js/Primitive_curry.cjs +++ /dev/null @@ -1,436 +0,0 @@ -'use strict'; - - -function app(_f, _args) { - while (true) { - let args = _args; - let f = _f; - let init_arity = f.length; - let arity = init_arity === 0 ? 1 : init_arity; - let len = args.length; - let d = arity - len | 0; - if (d === 0) { - return f.apply(null, args); - } - if (d >= 0) { - return x => app(f, args.concat([x])); - } - _args = args.slice(arity, len); - _f = f.apply(null, args.slice(0, arity)); - continue; - }; -} - -function __1(o) { - let arity = o.length; - if (arity === 1) { - return o; - } else { - return a0 => { - let arity = o.length; - if (arity === 1) { - return o(a0); - } else { - switch (arity) { - case 1 : - return o(a0); - case 2 : - return param => o(a0, param); - case 3 : - return (param, param$1) => o(a0, param, param$1); - case 4 : - return (param, param$1, param$2) => o(a0, param, param$1, param$2); - case 5 : - return (param, param$1, param$2, param$3) => o(a0, param, param$1, param$2, param$3); - case 6 : - return (param, param$1, param$2, param$3, param$4) => o(a0, param, param$1, param$2, param$3, param$4); - case 7 : - return (param, param$1, param$2, param$3, param$4, param$5) => o(a0, param, param$1, param$2, param$3, param$4, param$5); - default: - return app(o, [a0]); - } - } - }; - } -} - -function __2(o) { - let arity = o.length; - if (arity === 2) { - return o; - } else { - return (a0, a1) => { - let arity = o.length; - if (arity === 2) { - return o(a0, a1); - } else { - switch (arity) { - case 1 : - return app(o(a0), [a1]); - case 2 : - return o(a0, a1); - case 3 : - return param => o(a0, a1, param); - case 4 : - return (param, param$1) => o(a0, a1, param, param$1); - case 5 : - return (param, param$1, param$2) => o(a0, a1, param, param$1, param$2); - case 6 : - return (param, param$1, param$2, param$3) => o(a0, a1, param, param$1, param$2, param$3); - case 7 : - return (param, param$1, param$2, param$3, param$4) => o(a0, a1, param, param$1, param$2, param$3, param$4); - default: - return app(o, [ - a0, - a1 - ]); - } - } - }; - } -} - -function __3(o) { - let arity = o.length; - if (arity === 3) { - return o; - } else { - return (a0, a1, a2) => { - let arity = o.length; - if (arity === 3) { - return o(a0, a1, a2); - } else { - switch (arity) { - case 1 : - return app(o(a0), [ - a1, - a2 - ]); - case 2 : - return app(o(a0, a1), [a2]); - case 3 : - return o(a0, a1, a2); - case 4 : - return param => o(a0, a1, a2, param); - case 5 : - return (param, param$1) => o(a0, a1, a2, param, param$1); - case 6 : - return (param, param$1, param$2) => o(a0, a1, a2, param, param$1, param$2); - case 7 : - return (param, param$1, param$2, param$3) => o(a0, a1, a2, param, param$1, param$2, param$3); - default: - return app(o, [ - a0, - a1, - a2 - ]); - } - } - }; - } -} - -function __4(o) { - let arity = o.length; - if (arity === 4) { - return o; - } else { - return (a0, a1, a2, a3) => { - let arity = o.length; - if (arity === 4) { - return o(a0, a1, a2, a3); - } else { - switch (arity) { - case 1 : - return app(o(a0), [ - a1, - a2, - a3 - ]); - case 2 : - return app(o(a0, a1), [ - a2, - a3 - ]); - case 3 : - return app(o(a0, a1, a2), [a3]); - case 4 : - return o(a0, a1, a2, a3); - case 5 : - return param => o(a0, a1, a2, a3, param); - case 6 : - return (param, param$1) => o(a0, a1, a2, a3, param, param$1); - case 7 : - return (param, param$1, param$2) => o(a0, a1, a2, a3, param, param$1, param$2); - default: - return app(o, [ - a0, - a1, - a2, - a3 - ]); - } - } - }; - } -} - -function __5(o) { - let arity = o.length; - if (arity === 5) { - return o; - } else { - return (a0, a1, a2, a3, a4) => { - let arity = o.length; - if (arity === 5) { - return o(a0, a1, a2, a3, a4); - } else { - switch (arity) { - case 1 : - return app(o(a0), [ - a1, - a2, - a3, - a4 - ]); - case 2 : - return app(o(a0, a1), [ - a2, - a3, - a4 - ]); - case 3 : - return app(o(a0, a1, a2), [ - a3, - a4 - ]); - case 4 : - return app(o(a0, a1, a2, a3), [a4]); - case 5 : - return o(a0, a1, a2, a3, a4); - case 6 : - return param => o(a0, a1, a2, a3, a4, param); - case 7 : - return (param, param$1) => o(a0, a1, a2, a3, a4, param, param$1); - default: - return app(o, [ - a0, - a1, - a2, - a3, - a4 - ]); - } - } - }; - } -} - -function __6(o) { - let arity = o.length; - if (arity === 6) { - return o; - } else { - return (a0, a1, a2, a3, a4, a5) => { - let arity = o.length; - if (arity === 6) { - return o(a0, a1, a2, a3, a4, a5); - } else { - switch (arity) { - case 1 : - return app(o(a0), [ - a1, - a2, - a3, - a4, - a5 - ]); - case 2 : - return app(o(a0, a1), [ - a2, - a3, - a4, - a5 - ]); - case 3 : - return app(o(a0, a1, a2), [ - a3, - a4, - a5 - ]); - case 4 : - return app(o(a0, a1, a2, a3), [ - a4, - a5 - ]); - case 5 : - return app(o(a0, a1, a2, a3, a4), [a5]); - case 6 : - return o(a0, a1, a2, a3, a4, a5); - case 7 : - return param => o(a0, a1, a2, a3, a4, a5, param); - default: - return app(o, [ - a0, - a1, - a2, - a3, - a4, - a5 - ]); - } - } - }; - } -} - -function __7(o) { - let arity = o.length; - if (arity === 7) { - return o; - } else { - return (a0, a1, a2, a3, a4, a5, a6) => { - let arity = o.length; - if (arity === 7) { - return o(a0, a1, a2, a3, a4, a5, a6); - } else { - switch (arity) { - case 1 : - return app(o(a0), [ - a1, - a2, - a3, - a4, - a5, - a6 - ]); - case 2 : - return app(o(a0, a1), [ - a2, - a3, - a4, - a5, - a6 - ]); - case 3 : - return app(o(a0, a1, a2), [ - a3, - a4, - a5, - a6 - ]); - case 4 : - return app(o(a0, a1, a2, a3), [ - a4, - a5, - a6 - ]); - case 5 : - return app(o(a0, a1, a2, a3, a4), [ - a5, - a6 - ]); - case 6 : - return app(o(a0, a1, a2, a3, a4, a5), [a6]); - case 7 : - return o(a0, a1, a2, a3, a4, a5, a6); - default: - return app(o, [ - a0, - a1, - a2, - a3, - a4, - a5, - a6 - ]); - } - } - }; - } -} - -function __8(o) { - let arity = o.length; - if (arity === 8) { - return o; - } else { - return (a0, a1, a2, a3, a4, a5, a6, a7) => { - let arity = o.length; - if (arity === 8) { - return o(a0, a1, a2, a3, a4, a5, a6, a7); - } else { - switch (arity) { - case 1 : - return app(o(a0), [ - a1, - a2, - a3, - a4, - a5, - a6, - a7 - ]); - case 2 : - return app(o(a0, a1), [ - a2, - a3, - a4, - a5, - a6, - a7 - ]); - case 3 : - return app(o(a0, a1, a2), [ - a3, - a4, - a5, - a6, - a7 - ]); - case 4 : - return app(o(a0, a1, a2, a3), [ - a4, - a5, - a6, - a7 - ]); - case 5 : - return app(o(a0, a1, a2, a3, a4), [ - a5, - a6, - a7 - ]); - case 6 : - return app(o(a0, a1, a2, a3, a4, a5), [ - a6, - a7 - ]); - case 7 : - return app(o(a0, a1, a2, a3, a4, a5, a6), [a7]); - default: - return app(o, [ - a0, - a1, - a2, - a3, - a4, - a5, - a6, - a7 - ]); - } - } - }; - } -} - -exports.__1 = __1; -exports.__2 = __2; -exports.__3 = __3; -exports.__4 = __4; -exports.__5 = __5; -exports.__6 = __6; -exports.__7 = __7; -exports.__8 = __8; -/* No side effect */ diff --git a/packages/artifacts.json b/packages/artifacts.json index 074d94e85cd..58a471db3dd 100644 --- a/packages/artifacts.json +++ b/packages/artifacts.json @@ -288,12 +288,6 @@ "lib/ocaml/Primitive_char_extern.cmj", "lib/ocaml/Primitive_char_extern.cmt", "lib/ocaml/Primitive_char_extern.res", - "lib/ocaml/Primitive_curry.cmi", - "lib/ocaml/Primitive_curry.cmj", - "lib/ocaml/Primitive_curry.cmt", - "lib/ocaml/Primitive_curry.cmti", - "lib/ocaml/Primitive_curry.res", - "lib/ocaml/Primitive_curry.resi", "lib/ocaml/Primitive_dict.cmi", "lib/ocaml/Primitive_dict.cmj", "lib/ocaml/Primitive_dict.cmt", diff --git a/tests/ERROR_VARIANTS.md b/tests/ERROR_VARIANTS.md index 0c57b4748de..4d681bf6db1 100644 --- a/tests/ERROR_VARIANTS.md +++ b/tests/ERROR_VARIANTS.md @@ -240,6 +240,7 @@ Source: [typecore.ml:27](../compiler/ml/typecore.ml). | `Break_outside_loop` | ✓ | `break_outside_loop.res`, `break_in_nested_function.res` | | | `Continue_outside_loop` | ✓ | `continue_outside_loop.res`, `continue_in_nested_function.res` | | | `Literal_overflow` | ✓ | `intoverflow.res` | | +| `Polyvar_literal_overflow` | ✓ | `polyvar_int_overflow.res`, `polyvar_int_overflow_payload.res`, `polyvar_int_overflow_pattern.res` | | | `Unknown_literal` | ✓ | `unknown_literal.res` | | | `Illegal_letrec_pat` | ✓ | `illegal_letrec_pat.res` | | | `Empty_record_literal` | ✓ | `empty_record_literal.res` | | diff --git a/tests/build_tests/super_errors/expected/polyvar_int_overflow.res.expected b/tests/build_tests/super_errors/expected/polyvar_int_overflow.res.expected new file mode 100644 index 00000000000..1b426d85bc7 --- /dev/null +++ b/tests/build_tests/super_errors/expected/polyvar_int_overflow.res.expected @@ -0,0 +1,8 @@ + + We've found a bug for you! + /.../fixtures/polyvar_int_overflow.res:1:9-20 + + 1 │ let x = #99999999999 + 2 │ + + Integer literal exceeds int32 range. Use float or BigInt if larger values are required. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/polyvar_int_overflow_pattern.res.expected b/tests/build_tests/super_errors/expected/polyvar_int_overflow_pattern.res.expected new file mode 100644 index 00000000000..e1e0edd2d80 --- /dev/null +++ b/tests/build_tests/super_errors/expected/polyvar_int_overflow_pattern.res.expected @@ -0,0 +1,11 @@ + + We've found a bug for you! + /.../fixtures/polyvar_int_overflow_pattern.res:3:5-16 + + 1 │ let f = x => + 2 │ switch x { + 3 │ | #99999999999 => 1 + 4 │ | _ => 2 + 5 │ } + + Integer literal exceeds int32 range. Use float or BigInt if larger values are required. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/polyvar_int_overflow_payload.res.expected b/tests/build_tests/super_errors/expected/polyvar_int_overflow_payload.res.expected new file mode 100644 index 00000000000..7f2e11b90c8 --- /dev/null +++ b/tests/build_tests/super_errors/expected/polyvar_int_overflow_payload.res.expected @@ -0,0 +1,8 @@ + + We've found a bug for you! + /.../fixtures/polyvar_int_overflow_payload.res:1:9-25 + + 1 │ let x = #99999999999("a") + 2 │ + + Integer literal exceeds int32 range. Use float or BigInt if larger values are required. \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/polyvar_int_overflow.res b/tests/build_tests/super_errors/fixtures/polyvar_int_overflow.res new file mode 100644 index 00000000000..5f94eb66db7 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/polyvar_int_overflow.res @@ -0,0 +1 @@ +let x = #99999999999 diff --git a/tests/build_tests/super_errors/fixtures/polyvar_int_overflow_pattern.res b/tests/build_tests/super_errors/fixtures/polyvar_int_overflow_pattern.res new file mode 100644 index 00000000000..86bab872d3d --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/polyvar_int_overflow_pattern.res @@ -0,0 +1,5 @@ +let f = x => + switch x { + | #99999999999 => 1 + | _ => 2 + } diff --git a/tests/build_tests/super_errors/fixtures/polyvar_int_overflow_payload.res b/tests/build_tests/super_errors/fixtures/polyvar_int_overflow_payload.res new file mode 100644 index 00000000000..4473ed610fe --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/polyvar_int_overflow_payload.res @@ -0,0 +1 @@ +let x = #99999999999("a") diff --git a/tests/gentype_tests/typescript-react-example/src/Records.res.js b/tests/gentype_tests/typescript-react-example/src/Records.res.js index cc58487d4db..bd78028a8ff 100644 --- a/tests/gentype_tests/typescript-react-example/src/Records.res.js +++ b/tests/gentype_tests/typescript-react-example/src/Records.res.js @@ -69,16 +69,6 @@ function findAddress2(business) { })); } -let someBusiness2_owner = null; - -let someBusiness2_address2 = null; - -let someBusiness2 = { - name: "SomeBusiness", - owner: someBusiness2_owner, - address2: someBusiness2_address2 -}; - function computeArea3(o) { return (o.x * o.y | 0) * Belt_Option.mapWithDefault(Primitive_option.fromNullable(o.z), 1, n => n) | 0; } @@ -130,6 +120,12 @@ let someBusiness = { address: undefined }; +let someBusiness2 = { + name: "SomeBusiness", + owner: null, + address2: null +}; + export { origin, computeArea, diff --git a/tests/ounit_tests/ounit_js_analyzer_tests.ml b/tests/ounit_tests/ounit_js_analyzer_tests.ml index c28e17eb6c4..47e885e23fa 100644 --- a/tests/ounit_tests/ounit_js_analyzer_tests.ml +++ b/tests/ounit_tests/ounit_js_analyzer_tests.ml @@ -30,7 +30,7 @@ let for_await_of_statement = } let record_rest_statement ~source ~field ~rest = - Js_stmt_make.define_variable ~kind:Lam_compat.Strict rest + Js_stmt_make.define_variable ~kind:Lambda.Strict rest (record_rest_expression source field) let function_expression param body = @@ -56,7 +56,7 @@ let transform_expression expression = Js_pass_record_rest.program { J.block = - [Js_stmt_make.define_variable ~kind:Lam_compat.Strict fn expression]; + [Js_stmt_make.define_variable ~kind:Lambda.Strict fn expression]; exports = []; export_set = Set_ident.empty; } @@ -169,7 +169,7 @@ let suites = { J.block = [ - Js_stmt_make.define_variable ~kind:Lam_compat.Strict rest + Js_stmt_make.define_variable ~kind:Lambda.Strict rest (Js_exp_make.record_rest [ { diff --git a/tests/tests/src/demo_page.mjs b/tests/tests/src/demo_page.mjs index cacf467d0b9..7f49edcbe43 100644 --- a/tests/tests/src/demo_page.mjs +++ b/tests/tests/src/demo_page.mjs @@ -4,7 +4,7 @@ import * as React from "react"; import * as ReactDom from "react-dom"; function fib(x) { - if (x !== 2 && x !== 1) { + if (x !== 1 && x !== 2) { return fib(x - 1 | 0) + fib(x - 2 | 0) | 0; } else { return 1; diff --git a/tests/tests/src/gpr_1762_test.mjs b/tests/tests/src/gpr_1762_test.mjs index e276e2a5618..776e266c272 100644 --- a/tests/tests/src/gpr_1762_test.mjs +++ b/tests/tests/src/gpr_1762_test.mjs @@ -12,7 +12,7 @@ function update() { return true; } -v.contents = v.contents + 1 | 0; +update(); Mocha.describe("Gpr_1762_test", () => { Mocha.test("gpr_1762 ref increment test", () => Test_utils.eq("File \"gpr_1762_test.res\", line 21, characters 7-14", v.contents, 4)); diff --git a/tests/tests/src/gpr_3877_test.mjs b/tests/tests/src/gpr_3877_test.mjs index 2c16b2d958e..af886e0d791 100644 --- a/tests/tests/src/gpr_3877_test.mjs +++ b/tests/tests/src/gpr_3877_test.mjs @@ -3,7 +3,7 @@ function test(code) { if (code > 599 || code < 500) { - if (code !== 201 && code !== 200) { + if (code !== 200 && code !== 201) { return "the catch all"; } else { return "good response"; diff --git a/tests/tests/src/mario_game.mjs b/tests/tests/src/mario_game.mjs index 961add01bb8..43abdd9c486 100644 --- a/tests/tests/src/mario_game.mjs +++ b/tests/tests/src/mario_game.mjs @@ -1878,58 +1878,42 @@ function process_collision(dir, c1, c2, state) { } if (exit$4 === 4) { let exit$5 = 0; - let typ$2; switch (t1) { case "GKoopaShell" : - if (typeof t2$3 !== "object") { - if (t2$3 === "Brick") { - dec_health(o2$6); - reverse_left_right(o1$4); - return [ - undefined, - undefined - ]; - } - exit$5 = 5; - } else { - typ$2 = t2$3._0; - exit$5 = 6; - } - break; case "RKoopaShell" : - if (typeof t2$3 !== "object") { - if (t2$3 === "Brick") { - dec_health(o2$6); - reverse_left_right(o1$4); - return [ - undefined, - undefined - ]; - } - exit$5 = 5; - } else { - typ$2 = t2$3._0; - exit$5 = 6; - } + exit$5 = 5; break; default: - exit$5 = 5; + rev_dir(o1$4, t1, s1$3); + return [ + undefined, + undefined + ]; } - switch (exit$5) { - case 5 : + if (exit$5 === 5) { + if (typeof t2$3 !== "object") { + if (t2$3 === "Brick") { + dec_health(o2$6); + reverse_left_right(o1$4); + return [ + undefined, + undefined + ]; + } rev_dir(o1$4, t1, s1$3); return [ undefined, undefined ]; - case 6 : + } else { let updated_block$1 = evolve_block(o2$6, context); - let spawned_item$1 = spawn_above(o1$4.dir, o2$6, typ$2, context); + let spawned_item$1 = spawn_above(o1$4.dir, o2$6, t2$3._0, context); rev_dir(o1$4, t1, s1$3); return [ updated_block$1, spawned_item$1 ]; + } } } break; diff --git a/tests/tests/src/option_repr_test.mjs b/tests/tests/src/option_repr_test.mjs index 5ef9b6b614c..02ae0cb4304 100644 --- a/tests/tests/src/option_repr_test.mjs +++ b/tests/tests/src/option_repr_test.mjs @@ -151,14 +151,10 @@ Mocha.describe("Option_repr_test", () => { Test_utils.ok("File \"option_repr_test.res\", line 120, characters 7-14", Primitive_object.lessthan(undefined, Primitive_option.some(undefined))); Test_utils.ok("File \"option_repr_test.res\", line 121, characters 7-14", Primitive_object.greaterthan(Primitive_option.some(undefined), undefined)); }); - Mocha.test("option greater than operations", () => { - let xs_0 = gtx(Primitive_option.some(null), Primitive_option.some(undefined)); - let xs = { - hd: xs_0, - tl: /* [] */0 - }; - Test_utils.ok("File \"option_repr_test.res\", line 125, characters 7-14", Stdlib_List.every(xs, x => x)); - }); + Mocha.test("option greater than operations", () => Test_utils.ok("File \"option_repr_test.res\", line 125, characters 7-14", Stdlib_List.every({ + hd: Primitive_object.greaterthan(null, Primitive_option.some(undefined)) && Primitive_object.lessthan(Primitive_option.some(undefined), null), + tl: /* [] */0 + }, x => x))); Mocha.test("option less than operations", () => { let xs_0 = Primitive_object.lessthan(Primitive_option.some(undefined), 3) && Primitive_object.greaterthan(3, Primitive_option.some(undefined)); let xs_1 = { @@ -176,11 +172,11 @@ Mocha.describe("Option_repr_test", () => { tl: { hd: Primitive_object.lessthan(undefined, Primitive_option.some(undefined)) && Primitive_object.greaterthan(Primitive_option.some(undefined), undefined), tl: { - hd: ltx(undefined, null), + hd: Primitive_object.lessthan(undefined, null) && Primitive_object.greaterthan(null, undefined), tl: { hd: ltx(undefined, x => x), tl: { - hd: ltx(null, 3), + hd: Primitive_object.lessthan(null, 3) && Primitive_object.greaterthan(3, null), tl: /* [] */0 } } @@ -198,9 +194,10 @@ Mocha.describe("Option_repr_test", () => { }; Test_utils.ok("File \"option_repr_test.res\", line 130, characters 6-13", Stdlib_List.every(xs, x => x)); }); - Mocha.test("option equality operations", () => { - let xs_1 = { - hd: neqx(undefined, null), + Mocha.test("option equality operations", () => Test_utils.ok("File \"option_repr_test.res\", line 149, characters 6-13", Stdlib_List.every({ + hd: true, + tl: { + hd: undefined !== null && null !== undefined, tl: { hd: Primitive_object.equal(Primitive_option.some(undefined), Primitive_option.some(undefined)) && Primitive_object.equal(Primitive_option.some(undefined), Primitive_option.some(undefined)), tl: { @@ -211,13 +208,8 @@ Mocha.describe("Option_repr_test", () => { } } } - }; - let xs = { - hd: true, - tl: xs_1 - }; - Test_utils.ok("File \"option_repr_test.res\", line 149, characters 6-13", Stdlib_List.every(xs, x => x)); - }); + } + }, x => x))); }); let f7; diff --git a/tests/tests/src/option_wrapping_test.mjs b/tests/tests/src/option_wrapping_test.mjs index 9b6e41bc759..1f008f8ad27 100644 --- a/tests/tests/src/option_wrapping_test.mjs +++ b/tests/tests/src/option_wrapping_test.mjs @@ -16,10 +16,6 @@ let x7 = [ let x8 = () => {}; -let x10 = null; - -let x11 = Primitive_option.some(undefined); - let x20 = null; let x21 = new Date(); @@ -89,6 +85,10 @@ let x5 = { x: 42 }; +let x10 = null; + +let x11 = Primitive_option.some(undefined); + let x12 = "test"; let x39 = true; diff --git a/tests/tests/src/rec_module_test.mjs b/tests/tests/src/rec_module_test.mjs index 38f42a7db05..05c2bf00924 100644 --- a/tests/tests/src/rec_module_test.mjs +++ b/tests/tests/src/rec_module_test.mjs @@ -92,6 +92,27 @@ Mocha.describe("Rec_module_test", () => { Mocha.test("test5", () => Test_utils.eq("File \"rec_module_test.res\", line 91, characters 7-14", false, B.odd(2))); }); +let effects = { + contents: /* [] */0 +}; + +function record(s) { + effects.contents = { + hd: s, + tl: effects.contents + }; +} + +record("with field"); + +let WithField = { + n: 1 +}; + +record("empty signature"); + +let EmptySig; + export { A, B, @@ -99,5 +120,9 @@ export { BB, Even, Odd, + effects, + record, + EmptySig, + WithField, } /* Not a pure module */ diff --git a/tests/tests/src/rec_module_test.res b/tests/tests/src/rec_module_test.res index 25ab6595dc3..4480d06444a 100644 --- a/tests/tests/src/rec_module_test.res +++ b/tests/tests/src/rec_module_test.res @@ -91,3 +91,20 @@ describe(__MODULE__, () => { eq(__LOC__, false, B.odd(2)) }) }) + +/* A recursive module whose signature has no fields still has to run its right + hand side: the shape is empty, so no runtime dummy is created and nothing is + patched, but the effects must survive. Both calls below have to appear in the + generated output. */ +let effects = ref(list{}) +let record = s => effects := list{s, ...effects.contents} + +module rec EmptySig: {} = { + let () = record("empty signature") +} +and WithField: { + let n: int +} = { + let () = record("with field") + let n = 1 +} diff --git a/tests/tests/src/test_demo.mjs b/tests/tests/src/test_demo.mjs index b622586bcdb..6b82fc3bd55 100644 --- a/tests/tests/src/test_demo.mjs +++ b/tests/tests/src/test_demo.mjs @@ -3,7 +3,7 @@ import * as Stdlib_List from "@rescript/runtime/lib/es6/Stdlib_List.mjs"; function fib(x) { - if (x !== 2 && x !== 1) { + if (x !== 1 && x !== 2) { return fib(x - 1 | 0) + fib(x - 2 | 0) | 0; } else { return 1; diff --git a/tests/tests/src/test_fib.mjs b/tests/tests/src/test_fib.mjs index 4e488a8269b..ff50381b3a5 100644 --- a/tests/tests/src/test_fib.mjs +++ b/tests/tests/src/test_fib.mjs @@ -10,7 +10,7 @@ function fib(x) { } function fib2(x) { - if (x !== 2 && x !== 1) { + if (x !== 1 && x !== 2) { return fib2(x - 1 | 0) + fib2(x - 2 | 0) | 0; } else { return 1; diff --git a/tests/tests/src/test_incr_ref.mjs b/tests/tests/src/test_incr_ref.mjs index 6e22f1919fb..f5a7945013f 100644 --- a/tests/tests/src/test_incr_ref.mjs +++ b/tests/tests/src/test_incr_ref.mjs @@ -7,7 +7,13 @@ u = u + 1 | 0; let v; +function onExpression() { + let ref = mkRef(); + ref.contents = ref.contents + 1 | 0; +} + export { v, + onExpression, } /* v Not a pure module */ diff --git a/tests/tests/src/test_incr_ref.res b/tests/tests/src/test_incr_ref.res index 8605ac49a15..34485d403dd 100644 --- a/tests/tests/src/test_incr_ref.res +++ b/tests/tests/src/test_incr_ref.res @@ -6,3 +6,9 @@ include ( let v: unit } ) + +/* The reference is an expression, not a variable, so it has to be bound: it + must be evaluated once, not once per mention. */ +@val external mkRef: unit => ref = "mkRef" + +let onExpression = () => Int.Ref.increment(mkRef()) diff --git a/tests/tests/src/test_per.res b/tests/tests/src/test_per.res index da968bff30a..835873593ea 100644 --- a/tests/tests/src/test_per.res +++ b/tests/tests/src/test_per.res @@ -57,8 +57,6 @@ external \"||": (bool, bool) => bool = "%sequor" external \"~-": int => int = "%negint" external \"~+": int => int = "%identity" -external succ: int => int = "%succint" -external pred: int => int = "%predint" external \"+": (int, int) => int = "%addint" external \"-": (int, int) => int = "%subint" external \"*": (int, int) => int = "%mulint"