From 6180ef654425decf0e3c36ea58451ba198eb32fa Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Fri, 28 Aug 2020 20:45:17 +0100 Subject: [PATCH 1/2] Symbol projections (#252) --- .depend | 131 +++++++-- Makefile | 3 +- flambdatest/mlexamples/int32.ml | 10 +- flambdatest/mlexamples/protect_refs.ml | 30 ++ flambdatest/mlexamples/symbol_projections.ml | 14 + flambdatest/mlexamples/symbol_projections2.ml | 12 + flambdatest/mlexamples/symbol_projections3.ml | 15 + flambdatest/mlexamples/symbol_projections4.ml | 21 ++ flambdatest/mlexamples/symbol_projections5.ml | 27 ++ flambdatest/mlexamples/symbol_projections6.ml | 27 ++ flambdatest/mlexamples/symbol_projections7.ml | 11 + middle_end/flambda/basic/mutability.ml | 5 + middle_end/flambda/basic/mutability.mli | 2 + middle_end/flambda/basic/simple.ml | 4 + middle_end/flambda/basic/simple.mli | 7 + .../compilenv_deps/reg_width_things.mli | 6 +- .../flambda/lifting/lift_inconstants.ml | 1 + middle_end/flambda/lifting/reification.ml | 30 +- .../flambda/lifting/sort_lifted_constants.ml | 6 +- .../flambda/simplify/env/simplify_envs.ml | 257 +++++++++++++++--- .../simplify/env/simplify_envs_intf.ml | 31 ++- .../simplify/simplify_binary_primitive.ml | 11 +- .../simplify/simplify_binary_primitive.mli | 3 +- .../flambda/simplify/simplify_common.ml | 169 +++++++++++- .../flambda/simplify/simplify_common.mli | 16 +- .../flambda/simplify/simplify_expr.rec.ml | 114 +++----- .../flambda/simplify/simplify_named.rec.ml | 174 ++++++++++-- .../flambda/simplify/simplify_primitive.mli | 3 +- .../simplify/simplify_set_of_closures.rec.ml | 73 +++-- .../simplify/simplify_ternary_primitive.ml | 6 +- .../simplify/simplify_ternary_primitive.mli | 3 +- .../simplify/simplify_unary_primitive.ml | 9 +- .../simplify/simplify_unary_primitive.mli | 3 +- .../simplify/simplify_variadic_primitive.ml | 10 +- .../simplify/simplify_variadic_primitive.mli | 3 +- .../flambda/terms/function_declarations.ml | 3 + .../flambda/terms/function_declarations.mli | 2 + middle_end/flambda/terms/symbol_projection.ml | 107 ++++++++ .../flambda/terms/symbol_projection.mli | 47 ++++ .../flambda/types/env/typing_env.rec.ml | 84 +++++- .../flambda/types/env/typing_env.rec.mli | 4 + .../flambda/types/env/typing_env_level.rec.ml | 122 +++++++-- .../types/env/typing_env_level.rec.mli | 4 + middle_end/flambda/types/flambda_type.mli | 5 + .../types/template/flambda_type.templ.ml | 11 +- utils/lmap.ml | 2 + utils/lmap.mli | 12 +- 47 files changed, 1374 insertions(+), 276 deletions(-) create mode 100644 flambdatest/mlexamples/protect_refs.ml create mode 100644 flambdatest/mlexamples/symbol_projections.ml create mode 100644 flambdatest/mlexamples/symbol_projections2.ml create mode 100644 flambdatest/mlexamples/symbol_projections3.ml create mode 100644 flambdatest/mlexamples/symbol_projections4.ml create mode 100644 flambdatest/mlexamples/symbol_projections5.ml create mode 100644 flambdatest/mlexamples/symbol_projections6.ml create mode 100644 flambdatest/mlexamples/symbol_projections7.ml create mode 100644 middle_end/flambda/terms/symbol_projection.ml create mode 100644 middle_end/flambda/terms/symbol_projection.mli diff --git a/.depend b/.depend index fbbaa09a7aaa..e27ed14c24e7 100644 --- a/.depend +++ b/.depend @@ -5199,35 +5199,29 @@ middle_end/flambda/inlining/inlining_transforms.cmi : \ middle_end/flambda/lifting/lift_inconstants.cmo : \ middle_end/flambda/compilenv_deps/variable.cmi \ middle_end/flambda/naming/var_in_binding_pos.cmi \ - lambda/tag.cmi \ middle_end/flambda/compilenv_deps/symbol.cmi \ middle_end/flambda/simplify/simplify_import.cmi \ middle_end/flambda/lifting/reification.cmi \ middle_end/flambda/compilenv_deps/linkage_name.cmi \ - middle_end/flambda/compilenv_deps/flambda_features.cmi \ middle_end/flambda/terms/flambda.cmi \ middle_end/flambda/compilenv_deps/compilation_unit.cmi \ middle_end/flambda/lifting/lift_inconstants.cmi middle_end/flambda/lifting/lift_inconstants.cmx : \ middle_end/flambda/compilenv_deps/variable.cmx \ middle_end/flambda/naming/var_in_binding_pos.cmx \ - lambda/tag.cmx \ middle_end/flambda/compilenv_deps/symbol.cmx \ middle_end/flambda/simplify/simplify_import.cmx \ middle_end/flambda/lifting/reification.cmx \ middle_end/flambda/compilenv_deps/linkage_name.cmx \ - middle_end/flambda/compilenv_deps/flambda_features.cmx \ middle_end/flambda/terms/flambda.cmx \ middle_end/flambda/compilenv_deps/compilation_unit.cmx \ middle_end/flambda/lifting/lift_inconstants.cmi middle_end/flambda/lifting/lift_inconstants.cmi : \ middle_end/flambda/naming/var_in_binding_pos.cmi \ middle_end/flambda/compilenv_deps/symbol.cmi \ - middle_end/flambda/basic/kinded_parameter.cmi \ middle_end/flambda/types/flambda_type.cmi \ middle_end/flambda/terms/flambda.cmi \ - middle_end/flambda/simplify/env/downwards_acc.cmi \ - middle_end/flambda/basic/continuation_extra_params_and_args.cmi + middle_end/flambda/simplify/env/downwards_acc.cmi middle_end/flambda/lifting/reification.cmo : \ middle_end/flambda/compilenv_deps/variable.cmi \ middle_end/flambda/naming/var_in_binding_pos.cmi \ @@ -5235,6 +5229,7 @@ middle_end/flambda/lifting/reification.cmo : \ middle_end/flambda/simplify/simplify_import.cmi \ middle_end/flambda/basic/simple.cmi \ middle_end/flambda/simplify/basic/reachable.cmi \ + middle_end/flambda/naming/name_occurrences.cmi \ middle_end/flambda/naming/name_mode.cmi \ middle_end/flambda/basic/mutability.cmi \ utils/misc.cmi \ @@ -5249,6 +5244,7 @@ middle_end/flambda/lifting/reification.cmx : \ middle_end/flambda/simplify/simplify_import.cmx \ middle_end/flambda/basic/simple.cmx \ middle_end/flambda/simplify/basic/reachable.cmx \ + middle_end/flambda/naming/name_occurrences.cmx \ middle_end/flambda/naming/name_mode.cmx \ middle_end/flambda/basic/mutability.cmx \ utils/misc.cmx \ @@ -5809,6 +5805,7 @@ middle_end/flambda/simplify/simplify.cmo : \ middle_end/flambda/compilenv_deps/target_imm.cmi \ lambda/tag.cmi \ middle_end/flambda/basic/symbol_scoping_rule.cmi \ + middle_end/flambda/terms/symbol_projection.cmi \ middle_end/flambda/compilenv_deps/symbol.cmi \ lambda/switch.cmi \ middle_end/flambda/lifting/sort_lifted_constants.cmi \ @@ -5833,7 +5830,6 @@ middle_end/flambda/simplify/simplify.cmo : \ utils/misc.cmi \ parsing/location.cmi \ middle_end/flambda/compilenv_deps/linkage_name.cmi \ - middle_end/flambda/lifting/lift_inconstants.cmi \ middle_end/flambda/basic/kinded_parameter.cmi \ middle_end/flambda/inlining/inlining_transforms.cmi \ middle_end/flambda/inlining/inlining_decision.cmi \ @@ -5875,6 +5871,7 @@ middle_end/flambda/simplify/simplify.cmx : \ middle_end/flambda/compilenv_deps/target_imm.cmx \ lambda/tag.cmx \ middle_end/flambda/basic/symbol_scoping_rule.cmx \ + middle_end/flambda/terms/symbol_projection.cmx \ middle_end/flambda/compilenv_deps/symbol.cmx \ lambda/switch.cmx \ middle_end/flambda/lifting/sort_lifted_constants.cmx \ @@ -5899,7 +5896,6 @@ middle_end/flambda/simplify/simplify.cmx : \ utils/misc.cmx \ parsing/location.cmx \ middle_end/flambda/compilenv_deps/linkage_name.cmx \ - middle_end/flambda/lifting/lift_inconstants.cmx \ middle_end/flambda/basic/kinded_parameter.cmx \ middle_end/flambda/inlining/inlining_transforms.cmx \ middle_end/flambda/inlining/inlining_decision.cmx \ @@ -5987,9 +5983,11 @@ middle_end/flambda/simplify/simplify_binary_primitive.cmi : \ middle_end/flambda/simplify/simplify_common.cmo : \ middle_end/flambda/compilenv_deps/variable.cmi \ middle_end/flambda/basic/var_within_closure.cmi \ + middle_end/flambda/naming/var_in_binding_pos.cmi \ utils/targetint.cmi \ lambda/tag.cmi \ middle_end/flambda/basic/symbol_scoping_rule.cmi \ + middle_end/flambda/terms/symbol_projection.cmi \ middle_end/flambda/simplify/simplify_import.cmi \ middle_end/flambda/basic/simple.cmi \ middle_end/flambda/terms/set_of_closures.cmi \ @@ -6015,9 +6013,11 @@ middle_end/flambda/simplify/simplify_common.cmo : \ middle_end/flambda/simplify/simplify_common.cmx : \ middle_end/flambda/compilenv_deps/variable.cmx \ middle_end/flambda/basic/var_within_closure.cmx \ + middle_end/flambda/naming/var_in_binding_pos.cmx \ utils/targetint.cmx \ lambda/tag.cmx \ middle_end/flambda/basic/symbol_scoping_rule.cmx \ + middle_end/flambda/terms/symbol_projection.cmx \ middle_end/flambda/simplify/simplify_import.cmx \ middle_end/flambda/basic/simple.cmx \ middle_end/flambda/terms/set_of_closures.cmx \ @@ -6048,6 +6048,7 @@ middle_end/flambda/simplify/simplify_common.cmi : \ middle_end/flambda/simplify/env/simplify_envs.cmi \ middle_end/flambda/basic/simple.cmi \ middle_end/flambda/simplify/basic/reachable.cmi \ + middle_end/flambda/naming/name_occurrences.cmi \ middle_end/flambda/naming/name_mode.cmi \ middle_end/flambda/types/flambda_type.cmi \ middle_end/flambda/terms/flambda_primitive.cmi \ @@ -6069,7 +6070,6 @@ middle_end/flambda/simplify/simplify_expr.rec.cmo : \ middle_end/flambda/unboxing/unbox_continuation_params.cmi \ middle_end/flambda/compilenv_deps/target_imm.cmi \ middle_end/flambda/basic/symbol_scoping_rule.cmi \ - middle_end/flambda/compilenv_deps/symbol.cmi \ lambda/switch.cmi \ middle_end/flambda/lifting/sort_lifted_constants.cmi \ middle_end/flambda/simplify/simplify_import.cmi \ @@ -6104,7 +6104,6 @@ middle_end/flambda/simplify/simplify_expr.rec.cmo : \ middle_end/flambda/basic/closure_id.cmi \ utils/clflags.cmi \ middle_end/flambda/terms/call_kind.cmi \ - middle_end/flambda/terms/bound_symbols.cmi \ middle_end/flambda/naming/bindable_let_bound.cmi \ middle_end/flambda/basic/apply_cont_rewrite_id.cmi \ middle_end/flambda/simplify/basic/apply_cont_rewrite.cmi \ @@ -6117,7 +6116,6 @@ middle_end/flambda/simplify/simplify_expr.rec.cmx : \ middle_end/flambda/unboxing/unbox_continuation_params.cmx \ middle_end/flambda/compilenv_deps/target_imm.cmx \ middle_end/flambda/basic/symbol_scoping_rule.cmx \ - middle_end/flambda/compilenv_deps/symbol.cmx \ lambda/switch.cmx \ middle_end/flambda/lifting/sort_lifted_constants.cmx \ middle_end/flambda/simplify/simplify_import.cmx \ @@ -6152,7 +6150,6 @@ middle_end/flambda/simplify/simplify_expr.rec.cmx : \ middle_end/flambda/basic/closure_id.cmx \ utils/clflags.cmx \ middle_end/flambda/terms/call_kind.cmx \ - middle_end/flambda/terms/bound_symbols.cmx \ middle_end/flambda/naming/bindable_let_bound.cmx \ middle_end/flambda/basic/apply_cont_rewrite_id.cmx \ middle_end/flambda/simplify/basic/apply_cont_rewrite.cmx \ @@ -6212,17 +6209,20 @@ middle_end/flambda/simplify/simplify_import.cmi : \ middle_end/flambda/basic/continuation_extra_params_and_args.cmi \ middle_end/flambda/basic/code_id_or_symbol.cmi middle_end/flambda/simplify/simplify_named.rec.cmo : \ + middle_end/flambda/compilenv_deps/variable.cmi \ middle_end/flambda/naming/var_in_binding_pos.cmi \ + middle_end/flambda/compilenv_deps/target_imm.cmi \ + middle_end/flambda/terms/symbol_projection.cmi \ middle_end/flambda/compilenv_deps/symbol.cmi \ middle_end/flambda/simplify/simplify_primitive.cmi \ middle_end/flambda/simplify/simplify_import.cmi \ middle_end/flambda/basic/simple.cmi \ middle_end/flambda/lifting/reification.cmi \ + middle_end/flambda/basic/reg_width_const.cmi \ middle_end/flambda/simplify/basic/reachable.cmi \ middle_end/flambda/naming/name_mode.cmi \ middle_end/flambda/basic/name.cmi \ utils/misc.cmi \ - middle_end/flambda/lifting/lift_inconstants.cmi \ middle_end/flambda/compilenv_deps/flambda_colours.cmi \ middle_end/flambda/simplify/env/downwards_acc.cmi \ middle_end/flambda/basic/closure_id.cmi \ @@ -6231,17 +6231,20 @@ middle_end/flambda/simplify/simplify_named.rec.cmo : \ middle_end/flambda/naming/bindable_let_bound.cmi \ middle_end/flambda/simplify/simplify_named.rec.cmi middle_end/flambda/simplify/simplify_named.rec.cmx : \ + middle_end/flambda/compilenv_deps/variable.cmx \ middle_end/flambda/naming/var_in_binding_pos.cmx \ + middle_end/flambda/compilenv_deps/target_imm.cmx \ + middle_end/flambda/terms/symbol_projection.cmx \ middle_end/flambda/compilenv_deps/symbol.cmx \ middle_end/flambda/simplify/simplify_primitive.cmx \ middle_end/flambda/simplify/simplify_import.cmx \ middle_end/flambda/basic/simple.cmx \ middle_end/flambda/lifting/reification.cmx \ + middle_end/flambda/basic/reg_width_const.cmx \ middle_end/flambda/simplify/basic/reachable.cmx \ middle_end/flambda/naming/name_mode.cmx \ middle_end/flambda/basic/name.cmx \ utils/misc.cmx \ - middle_end/flambda/lifting/lift_inconstants.cmx \ middle_end/flambda/compilenv_deps/flambda_colours.cmx \ middle_end/flambda/simplify/env/downwards_acc.cmx \ middle_end/flambda/basic/closure_id.cmx \ @@ -6250,7 +6253,6 @@ middle_end/flambda/simplify/simplify_named.rec.cmx : \ middle_end/flambda/naming/bindable_let_bound.cmx \ middle_end/flambda/simplify/simplify_named.rec.cmi middle_end/flambda/simplify/simplify_named.rec.cmi : \ - middle_end/flambda/compilenv_deps/symbol.cmi \ middle_end/flambda/simplify/basic/reachable.cmi \ middle_end/flambda/terms/flambda.cmi \ middle_end/flambda/simplify/env/downwards_acc.cmi \ @@ -6271,6 +6273,7 @@ middle_end/flambda/simplify/simplify_primitive.cmx : \ middle_end/flambda/simplify/simplify_primitive.cmi middle_end/flambda/simplify/simplify_primitive.cmi : \ middle_end/flambda/naming/var_in_binding_pos.cmi \ + middle_end/flambda/basic/simple.cmi \ middle_end/flambda/simplify/basic/reachable.cmi \ middle_end/flambda/types/flambda_type.cmi \ middle_end/flambda/terms/flambda_primitive.cmi \ @@ -6281,6 +6284,7 @@ middle_end/flambda/simplify/simplify_set_of_closures.rec.cmo : \ middle_end/flambda/compilenv_deps/variable.cmi \ middle_end/flambda/basic/var_within_closure.cmi \ middle_end/flambda/naming/var_in_binding_pos.cmi \ + middle_end/flambda/terms/symbol_projection.cmi \ middle_end/flambda/compilenv_deps/symbol.cmi \ middle_end/flambda/simplify/simplify_import.cmi \ middle_end/flambda/basic/simple.cmi \ @@ -6314,6 +6318,7 @@ middle_end/flambda/simplify/simplify_set_of_closures.rec.cmx : \ middle_end/flambda/compilenv_deps/variable.cmx \ middle_end/flambda/basic/var_within_closure.cmx \ middle_end/flambda/naming/var_in_binding_pos.cmx \ + middle_end/flambda/terms/symbol_projection.cmx \ middle_end/flambda/compilenv_deps/symbol.cmx \ middle_end/flambda/simplify/simplify_import.cmx \ middle_end/flambda/basic/simple.cmx \ @@ -6668,17 +6673,27 @@ middle_end/flambda/simplify/env/downwards_acc.cmi : \ middle_end/flambda/types/structures/code_age_relation.cmi middle_end/flambda/simplify/env/simplify_envs.cmo : \ middle_end/flambda/compilenv_deps/variable.cmi \ + middle_end/flambda/basic/var_within_closure.cmi \ middle_end/flambda/naming/var_in_binding_pos.cmi \ + utils/targetint.cmi \ + middle_end/flambda/compilenv_deps/target_imm.cmi \ + lambda/tag.cmi \ + middle_end/flambda/terms/symbol_projection.cmi \ middle_end/flambda/compilenv_deps/symbol.cmi \ middle_end/flambda/simplify/env/simplify_envs_intf.cmo \ middle_end/flambda/basic/simple.cmi \ + middle_end/flambda/terms/set_of_closures.cmi \ middle_end/flambda/basic/scope.cmi \ + middle_end/flambda/naming/name_occurrences.cmi \ middle_end/flambda/naming/name_mode.cmi \ middle_end/flambda/naming/name_in_binding_pos.cmi \ middle_end/flambda/basic/name.cmi \ + middle_end/flambda/basic/mutability.cmi \ utils/misc.cmi \ middle_end/flambda/basic/kinded_parameter.cmi \ + middle_end/flambda/terms/function_declarations.cmi \ middle_end/flambda/types/flambda_type.cmi \ + middle_end/flambda/types/kinds/flambda_kind.cmi \ middle_end/flambda/flambda_backend_intf.cmi \ middle_end/flambda/types/kinds/flambda_arity.cmi \ middle_end/flambda/terms/flambda.cmi \ @@ -6695,17 +6710,27 @@ middle_end/flambda/simplify/env/simplify_envs.cmo : \ middle_end/flambda/simplify/env/simplify_envs.cmi middle_end/flambda/simplify/env/simplify_envs.cmx : \ middle_end/flambda/compilenv_deps/variable.cmx \ + middle_end/flambda/basic/var_within_closure.cmx \ middle_end/flambda/naming/var_in_binding_pos.cmx \ + utils/targetint.cmx \ + middle_end/flambda/compilenv_deps/target_imm.cmx \ + lambda/tag.cmx \ + middle_end/flambda/terms/symbol_projection.cmx \ middle_end/flambda/compilenv_deps/symbol.cmx \ middle_end/flambda/simplify/env/simplify_envs_intf.cmx \ middle_end/flambda/basic/simple.cmx \ + middle_end/flambda/terms/set_of_closures.cmx \ middle_end/flambda/basic/scope.cmx \ + middle_end/flambda/naming/name_occurrences.cmx \ middle_end/flambda/naming/name_mode.cmx \ middle_end/flambda/naming/name_in_binding_pos.cmx \ middle_end/flambda/basic/name.cmx \ + middle_end/flambda/basic/mutability.cmx \ utils/misc.cmx \ middle_end/flambda/basic/kinded_parameter.cmx \ + middle_end/flambda/terms/function_declarations.cmx \ middle_end/flambda/types/flambda_type.cmx \ + middle_end/flambda/types/kinds/flambda_kind.cmx \ middle_end/flambda/flambda_backend_intf.cmi \ middle_end/flambda/types/kinds/flambda_arity.cmx \ middle_end/flambda/terms/flambda.cmx \ @@ -6725,9 +6750,11 @@ middle_end/flambda/simplify/env/simplify_envs.cmi : \ middle_end/flambda/simplify/env/simplify_envs_intf.cmo : \ middle_end/flambda/compilenv_deps/variable.cmi \ middle_end/flambda/naming/var_in_binding_pos.cmi \ + middle_end/flambda/terms/symbol_projection.cmi \ middle_end/flambda/compilenv_deps/symbol.cmi \ middle_end/flambda/basic/simple.cmi \ middle_end/flambda/basic/scope.cmi \ + middle_end/flambda/naming/name_occurrences.cmi \ middle_end/flambda/naming/name_in_binding_pos.cmi \ middle_end/flambda/basic/name.cmi \ middle_end/flambda/basic/kinded_parameter.cmi \ @@ -6749,9 +6776,11 @@ middle_end/flambda/simplify/env/simplify_envs_intf.cmo : \ middle_end/flambda/simplify/env/simplify_envs_intf.cmx : \ middle_end/flambda/compilenv_deps/variable.cmx \ middle_end/flambda/naming/var_in_binding_pos.cmx \ + middle_end/flambda/terms/symbol_projection.cmx \ middle_end/flambda/compilenv_deps/symbol.cmx \ middle_end/flambda/basic/simple.cmx \ middle_end/flambda/basic/scope.cmx \ + middle_end/flambda/naming/name_occurrences.cmx \ middle_end/flambda/naming/name_in_binding_pos.cmx \ middle_end/flambda/basic/name.cmx \ middle_end/flambda/basic/kinded_parameter.cmx \ @@ -6818,7 +6847,9 @@ middle_end/flambda/simplify/typing_helpers/continuation_uses.cmo : \ middle_end/flambda/basic/scope.cmi \ middle_end/flambda/simplify/typing_helpers/one_continuation_use.cmi \ utils/misc.cmi \ + middle_end/flambda/basic/kinded_parameter.cmi \ middle_end/flambda/types/flambda_type.cmi \ + middle_end/flambda/types/kinds/flambda_kind.cmi \ middle_end/flambda/compilenv_deps/flambda_features.cmi \ middle_end/flambda/compilenv_deps/flambda_colours.cmi \ middle_end/flambda/types/kinds/flambda_arity.cmi \ @@ -6833,7 +6864,9 @@ middle_end/flambda/simplify/typing_helpers/continuation_uses.cmx : \ middle_end/flambda/basic/scope.cmx \ middle_end/flambda/simplify/typing_helpers/one_continuation_use.cmx \ utils/misc.cmx \ + middle_end/flambda/basic/kinded_parameter.cmx \ middle_end/flambda/types/flambda_type.cmx \ + middle_end/flambda/types/kinds/flambda_kind.cmx \ middle_end/flambda/compilenv_deps/flambda_features.cmx \ middle_end/flambda/compilenv_deps/flambda_colours.cmx \ middle_end/flambda/types/kinds/flambda_arity.cmx \ @@ -6910,12 +6943,9 @@ middle_end/flambda/terms/apply_cont_expr.cmo : \ middle_end/flambda/naming/name_permutation.cmi \ middle_end/flambda/naming/name_occurrences.cmi \ utils/misc.cmi \ - middle_end/flambda/basic/invariant_env.cmi \ middle_end/flambda/cmx/ids_for_export.cmi \ utils/identifiable.cmi \ - middle_end/flambda/types/kinds/flambda_kind.cmi \ middle_end/flambda/compilenv_deps/flambda_colours.cmi \ - middle_end/flambda/types/kinds/flambda_arity.cmi \ lambda/debuginfo.cmi \ middle_end/flambda/basic/continuation.cmi \ middle_end/flambda/terms/apply_cont_expr.cmi @@ -6925,12 +6955,9 @@ middle_end/flambda/terms/apply_cont_expr.cmx : \ middle_end/flambda/naming/name_permutation.cmx \ middle_end/flambda/naming/name_occurrences.cmx \ utils/misc.cmx \ - middle_end/flambda/basic/invariant_env.cmx \ middle_end/flambda/cmx/ids_for_export.cmx \ utils/identifiable.cmx \ - middle_end/flambda/types/kinds/flambda_kind.cmx \ middle_end/flambda/compilenv_deps/flambda_colours.cmx \ - middle_end/flambda/types/kinds/flambda_arity.cmx \ lambda/debuginfo.cmx \ middle_end/flambda/basic/continuation.cmx \ middle_end/flambda/terms/apply_cont_expr.cmi @@ -7461,7 +7488,6 @@ middle_end/flambda/terms/function_params_and_body.rec.cmo : \ utils/printing_cache.cmi \ middle_end/flambda/naming/name_abstraction.cmi \ middle_end/flambda/basic/kinded_parameter.cmi \ - middle_end/flambda/types/kinds/flambda_kind.cmi \ middle_end/flambda/compilenv_deps/flambda_colours.cmi \ middle_end/flambda/types/kinds/flambda_arity.cmi \ middle_end/flambda/basic/exn_continuation.cmi \ @@ -7474,7 +7500,6 @@ middle_end/flambda/terms/function_params_and_body.rec.cmx : \ utils/printing_cache.cmx \ middle_end/flambda/naming/name_abstraction.cmx \ middle_end/flambda/basic/kinded_parameter.cmx \ - middle_end/flambda/types/kinds/flambda_kind.cmx \ middle_end/flambda/compilenv_deps/flambda_colours.cmx \ middle_end/flambda/types/kinds/flambda_arity.cmx \ middle_end/flambda/basic/exn_continuation.cmx \ @@ -7756,6 +7781,31 @@ middle_end/flambda/terms/switch_expr.cmi : \ middle_end/flambda/basic/expr_std.cmo \ middle_end/flambda/cmx/contains_ids.cmo \ middle_end/flambda/terms/apply_cont_expr.cmi +middle_end/flambda/terms/symbol_projection.cmo : \ + middle_end/flambda/basic/var_within_closure.cmi \ + utils/targetint.cmi \ + middle_end/flambda/compilenv_deps/symbol.cmi \ + middle_end/flambda/naming/name_occurrences.cmi \ + middle_end/flambda/naming/name_mode.cmi \ + middle_end/flambda/cmx/ids_for_export.cmi \ + middle_end/flambda/basic/closure_id.cmi \ + middle_end/flambda/terms/symbol_projection.cmi +middle_end/flambda/terms/symbol_projection.cmx : \ + middle_end/flambda/basic/var_within_closure.cmx \ + utils/targetint.cmx \ + middle_end/flambda/compilenv_deps/symbol.cmx \ + middle_end/flambda/naming/name_occurrences.cmx \ + middle_end/flambda/naming/name_mode.cmx \ + middle_end/flambda/cmx/ids_for_export.cmx \ + middle_end/flambda/basic/closure_id.cmx \ + middle_end/flambda/terms/symbol_projection.cmi +middle_end/flambda/terms/symbol_projection.cmi : \ + middle_end/flambda/basic/var_within_closure.cmi \ + utils/targetint.cmi \ + middle_end/flambda/compilenv_deps/symbol.cmi \ + middle_end/flambda/naming/contains_names.cmo \ + middle_end/flambda/cmx/contains_ids.cmo \ + middle_end/flambda/basic/closure_id.cmi middle_end/flambda/to_cmm/un_cps.cmo : \ middle_end/flambda/compilenv_deps/variable.cmi \ middle_end/flambda/basic/var_within_closure.cmi \ @@ -7794,6 +7844,7 @@ middle_end/flambda/to_cmm/un_cps.cmo : \ middle_end/flambda/compilenv_deps/flambda_features.cmi \ middle_end/flambda/compilenv_deps/flambda_colours.cmi \ middle_end/flambda/cmx/flambda_cmx_format.cmi \ + middle_end/flambda/types/kinds/flambda_arity.cmi \ middle_end/flambda/terms/flambda.cmi \ middle_end/flambda/cmx/exported_offsets.cmi \ middle_end/flambda/cmx/exported_code.cmi \ @@ -7857,6 +7908,7 @@ middle_end/flambda/to_cmm/un_cps.cmx : \ middle_end/flambda/compilenv_deps/flambda_features.cmx \ middle_end/flambda/compilenv_deps/flambda_colours.cmx \ middle_end/flambda/cmx/flambda_cmx_format.cmx \ + middle_end/flambda/types/kinds/flambda_arity.cmx \ middle_end/flambda/terms/flambda.cmx \ middle_end/flambda/cmx/exported_offsets.cmx \ middle_end/flambda/cmx/exported_code.cmx \ @@ -7896,8 +7948,8 @@ middle_end/flambda/to_cmm/un_cps_closure.cmo : \ middle_end/flambda/terms/flambda_unit.cmi \ middle_end/flambda/terms/flambda.cmi \ middle_end/flambda/cmx/exported_offsets.cmi \ + middle_end/flambda/cmx/exported_code.cmi \ middle_end/flambda/compilenv_deps/compilation_unit.cmi \ - middle_end/flambda/basic/code_id.cmi \ middle_end/flambda/basic/closure_id.cmi \ middle_end/flambda/to_cmm/un_cps_closure.cmi middle_end/flambda/to_cmm/un_cps_closure.cmx : \ @@ -7911,14 +7963,15 @@ middle_end/flambda/to_cmm/un_cps_closure.cmx : \ middle_end/flambda/terms/flambda_unit.cmx \ middle_end/flambda/terms/flambda.cmx \ middle_end/flambda/cmx/exported_offsets.cmx \ + middle_end/flambda/cmx/exported_code.cmx \ middle_end/flambda/compilenv_deps/compilation_unit.cmx \ - middle_end/flambda/basic/code_id.cmx \ middle_end/flambda/basic/closure_id.cmx \ middle_end/flambda/to_cmm/un_cps_closure.cmi middle_end/flambda/to_cmm/un_cps_closure.cmi : \ middle_end/flambda/basic/var_within_closure.cmi \ middle_end/flambda/terms/flambda_unit.cmi \ middle_end/flambda/cmx/exported_offsets.cmi \ + middle_end/flambda/cmx/exported_code.cmi \ middle_end/flambda/basic/closure_id.cmi middle_end/flambda/to_cmm/un_cps_env.cmo : \ middle_end/flambda/compilenv_deps/variable.cmi \ @@ -7930,6 +7983,7 @@ middle_end/flambda/to_cmm/un_cps_env.cmo : \ middle_end/flambda/basic/kinded_parameter.cmi \ middle_end/flambda/terms/function_declaration.cmi \ middle_end/flambda/compilenv_deps/flambda_features.cmi \ + middle_end/flambda/types/kinds/flambda_arity.cmi \ middle_end/flambda/terms/flambda.cmi \ middle_end/flambda/cmx/exported_offsets.cmi \ middle_end/flambda/cmx/exported_code.cmi \ @@ -7951,6 +8005,7 @@ middle_end/flambda/to_cmm/un_cps_env.cmx : \ middle_end/flambda/basic/kinded_parameter.cmx \ middle_end/flambda/terms/function_declaration.cmx \ middle_end/flambda/compilenv_deps/flambda_features.cmx \ + middle_end/flambda/types/kinds/flambda_arity.cmx \ middle_end/flambda/terms/flambda.cmx \ middle_end/flambda/cmx/exported_offsets.cmx \ middle_end/flambda/cmx/exported_code.cmx \ @@ -8140,6 +8195,7 @@ middle_end/flambda/types/flambda_type.cmo : \ middle_end/flambda/types/basic/tag_or_unknown_and_size.cmi \ middle_end/flambda/types/basic/tag_and_size.cmi \ lambda/tag.cmi \ + middle_end/flambda/terms/symbol_projection.cmi \ middle_end/flambda/compilenv_deps/symbol.cmi \ middle_end/flambda/types/basic/string_info.cmi \ middle_end/flambda/basic/simple.cmi \ @@ -8201,6 +8257,7 @@ middle_end/flambda/types/flambda_type.cmx : \ middle_end/flambda/types/basic/tag_or_unknown_and_size.cmx \ middle_end/flambda/types/basic/tag_and_size.cmx \ lambda/tag.cmx \ + middle_end/flambda/terms/symbol_projection.cmx \ middle_end/flambda/compilenv_deps/symbol.cmx \ middle_end/flambda/types/basic/string_info.cmx \ middle_end/flambda/basic/simple.cmx \ @@ -8256,6 +8313,7 @@ middle_end/flambda/types/flambda_type.cmi : \ utils/targetint.cmi \ middle_end/flambda/compilenv_deps/target_imm.cmi \ lambda/tag.cmi \ + middle_end/flambda/terms/symbol_projection.cmi \ middle_end/flambda/compilenv_deps/symbol.cmi \ middle_end/flambda/types/basic/string_info.cmi \ middle_end/flambda/basic/simple.cmi \ @@ -8426,6 +8484,7 @@ middle_end/flambda/types/type_grammar.rec.cmi : \ middle_end/flambda/types/type_head_intf.cmo : \ middle_end/flambda/compilenv_deps/rec_info.cmi \ utils/printing_cache.cmi \ + middle_end/flambda/types/basic/or_unknown.cmi \ middle_end/flambda/types/basic/or_bottom_or_absorbing.cmi \ middle_end/flambda/types/basic/or_bottom.cmi \ middle_end/flambda/types/structures/lattice_ops_intf.cmo \ @@ -8434,6 +8493,7 @@ middle_end/flambda/types/type_head_intf.cmo : \ middle_end/flambda/types/type_head_intf.cmx : \ middle_end/flambda/compilenv_deps/rec_info.cmx \ utils/printing_cache.cmx \ + middle_end/flambda/types/basic/or_unknown.cmx \ middle_end/flambda/types/basic/or_bottom_or_absorbing.cmx \ middle_end/flambda/types/basic/or_bottom.cmx \ middle_end/flambda/types/structures/lattice_ops_intf.cmx \ @@ -8665,6 +8725,7 @@ middle_end/flambda/types/env/meet_or_join_env.rec.cmi : \ middle_end/flambda/basic/simple.cmi middle_end/flambda/types/env/typing_env.rec.cmo : \ middle_end/flambda/compilenv_deps/variable.cmi \ + middle_end/flambda/terms/symbol_projection.cmi \ middle_end/flambda/compilenv_deps/symbol.cmi \ middle_end/flambda/basic/simple.cmi \ middle_end/flambda/basic/scope.cmi \ @@ -8689,6 +8750,7 @@ middle_end/flambda/types/env/typing_env.rec.cmo : \ middle_end/flambda/types/env/typing_env.rec.cmi middle_end/flambda/types/env/typing_env.rec.cmx : \ middle_end/flambda/compilenv_deps/variable.cmx \ + middle_end/flambda/terms/symbol_projection.cmx \ middle_end/flambda/compilenv_deps/symbol.cmx \ middle_end/flambda/basic/simple.cmx \ middle_end/flambda/basic/scope.cmx \ @@ -8712,6 +8774,8 @@ middle_end/flambda/types/env/typing_env.rec.cmx : \ middle_end/flambda/types/env/aliases.cmx \ middle_end/flambda/types/env/typing_env.rec.cmi middle_end/flambda/types/env/typing_env.rec.cmi : \ + middle_end/flambda/compilenv_deps/variable.cmi \ + middle_end/flambda/terms/symbol_projection.cmi \ middle_end/flambda/compilenv_deps/symbol.cmi \ middle_end/flambda/basic/simple.cmi \ middle_end/flambda/basic/scope.cmi \ @@ -8751,6 +8815,7 @@ middle_end/flambda/types/env/typing_env_extension.rec.cmi : \ middle_end/flambda/types/env/typing_env_level.rec.cmo : \ middle_end/flambda/compilenv_deps/variable.cmi \ middle_end/flambda/naming/var_in_binding_pos.cmi \ + middle_end/flambda/terms/symbol_projection.cmi \ middle_end/flambda/compilenv_deps/symbol.cmi \ middle_end/flambda/basic/simple.cmi \ utils/printing_cache.cmi \ @@ -8777,6 +8842,7 @@ middle_end/flambda/types/env/typing_env_level.rec.cmo : \ middle_end/flambda/types/env/typing_env_level.rec.cmx : \ middle_end/flambda/compilenv_deps/variable.cmx \ middle_end/flambda/naming/var_in_binding_pos.cmx \ + middle_end/flambda/terms/symbol_projection.cmx \ middle_end/flambda/compilenv_deps/symbol.cmx \ middle_end/flambda/basic/simple.cmx \ utils/printing_cache.cmx \ @@ -8802,6 +8868,7 @@ middle_end/flambda/types/env/typing_env_level.rec.cmx : \ middle_end/flambda/types/env/typing_env_level.rec.cmi middle_end/flambda/types/env/typing_env_level.rec.cmi : \ middle_end/flambda/compilenv_deps/variable.cmi \ + middle_end/flambda/terms/symbol_projection.cmi \ middle_end/flambda/compilenv_deps/symbol.cmi \ middle_end/flambda/basic/simple.cmi \ utils/printing_cache.cmi \ @@ -8832,6 +8899,7 @@ middle_end/flambda/types/kinds/flambda_kind.cmo : \ utils/targetint.cmi \ middle_end/flambda/compilenv_deps/target_imm.cmi \ utils/numbers.cmi \ + utils/misc.cmi \ utils/identifiable.cmi \ middle_end/flambda/compilenv_deps/flambda_colours.cmi \ middle_end/flambda/types/kinds/flambda_kind.cmi @@ -8839,6 +8907,7 @@ middle_end/flambda/types/kinds/flambda_kind.cmx : \ utils/targetint.cmx \ middle_end/flambda/compilenv_deps/target_imm.cmx \ utils/numbers.cmx \ + utils/misc.cmx \ utils/identifiable.cmx \ middle_end/flambda/compilenv_deps/flambda_colours.cmx \ middle_end/flambda/types/kinds/flambda_kind.cmi @@ -9085,6 +9154,7 @@ middle_end/flambda/types/structures/type_structure_intf.cmx : \ middle_end/flambda/cmx/contains_ids.cmx middle_end/flambda/types/type_of_kind/type_of_kind_naked_float0.rec.cmo : \ middle_end/flambda/compilenv_deps/rec_info.cmi \ + middle_end/flambda/types/basic/or_unknown.cmi \ middle_end/flambda/types/basic/or_bottom_or_absorbing.cmi \ middle_end/flambda/types/basic/or_bottom.cmi \ utils/numbers.cmi \ @@ -9094,6 +9164,7 @@ middle_end/flambda/types/type_of_kind/type_of_kind_naked_float0.rec.cmo : \ middle_end/flambda/types/type_of_kind/type_of_kind_naked_float0.rec.cmi middle_end/flambda/types/type_of_kind/type_of_kind_naked_float0.rec.cmx : \ middle_end/flambda/compilenv_deps/rec_info.cmx \ + middle_end/flambda/types/basic/or_unknown.cmx \ middle_end/flambda/types/basic/or_bottom_or_absorbing.cmx \ middle_end/flambda/types/basic/or_bottom.cmx \ utils/numbers.cmx \ @@ -9110,6 +9181,7 @@ middle_end/flambda/types/type_of_kind/type_of_kind_naked_immediate0.rec.cmo : \ lambda/tag.cmi \ middle_end/flambda/compilenv_deps/rec_info.cmi \ utils/printing_cache.cmi \ + middle_end/flambda/types/basic/or_unknown.cmi \ middle_end/flambda/types/basic/or_bottom_or_absorbing.cmi \ middle_end/flambda/types/basic/or_bottom.cmi \ middle_end/flambda/naming/name_occurrences.cmi \ @@ -9122,6 +9194,7 @@ middle_end/flambda/types/type_of_kind/type_of_kind_naked_immediate0.rec.cmx : \ lambda/tag.cmx \ middle_end/flambda/compilenv_deps/rec_info.cmx \ utils/printing_cache.cmx \ + middle_end/flambda/types/basic/or_unknown.cmx \ middle_end/flambda/types/basic/or_bottom_or_absorbing.cmx \ middle_end/flambda/types/basic/or_bottom.cmx \ middle_end/flambda/naming/name_occurrences.cmx \ @@ -9133,6 +9206,7 @@ middle_end/flambda/types/type_of_kind/type_of_kind_naked_immediate0.rec.cmi : \ middle_end/flambda/compilenv_deps/target_imm.cmi middle_end/flambda/types/type_of_kind/type_of_kind_naked_int32_0.rec.cmo : \ middle_end/flambda/compilenv_deps/rec_info.cmi \ + middle_end/flambda/types/basic/or_unknown.cmi \ middle_end/flambda/types/basic/or_bottom_or_absorbing.cmi \ middle_end/flambda/types/basic/or_bottom.cmi \ utils/numbers.cmi \ @@ -9142,6 +9216,7 @@ middle_end/flambda/types/type_of_kind/type_of_kind_naked_int32_0.rec.cmo : \ middle_end/flambda/types/type_of_kind/type_of_kind_naked_int32_0.rec.cmi middle_end/flambda/types/type_of_kind/type_of_kind_naked_int32_0.rec.cmx : \ middle_end/flambda/compilenv_deps/rec_info.cmx \ + middle_end/flambda/types/basic/or_unknown.cmx \ middle_end/flambda/types/basic/or_bottom_or_absorbing.cmx \ middle_end/flambda/types/basic/or_bottom.cmx \ utils/numbers.cmx \ @@ -9153,6 +9228,7 @@ middle_end/flambda/types/type_of_kind/type_of_kind_naked_int32_0.rec.cmi : \ middle_end/flambda/types/type_head_intf.cmo middle_end/flambda/types/type_of_kind/type_of_kind_naked_int64_0.rec.cmo : \ middle_end/flambda/compilenv_deps/rec_info.cmi \ + middle_end/flambda/types/basic/or_unknown.cmi \ middle_end/flambda/types/basic/or_bottom_or_absorbing.cmi \ middle_end/flambda/types/basic/or_bottom.cmi \ utils/numbers.cmi \ @@ -9162,6 +9238,7 @@ middle_end/flambda/types/type_of_kind/type_of_kind_naked_int64_0.rec.cmo : \ middle_end/flambda/types/type_of_kind/type_of_kind_naked_int64_0.rec.cmi middle_end/flambda/types/type_of_kind/type_of_kind_naked_int64_0.rec.cmx : \ middle_end/flambda/compilenv_deps/rec_info.cmx \ + middle_end/flambda/types/basic/or_unknown.cmx \ middle_end/flambda/types/basic/or_bottom_or_absorbing.cmx \ middle_end/flambda/types/basic/or_bottom.cmx \ utils/numbers.cmx \ @@ -9174,6 +9251,7 @@ middle_end/flambda/types/type_of_kind/type_of_kind_naked_int64_0.rec.cmi : \ middle_end/flambda/types/type_of_kind/type_of_kind_naked_nativeint0.rec.cmo : \ utils/targetint.cmi \ middle_end/flambda/compilenv_deps/rec_info.cmi \ + middle_end/flambda/types/basic/or_unknown.cmi \ middle_end/flambda/types/basic/or_bottom_or_absorbing.cmi \ middle_end/flambda/types/basic/or_bottom.cmi \ middle_end/flambda/naming/name_occurrences.cmi \ @@ -9183,6 +9261,7 @@ middle_end/flambda/types/type_of_kind/type_of_kind_naked_nativeint0.rec.cmo : \ middle_end/flambda/types/type_of_kind/type_of_kind_naked_nativeint0.rec.cmx : \ utils/targetint.cmx \ middle_end/flambda/compilenv_deps/rec_info.cmx \ + middle_end/flambda/types/basic/or_unknown.cmx \ middle_end/flambda/types/basic/or_bottom_or_absorbing.cmx \ middle_end/flambda/types/basic/or_bottom.cmx \ middle_end/flambda/naming/name_occurrences.cmx \ diff --git a/Makefile b/Makefile index f36210ecfe1a..ffab255c04c8 100644 --- a/Makefile +++ b/Makefile @@ -278,7 +278,8 @@ MIDDLE_END_FLAMBDA_BASIC=\ middle_end/flambda/basic/apply_cont_rewrite_id.cmo \ middle_end/flambda/basic/continuation_extra_params_and_args.cmo \ middle_end/flambda/basic/symbol_scoping_rule.cmo \ - middle_end/flambda/basic/or_deleted.cmo + middle_end/flambda/basic/or_deleted.cmo \ + middle_end/flambda/terms/symbol_projection.cmo MIDDLE_END_FLAMBDA_NAMING=\ middle_end/flambda/naming/contains_names.cmo \ diff --git a/flambdatest/mlexamples/int32.ml b/flambdatest/mlexamples/int32.ml index 851b48d96735..ca07f0e3c6f0 100644 --- a/flambdatest/mlexamples/int32.ml +++ b/flambdatest/mlexamples/int32.ml @@ -111,7 +111,7 @@ external ( asr ) : int -> int -> int = "%asrint" let max_int = (-1) lsr 1 let min_int = max_int + 1 - +(* (* Floating-point operations *) external ( ~-. ) : float -> float = "%negfloat" @@ -260,8 +260,9 @@ let bool_of_string_opt = function let string_of_int n = format_int "%d" n - +*) external int_of_string : string -> int = "caml_int_of_string" +(* let int_of_string_opt s = (* TODO: provide this directly as a non-raising primitive. *) @@ -561,7 +562,7 @@ let exit retcode = sys_exit retcode let _ = register_named_value "Pervasives.do_at_exit" do_at_exit - +*) end open Stdlib @@ -619,7 +620,7 @@ let unsigned_to_int = fun n -> let i = to_int n in Some (if i < 0 then i + move else i) | _ -> assert false - +(* external format : string -> int32 -> string = "caml_int32_format" let to_string n = format "%d" n @@ -651,3 +652,4 @@ let unsigned_div n d = let unsigned_rem n d = sub n (mul (unsigned_div n d) d) +*) diff --git a/flambdatest/mlexamples/protect_refs.ml b/flambdatest/mlexamples/protect_refs.ml new file mode 100644 index 000000000000..08e51b9f7bdd --- /dev/null +++ b/flambdatest/mlexamples/protect_refs.ml @@ -0,0 +1,30 @@ +let rec iter f = function + [] -> () + | a::l -> f a; iter f l + +type 'a ref = { mutable contents : 'a; } +external ref : 'a -> 'a ref = "%makemutable" +external ( ! ) : 'a ref -> 'a = "%field0" +external ( := ) : 'a ref -> 'a -> unit = "%setfield0" +external raise : exn -> 'a = "%raise" + +type ref_and_value = R : 'a ref * 'a -> ref_and_value + +let protect_refs = + let set_refs l = iter (fun (R (r, v)) -> r := v) l in + fun refs f -> + set_refs refs; + f () + +type unification_mode = + | Expression + | Pattern + +let umode = ref Expression + +let[@inline never] set_mode_pattern f = + protect_refs + [R (umode, Pattern)] f + +let () = + set_mode_pattern (fun () -> ()) diff --git a/flambdatest/mlexamples/symbol_projections.ml b/flambdatest/mlexamples/symbol_projections.ml new file mode 100644 index 000000000000..1ebe9b203075 --- /dev/null +++ b/flambdatest/mlexamples/symbol_projections.ml @@ -0,0 +1,14 @@ +external getenv : string -> string = "caml_sys_getenv" +external (+) : int -> int -> int = "%addint" + +let foo = + match getenv "FOO" with + | exception _ -> false + | _ -> true + +let f x = + let g y = + if foo then y + y + else y + in + x, g diff --git a/flambdatest/mlexamples/symbol_projections2.ml b/flambdatest/mlexamples/symbol_projections2.ml new file mode 100644 index 000000000000..ee40c1ef2db0 --- /dev/null +++ b/flambdatest/mlexamples/symbol_projections2.ml @@ -0,0 +1,12 @@ +(* From pchambart 2020-07-22, ocaml-flambda/ocaml issue #214 *) + +external opaque_identity : 'a -> 'a = "%opaque" +external (+) : int -> int -> int = "%addint" +let[@inline never] ignore _ = () + +let v = opaque_identity 33 + +let g () = + let () = ignore () in + let f x = x + v in + f diff --git a/flambdatest/mlexamples/symbol_projections3.ml b/flambdatest/mlexamples/symbol_projections3.ml new file mode 100644 index 000000000000..85f125d1defc --- /dev/null +++ b/flambdatest/mlexamples/symbol_projections3.ml @@ -0,0 +1,15 @@ +external getenv : string -> string = "caml_sys_getenv" +external (+) : int -> int -> int = "%addint" + +let foo = + match getenv "FOO" with + | exception _ -> false + | _ -> true + +let f x = + let g y = + if foo then y + y + else y + in + let block_to_lift = foo, foo in + x, g, block_to_lift diff --git a/flambdatest/mlexamples/symbol_projections4.ml b/flambdatest/mlexamples/symbol_projections4.ml new file mode 100644 index 000000000000..80c7bf1b0a68 --- /dev/null +++ b/flambdatest/mlexamples/symbol_projections4.ml @@ -0,0 +1,21 @@ +external getenv : string -> string = "caml_sys_getenv" +external (+) : int -> int -> int = "%addint" + +let foo = + match getenv "FOO" with + | exception _ -> false + | _ -> true + +let f x b = + if b then + let g y = + if foo then y + y + else y + in + x, g + else + let h y = + if foo then y + y + y + else y + in + x, h diff --git a/flambdatest/mlexamples/symbol_projections5.ml b/flambdatest/mlexamples/symbol_projections5.ml new file mode 100644 index 000000000000..728144344689 --- /dev/null +++ b/flambdatest/mlexamples/symbol_projections5.ml @@ -0,0 +1,27 @@ +external getenv : string -> string = "caml_sys_getenv" +external (+) : int -> int -> int = "%addint" +external (<) : int -> int -> bool = "%lessthan" +external (&&) : bool -> bool -> bool = "%logand" + +let foo = + match getenv "FOO" with + | exception _ -> false + | _ -> true + +type t = + | S of (int -> t) + | T of (int -> t) + +let f b = + if b then + let rec g y = + if y < 0 then S g + else T g + in + g + else + let rec h z = + if z < 0 then S h + else T h + in + h diff --git a/flambdatest/mlexamples/symbol_projections6.ml b/flambdatest/mlexamples/symbol_projections6.ml new file mode 100644 index 000000000000..ec4271605cd8 --- /dev/null +++ b/flambdatest/mlexamples/symbol_projections6.ml @@ -0,0 +1,27 @@ +external getenv : string -> string = "caml_sys_getenv" +external (+) : int -> int -> int = "%addint" +external (<) : int -> int -> bool = "%lessthan" +external (&&) : bool -> bool -> bool = "%sequand" + +let foo = + match getenv "FOO" with + | exception _ -> false + | _ -> true + +type t = + | S of (int -> (t * bool)) + | T of (int -> (t * bool)) + +let f b = + if b then + let rec g y = + if y < 0 && foo then S g, foo + else T g, foo + in + g + else + let rec h z = + if z < 0 && foo then S h, foo + else T h, foo + in + h diff --git a/flambdatest/mlexamples/symbol_projections7.ml b/flambdatest/mlexamples/symbol_projections7.ml new file mode 100644 index 000000000000..0040945ffd7c --- /dev/null +++ b/flambdatest/mlexamples/symbol_projections7.ml @@ -0,0 +1,11 @@ +external word_size : unit -> int = "%word_size" +external (+) : int -> int -> int = "%addint" +external opaque : 'a -> 'a = "%opaque" +let foo = + match word_size () with + | 32 -> (fun x -> x + 1) + | 64 -> + let y = opaque 2 in + (fun x -> x + y) + | _ -> + assert false diff --git a/middle_end/flambda/basic/mutability.ml b/middle_end/flambda/basic/mutability.ml index 04924d504a97..23464f98a3ff 100644 --- a/middle_end/flambda/basic/mutability.ml +++ b/middle_end/flambda/basic/mutability.ml @@ -50,3 +50,8 @@ let to_lambda t : Asttypes.mutable_flag = | Mutable -> Mutable | Immutable -> Immutable | Immutable_unique -> Immutable + +let is_mutable t = + match t with + | Mutable -> true + | Immutable | Immutable_unique -> false diff --git a/middle_end/flambda/basic/mutability.mli b/middle_end/flambda/basic/mutability.mli index 92df032e57d7..cb9284c60a2b 100644 --- a/middle_end/flambda/basic/mutability.mli +++ b/middle_end/flambda/basic/mutability.mli @@ -31,3 +31,5 @@ val compare : t -> t -> int val join : t -> t -> t val to_lambda : t -> Asttypes.mutable_flag + +val is_mutable : t -> bool diff --git a/middle_end/flambda/basic/simple.ml b/middle_end/flambda/basic/simple.ml index 71b95f6ea683..3f7634411f4e 100644 --- a/middle_end/flambda/basic/simple.ml +++ b/middle_end/flambda/basic/simple.ml @@ -47,6 +47,10 @@ let [@inline always] is_symbol t = let [@inline always] is_const t = pattern_match t ~name:(fun _ -> false) ~const:(fun _ -> true) +let pattern_match' t ~var ~symbol ~const = + pattern_match t ~const + ~name:(fun name -> Name.pattern_match name ~var ~symbol) + let const_from_descr descr = const (RWC.of_descr descr) let without_rec_info t = pattern_match t ~name ~const diff --git a/middle_end/flambda/basic/simple.mli b/middle_end/flambda/basic/simple.mli index 384b1a115ad9..0cd720c1ed16 100644 --- a/middle_end/flambda/basic/simple.mli +++ b/middle_end/flambda/basic/simple.mli @@ -78,6 +78,13 @@ val is_var : t -> bool val free_names_in_types : t -> Name_occurrences.t +val pattern_match' + : t + -> var:(Variable.t -> 'a) + -> symbol:(Symbol.t -> 'a) + -> const:(Reg_width_const.t -> 'a) + -> 'a + module List : sig type nonrec t = t list diff --git a/middle_end/flambda/compilenv_deps/reg_width_things.mli b/middle_end/flambda/compilenv_deps/reg_width_things.mli index 1a4428003743..8e32a3a53ade 100644 --- a/middle_end/flambda/compilenv_deps/reg_width_things.mli +++ b/middle_end/flambda/compilenv_deps/reg_width_things.mli @@ -164,9 +164,9 @@ module Simple : sig -> const:(Const.t -> 'a) -> 'a - (* [same s1 s2] returns true iff they represent the same name or const - i.e. [same s (with_rec_info s rec_info)] returns true *) - val same : t -> t -> bool + (* [same s1 s2] returns true iff they represent the same name or const + i.e. [same s (with_rec_info s rec_info)] returns true *) + val same : t -> t -> bool val export : t -> exported diff --git a/middle_end/flambda/lifting/lift_inconstants.ml b/middle_end/flambda/lifting/lift_inconstants.ml index 94ef48bb5dd4..dfb76a37386b 100644 --- a/middle_end/flambda/lifting/lift_inconstants.ml +++ b/middle_end/flambda/lifting/lift_inconstants.ml @@ -34,6 +34,7 @@ let reify_primitive_at_toplevel dacc bound_var ty = the [is_fully_static] check below. *) match T.reify ~allowed_if_free_vars_defined_in:typing_env + ~additional_free_var_criterion:(DE.is_defined_at_toplevel (DA.denv dacc)) ~allow_unique:true typing_env ~min_name_mode:NM.normal ty with diff --git a/middle_end/flambda/lifting/reification.ml b/middle_end/flambda/lifting/reification.ml index 31e45222d42c..4bf79da602d4 100644 --- a/middle_end/flambda/lifting/reification.ml +++ b/middle_end/flambda/lifting/reification.ml @@ -61,9 +61,26 @@ let lift dacc ty ~bound_to static_const = Misc.fatal_errorf "Cannot lift non-[Value] variable: %a" Variable.print bound_to end; + let symbol_projections = + Name_occurrences.fold_variables (Static_const.free_names static_const) + ~init:Variable.Map.empty + ~f:(fun symbol_projections var -> + match DE.find_symbol_projection (DA.denv dacc) var with + | None -> symbol_projections + | Some proj -> Variable.Map.add var proj symbol_projections) + in + (* + if not (Variable.Map.is_empty symbol_projections) then begin + Format.eprintf "\nConstant:@ %a@ Symbol projections when created:@ %a\n%!" + Static_const.print static_const + (Variable.Map.print Symbol_projection.print) symbol_projections + end; + *) let dacc = let denv = DA.denv dacc in - Lifted_constant.create_block_like symbol static_const denv ty + Lifted_constant.create_block_like symbol static_const denv + ~symbol_projections + ty |> DA.add_lifted_constant dacc in let dacc = @@ -92,7 +109,16 @@ let try_to_reify dacc (term : Reachable.t) ~bound_to ~allow_lifting = let denv = DE.add_equation_on_variable denv bound_to ty in Reachable.invalid (), DA.with_denv dacc denv, ty | Reachable _ -> - match T.reify (DE.typing_env denv) ~min_name_mode:occ_kind ty with + let typing_env = DE.typing_env denv in + let reify_result = + T.reify ~allowed_if_free_vars_defined_in:typing_env + ~additional_free_var_criterion:(fun var -> + DE.is_defined_at_toplevel denv var + || Option.is_some (DE.find_symbol_projection denv var)) + ~allow_unique:true + typing_env ~min_name_mode:NM.normal ty + in + match reify_result with | Lift to_lift -> if Name_mode.is_normal occ_kind && allow_lifting then let static_const = create_static_const to_lift in diff --git a/middle_end/flambda/lifting/sort_lifted_constants.ml b/middle_end/flambda/lifting/sort_lifted_constants.ml index 49647b3ad333..f79aa03a44fe 100644 --- a/middle_end/flambda/lifting/sort_lifted_constants.ml +++ b/middle_end/flambda/lifting/sort_lifted_constants.ml @@ -30,12 +30,10 @@ let build_dep_graph lifted_constants = ~f:(fun (dep_graph, code_id_or_symbol_to_const) definition -> let module D = LC.Definition in let free_names = - let free_names = - Static_const.free_names (D.defining_expr definition) - in + let free_names = D.free_names definition in match D.descr definition with | Code _ | Block_like _ -> free_names - | Set_of_closures { denv = _; closure_symbols_with_types; } -> + | Set_of_closures { closure_symbols_with_types; _; } -> (* To avoid existing sets of closures (with or without associated code) being pulled apart, we add a dependency from each of the closure symbols (in the current set) to all of the others diff --git a/middle_end/flambda/simplify/env/simplify_envs.ml b/middle_end/flambda/simplify/env/simplify_envs.ml index 0a62f7401eb4..9fbc9e31cae5 100644 --- a/middle_end/flambda/simplify/env/simplify_envs.ml +++ b/middle_end/flambda/simplify/env/simplify_envs.ml @@ -46,6 +46,7 @@ end = struct at_unit_toplevel : bool; unit_toplevel_exn_continuation : Continuation.t; symbols_currently_being_defined : Symbol.Set.t; + variables_defined_at_toplevel : Variable.Set.t; } let print ppf { backend = _; round; typing_env; get_imported_code = _; @@ -53,6 +54,7 @@ end = struct inlining_depth_increment; float_const_prop; code; at_unit_toplevel; unit_toplevel_exn_continuation; symbols_currently_being_defined; + variables_defined_at_toplevel; } = Format.fprintf ppf "@[(\ @[(round@ %d)@]@ \ @@ -64,6 +66,7 @@ end = struct @[(at_unit_toplevel@ %b)@]@ \ @[(unit_toplevel_exn_continuation@ %a)@]@ \ @[(symbols_currently_being_defined@ %a)@]@ \ + @[(variables_defined_at_toplevel@ %a)@]@ \ @[(code@ %a)@]\ )@]" round @@ -75,6 +78,7 @@ end = struct at_unit_toplevel Continuation.print unit_toplevel_exn_continuation Symbol.Set.print symbols_currently_being_defined + Variable.Set.print variables_defined_at_toplevel (Code_id.Map.print Code.print) code let invariant _t = () @@ -95,6 +99,7 @@ end = struct at_unit_toplevel = true; unit_toplevel_exn_continuation; symbols_currently_being_defined = Symbol.Set.empty; + variables_defined_at_toplevel = Variable.Set.empty; } let resolver t = TE.resolver t.typing_env @@ -115,6 +120,9 @@ end = struct let set_at_unit_toplevel_state t at_unit_toplevel = { t with at_unit_toplevel; } + let is_defined_at_toplevel t var = + Variable.Set.mem var t.variables_defined_at_toplevel + let get_inlining_depth_increment t = t.inlining_depth_increment let set_inlining_depth_increment t inlining_depth_increment = @@ -168,6 +176,7 @@ end = struct float_const_prop; code; at_unit_toplevel = _; unit_toplevel_exn_continuation; symbols_currently_being_defined; + variables_defined_at_toplevel; } = { backend; round; @@ -181,6 +190,7 @@ end = struct at_unit_toplevel = false; unit_toplevel_exn_continuation; symbols_currently_being_defined; + variables_defined_at_toplevel; } let define_variable t var kind = @@ -188,7 +198,17 @@ end = struct let var = Name_in_binding_pos.var var in TE.add_definition t.typing_env var kind in - { t with typing_env; } + let variables_defined_at_toplevel = + if t.at_unit_toplevel then + Variable.Set.add (Var_in_binding_pos.var var) + t.variables_defined_at_toplevel + else + t.variables_defined_at_toplevel + in + { t with + typing_env; + variables_defined_at_toplevel; + } let add_name t name ty = let typing_env = @@ -196,16 +216,41 @@ end = struct (TE.add_definition t.typing_env name (T.kind ty)) (Name_in_binding_pos.name name) ty in - { t with typing_env; } + let variables_defined_at_toplevel = + Name.pattern_match (Name_in_binding_pos.name name) + ~var:(fun var -> + if t.at_unit_toplevel then + Variable.Set.add var t.variables_defined_at_toplevel + else + t.variables_defined_at_toplevel) + ~symbol:(fun _ -> t.variables_defined_at_toplevel) + in + { t with + typing_env; + variables_defined_at_toplevel; + } - let add_variable t var ty = + let add_variable0 t var ty ~at_unit_toplevel = let typing_env = let var' = Name_in_binding_pos.var var in TE.add_equation (TE.add_definition t.typing_env var' (T.kind ty)) (Name.var (Var_in_binding_pos.var var)) ty in - { t with typing_env; } + let variables_defined_at_toplevel = + if at_unit_toplevel then + Variable.Set.add (Var_in_binding_pos.var var) + t.variables_defined_at_toplevel + else + t.variables_defined_at_toplevel + in + { t with + typing_env; + variables_defined_at_toplevel; + } + + let add_variable t var ty = + add_variable0 t var ty ~at_unit_toplevel:t.at_unit_toplevel let add_equation_on_variable t var ty = let typing_env = TE.add_equation t.typing_env (Name.var var) ty in @@ -260,19 +305,35 @@ end = struct let find_symbol t sym = find_name t (Name.symbol sym) + let add_symbol_projection t var proj = + { t with + typing_env = TE.add_symbol_projection t.typing_env var proj; + } + + let find_symbol_projection t var = + TE.find_symbol_projection t.typing_env var + let define_name t name kind = let typing_env = TE.add_definition t.typing_env name kind in - { t with typing_env; } + let variables_defined_at_toplevel = + Name.pattern_match (Name_in_binding_pos.name name) + ~var:(fun var -> + if t.at_unit_toplevel then + Variable.Set.add var t.variables_defined_at_toplevel + else + t.variables_defined_at_toplevel) + ~symbol:(fun _ -> t.variables_defined_at_toplevel) + in + { t with + typing_env; + variables_defined_at_toplevel; + } let define_name_if_undefined t name kind = if TE.mem t.typing_env (Name_in_binding_pos.to_name name) then t - else - let typing_env = - TE.add_definition t.typing_env name kind - in - { t with typing_env; } + else define_name t name kind let add_equation_on_name t name ty = let typing_env = TE.add_equation t.typing_env name ty in @@ -305,30 +366,33 @@ end = struct t params - let add_parameters t params ~param_types = + let add_parameters ?at_unit_toplevel t params ~param_types = if List.compare_lengths params param_types <> 0 then begin Misc.fatal_errorf "Mismatch between number of [params] and \ [param_types]:@ (%a)@ and@ %a" Kinded_parameter.List.print params (Format.pp_print_list ~pp_sep:Format.pp_print_space T.print) param_types end; + let at_unit_toplevel = + Option.value at_unit_toplevel ~default:t.at_unit_toplevel + in List.fold_left2 (fun t param param_type -> let var = Var_in_binding_pos.create (KP.var param) Name_mode.normal in - add_variable t var param_type) + add_variable0 t var param_type ~at_unit_toplevel) t params param_types - let add_parameters_with_unknown_types' t params = + let add_parameters_with_unknown_types' ?at_unit_toplevel t params = let param_types = ListLabels.map params ~f:(fun param -> T.unknown_with_subkind (KP.kind param)) in - add_parameters t params ~param_types, param_types + add_parameters ?at_unit_toplevel t params ~param_types, param_types - let add_parameters_with_unknown_types t params = - fst (add_parameters_with_unknown_types' t params) + let add_parameters_with_unknown_types ?at_unit_toplevel t params = + fst (add_parameters_with_unknown_types' ?at_unit_toplevel t params) let extend_typing_environment t env_extension = let typing_env = TE.add_env_extension t.typing_env env_extension in @@ -694,11 +758,13 @@ end = struct denv : Downwards_env.t; closure_symbols_with_types : (Symbol.t * Flambda_type.t) Closure_id.Lmap.t; + symbol_projections : Symbol_projection.t Variable.Map.t; } | Block_like of { symbol : Symbol.t; denv : Downwards_env.t; ty : Flambda_type.t; + symbol_projections : Symbol_projection.t Variable.Map.t; } type t = { @@ -706,6 +772,28 @@ end = struct defining_expr : Static_const.t; } + let binds_symbol t sym = + match t.descr with + | Code _ -> false + | Set_of_closures { closure_symbols_with_types; _ } -> + Closure_id.Lmap.exists (fun _ (sym', _) -> Symbol.equal sym sym') + closure_symbols_with_types + | Block_like { symbol; _ } -> Symbol.equal sym symbol + + let free_names t = + match t.descr with + | Code _ -> Static_const.free_names t.defining_expr + | Set_of_closures { symbol_projections; _ } + | Block_like { symbol_projections; _ } -> + (* The symbols mentioned in any symbol projections must be counted + as free names, so that the definition doesn't get placed too high + in the code. *) + Variable.Map.fold (fun _var proj free_names -> + Name_occurrences.add_symbol free_names + (Symbol_projection.symbol proj) Name_mode.normal) + symbol_projections + (Static_const.free_names t.defining_expr) + let print_descr ppf descr = match descr with | Code code_id -> Code_id.print ppf code_id @@ -730,6 +818,12 @@ end = struct let descr t = t.descr let defining_expr t = t.defining_expr + let symbol_projections t = + match t.descr with + | Code _ -> Variable.Map.empty + | Set_of_closures { symbol_projections; _ } + | Block_like { symbol_projections; _ } -> symbol_projections + let code code_id defining_expr = match defining_expr with | Static_const.Code code -> @@ -745,19 +839,22 @@ end = struct Misc.fatal_errorf "Not a code definition: %a" Static_const.print defining_expr - let set_of_closures denv ~closure_symbols_with_types defining_expr = + let set_of_closures denv ~closure_symbols_with_types + ~symbol_projections defining_expr = { descr = Set_of_closures { denv; closure_symbols_with_types; + symbol_projections; }; defining_expr; } - let block_like denv symbol ty defining_expr = + let block_like denv symbol ty ~symbol_projections defining_expr = { descr = Block_like { symbol; denv; ty; + symbol_projections; }; defining_expr; } @@ -771,7 +868,7 @@ end = struct let module P = Bound_symbols.Pattern in match t.descr with | Code code_id -> P.code code_id - | Set_of_closures { closure_symbols_with_types; denv = _; } -> + | Set_of_closures { closure_symbols_with_types; _; } -> P.set_of_closures (Closure_id.Lmap.map fst closure_symbols_with_types) | Block_like { symbol; _ } -> P.block_like symbol @@ -781,7 +878,7 @@ end = struct let types_of_symbols t = match t.descr with | Code _ -> Symbol.Map.empty - | Set_of_closures { denv; closure_symbols_with_types; } -> + | Set_of_closures { denv; closure_symbols_with_types; _ } -> Closure_id.Lmap.fold (fun _closure_id (symbol, ty) types_of_symbols -> Symbol.Map.add symbol (denv, ty) types_of_symbols) closure_symbols_with_types @@ -795,10 +892,12 @@ end = struct bound_symbols : Bound_symbols.t; defining_exprs : Static_const.Group.t; free_names : Name_occurrences.t; + symbol_projections : Symbol_projection.t Variable.Map.t; is_fully_static : bool; } let definitions t = t.definitions + let symbol_projections t = t.symbol_projections let free_names_of_defining_exprs t = t.free_names @@ -806,7 +905,7 @@ end = struct let print ppf { definitions; bound_symbols = _; defining_exprs = _; - free_names = _; is_fully_static = _; } = + free_names = _; is_fully_static = _; symbol_projections = _; } = Format.fprintf ppf "@[(%a)@]" (Format.pp_print_list ~pp_sep:Format.pp_print_space Definition.print) definitions @@ -819,36 +918,45 @@ end = struct ListLabels.map definitions ~f:Definition.defining_expr |> Static_const.Group.create - let create_block_like symbol defining_expr denv ty = + let create_block_like symbol ~symbol_projections defining_expr denv ty = (* CR mshinwell: check that [defining_expr] is not a set of closures or code *) - let definitions = [Definition.block_like denv symbol ty defining_expr] in + let definition = + Definition.block_like denv symbol ty ~symbol_projections defining_expr + in + let definitions = [definition] in { definitions; bound_symbols = compute_bound_symbols definitions; defining_exprs = compute_defining_exprs definitions; - free_names = Static_const.free_names defining_expr; + free_names = Definition.free_names definition; is_fully_static = Static_const.is_fully_static defining_expr; + symbol_projections = Definition.symbol_projections definition; } - let create_set_of_closures denv ~closure_symbols_with_types defining_expr = - let definitions = - [Definition.set_of_closures denv ~closure_symbols_with_types - defining_expr] + let create_set_of_closures denv ~closure_symbols_with_types + ~symbol_projections defining_expr = + let definition = + Definition.set_of_closures denv ~closure_symbols_with_types + ~symbol_projections defining_expr in + let definitions = [definition] in { definitions; bound_symbols = compute_bound_symbols definitions; defining_exprs = compute_defining_exprs definitions; - free_names = Static_const.free_names defining_expr; + free_names = Definition.free_names definition; is_fully_static = Static_const.is_fully_static defining_expr; + symbol_projections = Definition.symbol_projections definition; } let create_code code_id defining_expr = - let definitions = [Definition.code code_id defining_expr] in + let definition = Definition.code code_id defining_expr in + let definitions = [definition] in { definitions; bound_symbols = compute_bound_symbols definitions; defining_exprs = compute_defining_exprs definitions; - free_names = Static_const.free_names defining_expr; + free_names = Definition.free_names definition; is_fully_static = Static_const.is_fully_static defining_expr; + symbol_projections = Definition.symbol_projections definition; } let concat ts = @@ -882,11 +990,19 @@ end = struct true ts in + let symbol_projections = + List.fold_left (fun symbol_projections t -> + Variable.Map.disjoint_union ~eq:Symbol_projection.equal + t.symbol_projections symbol_projections) + Variable.Map.empty + ts + in { definitions; bound_symbols; defining_exprs; free_names; is_fully_static; + symbol_projections; } let defining_exprs t = @@ -906,6 +1022,85 @@ end = struct let all_defined_symbols t = Symbol.Map.keys (types_of_symbols t) + + let apply_projection t proj = + let symbol = Symbol_projection.symbol proj in + let matching_defining_exprs = + ListLabels.filter_map t.definitions ~f:(fun definition -> + if Definition.binds_symbol definition symbol then + Some (Definition.defining_expr definition) + else + None) + in + match matching_defining_exprs with + | [defining_expr] -> + let simple = + match Symbol_projection.projection proj, defining_expr with + | Block_load { index; }, Block (tag, mut, fields) -> + if not (Tag.Scannable.equal tag Tag.Scannable.zero) then begin + Misc.fatal_errorf "Symbol projection@ %a@ on block which doesn't \ + have tag zero:@ %a" + Symbol_projection.print proj + Static_const.print defining_expr + end; + if Mutability.is_mutable mut then begin + Misc.fatal_errorf "Symbol projection@ %a@ on mutable block:@ %a" + Symbol_projection.print proj + Static_const.print defining_expr + end; + let index = Targetint.OCaml.to_int_exn index in + begin match List.nth_opt fields index with + | Some field -> + begin match field with + | Symbol symbol -> Simple.symbol symbol + | Tagged_immediate imm -> + Simple.const_int (Target_imm.to_targetint imm) + | Dynamically_computed var -> Simple.var var + end + | None -> + Misc.fatal_errorf "Symbol projection@ %a@ has out-of-range \ + index:@ %a" + Symbol_projection.print proj + Static_const.print defining_expr + end; + | Project_var { project_from; var; }, Set_of_closures set -> + let decls = Set_of_closures.function_decls set in + if not (Function_declarations.binds_closure_id decls project_from) + then begin + Misc.fatal_errorf "Symbol projection@ %a@ has closure ID not \ + bound by this set of closures:@ %a" + Symbol_projection.print proj + Static_const.print defining_expr + end; + let closure_env = Set_of_closures.closure_elements set in + begin match Var_within_closure.Map.find var closure_env with + | exception Not_found -> + Misc.fatal_errorf "Symbol projection@ %a@ has closure var not \ + defined in the environment of this set of closures:@ %a" + Symbol_projection.print proj + Static_const.print defining_expr + | closure_entry -> closure_entry + end + | Block_load _, + (Code _ | Set_of_closures _ | Boxed_float _ | Boxed_int32 _ + | Boxed_int64 _ | Boxed_nativeint _ | Immutable_float_block _ + | Immutable_float_array _ | Mutable_string _ | Immutable_string _) + | Project_var _, + (Code _ | Block _ | Boxed_float _ | Boxed_int32 _ + | Boxed_int64 _ | Boxed_nativeint _ | Immutable_float_block _ + | Immutable_float_array _ | Mutable_string _ | Immutable_string _) -> + Misc.fatal_errorf "Symbol projection@ %a@ cannot be applied to:@ %a" + Symbol_projection.print proj + Static_const.print defining_expr + in + Some simple + | [] -> None + | _::_::_ -> + Misc.fatal_errorf "Symbol projection@ %a@ matches more than one \ + constant in:@ %a" + Symbol_projection.print proj + print t + end and Lifted_constant_state : sig include I.Lifted_constant_state with type lifted_constant := Lifted_constant.t diff --git a/middle_end/flambda/simplify/env/simplify_envs_intf.ml b/middle_end/flambda/simplify/env/simplify_envs_intf.ml index 75d8eef82be1..940962e15970 100644 --- a/middle_end/flambda/simplify/env/simplify_envs_intf.ml +++ b/middle_end/flambda/simplify/env/simplify_envs_intf.ml @@ -60,6 +60,12 @@ module type Downwards_env = sig val set_at_unit_toplevel_state : t -> bool -> t + val is_defined_at_toplevel : t -> Variable.t -> bool + + val add_symbol_projection : t -> Variable.t -> Symbol_projection.t -> t + + val find_symbol_projection : t -> Variable.t -> Symbol_projection.t option + val unit_toplevel_exn_continuation : t -> Continuation.t val enter_closure : t -> t @@ -119,15 +125,21 @@ module type Downwards_env = sig val define_parameters_as_bottom : t -> params:Kinded_parameter.t list -> t val add_parameters - : t + : ?at_unit_toplevel:bool + -> t -> Kinded_parameter.t list -> param_types:Flambda_type.t list -> t - val add_parameters_with_unknown_types : t -> Kinded_parameter.t list -> t + val add_parameters_with_unknown_types + : ?at_unit_toplevel:bool + -> t + -> Kinded_parameter.t list + -> t val add_parameters_with_unknown_types' - : t + : ?at_unit_toplevel:bool + -> t -> Kinded_parameter.t list -> t * (Flambda_type.t list) @@ -292,11 +304,13 @@ module type Lifted_constant = sig denv : downwards_env; closure_symbols_with_types : (Symbol.t * Flambda_type.t) Closure_id.Lmap.t; + symbol_projections : Symbol_projection.t Variable.Map.t; } | Block_like of { symbol : Symbol.t; denv : downwards_env; ty : Flambda_type.t; + symbol_projections : Symbol_projection.t Variable.Map.t; } type t @@ -313,6 +327,7 @@ module type Lifted_constant = sig : downwards_env -> closure_symbols_with_types : (Symbol.t * Flambda_type.t) Closure_id.Lmap.t + -> symbol_projections:Symbol_projection.t Variable.Map.t -> Flambda.Static_const.t -> t @@ -320,10 +335,15 @@ module type Lifted_constant = sig : downwards_env -> Symbol.t -> Flambda_type.t + -> symbol_projections:Symbol_projection.t Variable.Map.t -> Flambda.Static_const.t -> t val bound_symbols : t -> Bound_symbols.t + + val free_names : t -> Name_occurrences.t + + val symbol_projections : t -> Symbol_projection.t Variable.Map.t end type t @@ -334,6 +354,7 @@ module type Lifted_constant = sig them. *) val create_block_like : Symbol.t + -> symbol_projections:Symbol_projection.t Variable.Map.t -> Flambda.Static_const.t -> downwards_env -> Flambda_type.t @@ -342,6 +363,7 @@ module type Lifted_constant = sig val create_set_of_closures : downwards_env -> closure_symbols_with_types:(Symbol.t * Flambda_type.t) Closure_id.Lmap.t + -> symbol_projections:Symbol_projection.t Variable.Map.t -> Flambda.Static_const.t -> t @@ -354,6 +376,7 @@ module type Lifted_constant = sig val bound_symbols : t -> Bound_symbols.t val defining_exprs : t -> Flambda.Static_const.Group.t val types_of_symbols : t -> (downwards_env * Flambda_type.t) Symbol.Map.t + val symbol_projections : t -> Symbol_projection.t Variable.Map.t val concat : t list -> t @@ -362,6 +385,8 @@ module type Lifted_constant = sig val all_defined_symbols : t -> Symbol.Set.t val free_names_of_defining_exprs : t -> Name_occurrences.t + + val apply_projection : t -> Symbol_projection.t -> Simple.t option end module type Lifted_constant_state = sig diff --git a/middle_end/flambda/simplify/simplify_binary_primitive.ml b/middle_end/flambda/simplify/simplify_binary_primitive.ml index 0430cb10b713..5e29140f7dde 100644 --- a/middle_end/flambda/simplify/simplify_binary_primitive.ml +++ b/middle_end/flambda/simplify/simplify_binary_primitive.ml @@ -990,7 +990,7 @@ let try_cse dacc prim arg1 arg2 ~min_name_mode ~result_var | Ok arg2, _arg2_ty -> let original_prim : P.t = Binary (prim, arg1, arg2) in Simplify_common.try_cse dacc ~original_prim ~result_kind - ~min_name_mode ~result_var + ~args:[arg1; arg2] ~min_name_mode ~result_var let simplify_binary_primitive dacc (prim : P.binary_primitive) arg1 arg2 dbg ~result_var = @@ -998,7 +998,7 @@ let simplify_binary_primitive dacc (prim : P.binary_primitive) let result_var' = Var_in_binding_pos.var result_var in let invalid ty = let env_extension = TEE.one_equation (Name.var result_var') ty in - Reachable.invalid (), env_extension, dacc + Reachable.invalid (), env_extension, [arg1; arg2], dacc in match try_cse dacc prim arg1 arg2 ~min_name_mode ~result_var:result_var' @@ -1067,5 +1067,8 @@ let simplify_binary_primitive dacc (prim : P.binary_primitive) let env_extension = TEE.one_equation (Name.var result_var') ty in Reachable.reachable named, env_extension, dacc in - simplifier dacc ~original_term dbg ~arg1 ~arg1_ty ~arg2 ~arg2_ty - ~result_var + let reachable, env_extension, dacc = + simplifier dacc ~original_term dbg ~arg1 ~arg1_ty ~arg2 ~arg2_ty + ~result_var + in + reachable, env_extension, [arg1; arg2], dacc diff --git a/middle_end/flambda/simplify/simplify_binary_primitive.mli b/middle_end/flambda/simplify/simplify_binary_primitive.mli index 4b04d4415632..4ee5cd9479f1 100644 --- a/middle_end/flambda/simplify/simplify_binary_primitive.mli +++ b/middle_end/flambda/simplify/simplify_binary_primitive.mli @@ -25,4 +25,5 @@ val simplify_binary_primitive -> Simple.t -> Debuginfo.t -> result_var:Var_in_binding_pos.t - -> Reachable.t * Flambda_type.Typing_env_extension.t * Downwards_acc.t + -> Reachable.t * Flambda_type.Typing_env_extension.t + * Simple.t list * Downwards_acc.t diff --git a/middle_end/flambda/simplify/simplify_common.ml b/middle_end/flambda/simplify/simplify_common.ml index 38a8720c606a..166cd0d94116 100644 --- a/middle_end/flambda/simplify/simplify_common.ml +++ b/middle_end/flambda/simplify/simplify_common.ml @@ -28,7 +28,7 @@ let simplify_projection dacc ~original_term ~deconstructing ~shape ~result_var type cse = | Invalid of T.t - | Applied of (Reachable.t * TEE.t * DA.t) + | Applied of (Reachable.t * TEE.t * Simple.t list * DA.t) | Not_applied of DA.t let apply_cse dacc ~original_prim = @@ -43,7 +43,7 @@ let apply_cse dacc ~original_prim = | exception Not_found -> None | simple -> Some simple -let try_cse dacc ~original_prim ~result_kind ~min_name_mode +let try_cse dacc ~original_prim ~result_kind ~min_name_mode ~args ~result_var : cse = (* CR mshinwell: Use [meet] and [reify] for CSE? (discuss with lwhite) *) if not (Name_mode.equal min_name_mode Name_mode.normal) then Not_applied dacc @@ -53,7 +53,7 @@ let try_cse dacc ~original_prim ~result_kind ~min_name_mode let named = Named.create_simple replace_with in let ty = T.alias_type_of result_kind replace_with in let env_extension = TEE.one_equation (Name.var result_var) ty in - Applied (Reachable.reachable named, env_extension, dacc) + Applied (Reachable.reachable named, env_extension, args, dacc) | None -> let dacc = match P.Eligible_for_cse.create original_prim with @@ -342,24 +342,163 @@ let create_let_symbols uacc (scoping_rule : Symbol_scoping_rule.t) code_age_relation lifted_constant body = let bound_symbols = LC.bound_symbols lifted_constant in let defining_exprs = LC.defining_exprs lifted_constant in + let symbol_projections = LC.symbol_projections lifted_constant in let static_consts = defining_exprs |> Static_const.Group.to_list |> remove_unused_closure_vars_list uacc |> Static_const.Group.create in - match scoping_rule with - | Syntactic -> - create_let_symbol0 uacc code_age_relation bound_symbols static_consts body - | Dominator -> - let expr = - Expr.create_let_symbol bound_symbols scoping_rule static_consts body - in - let uacc = - Static_const.Group.pieces_of_code_by_code_id defining_exprs - |> UA.remember_code_for_cmx uacc - in - expr, uacc + let expr, uacc = + match scoping_rule with + | Syntactic -> + create_let_symbol0 uacc code_age_relation bound_symbols static_consts body + | Dominator -> + let expr = + Expr.create_let_symbol bound_symbols scoping_rule static_consts body + in + let uacc = + Static_const.Group.pieces_of_code_by_code_id defining_exprs + |> UA.remember_code_for_cmx uacc + in + expr, uacc + in + (* + if not (Variable.Map.is_empty symbol_projections) then begin + Format.eprintf "PLACING Constant:@ %a@ \nProjections:@ %a\n%!" + LC.print lifted_constant + (Variable.Map.print Symbol_projection.print) symbol_projections + end; + *) + let expr = + Variable.Map.fold (fun var proj expr -> + let rec apply_projection proj = + match LC.apply_projection lifted_constant proj with + | Some simple -> + (* If the projection is from one of the symbols bound by the + "let symbol" that we've just created, we'll always end up here, + avoiding any problem about where to do the projection versus + the initialisation of a possibly-recursive group of symbols. + We may end up with a "variable = variable" [Let] here, but + [Un_cps] (or a subsequent pass of [Simplify]) will remove it. + This is the same situation as when continuations are inlined; + we can't use a name permutation to resolve the problem as both + [var] and [var'] may occur in [expr], and permuting could cause + an unbound name. + It is possible for one projection to yield a variable that is + in turn defined by another symbol projection, so we need to + expand transitively. *) + Simple.pattern_match' simple + ~const:(fun _ -> Named.create_simple simple) + ~symbol:(fun _ -> Named.create_simple simple) + ~var:(fun var -> + match Variable.Map.find var symbol_projections with + | exception Not_found -> Named.create_simple simple + | proj -> apply_projection proj) + | None -> + let prim : P.t = + let symbol = Simple.symbol (Symbol_projection.symbol proj) in + match Symbol_projection.projection proj with + | Block_load { index; } -> + let index = Simple.const_int index in + let block_access_kind : P.Block_access_kind.t = + Values { + tag = Tag.Scannable.zero; + size = Unknown; + field_kind = Any_value; + } + in + Binary (Block_load (block_access_kind, Immutable), symbol, + index) + | Project_var { project_from; var; } -> + Unary (Project_var { project_from; var; }, symbol) + in + Named.create_prim prim Debuginfo.none + in + (* It's possible that this might create duplicates of the same + projection operation, but it's unlikely there will be a + significant number, and since we're at toplevel we tolerate + them. *) + let named = apply_projection proj in + Expr.create_let (Var_in_binding_pos.create var NM.normal) named expr) + symbol_projections + expr + in + expr, uacc + +let place_lifted_constants uacc (scoping_rule : Symbol_scoping_rule.t) + ~lifted_constants_from_defining_expr ~lifted_constants_from_body + ~put_bindings_around_body ~body ~critical_deps_of_bindings = + let calculate_constants_to_place lifted_constants ~critical_deps + ~to_float = + (* If we are at a [Dominator]-scoped binding, then we float up + as many constants as we can whose definitions are fully static + (i.e. do not involve variables) to the nearest enclosing + [Syntactic]ally-scoped [Let]-binding. This is done by peeling + off the definitions starting at the outermost one. We keep + track of the "critical dependencies", which are those symbols + that are definitely going to have their definitions placed at + the current [Let]-binding, and any reference to which in another + binding (even if fully static) will cause that binding to be + placed too. *) + (* CR-soon mshinwell: This won't be needed once we can remove + [Dominator]-scoped bindings; every "let symbol" can then have + [Dominator] scoping. This should both simplify the code and + increase speed a fair bit. *) + match scoping_rule with + | Syntactic -> + lifted_constants, to_float, critical_deps + | Dominator -> + LCS.fold_outermost_first lifted_constants + ~init:(LCS.empty, to_float, critical_deps) + ~f:(fun (to_place, to_float, critical_deps) lifted_const -> + let must_place = + (not (LC.is_fully_static lifted_const)) + || Name_occurrences.inter_domain_is_non_empty critical_deps + (LC.free_names_of_defining_exprs lifted_const) + in + if must_place then + let critical_deps = + LC.bound_symbols lifted_const + |> Bound_symbols.free_names + |> Name_occurrences.union critical_deps + in + let to_place = LCS.add_innermost to_place lifted_const in + to_place, to_float, critical_deps + else + let to_float = LCS.add_innermost to_float lifted_const in + to_place, to_float, critical_deps) + in + (* We handle constants arising from the defining expression, which + may be used in [bindings], separately from those arising from the + [body], which may reference the [bindings]. *) + let to_place_around_defining_expr, to_float, critical_deps = + calculate_constants_to_place lifted_constants_from_defining_expr + ~critical_deps:Name_occurrences.empty ~to_float:LCS.empty + in + let critical_deps = + (* Make sure we don't move constants past the binding(s) if there + is a dependency. *) + Name_occurrences.union critical_deps critical_deps_of_bindings + in + let to_place_around_body, to_float, _critical_deps = + calculate_constants_to_place lifted_constants_from_body + ~critical_deps ~to_float + in + (* Propagate constants that are to float upwards. *) + let uacc = UA.with_lifted_constants uacc to_float in + (* Place constants whose definitions must go at the current binding. *) + let place_constants uacc ~around constants = + LCS.fold_innermost_first constants ~init:(around, uacc) + ~f:(fun (body, uacc) lifted_const -> + create_let_symbols uacc scoping_rule + (UA.code_age_relation uacc) lifted_const body) + in + let body, uacc = + place_constants uacc ~around:body to_place_around_body + in + let body = put_bindings_around_body ~body in + place_constants uacc ~around:body to_place_around_defining_expr (* generate the projection of the i-th field of a n-tuple *) let project_tuple ~dbg ~size ~field tuple = diff --git a/middle_end/flambda/simplify/simplify_common.mli b/middle_end/flambda/simplify/simplify_common.mli index 2854b3115f00..635c67a28be5 100644 --- a/middle_end/flambda/simplify/simplify_common.mli +++ b/middle_end/flambda/simplify/simplify_common.mli @@ -29,8 +29,11 @@ val simplify_projection type cse = | Invalid of Flambda_type.t + (* CR mshinwell: Use a record type for the following and all of the + simplify_*primitive.mli files *) | Applied of - (Reachable.t * Flambda_type.Typing_env_extension.t * Downwards_acc.t) + (Reachable.t * Flambda_type.Typing_env_extension.t + * Simple.t list * Downwards_acc.t) | Not_applied of Downwards_acc.t val try_cse @@ -38,6 +41,7 @@ val try_cse -> original_prim:Flambda_primitive.t -> result_kind:Flambda_kind.t -> min_name_mode:Name_mode.t + -> args:Simple.t list -> result_var:Variable.t -> cse @@ -85,6 +89,16 @@ val create_let_symbols -> Flambda.Expr.t -> Flambda.Expr.t * Upwards_acc.t +val place_lifted_constants + : Upwards_acc.t + -> Symbol_scoping_rule.t + -> lifted_constants_from_defining_expr:Simplify_envs.Lifted_constant_state.t + -> lifted_constants_from_body:Simplify_envs.Lifted_constant_state.t + -> put_bindings_around_body:(body:Flambda.Expr.t -> Flambda.Expr.t) + -> body:Flambda.Expr.t + -> critical_deps_of_bindings:Name_occurrences.t + -> Flambda.Expr.t * Upwards_acc.t + (** Create the projection of a tuple (assumed to be a size-tuple of ocaml values. *) val project_tuple diff --git a/middle_end/flambda/simplify/simplify_expr.rec.ml b/middle_end/flambda/simplify/simplify_expr.rec.ml index 1c9de6132a26..b89a8032a319 100644 --- a/middle_end/flambda/simplify/simplify_expr.rec.ml +++ b/middle_end/flambda/simplify/simplify_expr.rec.ml @@ -101,80 +101,21 @@ let rec simplify_let Option.value ~default:Symbol_scoping_rule.Dominator (Bindable_let_bound.let_symbol_scoping_rule bindable_let_bound) in - let calculate_constants_to_place lifted_constants ~critical_deps - ~to_float = - (* If we are at a [Dominator]-scoped binding, then we float up - as many constants as we can whose definitions are fully static - (i.e. do not involve variables) to the nearest enclosing - [Syntactic]ally-scoped [Let]-binding. This is done by peeling - off the definitions starting at the outermost one. We keep - track of the "critical dependencies", which are those symbols - that are definitely going to have their definitions placed at - the current [Let]-binding, and any reference to which in another - binding (even if fully static) will cause that binding to be - placed too. *) - (* CR-soon mshinwell: This won't be needed once we can remove - [Dominator]-scoped bindings; every "let symbol" can then have - [Dominator] scoping. This should both simplify the code and - increase speed a fair bit. *) - match scoping_rule with - | Syntactic -> - lifted_constants, to_float, critical_deps - | Dominator -> - LCS.fold_outermost_first lifted_constants - ~init:(LCS.empty, to_float, critical_deps) - ~f:(fun (to_place, to_float, critical_deps) lifted_const -> - let must_place = - (not (LC.is_fully_static lifted_const)) - || Name_occurrences.inter_domain_is_non_empty critical_deps - (LC.free_names_of_defining_exprs lifted_const) - in - if must_place then - let critical_deps = - LC.bound_symbols lifted_const - |> Bound_symbols.free_names - |> Name_occurrences.union critical_deps - in - let to_place = LCS.add_innermost to_place lifted_const in - to_place, to_float, critical_deps - else - let to_float = LCS.add_innermost to_float lifted_const in - to_place, to_float, critical_deps) - in - (* We handle constants arising from the defining expression, which - may be used in [bindings], separately from those arising from the - [body], which may reference the [bindings]. *) - let to_place_around_defining_expr, to_float, critical_deps = - calculate_constants_to_place lifted_constants_from_defining_expr - ~critical_deps:Name_occurrences.empty ~to_float:LCS.empty - in - let critical_deps = - (* Make sure we don't move constants past the [bindings] if there - is a dependency. *) - ListLabels.fold_left bindings ~init:critical_deps + let critical_deps_of_bindings = + ListLabels.fold_left bindings ~init:Name_occurrences.empty ~f:(fun critical_deps (bound, _) -> Name_occurrences.union (Bindable_let_bound.free_names bound) critical_deps) in - let to_place_around_body, to_float, _critical_deps = - calculate_constants_to_place lifted_constants_from_body - ~critical_deps ~to_float - in - (* Propagate constants that are to float upwards. *) - let uacc = UA.with_lifted_constants uacc to_float in - (* Place constants whose definitions must go at the current [Let]. *) - let place_constants uacc ~around constants = - LCS.fold_innermost_first constants ~init:(around, uacc) - ~f:(fun (body, uacc) lifted_const -> - Simplify_common.create_let_symbols uacc scoping_rule - (UA.code_age_relation uacc) lifted_const body) - in - let body, uacc = - place_constants uacc ~around:body to_place_around_body - in - let body = Simplify_common.bind_let_bound ~bindings ~body in let body, uacc = - place_constants uacc ~around:body to_place_around_defining_expr + Simplify_common.place_lifted_constants uacc + scoping_rule + ~lifted_constants_from_defining_expr + ~lifted_constants_from_body + ~put_bindings_around_body:(fun ~body -> + Simplify_common.bind_let_bound ~bindings ~body) + ~body + ~critical_deps_of_bindings in body, user_data, uacc end) @@ -182,6 +123,7 @@ let rec simplify_let and simplify_one_continuation_handler : 'a. DA.t -> Continuation.t + -> at_unit_toplevel:bool -> Recursive.t -> CH.t -> params:KP.t list @@ -189,7 +131,8 @@ and simplify_one_continuation_handler : -> extra_params_and_args:Continuation_extra_params_and_args.t -> 'a k -> Continuation_handler.t * 'a * UA.t -= fun dacc cont (recursive : Recursive.t) (cont_handler : CH.t) ~params += fun dacc cont ~at_unit_toplevel + (recursive : Recursive.t) (cont_handler : CH.t) ~params ~(handler : Expr.t) ~(extra_params_and_args : EPA.t) k -> (* Format.eprintf "handler:@.%a@." @@ -246,9 +189,24 @@ Format.eprintf "About to simplify handler %a, params %a, EPA %a\n%!" KP.List.print used_extra_params in *) + let params' = used_params @ used_extra_params in + let handler, uacc = + (* We might need to place lifted constants now, as they could + depend on continuation parameters. *) + if (not at_unit_toplevel) + || List.compare_length_with params' 0 = 0 + then handler, uacc + else + Simplify_common.place_lifted_constants uacc + Dominator + ~lifted_constants_from_defining_expr:LCS.empty + ~lifted_constants_from_body:(UA.lifted_constants uacc) + ~put_bindings_around_body:(fun ~body -> body) + ~body:handler + ~critical_deps_of_bindings:(KP.List.free_names params') + in let handler = - let params = used_params @ used_extra_params in - CH.with_params_and_handler cont_handler (CPH.create params ~handler) + CH.with_params_and_handler cont_handler (CPH.create params' ~handler) in let rewrite = Apply_cont_rewrite.create ~original_params:params @@ -314,7 +272,8 @@ and simplify_non_recursive_let_cont_handler let is_exn_handler = CH.is_exn_handler cont_handler in CPH.pattern_match params_and_handler ~f:(fun params ~handler -> let denv_before_body = - DE.add_parameters_with_unknown_types (DA.denv dacc) params + DE.add_parameters_with_unknown_types ~at_unit_toplevel + (DA.denv dacc) params in let dacc_for_body = DE.increment_continuation_scope_level denv_before_body @@ -441,7 +400,8 @@ and simplify_non_recursive_let_cont_handler in try let handler, user_data, uacc = - simplify_one_continuation_handler dacc cont Non_recursive + simplify_one_continuation_handler dacc cont + ~at_unit_toplevel Non_recursive cont_handler ~params ~handler ~extra_params_and_args k in handler, user_data, uacc, is_single_inlinable_use, @@ -553,7 +513,8 @@ and simplify_recursive_let_cont_handlers let denv, arg_types = (* XXX These don't have the same scope level as the non-recursive case *) - DE.add_parameters_with_unknown_types' definition_denv params + DE.add_parameters_with_unknown_types' + ~at_unit_toplevel:false definition_denv params in (* CR mshinwell: This next part is dubious, use the rewritten version in the recursive-continuation-unboxing branch. *) @@ -588,7 +549,8 @@ and simplify_recursive_let_cont_handlers let dacc = DA.add_lifted_constants dacc prior_lifted_constants in let dacc = DA.map_denv dacc ~f:DE.set_not_at_unit_toplevel in let handler, user_data, uacc = - simplify_one_continuation_handler dacc cont Recursive + simplify_one_continuation_handler dacc cont + ~at_unit_toplevel:false Recursive cont_handler ~params ~handler ~extra_params_and_args: Continuation_extra_params_and_args.empty diff --git a/middle_end/flambda/simplify/simplify_named.rec.ml b/middle_end/flambda/simplify/simplify_named.rec.ml index 7362e6e04c69..30fb36e3f366 100644 --- a/middle_end/flambda/simplify/simplify_named.rec.ml +++ b/middle_end/flambda/simplify/simplify_named.rec.ml @@ -14,7 +14,7 @@ (* *) (**************************************************************************) -[@@@ocaml.warning "+a-30-40-41-42"] +[@@@ocaml.warning "+a-4-30-40-41-42"] open! Simplify_import @@ -26,6 +26,122 @@ type simplify_named_result = { let bindings_result bindings_outermost_first dacc = { bindings_outermost_first; dacc; } +let record_any_symbol_projection dacc (defining_expr : Reachable.t) + (prim : P.t) args bindable_let_bound ~bound_var named = + (* Projections from symbols bound to variables are important to remember, + since if such a variable occurs in a set of closures environment or + other value that can potentially be lifted, the knowledge that the + variable is equal to a symbol projection can make the difference between + being able to lift and not being able to lift. We try to avoid + recording symbol projections whose answer is known (in particular the + answer is a symbol or a constant), since such symbol projection + knowledge doesn't affect lifting decisions. *) + let can_record_proj = + (* We only need to record a projection if the defining expression remains + as a [Prim]. In particular if the defining expression simplified to + a variable (via the [Simple] constructor), then in the event that the + variable is itself a symbol projection, the environment will already + know this fact. + We don't need to record a projection if we are currently at toplevel, + since any variable involved in a constant to be lifted from that + position will also be at toplevel. *) + (not (DE.at_unit_toplevel (DA.denv dacc))) + && match defining_expr with + | Reachable (Prim _) -> true + | Reachable (Simple _ | Set_of_closures _ | Static_consts _) + | Invalid _ -> false + in + let proj = + let module SP = Symbol_projection in + (* The [args] being queried here are the post-simplification arguments + of the primitive, so we can directly read off whether they are + symbols or constants, as needed. *) + match prim with + | Unary (Project_var { project_from; var; }, _) + when can_record_proj -> + begin match args with + | [closure] -> + Simple.pattern_match' closure + ~const:(fun _ -> None) + ~symbol:(fun symbol_projected_from -> + Some (SP.create symbol_projected_from + (SP.Projection.project_var project_from var))) + ~var:(fun _ -> None) + | [] | _::_ -> + Misc.fatal_errorf "Expected one argument:@ %a@ =@ %a" + Bindable_let_bound.print bindable_let_bound + Named.print named + end + | Binary (Block_load _, _, _) when can_record_proj -> + begin match args with + | [block; index] -> + Simple.pattern_match index + ~const:(fun const -> + match Reg_width_const.descr const with + | Tagged_immediate imm -> + Simple.pattern_match' block + ~const:(fun _ -> None) + ~symbol:(fun symbol_projected_from -> + let index = Target_imm.to_targetint imm in + Some (SP.create symbol_projected_from + (SP.Projection.block_load ~index))) + ~var:(fun _ -> None) + | Naked_immediate _ | Naked_float _ + | Naked_int32 _ | Naked_int64 _ | Naked_nativeint _ -> + Misc.fatal_errorf "Kind error for [Block_load] index:@ \ + %a@ =@ %a" + Bindable_let_bound.print bindable_let_bound + Named.print named) + ~name:(fun _ -> None) + | [] | _::_ -> + Misc.fatal_errorf "Expected two arguments:@ %a@ =@ %a" + Bindable_let_bound.print bindable_let_bound + Named.print named + end + | Unary ( + ( Duplicate_block _ + | Duplicate_array _ + | Is_int + | Get_tag + | Array_length _ + | Bigarray_length _ + | String_length _ + | Int_as_pointer + | Opaque_identity + | Int_arith _ + | Float_arith _ + | Num_conv _ + | Boolean_not + | Unbox_number _ + | Box_number _ + | Select_closure _ + | Project_var _ ), _) + | Binary ( + ( Block_load _ + | Array_load _ + | String_or_bigstring_load _ + | Bigarray_load _ + | Phys_equal _ + | Int_arith _ + | Int_shift _ + | Int_comp _ + | Float_arith _ + | Float_comp _ ), _, _) + | Ternary ( + ( Block_set _ + | Array_set _ + | Bytes_or_bigstring_set _ + | Bigarray_set _ ), _, _, _) + | Variadic ( + ( Make_block _ + | Make_array _ ), _) -> None + in + match proj with + | None -> dacc + | Some proj -> + let var = Var_in_binding_pos.var bound_var in + DA.map_denv dacc ~f:(fun denv -> DE.add_symbol_projection denv var proj) + let simplify_named0 dacc (bindable_let_bound : Bindable_let_bound.t) (named : Named.t) = match named with @@ -47,7 +163,12 @@ let simplify_named0 dacc (bindable_let_bound : Bindable_let_bound.t) end | Prim (prim, dbg) -> let bound_var = Bindable_let_bound.must_be_singleton bindable_let_bound in - let term, env_extension, dacc = + let term, env_extension, simplified_args, dacc = + (* [simplified_args] has to be returned from [simplify_primitive] because + in at least one case (for [Project_var]), the simplifier may return + something other than a [Prim] as the [term]. However we need the + simplified arguments of the actual primitive for the symbol + projection check below. *) Simplify_primitive.simplify_primitive dacc ~original_named:named prim dbg ~result_var:bound_var in @@ -62,7 +183,15 @@ let simplify_named0 dacc (bindable_let_bound : Bindable_let_bound.t) Without this check, we could end up lifting definitions that have a type that looks like an allocation but that are instead a projection from a bigger structure. *) - let allow_lifting = P.only_generative_effects prim in + let allow_lifting = + (* CR mshinwell: We probably shouldn't lift if the let binding is going + to be deleted, as lifting may cause [Dominator]-scoped bindings to + be inserted, that cannot be deleted. However this situation probably + doesn't arise that much, and won't be an issue once we can lift + [Dominator]-scoped bindings. *) + P.only_generative_effects prim + && Name_mode.is_normal (Var_in_binding_pos.name_mode bound_var) + in let defining_expr, dacc, ty = Reification.try_to_reify dacc term ~bound_to:bound_var ~allow_lifting in @@ -70,32 +199,11 @@ let simplify_named0 dacc (bindable_let_bound : Bindable_let_bound.t) if T.is_bottom (DA.typing_env dacc) ty then Reachable.invalid () else defining_expr in - if DE.at_unit_toplevel (DA.denv dacc) - && allow_lifting - && Name_mode.is_normal (Var_in_binding_pos.name_mode bound_var) - then begin - match - Lift_inconstants.reify_primitive_at_toplevel dacc bound_var ty - with - | Cannot_reify -> - bindings_result [bindable_let_bound, defining_expr] dacc - | Shared symbol -> - let defining_expr = - Reachable.reachable (Named.create_simple (Simple.symbol symbol)) - in - bindings_result [bindable_let_bound, defining_expr] dacc - | Lift { symbol; static_const; } -> - let dacc = - LC.create_block_like symbol static_const (DA.denv dacc) ty - |> DA.add_lifted_constant_also_to_env dacc - in - let defining_expr = - Reachable.reachable (Named.create_simple (Simple.symbol symbol)) - in - bindings_result [bindable_let_bound, defining_expr] dacc - end - else - bindings_result [bindable_let_bound, defining_expr] dacc + let dacc = + record_any_symbol_projection dacc defining_expr prim simplified_args + bindable_let_bound ~bound_var named + in + bindings_result [bindable_let_bound, defining_expr] dacc | Set_of_closures set_of_closures -> let bindings, dacc = Simplify_set_of_closures.simplify_non_lifted_set_of_closures dacc @@ -173,7 +281,11 @@ let simplify_named0 dacc (bindable_let_bound : Bindable_let_bound.t) let typ = TE.find (DA.typing_env dacc) (Name.symbol symbol) (Some K.value) in - LC.create_block_like symbol static_const (DA.denv dacc) typ + (* The [symbol_projections] map is empty because we only introduce + symbol projections when lifting -- and [static_const] has + already been lifted. *) + LC.create_block_like symbol static_const (DA.denv dacc) + ~symbol_projections:Variable.Map.empty typ | Code code_id -> LC.create_code code_id static_const | Set_of_closures closure_symbols -> let closure_symbols_with_types = @@ -186,6 +298,8 @@ let simplify_named0 dacc (bindable_let_bound : Bindable_let_bound.t) in LC.create_set_of_closures (DA.denv dacc) ~closure_symbols_with_types + (* Same comment as above re. [symbol_projections]. *) + ~symbol_projections:Variable.Map.empty static_const) in let dacc = DA.add_lifted_constant dacc (LC.concat lifted_constants) in diff --git a/middle_end/flambda/simplify/simplify_primitive.mli b/middle_end/flambda/simplify/simplify_primitive.mli index 3a1883468acb..fad471e0d447 100644 --- a/middle_end/flambda/simplify/simplify_primitive.mli +++ b/middle_end/flambda/simplify/simplify_primitive.mli @@ -24,4 +24,5 @@ val simplify_primitive -> Flambda_primitive.t -> Debuginfo.t -> result_var:Var_in_binding_pos.t - -> Reachable.t * Flambda_type.Typing_env_extension.t * Downwards_acc.t + -> Reachable.t * Flambda_type.Typing_env_extension.t + * Simple.t list * Downwards_acc.t diff --git a/middle_end/flambda/simplify/simplify_set_of_closures.rec.ml b/middle_end/flambda/simplify/simplify_set_of_closures.rec.ml index 8cea3a4df91c..aa7a8451a9c6 100644 --- a/middle_end/flambda/simplify/simplify_set_of_closures.rec.ml +++ b/middle_end/flambda/simplify/simplify_set_of_closures.rec.ml @@ -551,7 +551,8 @@ let simplify_set_of_closures0 dacc context set_of_closures } let simplify_and_lift_set_of_closures dacc ~closure_bound_vars_inverse - ~closure_bound_vars set_of_closures ~closure_elements = + ~closure_bound_vars set_of_closures ~closure_elements + ~symbol_projections = let function_decls = Set_of_closures.function_decls set_of_closures in let closure_symbols = Closure_id.Lmap.mapi (fun closure_id _func_decl -> @@ -586,7 +587,7 @@ let simplify_and_lift_set_of_closures dacc ~closure_bound_vars_inverse Closure_id.Map.find closure_id closure_symbols_map in T.alias_type_of K.value (Simple.symbol closure_symbol)) - ~symbol:(fun _sym -> T.alias_type_of K.value closure_element))) + ~symbol:(fun _sym -> T.alias_type_of K.value closure_element))) closure_elements in let context = @@ -636,6 +637,7 @@ let simplify_and_lift_set_of_closures dacc ~closure_bound_vars_inverse Lifted_constant.create_set_of_closures denv ~closure_symbols_with_types + ~symbol_projections (Set_of_closures set_of_closures) in let dacc = @@ -711,6 +713,7 @@ type lifting_decision_result = { can_lift : bool; closure_elements : Simple.t Var_within_closure.Map.t; closure_element_types : T.t Var_within_closure.Map.t; + symbol_projections : Symbol_projection.t Variable.Map.t; } let type_closure_elements_and_make_lifting_decision_for_one_set dacc @@ -722,48 +725,69 @@ let type_closure_elements_and_make_lifting_decision_for_one_set dacc from the fact that closure elements cannot be deleted without a global analysis, as an inlined function's body may reference them out of scope of the closure declaration. *) - let closure_elements, closure_element_types = + let closure_elements, closure_element_types, symbol_projections = Var_within_closure.Map.fold - (fun closure_var simple (closure_elements, closure_element_types) -> - let simple, ty = - match S.simplify_simple dacc simple ~min_name_mode with + (fun closure_var env_entry + (closure_elements, closure_element_types, symbol_projections) -> + let env_entry, ty, symbol_projections = + match S.simplify_simple dacc env_entry ~min_name_mode with | Bottom, ty -> assert (K.equal (T.kind ty) K.value); - simple, ty - | Ok simple, ty -> simple, ty + env_entry, ty, symbol_projections + | Ok simple, ty -> + (* Note down separately if [simple] remains a variable and is known + to be equal to a projection from a symbol. *) + let symbol_projections = + Simple.pattern_match' simple + ~const:(fun _ -> symbol_projections) + ~symbol:(fun _ -> symbol_projections) + ~var:(fun var -> + (* [var] will already be canonical, as we require for the + symbol projections map. *) + match DE.find_symbol_projection (DA.denv dacc) var with + | None -> symbol_projections + | Some proj -> + Variable.Map.add var proj symbol_projections) + in + simple, ty, symbol_projections in let closure_elements = - Var_within_closure.Map.add closure_var simple closure_elements + Var_within_closure.Map.add closure_var env_entry closure_elements in let closure_element_types = Var_within_closure.Map.add closure_var ty closure_element_types in - closure_elements, closure_element_types) + closure_elements, closure_element_types, symbol_projections) (Set_of_closures.closure_elements set_of_closures) - (Var_within_closure.Map.empty, Var_within_closure.Map.empty) + (Var_within_closure.Map.empty, Var_within_closure.Map.empty, + Variable.Map.empty) in (* Note that [closure_bound_vars_inverse] doesn't need to include variables binding closures in other mutually-recursive sets, since if we get here in the case where we are considering lifting a set that has not been lifted before, there are never any other mutually-recursive sets ([Named.t] does not allow them). *) - let can_lift_even_if_not_at_toplevel = - Var_within_closure.Map.for_all (fun _ simple -> - Simple.pattern_match simple + let can_lift = + Var_within_closure.Map.for_all + (fun _ simple -> + Simple.pattern_match' simple ~const:(fun _ -> true) - ~name:(fun name -> - Name.pattern_match name - ~var:(fun var -> Variable.Map.mem var closure_bound_vars_inverse) - ~symbol:(fun _sym -> true))) + ~symbol:(fun _ -> true) + ~var:(fun var -> + DE.is_defined_at_toplevel (DA.denv dacc) var + || Variable.Map.mem var closure_bound_vars_inverse + (* If [var] is known to be a symbol projection, it doesn't + matter if it isn't in scope at the place where we will + eventually insert the "let symbol", as the binding to the + projection from the relevant symbol can always be + rematerialised. *) + || Variable.Map.mem var symbol_projections)) closure_elements in - let can_lift = - DE.at_unit_toplevel (DA.denv dacc) - || can_lift_even_if_not_at_toplevel - in { can_lift; closure_elements; closure_element_types; + symbol_projections; } let type_closure_elements_for_previously_lifted_set dacc @@ -795,13 +819,15 @@ let simplify_non_lifted_set_of_closures dacc closure_bound_vars in (* CR mshinwell: [closure_element_types] is barely worth keeping *) - let { can_lift; closure_elements; closure_element_types; } = + let { can_lift; closure_elements; closure_element_types; + symbol_projections; } = type_closure_elements_and_make_lifting_decision_for_one_set dacc ~min_name_mode ~closure_bound_vars_inverse set_of_closures in if can_lift then simplify_and_lift_set_of_closures dacc ~closure_bound_vars_inverse ~closure_bound_vars set_of_closures ~closure_elements + ~symbol_projections else simplify_non_lifted_set_of_closures0 dacc bound_vars ~closure_bound_vars set_of_closures ~closure_elements ~closure_element_types @@ -870,6 +896,7 @@ let simplify_lifted_sets_of_closures dacc ~all_sets_of_closures_and_symbols let { can_lift = _; closure_elements; closure_element_types; + symbol_projections = _; } = type_closure_elements_for_previously_lifted_set dacc ~min_name_mode:Name_mode.normal set_of_closures diff --git a/middle_end/flambda/simplify/simplify_ternary_primitive.ml b/middle_end/flambda/simplify/simplify_ternary_primitive.ml index 7c3bd64634f3..f0c7b7b1a4d4 100644 --- a/middle_end/flambda/simplify/simplify_ternary_primitive.ml +++ b/middle_end/flambda/simplify/simplify_ternary_primitive.ml @@ -37,7 +37,7 @@ let try_cse dacc prim arg1 arg2 arg3 ~min_name_mode ~result_var Ternary (prim, arg1, arg2, arg3) in Simplify_common.try_cse dacc ~original_prim ~result_kind - ~min_name_mode ~result_var + ~args:[arg1; arg2; arg3] ~min_name_mode ~result_var let simplify_ternary_primitive dacc (prim : P.ternary_primitive) arg1 arg2 arg3 dbg ~result_var = @@ -45,7 +45,7 @@ let simplify_ternary_primitive dacc (prim : P.ternary_primitive) let result_var' = Var_in_binding_pos.var result_var in let invalid ty = let env_extension = TEE.one_equation (Name.var result_var') ty in - Reachable.invalid (), env_extension, dacc + Reachable.invalid (), env_extension, [arg1; arg2; arg3], dacc in match try_cse dacc prim arg1 arg2 arg3 ~min_name_mode @@ -74,4 +74,4 @@ let simplify_ternary_primitive dacc (prim : P.ternary_primitive) in let ty = T.unknown result_kind in let env_extension = TEE.one_equation (Name.var result_var') ty in - Reachable.reachable named, env_extension, dacc + Reachable.reachable named, env_extension, [arg1; arg2; arg3], dacc diff --git a/middle_end/flambda/simplify/simplify_ternary_primitive.mli b/middle_end/flambda/simplify/simplify_ternary_primitive.mli index 2703762e2bb0..03f2e4a9a8c4 100644 --- a/middle_end/flambda/simplify/simplify_ternary_primitive.mli +++ b/middle_end/flambda/simplify/simplify_ternary_primitive.mli @@ -26,4 +26,5 @@ val simplify_ternary_primitive -> Simple.t -> Debuginfo.t -> result_var:Var_in_binding_pos.t - -> Reachable.t * Flambda_type.Typing_env_extension.t * Downwards_acc.t + -> Reachable.t * Flambda_type.Typing_env_extension.t + * Simple.t list * Downwards_acc.t diff --git a/middle_end/flambda/simplify/simplify_unary_primitive.ml b/middle_end/flambda/simplify/simplify_unary_primitive.ml index e15dbac74d8a..bb761dd2efef 100644 --- a/middle_end/flambda/simplify/simplify_unary_primitive.ml +++ b/middle_end/flambda/simplify/simplify_unary_primitive.ml @@ -449,7 +449,7 @@ let try_cse dacc prim arg ~min_name_mode ~result_var : Simplify_common.cse = | Ok arg, _arg_ty -> let original_prim : P.t = Unary (prim, arg) in Simplify_common.try_cse dacc ~original_prim ~result_kind - ~min_name_mode ~result_var + ~args:[arg] ~min_name_mode ~result_var let simplify_unary_primitive dacc (prim : P.unary_primitive) arg dbg ~result_var = @@ -457,7 +457,7 @@ let simplify_unary_primitive dacc (prim : P.unary_primitive) let result_var' = Var_in_binding_pos.var result_var in let invalid ty = let env_extension = TEE.one_equation (Name.var result_var') ty in - Reachable.invalid (), env_extension, dacc + Reachable.invalid (), env_extension, [arg], dacc in match try_cse dacc prim arg ~min_name_mode ~result_var:result_var' with | Invalid ty -> invalid ty @@ -515,4 +515,7 @@ let simplify_unary_primitive dacc (prim : P.unary_primitive) let env_extension = TEE.one_equation (Name.var result_var') ty in Reachable.reachable named, env_extension, dacc in - simplifier dacc ~original_term ~arg ~arg_ty ~result_var + let reachable, env_extension, dacc = + simplifier dacc ~original_term ~arg ~arg_ty ~result_var + in + reachable, env_extension, [arg], dacc diff --git a/middle_end/flambda/simplify/simplify_unary_primitive.mli b/middle_end/flambda/simplify/simplify_unary_primitive.mli index 1a9ac97ee646..d44f08c16807 100644 --- a/middle_end/flambda/simplify/simplify_unary_primitive.mli +++ b/middle_end/flambda/simplify/simplify_unary_primitive.mli @@ -24,4 +24,5 @@ val simplify_unary_primitive -> Simple.t -> Debuginfo.t -> result_var:Var_in_binding_pos.t - -> Reachable.t * Flambda_type.Typing_env_extension.t * Downwards_acc.t + -> Reachable.t * Flambda_type.Typing_env_extension.t + * Simple.t list * Downwards_acc.t diff --git a/middle_end/flambda/simplify/simplify_variadic_primitive.ml b/middle_end/flambda/simplify/simplify_variadic_primitive.ml index 2066348fed8b..03dddabe6ff8 100644 --- a/middle_end/flambda/simplify/simplify_variadic_primitive.ml +++ b/middle_end/flambda/simplify/simplify_variadic_primitive.ml @@ -26,7 +26,7 @@ let simplify_make_block_of_values dacc _prim dbg tag ~shape let invalid () = let ty = T.bottom K.value in let env_extension = TEE.one_equation (Name.var result_var) ty in - Reachable.invalid (), env_extension, dacc + Reachable.invalid (), env_extension, args, dacc in if List.compare_lengths shape args <> 0 then begin (* CR mshinwell: improve message *) @@ -69,7 +69,7 @@ let simplify_make_block_of_values dacc _prim dbg tag ~shape | Mutable -> T.any_value () in let env_extension = TEE.one_equation (Name.var result_var) ty in - Reachable.reachable term, env_extension, dacc + Reachable.reachable term, env_extension, args, dacc end let try_cse dacc ~original_prim prim args ~min_name_mode ~result_var @@ -87,7 +87,7 @@ let try_cse dacc ~original_prim prim args ~min_name_mode ~result_var | Unchanged -> original_prim in Simplify_common.try_cse dacc ~original_prim ~result_kind - ~min_name_mode ~result_var + ~min_name_mode ~args ~result_var (* if Name_mode.is_phantom min_name_mode then * (\* If this is producing the defining expr of a phantom binding, @@ -111,7 +111,7 @@ let simplify_variadic_primitive dacc ~original_named ~original_prim let result_var' = Var_in_binding_pos.var result_var in let invalid ty = let env_extension = TEE.one_equation (Name.var result_var') ty in - Reachable.invalid (), env_extension, dacc + Reachable.invalid (), env_extension, args, dacc in match try_cse dacc ~original_prim prim args ~min_name_mode ~result_var:result_var' @@ -154,4 +154,4 @@ let simplify_variadic_primitive dacc ~original_named ~original_prim T.array_of_length ~length in let env_extension = TEE.one_equation (Name.var result_var') ty in - Reachable.reachable named, env_extension, dacc + Reachable.reachable named, env_extension, args, dacc diff --git a/middle_end/flambda/simplify/simplify_variadic_primitive.mli b/middle_end/flambda/simplify/simplify_variadic_primitive.mli index fd2e1f7fe39a..51f2bf3b2d88 100644 --- a/middle_end/flambda/simplify/simplify_variadic_primitive.mli +++ b/middle_end/flambda/simplify/simplify_variadic_primitive.mli @@ -26,4 +26,5 @@ val simplify_variadic_primitive -> Simple.t list -> Debuginfo.t -> result_var:Var_in_binding_pos.t - -> Reachable.t * Flambda_type.Typing_env_extension.t * Downwards_acc.t + -> Reachable.t * Flambda_type.Typing_env_extension.t + * Simple.t list * Downwards_acc.t diff --git a/middle_end/flambda/terms/function_declarations.ml b/middle_end/flambda/terms/function_declarations.ml index b9bc5d6a37f1..d02979964111 100644 --- a/middle_end/flambda/terms/function_declarations.ml +++ b/middle_end/flambda/terms/function_declarations.ml @@ -87,3 +87,6 @@ let filter t ~f = let funs = Closure_id.Map.filter f t.funs in let in_order = Closure_id.Lmap.filter f t.in_order in { funs; in_order; } + +let binds_closure_id t closure_id = + Closure_id.Map.mem closure_id t.funs diff --git a/middle_end/flambda/terms/function_declarations.mli b/middle_end/flambda/terms/function_declarations.mli index 764962890dc7..654b9047c3b5 100644 --- a/middle_end/flambda/terms/function_declarations.mli +++ b/middle_end/flambda/terms/function_declarations.mli @@ -58,6 +58,8 @@ val funs_in_order : t -> Function_declaration.t Closure_id.Lmap.t (** [find f t] raises [Not_found] if [f] is not in [t]. *) val find : t -> Closure_id.t -> Function_declaration.t +val binds_closure_id : t -> Closure_id.t -> bool + val compare : t -> t -> int val filter : t -> f:(Closure_id.t -> Function_declaration.t -> bool) -> t diff --git a/middle_end/flambda/terms/symbol_projection.ml b/middle_end/flambda/terms/symbol_projection.ml new file mode 100644 index 000000000000..9eb19cb3db8e --- /dev/null +++ b/middle_end/flambda/terms/symbol_projection.ml @@ -0,0 +1,107 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Mark Shinwell, Jane Street Europe *) +(* *) +(* Copyright 2020 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-30-40-41-42"] + +module Projection = struct + type t = + | Block_load of { index : Targetint.OCaml.t; } + | Project_var of { + project_from : Closure_id.t; + var : Var_within_closure.t; + } + + let block_load ~index = Block_load { index; } + let project_var project_from var = Project_var { project_from; var; } + + let hash t = + match t with + | Block_load { index; } -> Targetint.OCaml.hash index + | Project_var { project_from; var; } -> + Hashtbl.hash (Closure_id.hash project_from, Var_within_closure.hash var) + + let print ppf t = + match t with + | Block_load { index; } -> + Format.fprintf ppf "@[(Block_load@ \ + @[(index@ %a)@]\ + )@]" + Targetint.OCaml.print index + | Project_var { project_from; var; } -> + Format.fprintf ppf "@[(Project_var@ \ + @[(project_from@ %a)@]@ \ + @[(var@ %a)@]\ + )@]" + Closure_id.print project_from + Var_within_closure.print var + + let compare t1 t2 = + match t1, t2 with + | Block_load { index = index1; }, Block_load { index = index2; } -> + Targetint.OCaml.compare index1 index2 + | Project_var { project_from = project_from1; var = var1; }, + Project_var { project_from = project_from2; var = var2; } -> + let c = Closure_id.compare project_from1 project_from2 in + if c <> 0 then c + else Var_within_closure.compare var1 var2 + | Block_load _, Project_var _ -> -1 + | Project_var _, Block_load _ -> 1 +end + +type t = { + symbol : Symbol.t; + projection : Projection.t; +} + +let print ppf { symbol; projection; } = + Format.fprintf ppf "@[(\ + @[(symbol@ %a)@]@ \ + @[(projection@ %a)@]\ + )@]" + Symbol.print symbol + Projection.print projection + +let create symbol projection = + { symbol; + projection; + } + +let symbol t = t.symbol +let projection t = t.projection + +let compare { symbol = symbol1; projection = projection1; } + { symbol = symbol2; projection = projection2; } = + let c = Symbol.compare symbol1 symbol2 in + if c <> 0 then c + else Projection.compare projection1 projection2 + +let equal t1 t2 = + compare t1 t2 = 0 + +let hash { symbol; projection; } = + Hashtbl.hash (Symbol.hash symbol, Projection.hash projection) + +let apply_name_permutation ({ symbol = _; projection = _; } as t) _perm = t + +let free_names { symbol; projection = _; } = + Name_occurrences.singleton_symbol symbol Name_mode.normal + +let all_ids_for_export { symbol; projection = _; } = + Ids_for_export.singleton_symbol symbol + +let import import_map { symbol; projection; } = + let symbol = Ids_for_export.Import_map.symbol import_map symbol in + { symbol; + projection; + } diff --git a/middle_end/flambda/terms/symbol_projection.mli b/middle_end/flambda/terms/symbol_projection.mli new file mode 100644 index 000000000000..7372ae2c404d --- /dev/null +++ b/middle_end/flambda/terms/symbol_projection.mli @@ -0,0 +1,47 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Mark Shinwell, Jane Street Europe *) +(* *) +(* Copyright 2020 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-30-40-41-42"] + +module Projection : sig + type t = private + | Block_load of { index : Targetint.OCaml.t; } + | Project_var of { + project_from : Closure_id.t; + var : Var_within_closure.t; + } + + val block_load : index:Targetint.OCaml.t -> t + + val project_var : Closure_id.t -> Var_within_closure.t -> t +end + +type t + +val print : Format.formatter -> t -> unit + +val create : Symbol.t -> Projection.t -> t + +val symbol : t -> Symbol.t + +val projection : t -> Projection.t + +val compare : t -> t -> int + +val equal : t -> t -> bool + +val hash : t -> int + +include Contains_names.S with type t := t +include Contains_ids.S with type t := t diff --git a/middle_end/flambda/types/env/typing_env.rec.ml b/middle_end/flambda/types/env/typing_env.rec.ml index 092039bdb732..005b4700c12e 100644 --- a/middle_end/flambda/types/env/typing_env.rec.ml +++ b/middle_end/flambda/types/env/typing_env.rec.ml @@ -56,6 +56,12 @@ module Cached : sig val with_cse : t -> cse:Simple.t Flambda_primitive.Eligible_for_cse.Map.t -> t + val add_symbol_projection : t -> Variable.t -> Symbol_projection.t -> t + + val find_symbol_projection : t -> Variable.t -> Symbol_projection.t option + + val symbol_projections : t -> Symbol_projection.t Variable.Map.t + val clean_for_export : t -> reachable_names:Name_occurrences.t -> t val import : Ids_for_export.Import_map.t -> t -> t @@ -67,6 +73,7 @@ end = struct (Type_grammar.t * Binding_time.t * Name_mode.t) Name.Map.t; aliases : Aliases.t; cse : Simple.t Flambda_primitive.Eligible_for_cse.Map.t; + symbol_projections : Symbol_projection.t Variable.Map.t; } let print_kind_and_mode ppf (ty, _, mode) = @@ -113,11 +120,13 @@ end = struct { names_to_types = Name.Map.empty; aliases = Aliases.empty; cse = Flambda_primitive.Eligible_for_cse.Map.empty; + symbol_projections = Variable.Map.empty; } let names_to_types t = t.names_to_types let aliases t = t.aliases let cse t = t.cse + let symbol_projections t = t.symbol_projections (* CR mshinwell: At least before the following two functions were split (used to be add-or-replace), the [names_to_types] map addition was a @@ -130,6 +139,7 @@ end = struct { names_to_types; aliases = new_aliases; cse = t.cse; + symbol_projections = t.symbol_projections; } let replace_variable_binding t var ty ~new_aliases = @@ -142,10 +152,20 @@ end = struct { names_to_types; aliases = new_aliases; cse = t.cse; + symbol_projections = t.symbol_projections; } let with_cse t ~cse = { t with cse; } + let add_symbol_projection t var proj = + let symbol_projections = Variable.Map.add var proj t.symbol_projections in + { t with symbol_projections; } + + let find_symbol_projection t var = + match Variable.Map.find var t.symbol_projections with + | exception Not_found -> None + | proj -> Some proj + let clean_for_export t ~reachable_names = (* Two things happen: - All variables are existentialized (mode is switched to in_types) @@ -166,11 +186,12 @@ end = struct current_compilation_unit) names_to_types in + (* [t.cse] is not exported, so doesn't need cleaning. *) { t with names_to_types; } - let import import_map { names_to_types; aliases; cse; } = + let import import_map { names_to_types; aliases; cse; symbol_projections; } = let module Import = Ids_for_export.Import_map in let names_to_types = Name.Map.fold (fun name (ty, binding_time, mode) acc -> @@ -194,7 +215,15 @@ end = struct cse Flambda_primitive.Eligible_for_cse.Map.empty in - { names_to_types; aliases; cse } + let symbol_projections = + Variable.Map.fold (fun var proj acc -> + Variable.Map.add (Import.variable import_map var) + (Symbol_projection.import import_map proj) + acc) + symbol_projections + Variable.Map.empty + in + { names_to_types; aliases; cse; symbol_projections; } let merge t1 t2 = let names_to_types = @@ -232,7 +261,19 @@ end = struct ~name:cannot_merge) t1.cse t2.cse in - { names_to_types; aliases; cse; } + let symbol_projections = + Variable.Map.union (fun var proj1 proj2 -> + if Symbol_projection.equal proj1 proj2 then Some proj1 + else + Misc.fatal_errorf "Cannot merge symbol projections for %a:@ \ + %a@ and@ %a" + Variable.print var + Symbol_projection.print proj1 + Symbol_projection.print proj2) + t1.symbol_projections + t2.symbol_projections + in + { names_to_types; aliases; cse; symbol_projections; } end module One_level = struct @@ -364,6 +405,8 @@ module Serializable = struct }; } + (* CR mshinwell for vlaviron: Shouldn't some of this be in + [Cached.all_ids_for_export]? *) let all_ids_for_export { defined_symbols; code_age_relation; just_after_level; } = @@ -393,6 +436,16 @@ module Serializable = struct (Cached.cse just_after_level) ids in + let ids = + Variable.Map.fold (fun var proj ids -> + let ids = + Ids_for_export.union ids + (Symbol_projection.all_ids_for_export proj) + in + Ids_for_export.add_variable ids var) + (Cached.symbol_projections just_after_level) + ids + in ids let import import_map { defined_symbols; @@ -818,6 +871,20 @@ let rec add_symbol_definitions t syms = closure_env; } +let add_symbol_projection t var proj = + let level = + Typing_env_level.add_symbol_projection (One_level.level t.current_level) + var proj + in + let current_level = + One_level.create (current_scope t) level + ~just_after_level:(Cached.add_symbol_projection (cached t) var proj) + in + with_current_level t ~current_level + +let find_symbol_projection t var = + Cached.find_symbol_projection (cached t) var + let kind_of_simple t simple = let [@inline always] const const = Type_grammar.kind (Type_grammar.type_for_const const) @@ -1068,9 +1135,14 @@ and add_env_extension_from_level t level : t = (Typing_env_level.equations level) t in - Flambda_primitive.Eligible_for_cse.Map.fold (fun prim bound_to t -> - add_cse t prim ~bound_to) - (Typing_env_level.cse level) + let t = + Flambda_primitive.Eligible_for_cse.Map.fold (fun prim bound_to t -> + add_cse t prim ~bound_to) + (Typing_env_level.cse level) + t + in + Variable.Map.fold (fun var proj t -> add_symbol_projection t var proj) + (Typing_env_level.symbol_projections level) t and add_env_extension t env_extension = diff --git a/middle_end/flambda/types/env/typing_env.rec.mli b/middle_end/flambda/types/env/typing_env.rec.mli index c9a8a88466b0..eab107eae212 100644 --- a/middle_end/flambda/types/env/typing_env.rec.mli +++ b/middle_end/flambda/types/env/typing_env.rec.mli @@ -52,6 +52,10 @@ val add_symbol_definition : t -> Symbol.t -> t val add_symbol_definitions : t -> Symbol.Set.t -> t +val add_symbol_projection : t -> Variable.t -> Symbol_projection.t -> t + +val find_symbol_projection : t -> Variable.t -> Symbol_projection.t option + val add_equations_on_params : t -> params:Kinded_parameter.t list diff --git a/middle_end/flambda/types/env/typing_env_level.rec.ml b/middle_end/flambda/types/env/typing_env_level.rec.ml index d0b3108a2c23..7aa065573426 100644 --- a/middle_end/flambda/types/env/typing_env_level.rec.ml +++ b/middle_end/flambda/types/env/typing_env_level.rec.ml @@ -21,6 +21,7 @@ type t = { binding_times : Variable.Set.t Binding_time.Map.t; equations : Type_grammar.t Name.Map.t; cse : Simple.t Flambda_primitive.Eligible_for_cse.Map.t; + symbol_projections : Symbol_projection.t Variable.Map.t; } let defined_vars t = t.defined_vars @@ -38,7 +39,10 @@ let defines_name_but_no_equations t name = *) let print_with_cache ~cache ppf - { defined_vars; binding_times = _; equations; cse; } = + { defined_vars; binding_times = _; equations; cse; + symbol_projections = _; } = + (* CR mshinwell: print symbol projections along with tidying up this + function *) let print_equations ppf equations = let equations = Name.Map.bindings equations in match equations with @@ -106,7 +110,9 @@ let fold_on_defined_vars f t init = t.binding_times init -let apply_name_permutation ({ defined_vars; binding_times; equations; cse; } as t) +let apply_name_permutation + ({ defined_vars; binding_times; equations; cse; symbol_projections; } + as t) perm = let defined_vars_changed = ref false in let defined_vars' = @@ -159,6 +165,9 @@ let apply_name_permutation ({ defined_vars; binding_times; equations; cse; } as cse Flambda_primitive.Eligible_for_cse.Map.empty in + (* CR mshinwell: Maybe we should call + [Symbol_projection.apply_name_permutation] even though it currently + does nothing? *) if (not !defined_vars_changed) && (not !equations_changed) && (not !cse_changed) @@ -168,9 +177,11 @@ let apply_name_permutation ({ defined_vars; binding_times; equations; cse; } as binding_times = binding_times'; equations = equations'; cse = cse'; + symbol_projections; } -let free_names { defined_vars; binding_times = _; equations; cse; } = +let free_names + { defined_vars; binding_times = _; equations; cse; symbol_projections; } = let free_names_defined_vars = Name_occurrences.create_variables (Variable.Map.keys defined_vars) Name_mode.in_types @@ -185,38 +196,57 @@ let free_names { defined_vars; binding_times = _; equations; cse; } = equations free_names_defined_vars in - Flambda_primitive.Eligible_for_cse.Map.fold - (fun prim (bound_to : Simple.t) acc -> - Simple.pattern_match bound_to - ~const:(fun _ -> acc) - ~name:(fun name -> - let free_in_prim = - Name_occurrences.downgrade_occurrences_at_strictly_greater_kind - (Flambda_primitive.Eligible_for_cse.free_names prim) - Name_mode.in_types - in - Name_occurrences.add_name free_in_prim - name Name_mode.in_types)) - cse - free_names_equations + let free_names = + Flambda_primitive.Eligible_for_cse.Map.fold + (fun prim (bound_to : Simple.t) acc -> + Simple.pattern_match bound_to + ~const:(fun _ -> acc) + ~name:(fun name -> + let free_in_prim = + Name_occurrences.downgrade_occurrences_at_strictly_greater_kind + (Flambda_primitive.Eligible_for_cse.free_names prim) + Name_mode.in_types + in + Name_occurrences.add_name free_in_prim + name Name_mode.in_types)) + cse + free_names_equations + in + Variable.Map.fold (fun _var proj free_names -> + Name_occurrences.union free_names + (Symbol_projection.free_names proj)) + symbol_projections + free_names let empty () = { defined_vars = Variable.Map.empty; binding_times = Binding_time.Map.empty; equations = Name.Map.empty; cse = Flambda_primitive.Eligible_for_cse.Map.empty; + symbol_projections = Variable.Map.empty; } -let is_empty { defined_vars; binding_times; equations; cse; } = +let is_empty + { defined_vars; binding_times; equations; cse; + symbol_projections; } = Variable.Map.is_empty defined_vars && Binding_time.Map.is_empty binding_times && Name.Map.is_empty equations && Flambda_primitive.Eligible_for_cse.Map.is_empty cse + && Variable.Map.is_empty symbol_projections let equations t = t.equations let cse t = t.cse +let symbol_projections t = t.symbol_projections + +let add_symbol_projection t var proj = + let symbol_projections = + Variable.Map.add var proj t.symbol_projections + in + { t with symbol_projections; } + let add_definition t var kind binding_time = if !Clflags.flambda_invariant_checks && Variable.Map.mem var t.defined_vars @@ -265,6 +295,7 @@ let one_equation name ty = binding_times = Binding_time.Map.empty; equations = Name.Map.singleton name ty; cse = Flambda_primitive.Eligible_for_cse.Map.empty; + symbol_projections = Variable.Map.empty; } let add_or_replace_equation t name ty = @@ -321,10 +352,16 @@ let concat (t1 : t) (t2 : t) = t1.cse t2.cse in + let symbol_projections = + Variable.Map.union (fun _var _proj1 proj2 -> Some proj2) + t1.symbol_projections + t2.symbol_projections + in { defined_vars; binding_times; equations; cse; + symbol_projections; } let meet_equation0 env t name typ = @@ -438,7 +475,6 @@ let meet0 env (t1 : t) (t2 : t) = (t, env) in let cse = - (* CR mshinwell: Add [Map.inter] (also used elsewhere) *) Flambda_primitive.Eligible_for_cse.Map.merge (fun _ simple1 simple2 -> match simple1, simple2 with | None, None | None, Some _ | Some _, None -> None @@ -447,7 +483,19 @@ let meet0 env (t1 : t) (t2 : t) = else None) t1.cse t2.cse in - { t with cse; } + let symbol_projections = + Variable.Map.merge (fun _ proj1 proj2 -> + match proj1, proj2 with + | None, None | None, Some _ | Some _, None -> None + | Some proj1, Some proj2 -> + if Symbol_projection.equal proj1 proj2 then Some proj1 + else None) + t1.symbol_projections t2.symbol_projections + in + { t with + cse; + symbol_projections; + } let meet env t1 t2 = (* Care: the domains of [t1] and [t2] are treated as contravariant. @@ -797,7 +845,8 @@ let join_cse envs_with_levels cse ~allowed = Name.Map.empty, allowed) -let construct_joined_level envs_with_levels ~allowed ~joined_types ~cse = +let construct_joined_level envs_with_levels ~env_at_fork ~allowed + ~joined_types ~cse = let module EP = Flambda_primitive.Eligible_for_cse in let defined_vars, binding_times = List.fold_left (fun (defined_vars, binding_times) @@ -854,10 +903,28 @@ let construct_joined_level envs_with_levels ~allowed ~joined_types ~cse = ~name:(fun name -> Name_occurrences.mem_name allowed name)) cse in + let symbol_projections = + List.fold_left (fun symbol_projections (_env_at_use, _id, _use_kind, t) -> + let projs_this_level = + Variable.Map.filter (fun var _ -> + let name = Name.var var in + Typing_env.mem ~min_name_mode:Name_mode.normal env_at_fork name + || Name_occurrences.mem_name allowed name) + t.symbol_projections + in + Variable.Map.union (fun _var proj1 proj2 -> + if Symbol_projection.equal proj1 proj2 then Some proj1 + else None) + symbol_projections + projs_this_level) + Variable.Map.empty + envs_with_levels + in { defined_vars; binding_times; equations; cse; + symbol_projections; } let check_join_inputs ~env_at_fork _envs_with_levels ~params @@ -1043,7 +1110,10 @@ let join ~env_at_fork envs_with_levels ~params *) (* Having calculated which equations to propagate, the resulting level can now be constructed. *) - let t = construct_joined_level envs_with_levels ~allowed ~joined_types ~cse in + let t = + construct_joined_level envs_with_levels ~env_at_fork ~allowed + ~joined_types ~cse + in (* Format.eprintf "Join result:@ %a\n%!" print t; *) @@ -1077,7 +1147,13 @@ let all_ids_for_export t = Ids_for_export.add_simple ids simple in let ids = Flambda_primitive.Eligible_for_cse.Map.fold cse t.cse ids in - ids + let symbol_projection var proj ids = + let ids = + Ids_for_export.union ids (Symbol_projection.all_ids_for_export proj) + in + Ids_for_export.add_variable ids var + in + Variable.Map.fold symbol_projection t.symbol_projections ids let import _import_map _t = Misc.fatal_error "Import not implemented on Typing_env_level" diff --git a/middle_end/flambda/types/env/typing_env_level.rec.mli b/middle_end/flambda/types/env/typing_env_level.rec.mli index 0c9b35b6d04a..7a8aecee8cd9 100644 --- a/middle_end/flambda/types/env/typing_env_level.rec.mli +++ b/middle_end/flambda/types/env/typing_env_level.rec.mli @@ -60,6 +60,10 @@ val add_cse -> bound_to:Simple.t -> t +val add_symbol_projection : t -> Variable.t -> Symbol_projection.t -> t + +val symbol_projections : t -> Symbol_projection.t Variable.Map.t + val concat : t -> t -> t val meet : Meet_env.t -> t -> t -> t diff --git a/middle_end/flambda/types/flambda_type.mli b/middle_end/flambda/types/flambda_type.mli index de8cdaf3b6c0..a597cb5c6861 100644 --- a/middle_end/flambda/types/flambda_type.mli +++ b/middle_end/flambda/types/flambda_type.mli @@ -94,6 +94,10 @@ module Typing_env : sig val add_symbol_definitions : t -> Symbol.Set.t -> t + val add_symbol_projection : t -> Variable.t -> Symbol_projection.t -> t + + val find_symbol_projection : t -> Variable.t -> Symbol_projection.t option + val add_equation : t -> Name.t -> flambda_type -> t val add_equations_on_params @@ -573,6 +577,7 @@ type reification_result = private val reify : ?allowed_if_free_vars_defined_in:Typing_env.t + -> ?additional_free_var_criterion:(Variable.t -> bool) -> ?disallowed_free_vars:Variable.Set.t -> ?allow_unique:bool -> Typing_env.t diff --git a/middle_end/flambda/types/template/flambda_type.templ.ml b/middle_end/flambda/types/template/flambda_type.templ.ml index 9220de393b39..0028cfafa371 100644 --- a/middle_end/flambda/types/template/flambda_type.templ.ml +++ b/middle_end/flambda/types/template/flambda_type.templ.ml @@ -722,14 +722,19 @@ type reification_result = (* CR mshinwell: Think more to identify all the cases that should be in this function. *) -let reify ?allowed_if_free_vars_defined_in ?disallowed_free_vars - ?(allow_unique = false) +let reify ?allowed_if_free_vars_defined_in ?additional_free_var_criterion + ?disallowed_free_vars ?(allow_unique = false) env ~min_name_mode t : reification_result = let var_allowed var = match allowed_if_free_vars_defined_in with | None -> false | Some allowed_if_free_vars_defined_in -> - Typing_env.mem ~min_name_mode allowed_if_free_vars_defined_in (Name.var var) + Typing_env.mem ~min_name_mode allowed_if_free_vars_defined_in + (Name.var var) + && begin match additional_free_var_criterion with + | None -> true + | Some criterion -> criterion var + end && match disallowed_free_vars with | None -> true | Some disallowed_free_vars -> diff --git a/utils/lmap.ml b/utils/lmap.ml index b5fb2fba4562..bc34335afc93 100644 --- a/utils/lmap.ml +++ b/utils/lmap.ml @@ -33,6 +33,7 @@ module type S = sig val map_sharing: ('a -> 'a) -> 'a t -> 'a t val filter_map: 'a t -> f:(key -> 'a -> 'b option) -> 'b t val to_seq : 'a t -> (key * 'a) Seq.t + val exists : (key -> 'a -> bool) -> 'a t -> bool val add_seq : (key * 'a) Seq.t -> 'a t -> 'a t val of_seq : (key * 'a) Seq.t -> 'a t @@ -56,6 +57,7 @@ module Make (T : Thing) : S with type key = T.t = struct let iter f m = List.iter (fun (k, v) -> f k v) m let fold f m b = List.fold_left (fun b (k, v) -> f k v b) b m let filter p m = List.filter (fun (k, v) -> p k v) m + let exists f m = List.exists (fun (k, v) -> f k v) m let keys m = List.map fst m let data m = List.map snd m let bindings m = m diff --git a/utils/lmap.mli b/utils/lmap.mli index ff90ac141c24..bbd8c358aa43 100644 --- a/utils/lmap.mli +++ b/utils/lmap.mli @@ -57,10 +57,10 @@ module type S = sig (** The key should not already exist in the map; this is not checked. *) val add : key -> 'a -> 'a t -> 'a t val singleton : key -> 'a -> 'a t - + (** Unlike [disjoint_union] on maps, the disjointness is not checked. *) val disjoint_union : 'a t -> 'a t -> 'a t - + (** The given maps must be pairwise disjoint, which is not checked. *) val disjoint_union_many: 'a t list -> 'a t val iter : (key -> 'a -> unit) -> 'a t -> unit @@ -69,7 +69,7 @@ module type S = sig val keys : _ t -> key list val data : 'a t -> 'a list val bindings : 'a t -> (key * 'a) list - + (** Keys in the list must be distinct, which is not checked. *) val of_list : (key * 'a) list -> 'a t val find : key -> 'a t -> 'a @@ -81,11 +81,13 @@ module type S = sig val map_sharing: ('a -> 'a) -> 'a t -> 'a t val filter_map: 'a t -> f:(key -> 'a -> 'b option) -> 'b t val to_seq : 'a t -> (key * 'a) Seq.t - + + val exists : (key -> 'a -> bool) -> 'a t -> bool + (** Keys in the sequence must be distinct from each other and from keys already in the map; neither of these conditions is checked. *) val add_seq : (key * 'a) Seq.t -> 'a t -> 'a t - + (** Keys in the sequence must be distinct, which is not checked. *) val of_seq : (key * 'a) Seq.t -> 'a t From daeadc4d784d99a1774517cb615c73aa7b36d767 Mon Sep 17 00:00:00 2001 From: Vincent Laviron Date: Thu, 27 Aug 2020 18:19:10 +0200 Subject: [PATCH 2/2] Tweak to symbol projection meet --- .../flambda/types/env/typing_env_level.rec.ml | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/middle_end/flambda/types/env/typing_env_level.rec.ml b/middle_end/flambda/types/env/typing_env_level.rec.ml index 7aa065573426..73a6fceb18e5 100644 --- a/middle_end/flambda/types/env/typing_env_level.rec.ml +++ b/middle_end/flambda/types/env/typing_env_level.rec.ml @@ -484,12 +484,17 @@ let meet0 env (t1 : t) (t2 : t) = t1.cse t2.cse in let symbol_projections = - Variable.Map.merge (fun _ proj1 proj2 -> - match proj1, proj2 with - | None, None | None, Some _ | Some _, None -> None - | Some proj1, Some proj2 -> - if Symbol_projection.equal proj1 proj2 then Some proj1 - else None) + Variable.Map.union (fun _ proj1 proj2 -> + (* CR vlaviron: + I'm not sure whether this can come up at all, but + if proj1 and proj2 are different then it means the corresponding + variable can be accessed through two different projections. + I think it would be safe to use any of them, but forgetting + the projection is guaranteed to be sound and I think it is + better for debugging problems if the meet function is kept + symmetrical. *) + if Symbol_projection.equal proj1 proj2 then Some proj1 + else None) t1.symbol_projections t2.symbol_projections in { t with