From 72ea849d2a16de0abb42afd85c014cb136822e1f Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Mon, 1 Apr 2019 17:18:47 +0100 Subject: Move some middle-end files around (#2281) * Various file moves in the middle end: this is the first stage of improving separation between the middle end and backend. * Creation of file_formats/ directory (with associated file moves) to hold the definitions of compilation artifact formats. * Creation of lambda/ directory (with associated file moves) to hold Lambda language definition files, transformation passes and construction passes from Typedtree. * Disable (hopefully temporarily) dynlink, debugger and ocamldoc for the dune build. --- middle_end/alias_analysis.ml | 168 -- middle_end/alias_analysis.mli | 63 - middle_end/allocated_const.ml | 86 - middle_end/allocated_const.mli | 38 - middle_end/augment_specialised_args.ml | 762 --------- middle_end/augment_specialised_args.mli | 65 - middle_end/backend_var.ml | 87 + middle_end/backend_var.mli | 54 + middle_end/base_types/closure_element.ml | 26 - middle_end/base_types/closure_element.mli | 32 - middle_end/base_types/closure_id.ml | 20 - middle_end/base_types/closure_id.mli | 27 - middle_end/base_types/closure_origin.ml | 22 - middle_end/base_types/closure_origin.mli | 21 - middle_end/base_types/compilation_unit.ml | 78 - middle_end/base_types/compilation_unit.mli | 34 - middle_end/base_types/export_id.ml | 29 - middle_end/base_types/export_id.mli | 28 - middle_end/base_types/id_types.ml | 93 -- middle_end/base_types/id_types.mli | 56 - middle_end/base_types/linkage_name.ml | 30 - middle_end/base_types/linkage_name.mli | 22 - middle_end/base_types/mutable_variable.ml | 22 - middle_end/base_types/mutable_variable.mli | 47 - middle_end/base_types/set_of_closures_id.ml | 29 - middle_end/base_types/set_of_closures_id.mli | 26 - middle_end/base_types/set_of_closures_origin.ml | 23 - middle_end/base_types/set_of_closures_origin.mli | 22 - middle_end/base_types/static_exception.ml | 23 - middle_end/base_types/static_exception.mli | 26 - middle_end/base_types/symbol.ml | 105 -- middle_end/base_types/symbol.mli | 44 - middle_end/base_types/tag.ml | 35 - middle_end/base_types/tag.mli | 29 - middle_end/base_types/var_within_closure.ml | 20 - middle_end/base_types/var_within_closure.mli | 24 - middle_end/base_types/variable.ml | 119 -- middle_end/base_types/variable.mli | 63 - middle_end/clambda.ml | 203 +++ middle_end/clambda.mli | 153 ++ middle_end/clambda_primitives.ml | 155 ++ middle_end/clambda_primitives.mli | 158 ++ middle_end/closure/closure.ml | 1472 +++++++++++++++++ middle_end/closure/closure.mli | 24 + middle_end/closure_conversion.ml | 737 --------- middle_end/closure_conversion.mli | 53 - middle_end/closure_conversion_aux.ml | 184 --- middle_end/closure_conversion_aux.mli | 94 -- middle_end/compilation_unit.ml | 78 + middle_end/compilation_unit.mli | 34 + middle_end/compilenv.ml | 452 ++++++ middle_end/compilenv.mli | 153 ++ middle_end/convert_primitives.ml | 153 ++ middle_end/convert_primitives.mli | 17 + middle_end/debuginfo.ml | 145 -- middle_end/debuginfo.mli | 46 - middle_end/effect_analysis.ml | 60 - middle_end/effect_analysis.mli | 27 - middle_end/extract_projections.ml | 190 --- middle_end/extract_projections.mli | 33 - middle_end/find_recursive_functions.ml | 34 - middle_end/find_recursive_functions.mli | 37 - middle_end/flambda.ml | 1272 --------------- middle_end/flambda.mli | 713 -------- middle_end/flambda/alias_analysis.ml | 168 ++ middle_end/flambda/alias_analysis.mli | 63 + middle_end/flambda/allocated_const.ml | 86 + middle_end/flambda/allocated_const.mli | 38 + middle_end/flambda/augment_specialised_args.ml | 762 +++++++++ middle_end/flambda/augment_specialised_args.mli | 65 + middle_end/flambda/base_types/closure_element.ml | 26 + middle_end/flambda/base_types/closure_element.mli | 32 + middle_end/flambda/base_types/closure_id.ml | 20 + middle_end/flambda/base_types/closure_id.mli | 27 + middle_end/flambda/base_types/closure_origin.ml | 22 + middle_end/flambda/base_types/closure_origin.mli | 21 + middle_end/flambda/base_types/export_id.ml | 29 + middle_end/flambda/base_types/export_id.mli | 28 + middle_end/flambda/base_types/id_types.ml | 93 ++ middle_end/flambda/base_types/id_types.mli | 56 + middle_end/flambda/base_types/mutable_variable.ml | 22 + middle_end/flambda/base_types/mutable_variable.mli | 47 + .../flambda/base_types/set_of_closures_id.ml | 29 + .../flambda/base_types/set_of_closures_id.mli | 26 + .../flambda/base_types/set_of_closures_origin.ml | 23 + .../flambda/base_types/set_of_closures_origin.mli | 22 + middle_end/flambda/base_types/static_exception.ml | 23 + middle_end/flambda/base_types/static_exception.mli | 26 + middle_end/flambda/base_types/tag.ml | 35 + middle_end/flambda/base_types/tag.mli | 29 + .../flambda/base_types/var_within_closure.ml | 20 + .../flambda/base_types/var_within_closure.mli | 24 + middle_end/flambda/build_export_info.ml | 711 ++++++++ middle_end/flambda/build_export_info.mli | 25 + middle_end/flambda/closure_conversion.ml | 737 +++++++++ middle_end/flambda/closure_conversion.mli | 53 + middle_end/flambda/closure_conversion_aux.ml | 184 +++ middle_end/flambda/closure_conversion_aux.mli | 94 ++ middle_end/flambda/closure_offsets.ml | 89 + middle_end/flambda/closure_offsets.mli | 27 + middle_end/flambda/effect_analysis.ml | 60 + middle_end/flambda/effect_analysis.mli | 27 + middle_end/flambda/export_info.ml | 555 +++++++ middle_end/flambda/export_info.mli | 195 +++ middle_end/flambda/export_info_for_pack.ml | 231 +++ middle_end/flambda/export_info_for_pack.mli | 34 + middle_end/flambda/extract_projections.ml | 190 +++ middle_end/flambda/extract_projections.mli | 33 + middle_end/flambda/find_recursive_functions.ml | 34 + middle_end/flambda/find_recursive_functions.mli | 37 + middle_end/flambda/flambda.ml | 1272 +++++++++++++++ middle_end/flambda/flambda.mli | 713 ++++++++ middle_end/flambda/flambda_invariants.ml | 800 +++++++++ middle_end/flambda/flambda_invariants.mli | 28 + middle_end/flambda/flambda_iterators.ml | 808 ++++++++++ middle_end/flambda/flambda_iterators.mli | 227 +++ middle_end/flambda/flambda_middle_end.ml | 200 +++ middle_end/flambda/flambda_middle_end.mli | 29 + middle_end/flambda/flambda_to_clambda.ml | 749 +++++++++ middle_end/flambda/flambda_to_clambda.mli | 38 + middle_end/flambda/flambda_utils.ml | 929 +++++++++++ middle_end/flambda/flambda_utils.mli | 220 +++ middle_end/flambda/freshening.ml | 458 ++++++ middle_end/flambda/freshening.mli | 167 ++ middle_end/flambda/import_approx.ml | 222 +++ middle_end/flambda/import_approx.mli | 34 + middle_end/flambda/inconstant_idents.ml | 502 ++++++ middle_end/flambda/inconstant_idents.mli | 36 + .../flambda/initialize_symbol_to_let_symbol.ml | 57 + .../flambda/initialize_symbol_to_let_symbol.mli | 25 + middle_end/flambda/inline_and_simplify.ml | 1703 ++++++++++++++++++++ middle_end/flambda/inline_and_simplify.mli | 40 + middle_end/flambda/inline_and_simplify_aux.ml | 738 +++++++++ middle_end/flambda/inline_and_simplify_aux.mli | 368 +++++ middle_end/flambda/inlining_cost.ml | 700 ++++++++ middle_end/flambda/inlining_cost.mli | 142 ++ middle_end/flambda/inlining_decision.ml | 741 +++++++++ middle_end/flambda/inlining_decision.mli | 43 + middle_end/flambda/inlining_decision_intf.mli | 49 + middle_end/flambda/inlining_stats.ml | 252 +++ middle_end/flambda/inlining_stats.mli | 46 + middle_end/flambda/inlining_stats_types.ml | 290 ++++ middle_end/flambda/inlining_stats_types.mli | 89 + middle_end/flambda/inlining_transforms.ml | 668 ++++++++ middle_end/flambda/inlining_transforms.mli | 105 ++ middle_end/flambda/invariant_params.ml | 420 +++++ middle_end/flambda/invariant_params.mli | 57 + middle_end/flambda/lift_code.ml | 163 ++ middle_end/flambda/lift_code.mli | 43 + middle_end/flambda/lift_constants.ml | 1019 ++++++++++++ middle_end/flambda/lift_constants.mli | 65 + .../flambda/lift_let_to_initialize_symbol.ml | 298 ++++ .../flambda/lift_let_to_initialize_symbol.mli | 38 + middle_end/flambda/parameter.ml | 69 + middle_end/flambda/parameter.mli | 52 + middle_end/flambda/pass_wrapper.ml | 35 + middle_end/flambda/pass_wrapper.mli | 26 + middle_end/flambda/projection.ml | 170 ++ middle_end/flambda/projection.mli | 80 + middle_end/flambda/ref_to_variables.ml | 199 +++ middle_end/flambda/ref_to_variables.mli | 23 + .../flambda/remove_free_vars_equal_to_args.ml | 99 ++ .../flambda/remove_free_vars_equal_to_args.mli | 23 + middle_end/flambda/remove_unused_arguments.ml | 242 +++ middle_end/flambda/remove_unused_arguments.mli | 39 + middle_end/flambda/remove_unused_closure_vars.ml | 125 ++ middle_end/flambda/remove_unused_closure_vars.mli | 26 + .../flambda/remove_unused_program_constructs.ml | 111 ++ .../flambda/remove_unused_program_constructs.mli | 24 + middle_end/flambda/share_constants.ml | 130 ++ middle_end/flambda/share_constants.mli | 22 + middle_end/flambda/simple_value_approx.ml | 1043 ++++++++++++ middle_end/flambda/simple_value_approx.mli | 501 ++++++ middle_end/flambda/simplify_boxed_integer_ops.ml | 116 ++ middle_end/flambda/simplify_boxed_integer_ops.mli | 28 + .../flambda/simplify_boxed_integer_ops_intf.mli | 45 + middle_end/flambda/simplify_common.ml | 86 + middle_end/flambda/simplify_common.mli | 80 + middle_end/flambda/simplify_primitives.ml | 302 ++++ middle_end/flambda/simplify_primitives.mli | 27 + .../flambda/traverse_for_exported_symbols.ml | 267 +++ .../flambda/traverse_for_exported_symbols.mli | 41 + middle_end/flambda/un_anf.ml | 817 ++++++++++ middle_end/flambda/un_anf.mli | 23 + middle_end/flambda/unbox_closures.ml | 87 + middle_end/flambda/unbox_closures.mli | 33 + middle_end/flambda/unbox_free_vars_of_closures.ml | 170 ++ middle_end/flambda/unbox_free_vars_of_closures.mli | 26 + middle_end/flambda/unbox_specialised_args.ml | 103 ++ middle_end/flambda/unbox_specialised_args.mli | 50 + middle_end/flambda_invariants.ml | 800 --------- middle_end/flambda_invariants.mli | 28 - middle_end/flambda_iterators.ml | 808 ---------- middle_end/flambda_iterators.mli | 227 --- middle_end/flambda_utils.ml | 929 ----------- middle_end/flambda_utils.mli | 220 --- middle_end/freshening.ml | 458 ------ middle_end/freshening.mli | 167 -- middle_end/inconstant_idents.ml | 502 ------ middle_end/inconstant_idents.mli | 36 - middle_end/initialize_symbol_to_let_symbol.ml | 57 - middle_end/initialize_symbol_to_let_symbol.mli | 25 - middle_end/inline_and_simplify.ml | 1703 -------------------- middle_end/inline_and_simplify.mli | 40 - middle_end/inline_and_simplify_aux.ml | 738 --------- middle_end/inline_and_simplify_aux.mli | 368 ----- middle_end/inlining_cost.ml | 700 -------- middle_end/inlining_cost.mli | 142 -- middle_end/inlining_decision.ml | 741 --------- middle_end/inlining_decision.mli | 43 - middle_end/inlining_decision_intf.mli | 49 - middle_end/inlining_stats.ml | 252 --- middle_end/inlining_stats.mli | 46 - middle_end/inlining_stats_types.ml | 290 ---- middle_end/inlining_stats_types.mli | 89 - middle_end/inlining_transforms.ml | 668 -------- middle_end/inlining_transforms.mli | 105 -- middle_end/int_replace_polymorphic_compare.ml | 8 - middle_end/int_replace_polymorphic_compare.mli | 8 - middle_end/invariant_params.ml | 420 ----- middle_end/invariant_params.mli | 57 - middle_end/lift_code.ml | 163 -- middle_end/lift_code.mli | 43 - middle_end/lift_constants.ml | 1019 ------------ middle_end/lift_constants.mli | 65 - middle_end/lift_let_to_initialize_symbol.ml | 298 ---- middle_end/lift_let_to_initialize_symbol.mli | 38 - middle_end/linkage_name.ml | 30 + middle_end/linkage_name.mli | 22 + middle_end/middle_end.ml | 200 --- middle_end/middle_end.mli | 29 - middle_end/parameter.ml | 69 - middle_end/parameter.mli | 52 - middle_end/pass_wrapper.ml | 35 - middle_end/pass_wrapper.mli | 26 - middle_end/printclambda.ml | 272 ++++ middle_end/printclambda.mli | 26 + middle_end/printclambda_primitives.ml | 202 +++ middle_end/printclambda_primitives.mli | 18 + middle_end/projection.ml | 170 -- middle_end/projection.mli | 80 - middle_end/ref_to_variables.ml | 199 --- middle_end/ref_to_variables.mli | 23 - middle_end/remove_free_vars_equal_to_args.ml | 99 -- middle_end/remove_free_vars_equal_to_args.mli | 23 - middle_end/remove_unused_arguments.ml | 242 --- middle_end/remove_unused_arguments.mli | 39 - middle_end/remove_unused_closure_vars.ml | 125 -- middle_end/remove_unused_closure_vars.mli | 26 - middle_end/remove_unused_program_constructs.ml | 111 -- middle_end/remove_unused_program_constructs.mli | 24 - middle_end/semantics_of_primitives.ml | 153 ++ middle_end/semantics_of_primitives.mli | 69 + middle_end/share_constants.ml | 130 -- middle_end/share_constants.mli | 22 - middle_end/simple_value_approx.ml | 1043 ------------ middle_end/simple_value_approx.mli | 501 ------ middle_end/simplify_boxed_integer_ops.ml | 116 -- middle_end/simplify_boxed_integer_ops.mli | 28 - middle_end/simplify_boxed_integer_ops_intf.mli | 45 - middle_end/simplify_common.ml | 86 - middle_end/simplify_common.mli | 80 - middle_end/simplify_primitives.ml | 302 ---- middle_end/simplify_primitives.mli | 27 - middle_end/symbol.ml | 105 ++ middle_end/symbol.mli | 44 + middle_end/unbox_closures.ml | 87 - middle_end/unbox_closures.mli | 33 - middle_end/unbox_free_vars_of_closures.ml | 170 -- middle_end/unbox_free_vars_of_closures.mli | 26 - middle_end/unbox_specialised_args.ml | 103 -- middle_end/unbox_specialised_args.mli | 50 - middle_end/variable.ml | 119 ++ middle_end/variable.mli | 63 + 274 files changed, 30425 insertions(+), 22753 deletions(-) delete mode 100644 middle_end/alias_analysis.ml delete mode 100644 middle_end/alias_analysis.mli delete mode 100644 middle_end/allocated_const.ml delete mode 100644 middle_end/allocated_const.mli delete mode 100644 middle_end/augment_specialised_args.ml delete mode 100644 middle_end/augment_specialised_args.mli create mode 100644 middle_end/backend_var.ml create mode 100644 middle_end/backend_var.mli delete mode 100644 middle_end/base_types/closure_element.ml delete mode 100644 middle_end/base_types/closure_element.mli delete mode 100644 middle_end/base_types/closure_id.ml delete mode 100644 middle_end/base_types/closure_id.mli delete mode 100644 middle_end/base_types/closure_origin.ml delete mode 100644 middle_end/base_types/closure_origin.mli delete mode 100644 middle_end/base_types/compilation_unit.ml delete mode 100644 middle_end/base_types/compilation_unit.mli delete mode 100644 middle_end/base_types/export_id.ml delete mode 100644 middle_end/base_types/export_id.mli delete mode 100644 middle_end/base_types/id_types.ml delete mode 100644 middle_end/base_types/id_types.mli delete mode 100644 middle_end/base_types/linkage_name.ml delete mode 100644 middle_end/base_types/linkage_name.mli delete mode 100644 middle_end/base_types/mutable_variable.ml delete mode 100644 middle_end/base_types/mutable_variable.mli delete mode 100644 middle_end/base_types/set_of_closures_id.ml delete mode 100644 middle_end/base_types/set_of_closures_id.mli delete mode 100644 middle_end/base_types/set_of_closures_origin.ml delete mode 100644 middle_end/base_types/set_of_closures_origin.mli delete mode 100644 middle_end/base_types/static_exception.ml delete mode 100644 middle_end/base_types/static_exception.mli delete mode 100644 middle_end/base_types/symbol.ml delete mode 100644 middle_end/base_types/symbol.mli delete mode 100644 middle_end/base_types/tag.ml delete mode 100644 middle_end/base_types/tag.mli delete mode 100644 middle_end/base_types/var_within_closure.ml delete mode 100644 middle_end/base_types/var_within_closure.mli delete mode 100644 middle_end/base_types/variable.ml delete mode 100644 middle_end/base_types/variable.mli create mode 100644 middle_end/clambda.ml create mode 100644 middle_end/clambda.mli create mode 100644 middle_end/clambda_primitives.ml create mode 100644 middle_end/clambda_primitives.mli create mode 100644 middle_end/closure/closure.ml create mode 100644 middle_end/closure/closure.mli delete mode 100644 middle_end/closure_conversion.ml delete mode 100644 middle_end/closure_conversion.mli delete mode 100644 middle_end/closure_conversion_aux.ml delete mode 100644 middle_end/closure_conversion_aux.mli create mode 100644 middle_end/compilation_unit.ml create mode 100644 middle_end/compilation_unit.mli create mode 100644 middle_end/compilenv.ml create mode 100644 middle_end/compilenv.mli create mode 100644 middle_end/convert_primitives.ml create mode 100644 middle_end/convert_primitives.mli delete mode 100644 middle_end/debuginfo.ml delete mode 100644 middle_end/debuginfo.mli delete mode 100644 middle_end/effect_analysis.ml delete mode 100644 middle_end/effect_analysis.mli delete mode 100644 middle_end/extract_projections.ml delete mode 100644 middle_end/extract_projections.mli delete mode 100644 middle_end/find_recursive_functions.ml delete mode 100644 middle_end/find_recursive_functions.mli delete mode 100644 middle_end/flambda.ml delete mode 100644 middle_end/flambda.mli create mode 100644 middle_end/flambda/alias_analysis.ml create mode 100644 middle_end/flambda/alias_analysis.mli create mode 100644 middle_end/flambda/allocated_const.ml create mode 100644 middle_end/flambda/allocated_const.mli create mode 100644 middle_end/flambda/augment_specialised_args.ml create mode 100644 middle_end/flambda/augment_specialised_args.mli create mode 100644 middle_end/flambda/base_types/closure_element.ml create mode 100644 middle_end/flambda/base_types/closure_element.mli create mode 100644 middle_end/flambda/base_types/closure_id.ml create mode 100644 middle_end/flambda/base_types/closure_id.mli create mode 100644 middle_end/flambda/base_types/closure_origin.ml create mode 100644 middle_end/flambda/base_types/closure_origin.mli create mode 100644 middle_end/flambda/base_types/export_id.ml create mode 100644 middle_end/flambda/base_types/export_id.mli create mode 100644 middle_end/flambda/base_types/id_types.ml create mode 100644 middle_end/flambda/base_types/id_types.mli create mode 100644 middle_end/flambda/base_types/mutable_variable.ml create mode 100644 middle_end/flambda/base_types/mutable_variable.mli create mode 100644 middle_end/flambda/base_types/set_of_closures_id.ml create mode 100644 middle_end/flambda/base_types/set_of_closures_id.mli create mode 100644 middle_end/flambda/base_types/set_of_closures_origin.ml create mode 100644 middle_end/flambda/base_types/set_of_closures_origin.mli create mode 100644 middle_end/flambda/base_types/static_exception.ml create mode 100644 middle_end/flambda/base_types/static_exception.mli create mode 100644 middle_end/flambda/base_types/tag.ml create mode 100644 middle_end/flambda/base_types/tag.mli create mode 100644 middle_end/flambda/base_types/var_within_closure.ml create mode 100644 middle_end/flambda/base_types/var_within_closure.mli create mode 100644 middle_end/flambda/build_export_info.ml create mode 100644 middle_end/flambda/build_export_info.mli create mode 100644 middle_end/flambda/closure_conversion.ml create mode 100644 middle_end/flambda/closure_conversion.mli create mode 100644 middle_end/flambda/closure_conversion_aux.ml create mode 100644 middle_end/flambda/closure_conversion_aux.mli create mode 100644 middle_end/flambda/closure_offsets.ml create mode 100644 middle_end/flambda/closure_offsets.mli create mode 100644 middle_end/flambda/effect_analysis.ml create mode 100644 middle_end/flambda/effect_analysis.mli create mode 100644 middle_end/flambda/export_info.ml create mode 100644 middle_end/flambda/export_info.mli create mode 100644 middle_end/flambda/export_info_for_pack.ml create mode 100644 middle_end/flambda/export_info_for_pack.mli create mode 100644 middle_end/flambda/extract_projections.ml create mode 100644 middle_end/flambda/extract_projections.mli create mode 100644 middle_end/flambda/find_recursive_functions.ml create mode 100644 middle_end/flambda/find_recursive_functions.mli create mode 100644 middle_end/flambda/flambda.ml create mode 100644 middle_end/flambda/flambda.mli create mode 100644 middle_end/flambda/flambda_invariants.ml create mode 100644 middle_end/flambda/flambda_invariants.mli create mode 100644 middle_end/flambda/flambda_iterators.ml create mode 100644 middle_end/flambda/flambda_iterators.mli create mode 100644 middle_end/flambda/flambda_middle_end.ml create mode 100644 middle_end/flambda/flambda_middle_end.mli create mode 100644 middle_end/flambda/flambda_to_clambda.ml create mode 100644 middle_end/flambda/flambda_to_clambda.mli create mode 100644 middle_end/flambda/flambda_utils.ml create mode 100644 middle_end/flambda/flambda_utils.mli create mode 100644 middle_end/flambda/freshening.ml create mode 100644 middle_end/flambda/freshening.mli create mode 100644 middle_end/flambda/import_approx.ml create mode 100644 middle_end/flambda/import_approx.mli create mode 100644 middle_end/flambda/inconstant_idents.ml create mode 100644 middle_end/flambda/inconstant_idents.mli create mode 100644 middle_end/flambda/initialize_symbol_to_let_symbol.ml create mode 100644 middle_end/flambda/initialize_symbol_to_let_symbol.mli create mode 100644 middle_end/flambda/inline_and_simplify.ml create mode 100644 middle_end/flambda/inline_and_simplify.mli create mode 100644 middle_end/flambda/inline_and_simplify_aux.ml create mode 100644 middle_end/flambda/inline_and_simplify_aux.mli create mode 100644 middle_end/flambda/inlining_cost.ml create mode 100644 middle_end/flambda/inlining_cost.mli create mode 100644 middle_end/flambda/inlining_decision.ml create mode 100644 middle_end/flambda/inlining_decision.mli create mode 100644 middle_end/flambda/inlining_decision_intf.mli create mode 100644 middle_end/flambda/inlining_stats.ml create mode 100644 middle_end/flambda/inlining_stats.mli create mode 100644 middle_end/flambda/inlining_stats_types.ml create mode 100644 middle_end/flambda/inlining_stats_types.mli create mode 100644 middle_end/flambda/inlining_transforms.ml create mode 100644 middle_end/flambda/inlining_transforms.mli create mode 100644 middle_end/flambda/invariant_params.ml create mode 100644 middle_end/flambda/invariant_params.mli create mode 100644 middle_end/flambda/lift_code.ml create mode 100644 middle_end/flambda/lift_code.mli create mode 100644 middle_end/flambda/lift_constants.ml create mode 100644 middle_end/flambda/lift_constants.mli create mode 100644 middle_end/flambda/lift_let_to_initialize_symbol.ml create mode 100644 middle_end/flambda/lift_let_to_initialize_symbol.mli create mode 100644 middle_end/flambda/parameter.ml create mode 100644 middle_end/flambda/parameter.mli create mode 100644 middle_end/flambda/pass_wrapper.ml create mode 100644 middle_end/flambda/pass_wrapper.mli create mode 100644 middle_end/flambda/projection.ml create mode 100644 middle_end/flambda/projection.mli create mode 100644 middle_end/flambda/ref_to_variables.ml create mode 100644 middle_end/flambda/ref_to_variables.mli create mode 100644 middle_end/flambda/remove_free_vars_equal_to_args.ml create mode 100644 middle_end/flambda/remove_free_vars_equal_to_args.mli create mode 100644 middle_end/flambda/remove_unused_arguments.ml create mode 100644 middle_end/flambda/remove_unused_arguments.mli create mode 100644 middle_end/flambda/remove_unused_closure_vars.ml create mode 100644 middle_end/flambda/remove_unused_closure_vars.mli create mode 100644 middle_end/flambda/remove_unused_program_constructs.ml create mode 100644 middle_end/flambda/remove_unused_program_constructs.mli create mode 100644 middle_end/flambda/share_constants.ml create mode 100644 middle_end/flambda/share_constants.mli create mode 100644 middle_end/flambda/simple_value_approx.ml create mode 100644 middle_end/flambda/simple_value_approx.mli create mode 100644 middle_end/flambda/simplify_boxed_integer_ops.ml create mode 100644 middle_end/flambda/simplify_boxed_integer_ops.mli create mode 100644 middle_end/flambda/simplify_boxed_integer_ops_intf.mli create mode 100644 middle_end/flambda/simplify_common.ml create mode 100644 middle_end/flambda/simplify_common.mli create mode 100644 middle_end/flambda/simplify_primitives.ml create mode 100644 middle_end/flambda/simplify_primitives.mli create mode 100644 middle_end/flambda/traverse_for_exported_symbols.ml create mode 100644 middle_end/flambda/traverse_for_exported_symbols.mli create mode 100644 middle_end/flambda/un_anf.ml create mode 100644 middle_end/flambda/un_anf.mli create mode 100644 middle_end/flambda/unbox_closures.ml create mode 100644 middle_end/flambda/unbox_closures.mli create mode 100644 middle_end/flambda/unbox_free_vars_of_closures.ml create mode 100644 middle_end/flambda/unbox_free_vars_of_closures.mli create mode 100644 middle_end/flambda/unbox_specialised_args.ml create mode 100644 middle_end/flambda/unbox_specialised_args.mli delete mode 100644 middle_end/flambda_invariants.ml delete mode 100644 middle_end/flambda_invariants.mli delete mode 100644 middle_end/flambda_iterators.ml delete mode 100644 middle_end/flambda_iterators.mli delete mode 100644 middle_end/flambda_utils.ml delete mode 100644 middle_end/flambda_utils.mli delete mode 100644 middle_end/freshening.ml delete mode 100644 middle_end/freshening.mli delete mode 100644 middle_end/inconstant_idents.ml delete mode 100644 middle_end/inconstant_idents.mli delete mode 100644 middle_end/initialize_symbol_to_let_symbol.ml delete mode 100644 middle_end/initialize_symbol_to_let_symbol.mli delete mode 100644 middle_end/inline_and_simplify.ml delete mode 100644 middle_end/inline_and_simplify.mli delete mode 100644 middle_end/inline_and_simplify_aux.ml delete mode 100644 middle_end/inline_and_simplify_aux.mli delete mode 100644 middle_end/inlining_cost.ml delete mode 100644 middle_end/inlining_cost.mli delete mode 100644 middle_end/inlining_decision.ml delete mode 100644 middle_end/inlining_decision.mli delete mode 100644 middle_end/inlining_decision_intf.mli delete mode 100644 middle_end/inlining_stats.ml delete mode 100644 middle_end/inlining_stats.mli delete mode 100644 middle_end/inlining_stats_types.ml delete mode 100644 middle_end/inlining_stats_types.mli delete mode 100644 middle_end/inlining_transforms.ml delete mode 100644 middle_end/inlining_transforms.mli delete mode 100644 middle_end/int_replace_polymorphic_compare.ml delete mode 100644 middle_end/int_replace_polymorphic_compare.mli delete mode 100644 middle_end/invariant_params.ml delete mode 100644 middle_end/invariant_params.mli delete mode 100644 middle_end/lift_code.ml delete mode 100644 middle_end/lift_code.mli delete mode 100644 middle_end/lift_constants.ml delete mode 100644 middle_end/lift_constants.mli delete mode 100644 middle_end/lift_let_to_initialize_symbol.ml delete mode 100644 middle_end/lift_let_to_initialize_symbol.mli create mode 100644 middle_end/linkage_name.ml create mode 100644 middle_end/linkage_name.mli delete mode 100644 middle_end/middle_end.ml delete mode 100644 middle_end/middle_end.mli delete mode 100644 middle_end/parameter.ml delete mode 100644 middle_end/parameter.mli delete mode 100644 middle_end/pass_wrapper.ml delete mode 100644 middle_end/pass_wrapper.mli create mode 100644 middle_end/printclambda.ml create mode 100644 middle_end/printclambda.mli create mode 100644 middle_end/printclambda_primitives.ml create mode 100644 middle_end/printclambda_primitives.mli delete mode 100644 middle_end/projection.ml delete mode 100644 middle_end/projection.mli delete mode 100644 middle_end/ref_to_variables.ml delete mode 100644 middle_end/ref_to_variables.mli delete mode 100644 middle_end/remove_free_vars_equal_to_args.ml delete mode 100644 middle_end/remove_free_vars_equal_to_args.mli delete mode 100644 middle_end/remove_unused_arguments.ml delete mode 100644 middle_end/remove_unused_arguments.mli delete mode 100644 middle_end/remove_unused_closure_vars.ml delete mode 100644 middle_end/remove_unused_closure_vars.mli delete mode 100644 middle_end/remove_unused_program_constructs.ml delete mode 100644 middle_end/remove_unused_program_constructs.mli create mode 100644 middle_end/semantics_of_primitives.ml create mode 100644 middle_end/semantics_of_primitives.mli delete mode 100644 middle_end/share_constants.ml delete mode 100644 middle_end/share_constants.mli delete mode 100644 middle_end/simple_value_approx.ml delete mode 100644 middle_end/simple_value_approx.mli delete mode 100644 middle_end/simplify_boxed_integer_ops.ml delete mode 100644 middle_end/simplify_boxed_integer_ops.mli delete mode 100644 middle_end/simplify_boxed_integer_ops_intf.mli delete mode 100644 middle_end/simplify_common.ml delete mode 100644 middle_end/simplify_common.mli delete mode 100644 middle_end/simplify_primitives.ml delete mode 100644 middle_end/simplify_primitives.mli create mode 100644 middle_end/symbol.ml create mode 100644 middle_end/symbol.mli delete mode 100644 middle_end/unbox_closures.ml delete mode 100644 middle_end/unbox_closures.mli delete mode 100644 middle_end/unbox_free_vars_of_closures.ml delete mode 100644 middle_end/unbox_free_vars_of_closures.mli delete mode 100644 middle_end/unbox_specialised_args.ml delete mode 100644 middle_end/unbox_specialised_args.mli create mode 100644 middle_end/variable.ml create mode 100644 middle_end/variable.mli (limited to 'middle_end') diff --git a/middle_end/alias_analysis.ml b/middle_end/alias_analysis.ml deleted file mode 100644 index fe97a36f51..0000000000 --- a/middle_end/alias_analysis.ml +++ /dev/null @@ -1,168 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -type allocation_point = - | Symbol of Symbol.t - | Variable of Variable.t - -type allocated_const = - | Normal of Allocated_const.t - | Array of Lambda.array_kind * Asttypes.mutable_flag * Variable.t list - | Duplicate_array of Lambda.array_kind * Asttypes.mutable_flag * Variable.t - -type constant_defining_value = - | Allocated_const of allocated_const - | Block of Tag.t * Variable.t list - | Set_of_closures of Flambda.set_of_closures - | Project_closure of Flambda.project_closure - | Move_within_set_of_closures of Flambda.move_within_set_of_closures - | Project_var of Flambda.project_var - | Field of Variable.t * int - | Symbol_field of Symbol.t * int - | Const of Flambda.const - | Symbol of Symbol.t - | Variable of Variable.t - -type initialize_symbol_field = Variable.t option - -type definitions = { - variable : constant_defining_value Variable.Tbl.t; - initialize_symbol : initialize_symbol_field list Symbol.Tbl.t; - symbol : Flambda.constant_defining_value Symbol.Tbl.t; -} - -let print_constant_defining_value ppf = function - | Allocated_const (Normal const) -> Allocated_const.print ppf const - | Allocated_const (Array (_, _, vars)) -> - Format.fprintf ppf "[| %a |]" - (Format.pp_print_list Variable.print) vars - | Allocated_const (Duplicate_array (_, _, var)) -> - Format.fprintf ppf "dup_array(%a)" Variable.print var - | Block (tag, vars) -> - Format.fprintf ppf "[|%a: %a|]" - Tag.print tag - (Format.pp_print_list Variable.print) vars - | Set_of_closures set -> Flambda.print_set_of_closures ppf set - | Project_closure project -> Flambda.print_project_closure ppf project - | Move_within_set_of_closures move -> - Flambda.print_move_within_set_of_closures ppf move - | Project_var project -> Flambda.print_project_var ppf project - | Field (var, field) -> Format.fprintf ppf "%a.(%d)" Variable.print var field - | Symbol_field (sym, field) -> - Format.fprintf ppf "%a.(%d)" Symbol.print sym field - | Const const -> Flambda.print_const ppf const - | Symbol symbol -> Symbol.print ppf symbol - | Variable var -> Variable.print ppf var - -let rec resolve_definition - (definitions: definitions) - (var: Variable.t) - (def: constant_defining_value) - ~the_dead_constant : allocation_point = - match def with - | Allocated_const _ - | Block _ - | Set_of_closures _ - | Project_closure _ - | Const _ - | Move_within_set_of_closures _ -> - Variable var - | Project_var {var} -> - fetch_variable definitions (Var_within_closure.unwrap var) - ~the_dead_constant - | Variable v -> - fetch_variable definitions v - ~the_dead_constant - | Symbol sym -> Symbol sym - | Field (v, n) -> - begin match fetch_variable definitions v ~the_dead_constant with - | Symbol s -> - fetch_symbol_field definitions s n ~the_dead_constant - | Variable v -> - fetch_variable_field definitions v n ~the_dead_constant - end - | Symbol_field (symbol, field) -> - fetch_symbol_field definitions symbol field ~the_dead_constant - -and fetch_variable - (definitions: definitions) - (var: Variable.t) - ~the_dead_constant : allocation_point = - match Variable.Tbl.find definitions.variable var with - | exception Not_found -> Variable var - | def -> resolve_definition definitions var def ~the_dead_constant - -and fetch_variable_field - (definitions: definitions) - (var: Variable.t) - (field: int) - ~the_dead_constant : allocation_point = - match Variable.Tbl.find definitions.variable var with - | Block (_, fields) -> - begin match List.nth fields field with - | exception Not_found -> Symbol the_dead_constant - | v -> fetch_variable definitions v ~the_dead_constant - end - | exception Not_found -> - Misc.fatal_errorf "No definition for field access to %a" Variable.print var - | Symbol _ | Variable _ | Project_var _ | Field _ | Symbol_field _ -> - (* Must have been resolved *) - assert false - | Const _ | Allocated_const _ - | Set_of_closures _ | Project_closure _ | Move_within_set_of_closures _ -> - Symbol the_dead_constant - -and fetch_symbol_field - (definitions: definitions) - (sym: Symbol.t) - (field: int) - ~the_dead_constant : allocation_point = - match Symbol.Tbl.find definitions.symbol sym with - | Block (_, fields) -> - begin match List.nth fields field with - | exception Not_found -> Symbol the_dead_constant - | Symbol s -> Symbol s - | Const _ -> Symbol sym - end - | exception Not_found -> - begin match Symbol.Tbl.find definitions.initialize_symbol sym with - | fields -> - begin match List.nth fields field with - | None -> - Misc.fatal_errorf "Constant field access to an inconstant %a" - Symbol.print sym - | Some v -> - fetch_variable definitions v ~the_dead_constant - end - | exception Not_found -> - Misc.fatal_errorf "No definition for field access to %a" - Symbol.print sym - end - | Allocated_const _ | Set_of_closures _ | Project_closure _ -> - Symbol the_dead_constant - -let run variable initialize_symbol symbol ~the_dead_constant = - let definitions = { variable; initialize_symbol; symbol; } in - Variable.Tbl.fold (fun var definition result -> - let definition = - resolve_definition definitions var definition ~the_dead_constant - in - Variable.Map.add var definition result) - definitions.variable - Variable.Map.empty diff --git a/middle_end/alias_analysis.mli b/middle_end/alias_analysis.mli deleted file mode 100644 index 515daeffa3..0000000000 --- a/middle_end/alias_analysis.mli +++ /dev/null @@ -1,63 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -type allocation_point = - | Symbol of Symbol.t - | Variable of Variable.t - -type allocated_const = - | Normal of Allocated_const.t - | Array of Lambda.array_kind * Asttypes.mutable_flag * Variable.t list - | Duplicate_array of Lambda.array_kind * Asttypes.mutable_flag * Variable.t - -type constant_defining_value = - | Allocated_const of allocated_const - | Block of Tag.t * Variable.t list - | Set_of_closures of Flambda.set_of_closures - | Project_closure of Flambda.project_closure - | Move_within_set_of_closures of Flambda.move_within_set_of_closures - | Project_var of Flambda.project_var - | Field of Variable.t * int - | Symbol_field of Symbol.t * int - | Const of Flambda.const - | Symbol of Symbol.t - | Variable of Variable.t - -type initialize_symbol_field = Variable.t option - -(** Simple alias analysis working over information about which - symbols have been assigned to variables; and which constants have - been assigned to symbols. The return value gives the assignment - of the defining values of constants to variables. - Also see comments for [Lift_constants], whose input feeds this - pass. - - Variables found to be ill-typed accesses to other constants, for - example arising from dead code, will be pointed at [the_dead_constant]. -*) -val run - : constant_defining_value Variable.Tbl.t - -> initialize_symbol_field list Symbol.Tbl.t - -> Flambda.constant_defining_value Symbol.Tbl.t - -> the_dead_constant:Symbol.t - -> allocation_point Variable.Map.t - -val print_constant_defining_value - : Format.formatter - -> constant_defining_value - -> unit diff --git a/middle_end/allocated_const.ml b/middle_end/allocated_const.ml deleted file mode 100644 index 78dc4ee103..0000000000 --- a/middle_end/allocated_const.ml +++ /dev/null @@ -1,86 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -type t = - | Float of float - | Int32 of int32 - | Int64 of int64 - | Nativeint of nativeint - | Float_array of float list - | Immutable_float_array of float list - | String of string - | Immutable_string of string - -let compare_floats x1 x2 = - (* It is important to compare the bit patterns here, so as not to - be subject to bugs such as GPR#295. *) - Int64.compare (Int64.bits_of_float x1) (Int64.bits_of_float x2) - -let compare (x : t) (y : t) = - let rec compare_float_lists l1 l2 = - match l1, l2 with - | [], [] -> 0 - | [], _::_ -> -1 - | _::_, [] -> 1 - | h1::t1, h2::t2 -> - let c = compare_floats h1 h2 in - if c <> 0 then c else compare_float_lists t1 t2 - in - match x, y with - | Float x, Float y -> compare_floats x y - | Int32 x, Int32 y -> Int32.compare x y - | Int64 x, Int64 y -> Int64.compare x y - | Nativeint x, Nativeint y -> Nativeint.compare x y - | Float_array x, Float_array y -> compare_float_lists x y - | Immutable_float_array x, Immutable_float_array y -> compare_float_lists x y - | String x, String y -> String.compare x y - | Immutable_string x, Immutable_string y -> String.compare x y - | Float _, _ -> -1 - | _, Float _ -> 1 - | Int32 _, _ -> -1 - | _, Int32 _ -> 1 - | Int64 _, _ -> -1 - | _, Int64 _ -> 1 - | Nativeint _, _ -> -1 - | _, Nativeint _ -> 1 - | Float_array _, _ -> -1 - | _, Float_array _ -> 1 - | Immutable_float_array _, _ -> -1 - | _, Immutable_float_array _ -> 1 - | String _, _ -> -1 - | _, String _ -> 1 - -let print ppf (t : t) = - let fprintf = Format.fprintf in - let floats ppf fl = - List.iter (fun f -> fprintf ppf "@ %f" f) fl - in - match t with - | String s -> fprintf ppf "%S" s - | Immutable_string s -> fprintf ppf "#%S" s - | Int32 n -> fprintf ppf "%lil" n - | Int64 n -> fprintf ppf "%LiL" n - | Nativeint n -> fprintf ppf "%nin" n - | Float f -> fprintf ppf "%f" f - | Float_array [] -> fprintf ppf "[| |]" - | Float_array (f1 :: fl) -> - fprintf ppf "@[<1>[|@[%f%a@]|]@]" f1 floats fl - | Immutable_float_array [] -> fprintf ppf "[|# |]" - | Immutable_float_array (f1 :: fl) -> - fprintf ppf "@[<1>[|# @[%f%a@]|]@]" f1 floats fl diff --git a/middle_end/allocated_const.mli b/middle_end/allocated_const.mli deleted file mode 100644 index 0bdbe49ec4..0000000000 --- a/middle_end/allocated_const.mli +++ /dev/null @@ -1,38 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -(** Constants that are always allocated (possibly statically). Blocks - are not included here since they are always encoded using - [Prim (Pmakeblock, ...)]. *) - -type t = - | Float of float - | Int32 of int32 - | Int64 of int64 - | Nativeint of nativeint - (* CR-someday mshinwell: consider using "float array" *) - | Float_array of float list - | Immutable_float_array of float list - | String of string - | Immutable_string of string - -val compare_floats : float -> float -> int - -val compare : t -> t -> int - -val print : Format.formatter -> t -> unit diff --git a/middle_end/augment_specialised_args.ml b/middle_end/augment_specialised_args.ml deleted file mode 100644 index c3a3078512..0000000000 --- a/middle_end/augment_specialised_args.ml +++ /dev/null @@ -1,762 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -module E = Inline_and_simplify_aux.Env -module B = Inlining_cost.Benefit - -module Definition = struct - type t = - | Existing_inner_free_var of Variable.t - | Projection_from_existing_specialised_arg of Projection.t - - include Identifiable.Make (struct - type nonrec t = t - - let compare t1 t2 = - match t1, t2 with - | Existing_inner_free_var var1, Existing_inner_free_var var2 -> - Variable.compare var1 var2 - | Projection_from_existing_specialised_arg proj1, - Projection_from_existing_specialised_arg proj2 -> - Projection.compare proj1 proj2 - | Existing_inner_free_var _, _ -> -1 - | _, Existing_inner_free_var _ -> 1 - - let equal t1 t2 = - (compare t1 t2) = 0 - - let hash = Hashtbl.hash - - let print ppf t = - match t with - | Existing_inner_free_var var -> - Format.fprintf ppf "Existing_inner_free_var %a" - Variable.print var - | Projection_from_existing_specialised_arg projection -> - Format.fprintf ppf "Projection_from_existing_specialised_arg %a" - Projection.print projection - - let output _ _ = failwith "Definition.output not yet implemented" - end) -end - -module What_to_specialise = struct - type t = { - (* [definitions] is indexed by (fun_var, group) *) - definitions : Definition.t list Variable.Pair.Map.t; - set_of_closures : Flambda.set_of_closures; - make_direct_call_surrogates_for : Variable.Set.t; - } - - let create ~set_of_closures = - { definitions = Variable.Pair.Map.empty; - set_of_closures; - make_direct_call_surrogates_for = Variable.Set.empty; - } - - let new_specialised_arg t ~fun_var ~group ~definition = - let key = fun_var, group in - let definitions = - match Variable.Pair.Map.find key t.definitions with - | exception Not_found -> [] - | definitions -> definitions - in - let definitions = - Variable.Pair.Map.add (fun_var, group) (definition :: definitions) - t.definitions - in - { t with definitions; } - - let make_direct_call_surrogate_for t ~fun_var = - match Variable.Map.find fun_var t.set_of_closures.function_decls.funs with - | exception Not_found -> - Misc.fatal_errorf "use_direct_call_surrogate_for: %a is not a fun_var \ - from the given set of closures" - Variable.print fun_var - | _ -> - { t with - make_direct_call_surrogates_for = - Variable.Set.add fun_var t.make_direct_call_surrogates_for; - } -end - -module W = What_to_specialise - -module type S = sig - val pass_name : string - - val what_to_specialise - : env:Inline_and_simplify_aux.Env.t - -> set_of_closures:Flambda.set_of_closures - -> What_to_specialise.t -end - -module Processed_what_to_specialise = struct - type for_one_function = { - fun_var : Variable.t; - function_decl : Flambda.function_declaration; - make_direct_call_surrogates : bool; - new_definitions_indexed_by_new_inner_vars : Definition.t Variable.Map.t; - all_new_definitions : Definition.Set.t; - new_inner_to_new_outer_vars : Variable.t Variable.Map.t; - total_number_of_args : int; - existing_specialised_args : Flambda.specialised_to Variable.Map.t; - } - - type t = { - set_of_closures : Flambda.set_of_closures; - existing_definitions_via_spec_args_indexed_by_fun_var - : Definition.Set.t Variable.Map.t; - (* The following two maps' definitions have already been rewritten - into their lifted form (i.e. they reference outer rather than inner - variables). *) - new_lifted_defns_indexed_by_new_outer_vars : Projection.t Variable.Map.t; - new_outer_vars_indexed_by_new_lifted_defns : Variable.t Projection.Map.t; - functions : for_one_function Variable.Map.t; - make_direct_call_surrogates_for : Variable.Set.t; - } - - let lift_projection t ~(projection : Projection.t) = - (* The lifted definition must be in terms of outer variables, - not inner variables. *) - let find_outer_var inner_var = - match Variable.Map.find inner_var t.set_of_closures.specialised_args with - | (outer_var : Flambda.specialised_to) -> outer_var.var - | exception Not_found -> - Misc.fatal_errorf "find_outer_var: expected %a \ - to be in [specialised_args], but it is \ - not. The projection was: %a. Set of closures: %a" - Variable.print inner_var - Projection.print projection - Flambda.print_set_of_closures t.set_of_closures - in - Projection.map_projecting_from projection ~f:find_outer_var - - let really_add_new_specialised_arg t ~group ~(definition : Definition.t) - ~(for_one_function : for_one_function) = - let fun_var = for_one_function.fun_var in - (* We know here that a new specialised argument must be added. This - needs a "new inner var" and a "new outer var". However if there - is already a lifted projection being introduced around the set - of closures (corresponding to another new specialised argument), - we should re-use its "new outer var" to avoid duplication of - projection definitions. Likewise if the definition is just - [Existing_inner_free_var], in which case we can use the - corresponding existing outer free variable. *) - let new_outer_var, t = - let existing_outer_var = - match definition with - | Existing_inner_free_var _ -> None - | Projection_from_existing_specialised_arg projection -> - let projection = lift_projection t ~projection in - match - Projection.Map.find projection - t.new_outer_vars_indexed_by_new_lifted_defns - with - | new_outer_var -> Some new_outer_var - | exception Not_found -> None - in - match existing_outer_var with - | Some existing_outer_var -> existing_outer_var, t - | None -> - match definition with - | Existing_inner_free_var existing_inner_var -> - begin match - Variable.Map.find existing_inner_var - t.set_of_closures.free_vars - with - | exception Not_found -> - Misc.fatal_errorf "really_add_new_specialised_arg: \ - Existing_inner_free_var %a is not an inner free variable \ - of %a in %a" - Variable.print existing_inner_var - Variable.print fun_var - Flambda.print_set_of_closures t.set_of_closures - | existing_outer_var -> existing_outer_var.var, t - end - | Projection_from_existing_specialised_arg projection -> - let new_outer_var = Variable.rename group in - let projection = lift_projection t ~projection in - let new_outer_vars_indexed_by_new_lifted_defns = - Projection.Map.add - projection new_outer_var - t.new_outer_vars_indexed_by_new_lifted_defns - in - let new_lifted_defns_indexed_by_new_outer_vars = - Variable.Map.add - new_outer_var projection - t.new_lifted_defns_indexed_by_new_outer_vars - in - let t = - { t with - new_outer_vars_indexed_by_new_lifted_defns; - new_lifted_defns_indexed_by_new_outer_vars; - } - in - new_outer_var, t - in - let new_inner_var = Variable.rename group in - let new_inner_to_new_outer_vars = - Variable.Map.add new_inner_var new_outer_var - for_one_function.new_inner_to_new_outer_vars - in - let for_one_function : for_one_function = - { for_one_function with - new_definitions_indexed_by_new_inner_vars = - Variable.Map.add new_inner_var definition - for_one_function.new_definitions_indexed_by_new_inner_vars; - all_new_definitions = - Definition.Set.add definition - for_one_function.all_new_definitions; - new_inner_to_new_outer_vars; - total_number_of_args = for_one_function.total_number_of_args + 1; - } - in - { t with - functions = Variable.Map.add fun_var for_one_function t.functions; - } - - let new_specialised_arg t ~fun_var ~group ~definition = - let for_one_function : for_one_function = - match Variable.Map.find fun_var t.functions with - | exception Not_found -> - begin - match Variable.Map.find fun_var t.set_of_closures.function_decls.funs - with - | exception Not_found -> assert false - | (function_decl : Flambda.function_declaration) -> - let params = Parameter.Set.vars function_decl.params in - let existing_specialised_args = - Variable.Map.filter (fun inner_var _spec_to -> - Variable.Set.mem inner_var params) - t.set_of_closures.specialised_args - in - let make_direct_call_surrogates = - Variable.Set.mem fun_var t.make_direct_call_surrogates_for - in - { fun_var; - function_decl; - make_direct_call_surrogates; - new_definitions_indexed_by_new_inner_vars = Variable.Map.empty; - all_new_definitions = Definition.Set.empty; - new_inner_to_new_outer_vars = Variable.Map.empty; - (* The "+ 1" is just in case there is a closure environment - parameter added later. *) - total_number_of_args = List.length function_decl.params + 1; - existing_specialised_args; - } - end - | for_one_function -> for_one_function - in - (* Determine whether there already exists an existing specialised argument - that is known to be equal to the one proposed to this function. If so, - use that instead. (Note that we also desire to dedup against any - new specialised arguments added to the current function; but that - happens automatically since [Extract_projections] returns a set.) *) - let exists_already = - match - Variable.Map.find fun_var - t.existing_definitions_via_spec_args_indexed_by_fun_var - with - | exception Not_found -> false - | definitions -> Definition.Set.mem definition definitions - in - if exists_already then t - else really_add_new_specialised_arg t ~group ~definition ~for_one_function - - let create ~env ~(what_to_specialise : W.t) = - let existing_definitions_via_spec_args_indexed_by_fun_var = - Variable.Map.map (fun (function_decl : Flambda.function_declaration) -> - if function_decl.stub then - Definition.Set.empty - else - let params = Parameter.Set.vars function_decl.params in - Variable.Map.fold (fun inner_var - (spec_to : Flambda.specialised_to) definitions -> - if not (Variable.Set.mem inner_var params) then - definitions - else - let definition : Definition.t = - match spec_to.projection with - | None -> Existing_inner_free_var inner_var - | Some projection -> - Projection_from_existing_specialised_arg projection - in - Definition.Set.add definition definitions) - what_to_specialise.set_of_closures.specialised_args - Definition.Set.empty) - what_to_specialise.set_of_closures.function_decls.funs - in - let t : t = - { set_of_closures = what_to_specialise.set_of_closures; - existing_definitions_via_spec_args_indexed_by_fun_var; - new_lifted_defns_indexed_by_new_outer_vars = Variable.Map.empty; - new_outer_vars_indexed_by_new_lifted_defns = Projection.Map.empty; - functions = Variable.Map.empty; - make_direct_call_surrogates_for = - what_to_specialise.make_direct_call_surrogates_for; - } - in - (* It is important to limit the number of arguments added: if arguments - end up being passed on the stack, tail call optimization will be - disabled (see asmcomp/selectgen.ml). - For each group of new specialised args provided by [T], either all or - none of them will be added. (This is to avoid the situation where we - add extra arguments but yet fail to eliminate an original one by - stopping part-way through the specialised args addition.) *) - let by_group = - Variable.Pair.Map.fold (fun (fun_var, group) definitions by_group -> - let fun_vars_and_definitions = - match Variable.Map.find group by_group with - | exception Not_found -> [] - | fun_vars_and_definitions -> fun_vars_and_definitions - in - Variable.Map.add group - ((fun_var, definitions)::fun_vars_and_definitions) - by_group) - what_to_specialise.definitions - Variable.Map.empty - in - let module Backend = (val (E.backend env) : Backend_intf.S) in - Variable.Map.fold (fun group fun_vars_and_definitions t -> - let original_t = t in - let t = - (* Try adding all specialised args in the current group. *) - List.fold_left (fun t (fun_var, definitions) -> - List.fold_left (fun t definition -> - new_specialised_arg t ~fun_var ~group ~definition) - t - definitions) - t - fun_vars_and_definitions - in - let some_function_has_too_many_args = - Variable.Map.exists (fun _ (for_one_function : for_one_function) -> - for_one_function.total_number_of_args - > Backend.max_sensible_number_of_arguments) - t.functions - in - if some_function_has_too_many_args then - original_t (* drop this group *) - else - t) - by_group - t -end - -module P = Processed_what_to_specialise - -let check_invariants ~pass_name ~(set_of_closures : Flambda.set_of_closures) - ~original_set_of_closures = - if !Clflags.flambda_invariant_checks then begin - Variable.Map.iter (fun fun_var - (function_decl : Flambda.function_declaration) -> - let params = Parameter.Set.vars function_decl.params in - Variable.Map.iter (fun inner_var - (outer_var : Flambda.specialised_to) -> - if Variable.Set.mem inner_var params then begin - assert (not (Variable.Set.mem outer_var.var - function_decl.free_variables)); - match outer_var.projection with - | None -> () - | Some projection -> - let from = Projection.projecting_from projection in - if not (Variable.Set.mem from params) then begin - Misc.fatal_errorf "Augment_specialised_args (%s): \ - specialised argument (%a -> %a) references a \ - projection variable that is not a specialised \ - argument of the function %a. @ The set of closures \ - before the transformation was:@ %a. @ The set of \ - closures after the transformation was:@ %a." - pass_name - Variable.print inner_var - Flambda.print_specialised_to outer_var - Variable.print fun_var - Flambda.print_set_of_closures original_set_of_closures - Flambda.print_set_of_closures set_of_closures - end - end) - set_of_closures.specialised_args) - set_of_closures.function_decls.funs - end - -module Make (T : S) = struct - let () = Pass_wrapper.register ~pass_name:T.pass_name - - let rename_function_and_parameters ~fun_var - ~(function_decl : Flambda.function_declaration) = - let new_fun_var = Variable.rename fun_var in - let params_renaming_list = - List.map (fun param -> - let new_param = Parameter.rename param in - param, new_param) - function_decl.params - in - let renamed_params = List.map snd params_renaming_list in - let params_renaming = - Variable.Map.of_list - (List.map (fun (param, new_param) -> - Parameter.var param, Parameter.var new_param) - params_renaming_list) - in - new_fun_var, params_renaming, renamed_params - - let create_wrapper ~(for_one_function : P.for_one_function) ~benefit = - let fun_var = for_one_function.fun_var in - let function_decl = for_one_function.function_decl in - (* To avoid increasing the free variables of the wrapper, for - general cleanliness, we restate the definitions of the - newly-specialised arguments in the wrapper itself in terms of the - original specialised arguments. The variables bound to these - definitions are called the "specialised args bound in the wrapper". - Note that the domain of [params_renaming] is a (non-strict) superset - of the "inner vars" of the original specialised args. *) - let params = Parameter.Set.vars function_decl.params in - let new_fun_var, params_renaming, wrapper_params = - rename_function_and_parameters ~fun_var ~function_decl - in - let find_wrapper_param param = - assert (Variable.Set.mem param params); - match Variable.Map.find param params_renaming with - | wrapper_param -> wrapper_param - | exception Not_found -> - Misc.fatal_errorf "find_wrapper_param: expected %a \ - to be in [params_renaming], but it is not." - Variable.print param - in - let new_inner_vars_to_spec_args_bound_in_the_wrapper_renaming = - Variable.Map.mapi (fun new_inner_var _ -> - Variable.rename new_inner_var) - for_one_function.new_definitions_indexed_by_new_inner_vars - in - let spec_args_bound_in_the_wrapper = - (* N.B.: in the order matching the new specialised argument parameters - to the main function. *) - Variable.Map.data - new_inner_vars_to_spec_args_bound_in_the_wrapper_renaming - in - (* New definitions that project from existing specialised args need - to be rewritten to use the corresponding specialised args of - the wrapper. Definitions that are just equality to existing - inner free variables do not need to be changed. Once this has - been done the wrapper body can be constructed. - We also need to rewrite definitions for any existing specialised - args; these now have corresponding wrapper parameters that must - also be specialised. *) - let wrapper_body, benefit = - let apply : Flambda.expr = - Apply { - func = new_fun_var; - args = - (Parameter.List.vars wrapper_params) @ - spec_args_bound_in_the_wrapper; - kind = Direct (Closure_id.wrap new_fun_var); - dbg = Debuginfo.none; - inline = Default_inline; - specialise = Default_specialise; - } - in - Variable.Map.fold (fun new_inner_var definition (wrapper_body, benefit) -> - let definition : Definition.t = - match (definition : Definition.t) with - | Existing_inner_free_var _ -> definition - | Projection_from_existing_specialised_arg projection -> - Projection_from_existing_specialised_arg - (Projection.map_projecting_from projection - ~f:find_wrapper_param) - in - let benefit = - match (definition : Definition.t) with - | Existing_inner_free_var _ -> benefit - | Projection_from_existing_specialised_arg projection -> - B.add_projection projection benefit - in - match - Variable.Map.find new_inner_var - new_inner_vars_to_spec_args_bound_in_the_wrapper_renaming - with - | exception Not_found -> assert false - | new_inner_var_of_wrapper -> - let named : Flambda.named = - match definition with - | Existing_inner_free_var existing_inner_var -> - Expr (Var existing_inner_var) - | Projection_from_existing_specialised_arg projection -> - Flambda_utils.projection_to_named projection - in - let wrapper_body = - Flambda.create_let new_inner_var_of_wrapper named wrapper_body - in - (wrapper_body, benefit)) - for_one_function.new_definitions_indexed_by_new_inner_vars - (apply, benefit) - in - let rewritten_existing_specialised_args = - Variable.Map.fold (fun inner_var (spec_to : Flambda.specialised_to) - result -> - let inner_var = find_wrapper_param inner_var in - let projection = - match spec_to.projection with - | None -> None - | Some projection -> - Some (Projection.map_projecting_from projection - ~f:find_wrapper_param) - in - let spec_to : Flambda.specialised_to = - { var = spec_to.var; - projection; - } - in - Variable.Map.add inner_var spec_to result) - for_one_function.existing_specialised_args - Variable.Map.empty - in - let new_function_decl = - Flambda.create_function_declaration - ~params:wrapper_params - ~body:wrapper_body - ~stub:true - ~dbg:Debuginfo.none - ~inline:Default_inline - ~specialise:Default_specialise - ~is_a_functor:false - ~closure_origin:function_decl.closure_origin - in - new_fun_var, new_function_decl, rewritten_existing_specialised_args, - benefit - - let rewrite_function_decl (t : P.t) ~env ~duplicate_function - ~(for_one_function : P.for_one_function) ~benefit = - let set_of_closures = t.set_of_closures in - let fun_var = for_one_function.fun_var in - let function_decl = for_one_function.function_decl in - let num_definitions = - Variable.Map.cardinal for_one_function. - new_definitions_indexed_by_new_inner_vars - in - if function_decl.stub - || num_definitions < 1 - || Variable.Map.mem fun_var set_of_closures.direct_call_surrogates - then - None - else - let new_fun_var, wrapper, rewritten_existing_specialised_args, benefit = - create_wrapper ~for_one_function ~benefit - in - let new_specialised_args = - Variable.Map.mapi (fun new_inner_var (definition : Definition.t) - : Flambda.specialised_to -> - assert (not (Variable.Map.mem new_inner_var - set_of_closures.specialised_args)); - match - Variable.Map.find new_inner_var - for_one_function.new_inner_to_new_outer_vars - with - | exception Not_found -> assert false - | new_outer_var -> - match definition with - | Existing_inner_free_var _ -> - { var = new_outer_var; - projection = None; - } - | Projection_from_existing_specialised_arg projection -> - let projecting_from = Projection.projecting_from projection in - assert (Variable.Map.mem projecting_from - set_of_closures.specialised_args); - assert (Variable.Set.mem projecting_from - (Parameter.Set.vars function_decl.params)); - { var = new_outer_var; - projection = Some projection; - }) - for_one_function.new_definitions_indexed_by_new_inner_vars - in - let specialised_args = - Variable.Map.disjoint_union rewritten_existing_specialised_args - new_specialised_args - in - let specialised_args, existing_function_decl = - if not for_one_function.make_direct_call_surrogates then - specialised_args, None - else - let function_decl, new_specialised_args = - duplicate_function ~env ~set_of_closures ~fun_var ~new_fun_var - in - let specialised_args = - Variable.Map.disjoint_union specialised_args new_specialised_args - in - specialised_args, Some function_decl - in - let all_params = - let new_params = - Variable.Set.elements (Variable.Map.keys - for_one_function.new_inner_to_new_outer_vars) - in - let new_params = - List.map Parameter.wrap new_params - in - function_decl.params @ new_params - in - let closure_origin = - Closure_origin.create (Closure_id.wrap new_fun_var) - in - let rewritten_function_decl = - Flambda.create_function_declaration - ~params:all_params - ~body:function_decl.body - ~stub:function_decl.stub - ~dbg:function_decl.dbg - ~inline:function_decl.inline - ~specialise:function_decl.specialise - ~is_a_functor:function_decl.is_a_functor - ~closure_origin - in - let funs, direct_call_surrogates = - if for_one_function.make_direct_call_surrogates then - let surrogate = Variable.rename fun_var in - let funs = - (* In this case, the original function declaration remains - untouched up to alpha-equivalence. Direct calls to it - (including inside the rewritten original function) will be - replaced by calls to the surrogate (i.e. the wrapper) which - will then be inlined. *) - let existing_function_decl = - match existing_function_decl with - | Some decl -> decl - | None -> assert false - in - Variable.Map.add new_fun_var rewritten_function_decl - (Variable.Map.add surrogate wrapper - (Variable.Map.add fun_var existing_function_decl - Variable.Map.empty)) - in - let direct_call_surrogates = - Variable.Map.add fun_var surrogate Variable.Map.empty - in - funs, direct_call_surrogates - else - let funs = - Variable.Map.add new_fun_var rewritten_function_decl - (Variable.Map.add fun_var wrapper Variable.Map.empty) - in - funs, Variable.Map.empty - in - let free_vars = Variable.Map.empty in - Some (funs, free_vars, specialised_args, direct_call_surrogates, benefit) - - let add_lifted_projections_around_set_of_closures - ~(set_of_closures : Flambda.set_of_closures) ~benefit - ~new_lifted_defns_indexed_by_new_outer_vars = - let body = - Flambda_utils.name_expr - ~name:Internal_variable_names.set_of_closures - (Set_of_closures set_of_closures) - in - Variable.Map.fold (fun new_outer_var (projection : Projection.t) - (expr, benefit) -> - let named = Flambda_utils.projection_to_named projection in - let benefit = B.add_projection projection benefit in - let expr = Flambda.create_let new_outer_var named expr in - expr, benefit) - new_lifted_defns_indexed_by_new_outer_vars - (body, benefit) - - let rewrite_set_of_closures_core ~env ~duplicate_function ~benefit - ~(set_of_closures : Flambda.set_of_closures) = - let what_to_specialise = - P.create ~env - ~what_to_specialise:(T.what_to_specialise ~env ~set_of_closures) - in - let original_set_of_closures = set_of_closures in - let funs, free_vars, specialised_args, direct_call_surrogates, - done_something, benefit = - Variable.Map.fold (fun fun_var function_decl - (funs, free_vars, specialised_args, direct_call_surrogates, - done_something, benefit) -> - match Variable.Map.find fun_var what_to_specialise.functions with - | exception Not_found -> - let funs = Variable.Map.add fun_var function_decl funs in - funs, free_vars, specialised_args, direct_call_surrogates, - done_something, benefit - | (for_one_function : P.for_one_function) -> - assert (Variable.equal fun_var for_one_function.fun_var); - match - rewrite_function_decl what_to_specialise ~env - ~duplicate_function ~for_one_function ~benefit - with - | None -> - let function_decl = for_one_function.function_decl in - let funs = Variable.Map.add fun_var function_decl funs in - funs, free_vars, specialised_args, direct_call_surrogates, - done_something, benefit - | Some (funs', free_vars', specialised_args', - direct_call_surrogates', benefit) -> - let funs = Variable.Map.disjoint_union funs funs' in - let direct_call_surrogates = - Variable.Map.disjoint_union direct_call_surrogates - direct_call_surrogates' - in - let free_vars = - Variable.Map.disjoint_union free_vars free_vars' - in - let specialised_args = - Variable.Map.disjoint_union specialised_args specialised_args' - in - funs, free_vars, specialised_args, direct_call_surrogates, true, - benefit) - set_of_closures.function_decls.funs - (Variable.Map.empty, set_of_closures.free_vars, - set_of_closures.specialised_args, - set_of_closures.direct_call_surrogates, false, benefit) - in - if not done_something then - None - else - let function_decls = - Flambda.update_function_declarations set_of_closures.function_decls - ~funs - in - assert (Variable.Map.cardinal specialised_args - >= Variable.Map.cardinal original_set_of_closures.specialised_args); - let set_of_closures = - Flambda.create_set_of_closures - ~function_decls - ~free_vars - ~specialised_args - ~direct_call_surrogates - in - if !Clflags.flambda_invariant_checks then begin - check_invariants ~set_of_closures ~original_set_of_closures - ~pass_name:T.pass_name - end; - let expr, benefit = - add_lifted_projections_around_set_of_closures ~set_of_closures ~benefit - ~new_lifted_defns_indexed_by_new_outer_vars: - what_to_specialise.new_lifted_defns_indexed_by_new_outer_vars - in - Some (expr, benefit) - - let rewrite_set_of_closures ~env ~duplicate_function ~set_of_closures = - Pass_wrapper.with_dump ~ppf_dump:(Inline_and_simplify_aux.Env.ppf_dump env) - ~pass_name:T.pass_name ~input:set_of_closures - ~print_input:Flambda.print_set_of_closures - ~print_output:(fun ppf (expr, _) -> Flambda.print ppf expr) - ~f:(fun () -> - rewrite_set_of_closures_core ~env ~duplicate_function - ~benefit:B.zero ~set_of_closures) -end diff --git a/middle_end/augment_specialised_args.mli b/middle_end/augment_specialised_args.mli deleted file mode 100644 index 5c48a12652..0000000000 --- a/middle_end/augment_specialised_args.mli +++ /dev/null @@ -1,65 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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. *) -(* *) -(**************************************************************************) - -(** Helper module for adding specialised arguments to sets of closures. *) - -module Definition : sig - type t = - | Existing_inner_free_var of Variable.t - | Projection_from_existing_specialised_arg of Projection.t -end - -module What_to_specialise : sig - type t - - val create - : set_of_closures:Flambda.set_of_closures - -> t - - val new_specialised_arg - : t - -> fun_var:Variable.t - -> group:Variable.t - -> definition:Definition.t (* [projecting_from] "existing inner vars" *) - -> t - - val make_direct_call_surrogate_for : t -> fun_var:Variable.t -> t -end - -module type S = sig - val pass_name : string - - val what_to_specialise - : env:Inline_and_simplify_aux.Env.t - -> set_of_closures:Flambda.set_of_closures - -> What_to_specialise.t -end - -module Make (T : S) : sig - (** [duplicate_function] should be - [Inline_and_simplify.duplicate_function]. *) - val rewrite_set_of_closures - : env:Inline_and_simplify_aux.Env.t - -> duplicate_function:( - env:Inline_and_simplify_aux.Env.t - -> set_of_closures:Flambda.set_of_closures - -> fun_var:Variable.t - -> new_fun_var:Variable.t - -> Flambda.function_declaration - * Flambda.specialised_to Variable.Map.t) - -> set_of_closures:Flambda.set_of_closures - -> (Flambda.expr * Inlining_cost.Benefit.t) option -end diff --git a/middle_end/backend_var.ml b/middle_end/backend_var.ml new file mode 100644 index 0000000000..39af7f6062 --- /dev/null +++ b/middle_end/backend_var.ml @@ -0,0 +1,87 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Mark Shinwell, Jane Street Europe *) +(* *) +(* Copyright 2018 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-4-30-40-41-42"] + +include Ident + +type backend_var = t + +module Provenance = struct + type t = { + module_path : Path.t; + location : Debuginfo.t; + original_ident : Ident.t; + } + + let print ppf { module_path; location; original_ident; } = + Format.fprintf ppf "@[(\ + @[(module_path@ %a)@]@ \ + @[(location@ %a)@]@ \ + @[(original_ident@ %a)@]\ + )@]" + Path.print module_path + Debuginfo.print_compact location + Ident.print original_ident + + let create ~module_path ~location ~original_ident = + { module_path; + location; + original_ident; + } + + let module_path t = t.module_path + let location t = t.location + let original_ident t = t.original_ident +end + +module With_provenance = struct + type t = + | Without_provenance of backend_var + | With_provenance of { + var : backend_var; + provenance : Provenance.t; + } + + let create ?provenance var = + match provenance with + | None -> Without_provenance var + | Some provenance -> With_provenance { var; provenance; } + + let var t = + match t with + | Without_provenance var + | With_provenance { var; provenance = _; } -> var + + let provenance t = + match t with + | Without_provenance _ -> None + | With_provenance { var = _; provenance; } -> Some provenance + + let name t = name (var t) + + let rename t = + let var = rename (var t) in + match provenance t with + | None -> Without_provenance var + | Some provenance -> With_provenance { var; provenance; } + + let print ppf t = + match provenance t with + | None -> print ppf (var t) + | Some provenance -> + Format.fprintf ppf "%a[%a]" + print (var t) + Provenance.print provenance +end diff --git a/middle_end/backend_var.mli b/middle_end/backend_var.mli new file mode 100644 index 0000000000..f236be1e47 --- /dev/null +++ b/middle_end/backend_var.mli @@ -0,0 +1,54 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Mark Shinwell, Jane Street Europe *) +(* *) +(* Copyright 2018 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. *) +(* *) +(**************************************************************************) + +(** Variables used in the backend, optionally equipped with "provenance" + information, used for the emission of debugging information. *) + +[@@@ocaml.warning "+a-4-30-40-41-42"] + +include module type of struct include Ident end + +type backend_var = t + +module Provenance : sig + type t + + val create + : module_path:Path.t + -> location:Debuginfo.t + -> original_ident:Ident.t + -> t + + val module_path : t -> Path.t + val location : t -> Debuginfo.t + val original_ident : t -> Ident.t + + val print : Format.formatter -> t -> unit +end + +module With_provenance : sig + (** Values of type [t] should be used for variables in binding position. *) + type t + + val print : Format.formatter -> t -> unit + + val create : ?provenance:Provenance.t -> backend_var -> t + + val var : t -> backend_var + val provenance : t -> Provenance.t option + + val name : t -> string + + val rename : t -> t +end diff --git a/middle_end/base_types/closure_element.ml b/middle_end/base_types/closure_element.ml deleted file mode 100644 index 561e080396..0000000000 --- a/middle_end/base_types/closure_element.ml +++ /dev/null @@ -1,26 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -include Variable - -let wrap t = t -let unwrap t = t - -let wrap_map t = t -let unwrap_set t = t diff --git a/middle_end/base_types/closure_element.mli b/middle_end/base_types/closure_element.mli deleted file mode 100644 index d78dd9b369..0000000000 --- a/middle_end/base_types/closure_element.mli +++ /dev/null @@ -1,32 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -include Identifiable.S - -val wrap : Variable.t -> t -val unwrap : t -> Variable.t - -val wrap_map : 'a Variable.Map.t -> 'a Map.t -val unwrap_set : Set.t -> Variable.Set.t - -val in_compilation_unit : t -> Compilation_unit.t -> bool -val get_compilation_unit : t -> Compilation_unit.t - -val unique_name : t -> string - -val output_full : out_channel -> t -> unit diff --git a/middle_end/base_types/closure_id.ml b/middle_end/base_types/closure_id.ml deleted file mode 100644 index 466f59a237..0000000000 --- a/middle_end/base_types/closure_id.ml +++ /dev/null @@ -1,20 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -include Closure_element diff --git a/middle_end/base_types/closure_id.mli b/middle_end/base_types/closure_id.mli deleted file mode 100644 index 853a07f7f4..0000000000 --- a/middle_end/base_types/closure_id.mli +++ /dev/null @@ -1,27 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -(** CR-someday lwhite: "Closure_id" is quite a generic name. I wonder - whether something like "Closure_label" would better capture that it is - the label of a projection. *) - -(** An identifier, unique across the whole program (not just one compilation - unit), that identifies a closure within a particular set of closures - (viz. [Project_closure]). *) - -include module type of Closure_element diff --git a/middle_end/base_types/closure_origin.ml b/middle_end/base_types/closure_origin.ml deleted file mode 100644 index 2285c687e3..0000000000 --- a/middle_end/base_types/closure_origin.ml +++ /dev/null @@ -1,22 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell, Leo White and Fu Yong Quah, Jane Street Europe *) -(* *) -(* Copyright 2013--2017 OCamlPro SAS *) -(* Copyright 2014--2017 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -include Closure_id - -let create t = t diff --git a/middle_end/base_types/closure_origin.mli b/middle_end/base_types/closure_origin.mli deleted file mode 100644 index 86fcd56cc6..0000000000 --- a/middle_end/base_types/closure_origin.mli +++ /dev/null @@ -1,21 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell, Leo White and Fu Yong Quah, Jane Street Europe *) -(* *) -(* Copyright 2013--2017 OCamlPro SAS *) -(* Copyright 2014--2017 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. *) -(* *) -(**************************************************************************) - -include Identifiable.S - -val create : Closure_id.t -> t - -val get_compilation_unit : t -> Compilation_unit.t diff --git a/middle_end/base_types/compilation_unit.ml b/middle_end/base_types/compilation_unit.ml deleted file mode 100644 index 7fb48167bc..0000000000 --- a/middle_end/base_types/compilation_unit.ml +++ /dev/null @@ -1,78 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -type t = { - id : Ident.t; - linkage_name : Linkage_name.t; - hash : int; -} - -let string_for_printing t = Ident.name t.id - -include Identifiable.Make (struct - type nonrec t = t - - (* Multiple units can have the same [id] if they come from different packs. - To distinguish these we also keep the linkage name, which contains the - name of the pack. *) - let compare v1 v2 = - if v1 == v2 then 0 - else - let c = compare v1.hash v2.hash in - if c = 0 then - let v1_id = Ident.name v1.id in - let v2_id = Ident.name v2.id in - let c = String.compare v1_id v2_id in - if c = 0 then - Linkage_name.compare v1.linkage_name v2.linkage_name - else - c - else c - - let equal x y = - if x == y then true - else compare x y = 0 - - let print ppf t = Format.pp_print_string ppf (string_for_printing t) - - let output oc x = output_string oc (Ident.name x.id) - let hash x = x.hash -end) - -let create (id : Ident.t) linkage_name = - if not (Ident.persistent id) then begin - Misc.fatal_error "Compilation_unit.create with non-persistent Ident.t" - end; - { id; linkage_name; hash = Hashtbl.hash (Ident.name id); } - -let get_persistent_ident cu = cu.id -let get_linkage_name cu = cu.linkage_name - -let current = ref None -let is_current arg = - match !current with - | None -> Misc.fatal_error "Current compilation unit is not set!" - | Some cur -> equal cur arg -let set_current t = current := Some t -let get_current () = !current -let get_current_exn () = - match !current with - | Some current -> current - | None -> Misc.fatal_error "Compilation_unit.get_current_exn" -let get_current_id_exn () = get_persistent_ident (get_current_exn ()) diff --git a/middle_end/base_types/compilation_unit.mli b/middle_end/base_types/compilation_unit.mli deleted file mode 100644 index fc7d3bfded..0000000000 --- a/middle_end/base_types/compilation_unit.mli +++ /dev/null @@ -1,34 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -include Identifiable.S - -(* The [Ident.t] must be persistent. This function raises an exception - if that is not the case. *) -val create : Ident.t -> Linkage_name.t -> t - -val get_persistent_ident : t -> Ident.t -val get_linkage_name : t -> Linkage_name.t - -val is_current : t -> bool -val set_current : t -> unit -val get_current : unit -> t option -val get_current_exn : unit -> t -val get_current_id_exn : unit -> Ident.t - -val string_for_printing : t -> string diff --git a/middle_end/base_types/export_id.ml b/middle_end/base_types/export_id.ml deleted file mode 100644 index 681ac955af..0000000000 --- a/middle_end/base_types/export_id.ml +++ /dev/null @@ -1,29 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -module Id : Id_types.Id = Id_types.Id (struct end) -module Unit_id = Id_types.UnitId (Id) (Compilation_unit) - -type t = Unit_id.t - -include Identifiable.Make (Unit_id) - -let create = Unit_id.create -let get_compilation_unit = Unit_id.unit -let name = Unit_id.name diff --git a/middle_end/base_types/export_id.mli b/middle_end/base_types/export_id.mli deleted file mode 100644 index 54c14418e4..0000000000 --- a/middle_end/base_types/export_id.mli +++ /dev/null @@ -1,28 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -(* Keys representing value descriptions that may be written into - intermediate files and loaded by a dependent compilation unit. - These keys are used to ensure maximal sharing of value descriptions, - which may be substantial. *) - -include Identifiable.S - -val create : ?name:string -> Compilation_unit.t -> t -val name : t -> string option -val get_compilation_unit : t -> Compilation_unit.t diff --git a/middle_end/base_types/id_types.ml b/middle_end/base_types/id_types.ml deleted file mode 100644 index 6d2e274311..0000000000 --- a/middle_end/base_types/id_types.ml +++ /dev/null @@ -1,93 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -module type BaseId = sig - type t - val equal : t -> t -> bool - val compare : t -> t -> int - val hash : t -> int - val name : t -> string option - val to_string : t -> string - val output : out_channel -> t -> unit - val print : Format.formatter -> t -> unit -end - -module type Id = sig - include BaseId - val create : ?name:string -> unit -> t -end - -module type UnitId = sig - module Compilation_unit : Identifiable.Thing - include BaseId - val create : ?name:string -> Compilation_unit.t -> t - val unit : t -> Compilation_unit.t -end - -module Id(E:sig end) : Id = struct - type t = int * string - let empty_string = "" - let create = let r = ref 0 in - fun ?(name=empty_string) () -> incr r; !r, name - let equal (t1,_) (t2,_) = (t1:int) = t2 - let compare (t1,_) (t2,_) = t1 - t2 - let hash (t,_) = t - let name (_,name) = - if name == empty_string - then None - else Some name - let to_string (t,name) = - if name == empty_string - then Int.to_string t - else Printf.sprintf "%s_%i" name t - let output fd t = output_string fd (to_string t) - let print ppf v = Format.pp_print_string ppf (to_string v) -end - -module UnitId(Innerid:Id)(Compilation_unit:Identifiable.Thing) : - UnitId with module Compilation_unit := Compilation_unit = struct - type t = { - id : Innerid.t; - unit : Compilation_unit.t; - } - let compare x y = - let c = Innerid.compare x.id y.id in - if c <> 0 - then c - else Compilation_unit.compare x.unit y.unit - let output oc x = - Printf.fprintf oc "%a.%a" - Compilation_unit.output x.unit - Innerid.output x.id - let print ppf x = - Format.fprintf ppf "%a.%a" - Compilation_unit.print x.unit - Innerid.print x.id - let hash off = Hashtbl.hash off - let equal o1 o2 = compare o1 o2 = 0 - let name o = Innerid.name o.id - let to_string x = - Format.asprintf "%a.%a" - Compilation_unit.print x.unit - Innerid.print x.id - let create ?name unit = - let id = Innerid.create ?name () in - { id; unit } - let unit x = x.unit -end diff --git a/middle_end/base_types/id_types.mli b/middle_end/base_types/id_types.mli deleted file mode 100644 index 48ca037caf..0000000000 --- a/middle_end/base_types/id_types.mli +++ /dev/null @@ -1,56 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -(* CR-soon mshinwell: This module should be removed. *) - -(** Generic identifier type *) -module type BaseId = -sig - type t - val equal : t -> t -> bool - val compare : t -> t -> int - val hash : t -> int - val name : t -> string option - val to_string : t -> string - val output : out_channel -> t -> unit - val print : Format.formatter -> t -> unit -end - -module type Id = -sig - include BaseId - val create : ?name:string -> unit -> t -end - -(** Fully qualified identifiers *) -module type UnitId = -sig - module Compilation_unit : Identifiable.Thing - include BaseId - val create : ?name:string -> Compilation_unit.t -> t - val unit : t -> Compilation_unit.t -end - -(** If applied generatively, i.e. [Id(struct end)], creates a new type - of identifiers. *) -module Id : functor (E : sig end) -> Id - -module UnitId : - functor (Id : Id) -> - functor (Compilation_unit : Identifiable.Thing) -> - UnitId with module Compilation_unit := Compilation_unit diff --git a/middle_end/base_types/linkage_name.ml b/middle_end/base_types/linkage_name.ml deleted file mode 100644 index 46febfba8f..0000000000 --- a/middle_end/base_types/linkage_name.ml +++ /dev/null @@ -1,30 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -type t = string - -include Identifiable.Make (struct - include String - let hash = Hashtbl.hash - let print ppf t = Format.pp_print_string ppf t - let output chan t = output_string chan t -end) - -let create t = t -let to_string t = t diff --git a/middle_end/base_types/linkage_name.mli b/middle_end/base_types/linkage_name.mli deleted file mode 100644 index 58731917cd..0000000000 --- a/middle_end/base_types/linkage_name.mli +++ /dev/null @@ -1,22 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -include Identifiable.S - -val create : string -> t -val to_string : t -> string diff --git a/middle_end/base_types/mutable_variable.ml b/middle_end/base_types/mutable_variable.ml deleted file mode 100644 index 07fe3152da..0000000000 --- a/middle_end/base_types/mutable_variable.ml +++ /dev/null @@ -1,22 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -include Variable - -let create_from_variable = rename diff --git a/middle_end/base_types/mutable_variable.mli b/middle_end/base_types/mutable_variable.mli deleted file mode 100644 index 17fe208fe0..0000000000 --- a/middle_end/base_types/mutable_variable.mli +++ /dev/null @@ -1,47 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -include Identifiable.S - -val create - : ?current_compilation_unit:Compilation_unit.t - -> Internal_variable_names.t - -> t - -val create_with_same_name_as_ident : Ident.t -> t - -val create_from_variable - : ?current_compilation_unit:Compilation_unit.t - -> Variable.t - -> t - -val rename - : ?current_compilation_unit:Compilation_unit.t - -> t - -> t - -val in_compilation_unit : t -> Compilation_unit.t -> bool - -val name : t -> string - -val unique_name : t -> string - -val print_list : Format.formatter -> t list -> unit -val print_opt : Format.formatter -> t option -> unit - -val output_full : out_channel -> t -> unit diff --git a/middle_end/base_types/set_of_closures_id.ml b/middle_end/base_types/set_of_closures_id.ml deleted file mode 100644 index 681ac955af..0000000000 --- a/middle_end/base_types/set_of_closures_id.ml +++ /dev/null @@ -1,29 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -module Id : Id_types.Id = Id_types.Id (struct end) -module Unit_id = Id_types.UnitId (Id) (Compilation_unit) - -type t = Unit_id.t - -include Identifiable.Make (Unit_id) - -let create = Unit_id.create -let get_compilation_unit = Unit_id.unit -let name = Unit_id.name diff --git a/middle_end/base_types/set_of_closures_id.mli b/middle_end/base_types/set_of_closures_id.mli deleted file mode 100644 index 811cb66102..0000000000 --- a/middle_end/base_types/set_of_closures_id.mli +++ /dev/null @@ -1,26 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -(** An identifier, unique across the whole program, that identifies a set - of closures (viz. [Set_of_closures]). *) - -include Identifiable.S - -val create : ?name:string -> Compilation_unit.t -> t -val name : t -> string option -val get_compilation_unit : t -> Compilation_unit.t diff --git a/middle_end/base_types/set_of_closures_origin.ml b/middle_end/base_types/set_of_closures_origin.ml deleted file mode 100644 index a5ef8c7c3d..0000000000 --- a/middle_end/base_types/set_of_closures_origin.ml +++ /dev/null @@ -1,23 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -include Set_of_closures_id - -let create t = t -let rename f t = f t diff --git a/middle_end/base_types/set_of_closures_origin.mli b/middle_end/base_types/set_of_closures_origin.mli deleted file mode 100644 index 4c9cfdcf80..0000000000 --- a/middle_end/base_types/set_of_closures_origin.mli +++ /dev/null @@ -1,22 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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. *) -(* *) -(**************************************************************************) - -include Identifiable.S - -val create : Set_of_closures_id.t -> t - -val get_compilation_unit : t -> Compilation_unit.t -val rename : (Set_of_closures_id.t -> Set_of_closures_id.t) -> t -> t diff --git a/middle_end/base_types/static_exception.ml b/middle_end/base_types/static_exception.ml deleted file mode 100644 index 6cecae6328..0000000000 --- a/middle_end/base_types/static_exception.ml +++ /dev/null @@ -1,23 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -include Numbers.Int - -let create () = Lambda.next_raise_count () -let to_int t = t diff --git a/middle_end/base_types/static_exception.mli b/middle_end/base_types/static_exception.mli deleted file mode 100644 index 88f690aa10..0000000000 --- a/middle_end/base_types/static_exception.mli +++ /dev/null @@ -1,26 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -(** An identifier that is used to label static exceptions. Its - uniqueness properties are unspecified. *) - -include Identifiable.S - -val create : unit -> t - -val to_int : t -> int diff --git a/middle_end/base_types/symbol.ml b/middle_end/base_types/symbol.ml deleted file mode 100644 index 22a2e0a70e..0000000000 --- a/middle_end/base_types/symbol.ml +++ /dev/null @@ -1,105 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - - -type t = - | Linkage of - { compilation_unit : Compilation_unit.t; - label : Linkage_name.t; - hash : int; } - | Variable of - { compilation_unit : Compilation_unit.t; - variable : Variable.t; } - -let label t = - match t with - | Linkage { label; _ } -> label - | Variable { variable; _ } -> - (* Use the variable's compilation unit for the label, since the - symbol's compilation unit might be a pack *) - let compilation_unit = Variable.get_compilation_unit variable in - let unit_linkage_name = - Linkage_name.to_string - (Compilation_unit.get_linkage_name compilation_unit) - in - let label = unit_linkage_name ^ "__" ^ Variable.unique_name variable in - Linkage_name.create label - -include Identifiable.Make (struct - - type nonrec t = t - - let compare t1 t2 = - if t1 == t2 then 0 - else begin - match t1, t2 with - | Linkage _, Variable _ -> 1 - | Variable _, Linkage _ -> -1 - | Linkage l1, Linkage l2 -> - let c = compare l1.hash l2.hash in - if c <> 0 then c else begin - (* Linkage names are unique across a whole project, so just comparing - those is sufficient. *) - Linkage_name.compare l1.label l2.label - end - | Variable v1, Variable v2 -> - Variable.compare v1.variable v2.variable - end - - let equal x y = - if x == y then true - else compare x y = 0 - - let output chan t = - Linkage_name.output chan (label t) - - let hash t = - match t with - | Linkage { hash; _ } -> hash - | Variable { variable } -> Variable.hash variable - - let print ppf t = - Linkage_name.print ppf (label t) - -end) - -let of_global_linkage compilation_unit label = - let hash = Linkage_name.hash label in - Linkage { compilation_unit; hash; label } - -let of_variable variable = - let compilation_unit = Variable.get_compilation_unit variable in - Variable { variable; compilation_unit } - -let import_for_pack ~pack:compilation_unit symbol = - match symbol with - | Linkage l -> Linkage { l with compilation_unit } - | Variable v -> Variable { v with compilation_unit } - -let compilation_unit t = - match t with - | Linkage { compilation_unit; _ } -> compilation_unit - | Variable { compilation_unit; _ } -> compilation_unit - -let print_opt ppf = function - | None -> Format.fprintf ppf "" - | Some t -> print ppf t - -let compare_lists l1 l2 = - Misc.Stdlib.List.compare compare l1 l2 diff --git a/middle_end/base_types/symbol.mli b/middle_end/base_types/symbol.mli deleted file mode 100644 index d2771af244..0000000000 --- a/middle_end/base_types/symbol.mli +++ /dev/null @@ -1,44 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -(** A symbol identifies a constant provided by either: - - another compilation unit; or - - a top-level module. - - * [sym_unit] is the compilation unit containing the value. - * [sym_label] is the linkage name of the variable. - - The label must be globally unique: two compilation units linked in the - same program must not share labels. *) - -include Identifiable.S - -val of_variable : Variable.t -> t - -(* Create the symbol without prefixing with the compilation unit. - Used for global symbols like predefined exceptions *) -val of_global_linkage : Compilation_unit.t -> Linkage_name.t -> t - -val import_for_pack : pack:Compilation_unit.t -> t -> t - -val compilation_unit : t -> Compilation_unit.t -val label : t -> Linkage_name.t - -val print_opt : Format.formatter -> t option -> unit - -val compare_lists : t list -> t list -> int diff --git a/middle_end/base_types/tag.ml b/middle_end/base_types/tag.ml deleted file mode 100644 index cfa51ddbb2..0000000000 --- a/middle_end/base_types/tag.ml +++ /dev/null @@ -1,35 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -type t = int - -include Identifiable.Make (Numbers.Int) - -let create_exn tag = - if tag < 0 || tag > 255 then - Misc.fatal_error (Printf.sprintf "Tag.create_exn %d" tag) - else - tag - -let to_int t = t - -let zero = 0 -let object_tag = Obj.object_tag - -let compare : t -> t -> int = Stdlib.compare diff --git a/middle_end/base_types/tag.mli b/middle_end/base_types/tag.mli deleted file mode 100644 index 12ce55255c..0000000000 --- a/middle_end/base_types/tag.mli +++ /dev/null @@ -1,29 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -(** Tags on runtime boxed values. *) - -include Identifiable.S - -val create_exn : int -> t -val to_int : t -> int - -val zero : t -val object_tag : t - -val compare : t -> t -> int diff --git a/middle_end/base_types/var_within_closure.ml b/middle_end/base_types/var_within_closure.ml deleted file mode 100644 index 466f59a237..0000000000 --- a/middle_end/base_types/var_within_closure.ml +++ /dev/null @@ -1,20 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -include Closure_element diff --git a/middle_end/base_types/var_within_closure.mli b/middle_end/base_types/var_within_closure.mli deleted file mode 100644 index 56f0af0ad6..0000000000 --- a/middle_end/base_types/var_within_closure.mli +++ /dev/null @@ -1,24 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -(** An identifier, unique across the whole program, that identifies a - particular variable within a particular closure. Only - [Project_var], and not [Var], nodes are tagged with these - identifiers. *) - -include module type of Closure_element diff --git a/middle_end/base_types/variable.ml b/middle_end/base_types/variable.ml deleted file mode 100644 index 64099a73b6..0000000000 --- a/middle_end/base_types/variable.ml +++ /dev/null @@ -1,119 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -type t = { - compilation_unit : Compilation_unit.t; - name : string; - name_stamp : int; - (** [name_stamp]s are unique within any given compilation unit. *) -} - -include Identifiable.Make (struct - type nonrec t = t - - let compare t1 t2 = - if t1 == t2 then 0 - else - let c = t1.name_stamp - t2.name_stamp in - if c <> 0 then c - else Compilation_unit.compare t1.compilation_unit t2.compilation_unit - - let equal t1 t2 = - if t1 == t2 then true - else - t1.name_stamp = t2.name_stamp - && Compilation_unit.equal t1.compilation_unit t2.compilation_unit - - let output chan t = - output_string chan t.name; - output_string chan "_"; - output_string chan (Int.to_string t.name_stamp) - - let hash t = t.name_stamp lxor (Compilation_unit.hash t.compilation_unit) - - let print ppf t = - if Compilation_unit.equal t.compilation_unit - (Compilation_unit.get_current_exn ()) - then begin - Format.fprintf ppf "%s/%d" - t.name t.name_stamp - end else begin - Format.fprintf ppf "%a.%s/%d" - Compilation_unit.print t.compilation_unit - t.name t.name_stamp - end -end) - -let previous_name_stamp = ref (-1) - -let create_with_name_string ?current_compilation_unit name = - let compilation_unit = - match current_compilation_unit with - | Some compilation_unit -> compilation_unit - | None -> Compilation_unit.get_current_exn () - in - let name_stamp = - incr previous_name_stamp; - !previous_name_stamp - in - { compilation_unit; - name; - name_stamp; - } - -let create ?current_compilation_unit name = - let name = (name : Internal_variable_names.t :> string) in - create_with_name_string ?current_compilation_unit name - -let create_with_same_name_as_ident ident = - create_with_name_string (Ident.name ident) - -let rename ?current_compilation_unit t = - create_with_name_string ?current_compilation_unit t.name - -let in_compilation_unit t cu = - Compilation_unit.equal cu t.compilation_unit - -let get_compilation_unit t = t.compilation_unit - -let name t = t.name - -let unique_name t = - t.name ^ "_" ^ (Int.to_string t.name_stamp) - -let print_list ppf ts = - List.iter (fun t -> Format.fprintf ppf "@ %a" print t) ts - -let debug_when_stamp_matches t ~stamp ~f = - if t.name_stamp = stamp then f () - -let print_opt ppf = function - | None -> Format.fprintf ppf "" - | Some t -> print ppf t - -type pair = t * t -module Pair = Identifiable.Make (Identifiable.Pair (T) (T)) - -let compare_lists l1 l2 = - Misc.Stdlib.List.compare compare l1 l2 - -let output_full chan t = - Compilation_unit.output chan t.compilation_unit; - output_string chan "."; - output chan t diff --git a/middle_end/base_types/variable.mli b/middle_end/base_types/variable.mli deleted file mode 100644 index b5d3f136ae..0000000000 --- a/middle_end/base_types/variable.mli +++ /dev/null @@ -1,63 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -(** [Variable.t] is the equivalent of a non-persistent [Ident.t] in - the [Flambda] tree. It wraps an [Ident.t] together with its source - [compilation_unit]. As such, it is unique within a whole program, - not just one compilation unit. - - Introducing a new type helps in tracing the source of identifiers - when debugging the inliner. It also avoids Ident renaming when - importing cmx files. -*) - -include Identifiable.S - -val create - : ?current_compilation_unit:Compilation_unit.t - -> Internal_variable_names.t - -> t -val create_with_same_name_as_ident : Ident.t -> t - -val rename - : ?current_compilation_unit:Compilation_unit.t - -> t - -> t - -val in_compilation_unit : t -> Compilation_unit.t -> bool - -val name : t -> string - -val unique_name : t -> string - -val get_compilation_unit : t -> Compilation_unit.t - -val print_list : Format.formatter -> t list -> unit -val print_opt : Format.formatter -> t option -> unit - -(** If the given variable has the given stamp, call the user-supplied - function. For debugging purposes only. *) -val debug_when_stamp_matches : t -> stamp:int -> f:(unit -> unit) -> unit - -type pair = t * t -module Pair : Identifiable.S with type t := pair - -val compare_lists : t list -> t list -> int - -val output_full : out_channel -> t -> unit -(** Unlike [output], [output_full] includes the compilation unit. *) diff --git a/middle_end/clambda.ml b/middle_end/clambda.ml new file mode 100644 index 0000000000..406bfbccda --- /dev/null +++ b/middle_end/clambda.ml @@ -0,0 +1,203 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* A variant of the "lambda" code with direct / indirect calls explicit + and closures explicit too *) + +open Asttypes +open Lambda + +type function_label = string + +type ustructured_constant = + | Uconst_float of float + | Uconst_int32 of int32 + | Uconst_int64 of int64 + | Uconst_nativeint of nativeint + | Uconst_block of int * uconstant list + | Uconst_float_array of float list + | Uconst_string of string + | Uconst_closure of ufunction list * string * uconstant list + +and uconstant = + | Uconst_ref of string * ustructured_constant option + | Uconst_int of int + | Uconst_ptr of int + +and uphantom_defining_expr = + | Uphantom_const of uconstant + | Uphantom_var of Backend_var.t + | Uphantom_offset_var of { var : Backend_var.t; offset_in_words : int; } + | Uphantom_read_field of { var : Backend_var.t; field : int; } + | Uphantom_read_symbol_field of { sym : string; field : int; } + | Uphantom_block of { tag : int; fields : Backend_var.t list; } + +and ulambda = + Uvar of Backend_var.t + | Uconst of uconstant + | Udirect_apply of function_label * ulambda list * Debuginfo.t + | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t + | Uclosure of ufunction list * ulambda list + | Uoffset of ulambda * int + | Ulet of mutable_flag * value_kind * Backend_var.With_provenance.t + * ulambda * ulambda + | Uphantom_let of Backend_var.With_provenance.t + * uphantom_defining_expr option * ulambda + | Uletrec of (Backend_var.With_provenance.t * ulambda) list * ulambda + | Uprim of Clambda_primitives.primitive * ulambda list * Debuginfo.t + | Uswitch of ulambda * ulambda_switch * Debuginfo.t + | Ustringswitch of ulambda * (string * ulambda) list * ulambda option + | Ustaticfail of int * ulambda list + | Ucatch of + int * + (Backend_var.With_provenance.t * value_kind) list * + ulambda * + ulambda + | Utrywith of ulambda * Backend_var.With_provenance.t * ulambda + | Uifthenelse of ulambda * ulambda * ulambda + | Usequence of ulambda * ulambda + | Uwhile of ulambda * ulambda + | Ufor of Backend_var.With_provenance.t * ulambda * ulambda + * direction_flag * ulambda + | Uassign of Backend_var.t * ulambda + | Usend of meth_kind * ulambda * ulambda * ulambda list * Debuginfo.t + | Uunreachable + +and ufunction = { + label : function_label; + arity : int; + params : (Backend_var.With_provenance.t * value_kind) list; + return : value_kind; + body : ulambda; + dbg : Debuginfo.t; + env : Backend_var.t option; +} + +and ulambda_switch = + { us_index_consts: int array; + us_actions_consts : ulambda array; + us_index_blocks: int array; + us_actions_blocks: ulambda array} + +(* Description of known functions *) + +type function_description = + { fun_label: function_label; (* Label of direct entry point *) + fun_arity: int; (* Number of arguments *) + mutable fun_closed: bool; (* True if environment not used *) + mutable fun_inline: (Backend_var.With_provenance.t list * ulambda) option; + mutable fun_float_const_prop: bool (* Can propagate FP consts *) + } + +(* Approximation of values *) + +type value_approximation = + Value_closure of function_description * value_approximation + | Value_tuple of value_approximation array + | Value_unknown + | Value_const of uconstant + | Value_global_field of string * int + +(* Preallocated globals *) + +type usymbol_provenance = { + original_idents : Ident.t list; + module_path : Path.t; +} + +type uconstant_block_field = + | Uconst_field_ref of string + | Uconst_field_int of int + +type preallocated_block = { + symbol : string; + exported : bool; + tag : int; + fields : uconstant_block_field option list; + provenance : usymbol_provenance option; +} + +type preallocated_constant = { + symbol : string; + exported : bool; + definition : ustructured_constant; + provenance : usymbol_provenance option; +} + +(* Comparison functions for constants. We must not use Stdlib.compare + because it compares "0.0" and "-0.0" equal. (PR#6442) *) + +let compare_floats x1 x2 = + Int64.compare (Int64.bits_of_float x1) (Int64.bits_of_float x2) + +let rec compare_float_lists l1 l2 = + match l1, l2 with + | [], [] -> 0 + | [], _::_ -> -1 + | _::_, [] -> 1 + | h1::t1, h2::t2 -> + let c = compare_floats h1 h2 in + if c <> 0 then c else compare_float_lists t1 t2 + +let compare_constants c1 c2 = + match c1, c2 with + | Uconst_ref(lbl1, _c1), Uconst_ref(lbl2, _c2) -> String.compare lbl1 lbl2 + (* Same labels -> same constants. + Different labels -> different constants, even if the contents + match, because of string constants that must not be + reshared. *) + | Uconst_int n1, Uconst_int n2 -> Stdlib.compare n1 n2 + | Uconst_ptr n1, Uconst_ptr n2 -> Stdlib.compare n1 n2 + | Uconst_ref _, _ -> -1 + | Uconst_int _, Uconst_ref _ -> 1 + | Uconst_int _, Uconst_ptr _ -> -1 + | Uconst_ptr _, _ -> 1 + +let rec compare_constant_lists l1 l2 = + match l1, l2 with + | [], [] -> 0 + | [], _::_ -> -1 + | _::_, [] -> 1 + | h1::t1, h2::t2 -> + let c = compare_constants h1 h2 in + if c <> 0 then c else compare_constant_lists t1 t2 + +let rank_structured_constant = function + | Uconst_float _ -> 0 + | Uconst_int32 _ -> 1 + | Uconst_int64 _ -> 2 + | Uconst_nativeint _ -> 3 + | Uconst_block _ -> 4 + | Uconst_float_array _ -> 5 + | Uconst_string _ -> 6 + | Uconst_closure _ -> 7 + +let compare_structured_constants c1 c2 = + match c1, c2 with + | Uconst_float x1, Uconst_float x2 -> compare_floats x1 x2 + | Uconst_int32 x1, Uconst_int32 x2 -> Int32.compare x1 x2 + | Uconst_int64 x1, Uconst_int64 x2 -> Int64.compare x1 x2 + | Uconst_nativeint x1, Uconst_nativeint x2 -> Nativeint.compare x1 x2 + | Uconst_block(t1, l1), Uconst_block(t2, l2) -> + let c = t1 - t2 (* no overflow possible here *) in + if c <> 0 then c else compare_constant_lists l1 l2 + | Uconst_float_array l1, Uconst_float_array l2 -> + compare_float_lists l1 l2 + | Uconst_string s1, Uconst_string s2 -> String.compare s1 s2 + | Uconst_closure (_,lbl1,_), Uconst_closure (_,lbl2,_) -> + String.compare lbl1 lbl2 + | _, _ -> + (* no overflow possible here *) + rank_structured_constant c1 - rank_structured_constant c2 diff --git a/middle_end/clambda.mli b/middle_end/clambda.mli new file mode 100644 index 0000000000..ddd0956dee --- /dev/null +++ b/middle_end/clambda.mli @@ -0,0 +1,153 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* A variant of the "lambda" code with direct / indirect calls explicit + and closures explicit too *) + +open Asttypes +open Lambda + +type function_label = string + +type ustructured_constant = + | Uconst_float of float + | Uconst_int32 of int32 + | Uconst_int64 of int64 + | Uconst_nativeint of nativeint + | Uconst_block of int * uconstant list + | Uconst_float_array of float list + | Uconst_string of string + | Uconst_closure of ufunction list * string * uconstant list + +and uconstant = + | Uconst_ref of string * ustructured_constant option + | Uconst_int of int + | Uconst_ptr of int + +and uphantom_defining_expr = + | Uphantom_const of uconstant + (** The phantom-let-bound variable is a constant. *) + | Uphantom_var of Backend_var.t + (** The phantom-let-bound variable is an alias for another variable. *) + | Uphantom_offset_var of { var : Backend_var.t; offset_in_words : int; } + (** The phantom-let-bound-variable's value is defined by adding the given + number of words to the pointer contained in the given identifier. *) + | Uphantom_read_field of { var : Backend_var.t; field : int; } + (** The phantom-let-bound-variable's value is found by adding the given + number of words to the pointer contained in the given identifier, then + dereferencing. *) + | Uphantom_read_symbol_field of { sym : string; field : int; } + (** As for [Uphantom_read_var_field], but with the pointer specified by + a symbol. *) + | Uphantom_block of { tag : int; fields : Backend_var.t list; } + (** The phantom-let-bound variable points at a block with the given + structure. *) + +and ulambda = + Uvar of Backend_var.t + | Uconst of uconstant + | Udirect_apply of function_label * ulambda list * Debuginfo.t + | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t + | Uclosure of ufunction list * ulambda list + | Uoffset of ulambda * int + | Ulet of mutable_flag * value_kind * Backend_var.With_provenance.t + * ulambda * ulambda + | Uphantom_let of Backend_var.With_provenance.t + * uphantom_defining_expr option * ulambda + | Uletrec of (Backend_var.With_provenance.t * ulambda) list * ulambda + | Uprim of Clambda_primitives.primitive * ulambda list * Debuginfo.t + | Uswitch of ulambda * ulambda_switch * Debuginfo.t + | Ustringswitch of ulambda * (string * ulambda) list * ulambda option + | Ustaticfail of int * ulambda list + | Ucatch of + int * + (Backend_var.With_provenance.t * value_kind) list * + ulambda * + ulambda + | Utrywith of ulambda * Backend_var.With_provenance.t * ulambda + | Uifthenelse of ulambda * ulambda * ulambda + | Usequence of ulambda * ulambda + | Uwhile of ulambda * ulambda + | Ufor of Backend_var.With_provenance.t * ulambda * ulambda + * direction_flag * ulambda + | Uassign of Backend_var.t * ulambda + | Usend of meth_kind * ulambda * ulambda * ulambda list * Debuginfo.t + | Uunreachable + +and ufunction = { + label : function_label; + arity : int; + params : (Backend_var.With_provenance.t * value_kind) list; + return : value_kind; + body : ulambda; + dbg : Debuginfo.t; + env : Backend_var.t option; +} + +and ulambda_switch = + { us_index_consts: int array; + us_actions_consts: ulambda array; + us_index_blocks: int array; + us_actions_blocks: ulambda array} + +(* Description of known functions *) + +type function_description = + { fun_label: function_label; (* Label of direct entry point *) + fun_arity: int; (* Number of arguments *) + mutable fun_closed: bool; (* True if environment not used *) + mutable fun_inline: (Backend_var.With_provenance.t list * ulambda) option; + mutable fun_float_const_prop: bool (* Can propagate FP consts *) + } + +(* Approximation of values *) + +type value_approximation = + Value_closure of function_description * value_approximation + | Value_tuple of value_approximation array + | Value_unknown + | Value_const of uconstant + | Value_global_field of string * int + +(* Comparison functions for constants *) + +val compare_structured_constants: + ustructured_constant -> ustructured_constant -> int +val compare_constants: + uconstant -> uconstant -> int + +type usymbol_provenance = { + original_idents : Ident.t list; + module_path : Path.t; +} + +type uconstant_block_field = + | Uconst_field_ref of string + | Uconst_field_int of int + +type preallocated_block = { + symbol : string; + exported : bool; + tag : int; + fields : uconstant_block_field option list; + provenance : usymbol_provenance option; +} + +type preallocated_constant = { + symbol : string; + exported : bool; + definition : ustructured_constant; + provenance : usymbol_provenance option; +} diff --git a/middle_end/clambda_primitives.ml b/middle_end/clambda_primitives.ml new file mode 100644 index 0000000000..a7c9798f36 --- /dev/null +++ b/middle_end/clambda_primitives.ml @@ -0,0 +1,155 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type mutable_flag = Asttypes.mutable_flag + +type immediate_or_pointer = Lambda.immediate_or_pointer + +type initialization_or_assignment = Lambda.initialization_or_assignment + +type is_safe = Lambda.is_safe + +type boxed = + | Boxed + | Unboxed + +type memory_access_size = + | Sixteen + | Thirty_two + | Sixty_four + +type primitive = + | Pread_symbol of string + (* Operations on heap blocks *) + | Pmakeblock of int * mutable_flag * block_shape + | Pfield of int + | Pfield_computed + | Psetfield of int * immediate_or_pointer * initialization_or_assignment + | Psetfield_computed of immediate_or_pointer * initialization_or_assignment + | Pfloatfield of int + | Psetfloatfield of int * initialization_or_assignment + | Pduprecord of Types.record_representation * int + (* External call *) + | Pccall of Primitive.description + (* Exceptions *) + | Praise of raise_kind + (* Boolean operations *) + | Psequand | Psequor | Pnot + (* Integer operations *) + | Pnegint | Paddint | Psubint | Pmulint + | Pdivint of is_safe | Pmodint of is_safe + | Pandint | Porint | Pxorint + | Plslint | Plsrint | Pasrint + | Pintcomp of integer_comparison + | Poffsetint of int + | Poffsetref of int + (* Float operations *) + | Pintoffloat | Pfloatofint + | Pnegfloat | Pabsfloat + | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat + | Pfloatcomp of float_comparison + (* String operations *) + | Pstringlength | Pstringrefu | Pstringrefs + | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets + (* Array operations *) + | Pmakearray of array_kind * mutable_flag + | Pduparray of array_kind * mutable_flag + (** For [Pduparray], the argument must be an immutable array. + The arguments of [Pduparray] give the kind and mutability of the + array being *produced* by the duplication. *) + | Parraylength of array_kind + | Parrayrefu of array_kind + | Parraysetu of array_kind + | Parrayrefs of array_kind + | Parraysets of array_kind + (* Test if the argument is a block or an immediate integer *) + | Pisint + (* Test if the (integer) argument is outside an interval *) + | Pisout + (* Operations on boxed integers (Nativeint.t, Int32.t, Int64.t) *) + | Pbintofint of boxed_integer + | Pintofbint of boxed_integer + | Pcvtbint of boxed_integer (*source*) * boxed_integer (*destination*) + | Pnegbint of boxed_integer + | Paddbint of boxed_integer + | Psubbint of boxed_integer + | Pmulbint of boxed_integer + | Pdivbint of { size : boxed_integer; is_safe : is_safe } + | Pmodbint of { size : boxed_integer; is_safe : is_safe } + | Pandbint of boxed_integer + | Porbint of boxed_integer + | Pxorbint of boxed_integer + | Plslbint of boxed_integer + | Plsrbint of boxed_integer + | Pasrbint of boxed_integer + | Pbintcomp of boxed_integer * integer_comparison + (* Operations on big arrays: (unsafe, #dimensions, kind, layout) *) + | Pbigarrayref of bool * int * bigarray_kind * bigarray_layout + | Pbigarrayset of bool * int * bigarray_kind * bigarray_layout + (* size of the nth dimension of a big array *) + | Pbigarraydim of int + (* load/set 16,32,64 bits from a string: (unsafe)*) + | Pstring_load of (memory_access_size * is_safe) + | Pbytes_load of (memory_access_size * is_safe) + | Pbytes_set of (memory_access_size * is_safe) + (* load/set 16,32,64 bits from a + (char, int8_unsigned_elt, c_layout) Bigarray.Array1.t : (unsafe) *) + | Pbigstring_load of (memory_access_size * is_safe) + | Pbigstring_set of (memory_access_size * is_safe) + (* byte swap *) + | Pbswap16 + | Pbbswap of boxed_integer + (* Integer to external pointer *) + | Pint_as_pointer + (* Inhibition of optimisation *) + | Popaque + +and integer_comparison = Lambda.integer_comparison = + Ceq | Cne | Clt | Cgt | Cle | Cge + +and float_comparison = Lambda.float_comparison = + CFeq | CFneq | CFlt | CFnlt | CFgt | CFngt | CFle | CFnle | CFge | CFnge + +and array_kind = Lambda.array_kind = + Pgenarray | Paddrarray | Pintarray | Pfloatarray + +and value_kind = Lambda.value_kind = + (* CR mshinwell: Pfloatval should be renamed to Pboxedfloatval *) + Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval + +and block_shape = Lambda.block_shape +and boxed_integer = Primitive.boxed_integer = + Pnativeint | Pint32 | Pint64 + +and bigarray_kind = Lambda.bigarray_kind = + Pbigarray_unknown + | Pbigarray_float32 | Pbigarray_float64 + | Pbigarray_sint8 | Pbigarray_uint8 + | Pbigarray_sint16 | Pbigarray_uint16 + | Pbigarray_int32 | Pbigarray_int64 + | Pbigarray_caml_int | Pbigarray_native_int + | Pbigarray_complex32 | Pbigarray_complex64 + +and bigarray_layout = Lambda.bigarray_layout = + Pbigarray_unknown_layout + | Pbigarray_c_layout + | Pbigarray_fortran_layout + +and raise_kind = Lambda.raise_kind = + | Raise_regular + | Raise_reraise + | Raise_notrace + +let equal (x: primitive) (y: primitive) = x = y diff --git a/middle_end/clambda_primitives.mli b/middle_end/clambda_primitives.mli new file mode 100644 index 0000000000..d534ca9cfa --- /dev/null +++ b/middle_end/clambda_primitives.mli @@ -0,0 +1,158 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type mutable_flag = Asttypes.mutable_flag + +type immediate_or_pointer = Lambda.immediate_or_pointer + +type initialization_or_assignment = Lambda.initialization_or_assignment + +type is_safe = Lambda.is_safe + +type boxed = + | Boxed + | Unboxed + +type memory_access_size = + | Sixteen + | Thirty_two + | Sixty_four + +type primitive = + | Pread_symbol of string + (* Operations on heap blocks *) + | Pmakeblock of int * mutable_flag * block_shape + | Pfield of int + | Pfield_computed + | Psetfield of int * immediate_or_pointer * initialization_or_assignment + | Psetfield_computed of immediate_or_pointer * initialization_or_assignment + | Pfloatfield of int + | Psetfloatfield of int * initialization_or_assignment + | Pduprecord of Types.record_representation * int + (* External call *) + | Pccall of Primitive.description + (* Exceptions *) + | Praise of raise_kind + (* Boolean operations *) + | Psequand | Psequor | Pnot + (* Integer operations *) + | Pnegint | Paddint | Psubint | Pmulint + | Pdivint of is_safe | Pmodint of is_safe + | Pandint | Porint | Pxorint + | Plslint | Plsrint | Pasrint + | Pintcomp of integer_comparison + | Poffsetint of int + | Poffsetref of int + (* Float operations *) + | Pintoffloat | Pfloatofint + | Pnegfloat | Pabsfloat + | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat + | Pfloatcomp of float_comparison + (* String operations *) + | Pstringlength | Pstringrefu | Pstringrefs + | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets + (* Array operations *) + | Pmakearray of array_kind * mutable_flag + (** For [Pmakearray], the list of arguments must not be empty. The empty + array should be represented by a distinguished constant in the middle + end. *) + | Pduparray of array_kind * mutable_flag + (** For [Pduparray], the argument must be an immutable array. + The arguments of [Pduparray] give the kind and mutability of the + array being *produced* by the duplication. *) + | Parraylength of array_kind + | Parrayrefu of array_kind + | Parraysetu of array_kind + | Parrayrefs of array_kind + | Parraysets of array_kind + (* Test if the argument is a block or an immediate integer *) + | Pisint + (* Test if the (integer) argument is outside an interval *) + | Pisout + (* Operations on boxed integers (Nativeint.t, Int32.t, Int64.t) *) + | Pbintofint of boxed_integer + | Pintofbint of boxed_integer + | Pcvtbint of boxed_integer (*source*) * boxed_integer (*destination*) + | Pnegbint of boxed_integer + | Paddbint of boxed_integer + | Psubbint of boxed_integer + | Pmulbint of boxed_integer + | Pdivbint of { size : boxed_integer; is_safe : is_safe } + | Pmodbint of { size : boxed_integer; is_safe : is_safe } + | Pandbint of boxed_integer + | Porbint of boxed_integer + | Pxorbint of boxed_integer + | Plslbint of boxed_integer + | Plsrbint of boxed_integer + | Pasrbint of boxed_integer + | Pbintcomp of boxed_integer * integer_comparison + (* Operations on big arrays: (unsafe, #dimensions, kind, layout) *) + | Pbigarrayref of bool * int * bigarray_kind * bigarray_layout + | Pbigarrayset of bool * int * bigarray_kind * bigarray_layout + (* size of the nth dimension of a big array *) + | Pbigarraydim of int + (* load/set 16,32,64 bits from a string: (unsafe)*) + | Pstring_load of (memory_access_size * is_safe) + | Pbytes_load of (memory_access_size * is_safe) + | Pbytes_set of (memory_access_size * is_safe) + (* load/set 16,32,64 bits from a + (char, int8_unsigned_elt, c_layout) Bigarray.Array1.t : (unsafe) *) + | Pbigstring_load of (memory_access_size * is_safe) + | Pbigstring_set of (memory_access_size * is_safe) + (* byte swap *) + | Pbswap16 + | Pbbswap of boxed_integer + (* Integer to external pointer *) + | Pint_as_pointer + (* Inhibition of optimisation *) + | Popaque + +and integer_comparison = Lambda.integer_comparison = + Ceq | Cne | Clt | Cgt | Cle | Cge + +and float_comparison = Lambda.float_comparison = + CFeq | CFneq | CFlt | CFnlt | CFgt | CFngt | CFle | CFnle | CFge | CFnge + +and array_kind = Lambda.array_kind = + Pgenarray | Paddrarray | Pintarray | Pfloatarray + +and value_kind = Lambda.value_kind = + (* CR mshinwell: Pfloatval should be renamed to Pboxedfloatval *) + Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval + +and block_shape = Lambda.block_shape +and boxed_integer = Primitive.boxed_integer = + Pnativeint | Pint32 | Pint64 + +and bigarray_kind = Lambda.bigarray_kind = + Pbigarray_unknown + | Pbigarray_float32 | Pbigarray_float64 + | Pbigarray_sint8 | Pbigarray_uint8 + | Pbigarray_sint16 | Pbigarray_uint16 + | Pbigarray_int32 | Pbigarray_int64 + | Pbigarray_caml_int | Pbigarray_native_int + | Pbigarray_complex32 | Pbigarray_complex64 + +and bigarray_layout = Lambda.bigarray_layout = + Pbigarray_unknown_layout + | Pbigarray_c_layout + | Pbigarray_fortran_layout + +and raise_kind = Lambda.raise_kind = + | Raise_regular + | Raise_reraise + | Raise_notrace + +val equal : primitive -> primitive -> bool diff --git a/middle_end/closure/closure.ml b/middle_end/closure/closure.ml new file mode 100644 index 0000000000..20767f623f --- /dev/null +++ b/middle_end/closure/closure.ml @@ -0,0 +1,1472 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Introduction of closures, uncurrying, recognition of direct calls *) + +open Misc +open Asttypes +open Primitive +open Lambda +open Switch +open Clambda +module P = Clambda_primitives + +module Int = Numbers.Int +module Storer = + Switch.Store + (struct + type t = lambda + type key = lambda + let make_key = Lambda.make_key + let compare_key = Stdlib.compare + end) + +module V = Backend_var +module VP = Backend_var.With_provenance + +(* The current backend *) + +let no_phantom_lets () = + Misc.fatal_error "Closure does not support phantom let generation" + +(* Auxiliaries for compiling functions *) + +let rec split_list n l = + if n <= 0 then ([], l) else begin + match l with + [] -> fatal_error "Closure.split_list" + | a::l -> let (l1, l2) = split_list (n-1) l in (a::l1, l2) + end + +let rec build_closure_env env_param pos = function + [] -> V.Map.empty + | id :: rem -> + V.Map.add id + (Uprim(P.Pfield pos, [Uvar env_param], Debuginfo.none)) + (build_closure_env env_param (pos+1) rem) + +(* Auxiliary for accessing globals. We change the name of the global + to the name of the corresponding asm symbol. This is done here + and no longer in Cmmgen so that approximations stored in .cmx files + contain the right names if the -for-pack option is active. *) + +let getglobal dbg id = + Uprim(P.Pread_symbol (Compilenv.symbol_for_global id), [], dbg) + +(* Check if a variable occurs in a [clambda] term. *) + +let occurs_var var u = + let rec occurs = function + Uvar v -> v = var + | Uconst _ -> false + | Udirect_apply(_lbl, args, _) -> List.exists occurs args + | Ugeneric_apply(funct, args, _) -> occurs funct || List.exists occurs args + | Uclosure(_fundecls, clos) -> List.exists occurs clos + | Uoffset(u, _ofs) -> occurs u + | Ulet(_str, _kind, _id, def, body) -> occurs def || occurs body + | Uphantom_let _ -> no_phantom_lets () + | Uletrec(decls, body) -> + List.exists (fun (_id, u) -> occurs u) decls || occurs body + | Uprim(_p, args, _) -> List.exists occurs args + | Uswitch(arg, s, _dbg) -> + occurs arg || + occurs_array s.us_actions_consts || occurs_array s.us_actions_blocks + | Ustringswitch(arg,sw,d) -> + occurs arg || + List.exists (fun (_,e) -> occurs e) sw || + (match d with None -> false | Some d -> occurs d) + | Ustaticfail (_, args) -> List.exists occurs args + | Ucatch(_, _, body, hdlr) -> occurs body || occurs hdlr + | Utrywith(body, _exn, hdlr) -> occurs body || occurs hdlr + | Uifthenelse(cond, ifso, ifnot) -> + occurs cond || occurs ifso || occurs ifnot + | Usequence(u1, u2) -> occurs u1 || occurs u2 + | Uwhile(cond, body) -> occurs cond || occurs body + | Ufor(_id, lo, hi, _dir, body) -> occurs lo || occurs hi || occurs body + | Uassign(id, u) -> id = var || occurs u + | Usend(_, met, obj, args, _) -> + occurs met || occurs obj || List.exists occurs args + | Uunreachable -> false + and occurs_array a = + try + for i = 0 to Array.length a - 1 do + if occurs a.(i) then raise Exit + done; + false + with Exit -> + true + in occurs u + +(* Determine whether the estimated size of a clambda term is below + some threshold *) + +let prim_size prim args = + let open Clambda_primitives in + match prim with + | Pread_symbol _ -> 1 + | Pmakeblock _ -> 5 + List.length args + | Pfield _ -> 1 + | Psetfield(_f, isptr, init) -> + begin match init with + | Root_initialization -> 1 (* never causes a write barrier hit *) + | Assignment | Heap_initialization -> + match isptr with + | Pointer -> 4 + | Immediate -> 1 + end + | Pfloatfield _ -> 1 + | Psetfloatfield _ -> 1 + | Pduprecord _ -> 10 + List.length args + | Pccall p -> (if p.prim_alloc then 10 else 4) + List.length args + | Praise _ -> 4 + | Pstringlength -> 5 + | Pbyteslength -> 5 + | Pstringrefs -> 6 + | Pbytesrefs | Pbytessets -> 6 + | Pmakearray _ -> 5 + List.length args + | Parraylength kind -> if kind = Pgenarray then 6 else 2 + | Parrayrefu kind -> if kind = Pgenarray then 12 else 2 + | Parraysetu kind -> if kind = Pgenarray then 16 else 4 + | Parrayrefs kind -> if kind = Pgenarray then 18 else 8 + | Parraysets kind -> if kind = Pgenarray then 22 else 10 + | Pbigarrayref(_, ndims, _, _) -> 4 + ndims * 6 + | Pbigarrayset(_, ndims, _, _) -> 4 + ndims * 6 + | _ -> 2 (* arithmetic and comparisons *) + +(* Very raw approximation of switch cost *) + +let lambda_smaller lam threshold = + let size = ref 0 in + let rec lambda_size lam = + if !size > threshold then raise Exit; + match lam with + Uvar _ -> () + | Uconst _ -> incr size + | Udirect_apply(_, args, _) -> + size := !size + 4; lambda_list_size args + | Ugeneric_apply(fn, args, _) -> + size := !size + 6; lambda_size fn; lambda_list_size args + | Uclosure _ -> + raise Exit (* inlining would duplicate function definitions *) + | Uoffset(lam, _ofs) -> + incr size; lambda_size lam + | Ulet(_str, _kind, _id, lam, body) -> + lambda_size lam; lambda_size body + | Uphantom_let _ -> no_phantom_lets () + | Uletrec _ -> + raise Exit (* usually too large *) + | Uprim(prim, args, _) -> + size := !size + prim_size prim args; + lambda_list_size args + | Uswitch(lam, cases, _dbg) -> + if Array.length cases.us_actions_consts > 1 then size := !size + 5 ; + if Array.length cases.us_actions_blocks > 1 then size := !size + 5 ; + lambda_size lam; + lambda_array_size cases.us_actions_consts ; + lambda_array_size cases.us_actions_blocks + | Ustringswitch (lam,sw,d) -> + lambda_size lam ; + (* as ifthenelse *) + List.iter + (fun (_,lam) -> + size := !size+2 ; + lambda_size lam) + sw ; + Misc.may lambda_size d + | Ustaticfail (_,args) -> lambda_list_size args + | Ucatch(_, _, body, handler) -> + incr size; lambda_size body; lambda_size handler + | Utrywith(body, _id, handler) -> + size := !size + 8; lambda_size body; lambda_size handler + | Uifthenelse(cond, ifso, ifnot) -> + size := !size + 2; + lambda_size cond; lambda_size ifso; lambda_size ifnot + | Usequence(lam1, lam2) -> + lambda_size lam1; lambda_size lam2 + | Uwhile(cond, body) -> + size := !size + 2; lambda_size cond; lambda_size body + | Ufor(_id, low, high, _dir, body) -> + size := !size + 4; lambda_size low; lambda_size high; lambda_size body + | Uassign(_id, lam) -> + incr size; lambda_size lam + | Usend(_, met, obj, args, _) -> + size := !size + 8; + lambda_size met; lambda_size obj; lambda_list_size args + | Uunreachable -> () + and lambda_list_size l = List.iter lambda_size l + and lambda_array_size a = Array.iter lambda_size a in + try + lambda_size lam; !size <= threshold + with Exit -> + false + +let is_pure_prim p = + let open Semantics_of_primitives in + match Semantics_of_primitives.for_primitive p with + | (No_effects | Only_generative_effects), _ -> true + | Arbitrary_effects, _ -> false + +(* Check if a clambda term is ``pure'', + that is without side-effects *and* not containing function definitions *) + +let rec is_pure = function + Uvar _ -> true + | Uconst _ -> true + | Uprim(p, args, _) -> is_pure_prim p && List.for_all is_pure args + | Uoffset(arg, _) -> is_pure arg + | Ulet(Immutable, _, _var, def, body) -> + is_pure def && is_pure body + | _ -> false + +(* Simplify primitive operations on known arguments *) + +let make_const c = (Uconst c, Value_const c) +let make_const_ref c = + make_const(Uconst_ref(Compilenv.new_structured_constant ~shared:true c, + Some c)) +let make_const_int n = make_const (Uconst_int n) +let make_const_ptr n = make_const (Uconst_ptr n) +let make_const_bool b = make_const_ptr(if b then 1 else 0) + +let make_integer_comparison cmp x y = + let open Clambda_primitives in + make_const_bool + (match cmp with + Ceq -> x = y + | Cne -> x <> y + | Clt -> x < y + | Cgt -> x > y + | Cle -> x <= y + | Cge -> x >= y) + +let make_float_comparison cmp x y = + make_const_bool + (match cmp with + | CFeq -> x = y + | CFneq -> not (x = y) + | CFlt -> x < y + | CFnlt -> not (x < y) + | CFgt -> x > y + | CFngt -> not (x > y) + | CFle -> x <= y + | CFnle -> not (x <= y) + | CFge -> x >= y + | CFnge -> not (x >= y)) + +let make_const_float n = make_const_ref (Uconst_float n) +let make_const_natint n = make_const_ref (Uconst_nativeint n) +let make_const_int32 n = make_const_ref (Uconst_int32 n) +let make_const_int64 n = make_const_ref (Uconst_int64 n) + +(* The [fpc] parameter is true if constant propagation of + floating-point computations is allowed *) + +let simplif_arith_prim_pure ~backend fpc p (args, approxs) dbg = + let module B = (val backend : Backend_intf.S) in + let open Clambda_primitives in + let default = (Uprim(p, args, dbg), Value_unknown) in + match approxs with + (* int (or enumerated type) *) + | [ Value_const(Uconst_int n1 | Uconst_ptr n1) ] -> + begin match p with + | Pnot -> make_const_bool (n1 = 0) + | Pnegint -> make_const_int (- n1) + | Poffsetint n -> make_const_int (n + n1) + | Pfloatofint when fpc -> make_const_float (float_of_int n1) + | Pbintofint Pnativeint -> make_const_natint (Nativeint.of_int n1) + | Pbintofint Pint32 -> make_const_int32 (Int32.of_int n1) + | Pbintofint Pint64 -> make_const_int64 (Int64.of_int n1) + | Pbswap16 -> make_const_int (((n1 land 0xff) lsl 8) + lor ((n1 land 0xff00) lsr 8)) + | _ -> default + end + (* int (or enumerated type), int (or enumerated type) *) + | [ Value_const(Uconst_int n1 | Uconst_ptr n1); + Value_const(Uconst_int n2 | Uconst_ptr n2) ] -> + begin match p with + | Psequand -> make_const_bool (n1 <> 0 && n2 <> 0) + | Psequor -> make_const_bool (n1 <> 0 || n2 <> 0) + | Paddint -> make_const_int (n1 + n2) + | Psubint -> make_const_int (n1 - n2) + | Pmulint -> make_const_int (n1 * n2) + | Pdivint _ when n2 <> 0 -> make_const_int (n1 / n2) + | Pmodint _ when n2 <> 0 -> make_const_int (n1 mod n2) + | Pandint -> make_const_int (n1 land n2) + | Porint -> make_const_int (n1 lor n2) + | Pxorint -> make_const_int (n1 lxor n2) + | Plslint when 0 <= n2 && n2 < 8 * B.size_int -> + make_const_int (n1 lsl n2) + | Plsrint when 0 <= n2 && n2 < 8 * B.size_int -> + make_const_int (n1 lsr n2) + | Pasrint when 0 <= n2 && n2 < 8 * B.size_int -> + make_const_int (n1 asr n2) + | Pintcomp c -> make_integer_comparison c n1 n2 + | _ -> default + end + (* float *) + | [Value_const(Uconst_ref(_, Some (Uconst_float n1)))] when fpc -> + begin match p with + | Pintoffloat -> make_const_int (int_of_float n1) + | Pnegfloat -> make_const_float (-. n1) + | Pabsfloat -> make_const_float (abs_float n1) + | _ -> default + end + (* float, float *) + | [Value_const(Uconst_ref(_, Some (Uconst_float n1))); + Value_const(Uconst_ref(_, Some (Uconst_float n2)))] when fpc -> + begin match p with + | Paddfloat -> make_const_float (n1 +. n2) + | Psubfloat -> make_const_float (n1 -. n2) + | Pmulfloat -> make_const_float (n1 *. n2) + | Pdivfloat -> make_const_float (n1 /. n2) + | Pfloatcomp c -> make_float_comparison c n1 n2 + | _ -> default + end + (* nativeint *) + | [Value_const(Uconst_ref(_, Some (Uconst_nativeint n)))] -> + begin match p with + | Pintofbint Pnativeint -> make_const_int (Nativeint.to_int n) + | Pcvtbint(Pnativeint, Pint32) -> make_const_int32 (Nativeint.to_int32 n) + | Pcvtbint(Pnativeint, Pint64) -> make_const_int64 (Int64.of_nativeint n) + | Pnegbint Pnativeint -> make_const_natint (Nativeint.neg n) + | _ -> default + end + (* nativeint, nativeint *) + | [Value_const(Uconst_ref(_, Some (Uconst_nativeint n1))); + Value_const(Uconst_ref(_, Some (Uconst_nativeint n2)))] -> + begin match p with + | Paddbint Pnativeint -> make_const_natint (Nativeint.add n1 n2) + | Psubbint Pnativeint -> make_const_natint (Nativeint.sub n1 n2) + | Pmulbint Pnativeint -> make_const_natint (Nativeint.mul n1 n2) + | Pdivbint {size=Pnativeint} when n2 <> 0n -> + make_const_natint (Nativeint.div n1 n2) + | Pmodbint {size=Pnativeint} when n2 <> 0n -> + make_const_natint (Nativeint.rem n1 n2) + | Pandbint Pnativeint -> make_const_natint (Nativeint.logand n1 n2) + | Porbint Pnativeint -> make_const_natint (Nativeint.logor n1 n2) + | Pxorbint Pnativeint -> make_const_natint (Nativeint.logxor n1 n2) + | Pbintcomp(Pnativeint, c) -> make_integer_comparison c n1 n2 + | _ -> default + end + (* nativeint, int *) + | [Value_const(Uconst_ref(_, Some (Uconst_nativeint n1))); + Value_const(Uconst_int n2)] -> + begin match p with + | Plslbint Pnativeint when 0 <= n2 && n2 < 8 * B.size_int -> + make_const_natint (Nativeint.shift_left n1 n2) + | Plsrbint Pnativeint when 0 <= n2 && n2 < 8 * B.size_int -> + make_const_natint (Nativeint.shift_right_logical n1 n2) + | Pasrbint Pnativeint when 0 <= n2 && n2 < 8 * B.size_int -> + make_const_natint (Nativeint.shift_right n1 n2) + | _ -> default + end + (* int32 *) + | [Value_const(Uconst_ref(_, Some (Uconst_int32 n)))] -> + begin match p with + | Pintofbint Pint32 -> make_const_int (Int32.to_int n) + | Pcvtbint(Pint32, Pnativeint) -> make_const_natint (Nativeint.of_int32 n) + | Pcvtbint(Pint32, Pint64) -> make_const_int64 (Int64.of_int32 n) + | Pnegbint Pint32 -> make_const_int32 (Int32.neg n) + | _ -> default + end + (* int32, int32 *) + | [Value_const(Uconst_ref(_, Some (Uconst_int32 n1))); + Value_const(Uconst_ref(_, Some (Uconst_int32 n2)))] -> + begin match p with + | Paddbint Pint32 -> make_const_int32 (Int32.add n1 n2) + | Psubbint Pint32 -> make_const_int32 (Int32.sub n1 n2) + | Pmulbint Pint32 -> make_const_int32 (Int32.mul n1 n2) + | Pdivbint {size=Pint32} when n2 <> 0l -> + make_const_int32 (Int32.div n1 n2) + | Pmodbint {size=Pint32} when n2 <> 0l -> + make_const_int32 (Int32.rem n1 n2) + | Pandbint Pint32 -> make_const_int32 (Int32.logand n1 n2) + | Porbint Pint32 -> make_const_int32 (Int32.logor n1 n2) + | Pxorbint Pint32 -> make_const_int32 (Int32.logxor n1 n2) + | Pbintcomp(Pint32, c) -> make_integer_comparison c n1 n2 + | _ -> default + end + (* int32, int *) + | [Value_const(Uconst_ref(_, Some (Uconst_int32 n1))); + Value_const(Uconst_int n2)] -> + begin match p with + | Plslbint Pint32 when 0 <= n2 && n2 < 32 -> + make_const_int32 (Int32.shift_left n1 n2) + | Plsrbint Pint32 when 0 <= n2 && n2 < 32 -> + make_const_int32 (Int32.shift_right_logical n1 n2) + | Pasrbint Pint32 when 0 <= n2 && n2 < 32 -> + make_const_int32 (Int32.shift_right n1 n2) + | _ -> default + end + (* int64 *) + | [Value_const(Uconst_ref(_, Some (Uconst_int64 n)))] -> + begin match p with + | Pintofbint Pint64 -> make_const_int (Int64.to_int n) + | Pcvtbint(Pint64, Pint32) -> make_const_int32 (Int64.to_int32 n) + | Pcvtbint(Pint64, Pnativeint) -> make_const_natint (Int64.to_nativeint n) + | Pnegbint Pint64 -> make_const_int64 (Int64.neg n) + | _ -> default + end + (* int64, int64 *) + | [Value_const(Uconst_ref(_, Some (Uconst_int64 n1))); + Value_const(Uconst_ref(_, Some (Uconst_int64 n2)))] -> + begin match p with + | Paddbint Pint64 -> make_const_int64 (Int64.add n1 n2) + | Psubbint Pint64 -> make_const_int64 (Int64.sub n1 n2) + | Pmulbint Pint64 -> make_const_int64 (Int64.mul n1 n2) + | Pdivbint {size=Pint64} when n2 <> 0L -> + make_const_int64 (Int64.div n1 n2) + | Pmodbint {size=Pint64} when n2 <> 0L -> + make_const_int64 (Int64.rem n1 n2) + | Pandbint Pint64 -> make_const_int64 (Int64.logand n1 n2) + | Porbint Pint64 -> make_const_int64 (Int64.logor n1 n2) + | Pxorbint Pint64 -> make_const_int64 (Int64.logxor n1 n2) + | Pbintcomp(Pint64, c) -> make_integer_comparison c n1 n2 + | _ -> default + end + (* int64, int *) + | [Value_const(Uconst_ref(_, Some (Uconst_int64 n1))); + Value_const(Uconst_int n2)] -> + begin match p with + | Plslbint Pint64 when 0 <= n2 && n2 < 64 -> + make_const_int64 (Int64.shift_left n1 n2) + | Plsrbint Pint64 when 0 <= n2 && n2 < 64 -> + make_const_int64 (Int64.shift_right_logical n1 n2) + | Pasrbint Pint64 when 0 <= n2 && n2 < 64 -> + make_const_int64 (Int64.shift_right n1 n2) + | _ -> default + end + (* TODO: Pbbswap *) + (* Catch-all *) + | _ -> + default + +let field_approx n = function + | Value_tuple a when n < Array.length a -> a.(n) + | Value_const (Uconst_ref(_, Some (Uconst_block(_, l)))) + when n < List.length l -> + Value_const (List.nth l n) + | _ -> Value_unknown + +let simplif_prim_pure ~backend fpc p (args, approxs) dbg = + let open Clambda_primitives in + match p, args, approxs with + (* Block construction *) + | Pmakeblock(tag, Immutable, _kind), _, _ -> + let field = function + | Value_const c -> c + | _ -> raise Exit + in + begin try + let cst = Uconst_block (tag, List.map field approxs) in + let name = + Compilenv.new_structured_constant cst ~shared:true + in + make_const (Uconst_ref (name, Some cst)) + with Exit -> + (Uprim(p, args, dbg), Value_tuple (Array.of_list approxs)) + end + (* Field access *) + | Pfield n, _, [ Value_const(Uconst_ref(_, Some (Uconst_block(_, l)))) ] + when n < List.length l -> + make_const (List.nth l n) + | Pfield n, [ Uprim(P.Pmakeblock _, ul, _) ], [approx] + when n < List.length ul -> + (List.nth ul n, field_approx n approx) + (* Strings *) + | (Pstringlength | Pbyteslength), + _, + [ Value_const(Uconst_ref(_, Some (Uconst_string s))) ] -> + make_const_int (String.length s) + (* Kind test *) + | Pisint, _, [a1] -> + begin match a1 with + | Value_const(Uconst_int _ | Uconst_ptr _) -> make_const_bool true + | Value_const(Uconst_ref _) -> make_const_bool false + | Value_closure _ | Value_tuple _ -> make_const_bool false + | _ -> (Uprim(p, args, dbg), Value_unknown) + end + (* Catch-all *) + | _ -> + simplif_arith_prim_pure ~backend fpc p (args, approxs) dbg + +let simplif_prim ~backend fpc p (args, approxs as args_approxs) dbg = + if List.for_all is_pure args + then simplif_prim_pure ~backend fpc p args_approxs dbg + else + (* XXX : always return the same approxs as simplif_prim_pure? *) + let approx = + match p with + | P.Pmakeblock(_, Immutable, _kind) -> + Value_tuple (Array.of_list approxs) + | _ -> + Value_unknown + in + (Uprim(p, args, dbg), approx) + +(* Substitute variables in a [ulambda] term (a body of an inlined function) + and perform some more simplifications on integer primitives. + Also perform alpha-conversion on let-bound identifiers to avoid + clashes with locally-generated identifiers, and refresh raise counts + in order to avoid clashes with inlined code from other modules. + The variables must not be assigned in the term. + This is used to substitute "trivial" arguments for parameters + during inline expansion, and also for the translation of let rec + over functions. *) + +let approx_ulam = function + Uconst c -> Value_const c + | _ -> Value_unknown + +let find_action idxs acts tag = + if 0 <= tag && tag < Array.length idxs then begin + let idx = idxs.(tag) in + assert(0 <= idx && idx < Array.length acts); + Some acts.(idx) + end else + (* Can this happen? *) + None + +let subst_debuginfo loc dbg = + if !Clflags.debug then + Debuginfo.inline loc dbg + else + dbg + +let rec substitute loc ((backend, fpc) as st) sb rn ulam = + match ulam with + Uvar v -> + begin try V.Map.find v sb with Not_found -> ulam end + | Uconst _ -> ulam + | Udirect_apply(lbl, args, dbg) -> + let dbg = subst_debuginfo loc dbg in + Udirect_apply(lbl, List.map (substitute loc st sb rn) args, dbg) + | Ugeneric_apply(fn, args, dbg) -> + let dbg = subst_debuginfo loc dbg in + Ugeneric_apply(substitute loc st sb rn fn, + List.map (substitute loc st sb rn) args, dbg) + | Uclosure(defs, env) -> + (* Question: should we rename function labels as well? Otherwise, + there is a risk that function labels are not globally unique. + This should not happen in the current system because: + - Inlined function bodies contain no Uclosure nodes + (cf. function [lambda_smaller]) + - When we substitute offsets for idents bound by let rec + in [close], case [Lletrec], we discard the original + let rec body and use only the substituted term. *) + Uclosure(defs, List.map (substitute loc st sb rn) env) + | Uoffset(u, ofs) -> Uoffset(substitute loc st sb rn u, ofs) + | Ulet(str, kind, id, u1, u2) -> + let id' = VP.rename id in + Ulet(str, kind, id', substitute loc st sb rn u1, + substitute loc st + (V.Map.add (VP.var id) (Uvar (VP.var id')) sb) rn u2) + | Uphantom_let _ -> no_phantom_lets () + | Uletrec(bindings, body) -> + let bindings1 = + List.map (fun (id, rhs) -> + (VP.var id, VP.rename id, rhs)) bindings + in + let sb' = + List.fold_right (fun (id, id', _) s -> + V.Map.add id (Uvar (VP.var id')) s) + bindings1 sb + in + Uletrec( + List.map + (fun (_id, id', rhs) -> (id', substitute loc st sb' rn rhs)) + bindings1, + substitute loc st sb' rn body) + | Uprim(p, args, dbg) -> + let sargs = List.map (substitute loc st sb rn) args in + let dbg = subst_debuginfo loc dbg in + let (res, _) = + simplif_prim ~backend fpc p (sargs, List.map approx_ulam sargs) dbg in + res + | Uswitch(arg, sw, dbg) -> + let sarg = substitute loc st sb rn arg in + let action = + (* Unfortunately, we cannot easily deal with the + case of a constructed block (makeblock) bound to a local + identifier. This would require to keep track of + local let bindings (at least their approximations) + in this substitute function. + *) + match sarg with + | Uconst (Uconst_ref (_, Some (Uconst_block (tag, _)))) -> + find_action sw.us_index_blocks sw.us_actions_blocks tag + | Uconst (Uconst_ptr tag) -> + find_action sw.us_index_consts sw.us_actions_consts tag + | _ -> None + in + begin match action with + | Some u -> substitute loc st sb rn u + | None -> + Uswitch(sarg, + { sw with + us_actions_consts = + Array.map (substitute loc st sb rn) sw.us_actions_consts; + us_actions_blocks = + Array.map (substitute loc st sb rn) sw.us_actions_blocks; + }, + dbg) + end + | Ustringswitch(arg,sw,d) -> + Ustringswitch + (substitute loc st sb rn arg, + List.map (fun (s,act) -> s,substitute loc st sb rn act) sw, + Misc.may_map (substitute loc st sb rn) d) + | Ustaticfail (nfail, args) -> + let nfail = + match rn with + | Some rn -> + begin try + Int.Map.find nfail rn + with Not_found -> + fatal_errorf "Closure.split_list: invalid nfail (%d)" nfail + end + | None -> nfail in + Ustaticfail (nfail, List.map (substitute loc st sb rn) args) + | Ucatch(nfail, ids, u1, u2) -> + let nfail, rn = + match rn with + | Some rn -> + let new_nfail = next_raise_count () in + new_nfail, Some (Int.Map.add nfail new_nfail rn) + | None -> nfail, rn in + let ids' = List.map (fun (id, k) -> VP.rename id, k) ids in + let sb' = + List.fold_right2 + (fun (id, _) (id', _) s -> + V.Map.add (VP.var id) (Uvar (VP.var id')) s + ) + ids ids' sb + in + Ucatch(nfail, ids', substitute loc st sb rn u1, + substitute loc st sb' rn u2) + | Utrywith(u1, id, u2) -> + let id' = VP.rename id in + Utrywith(substitute loc st sb rn u1, id', + substitute loc st + (V.Map.add (VP.var id) (Uvar (VP.var id')) sb) rn u2) + | Uifthenelse(u1, u2, u3) -> + begin match substitute loc st sb rn u1 with + Uconst (Uconst_ptr n) -> + if n <> 0 then + substitute loc st sb rn u2 + else + substitute loc st sb rn u3 + | Uprim(P.Pmakeblock _, _, _) -> + substitute loc st sb rn u2 + | su1 -> + Uifthenelse(su1, substitute loc st sb rn u2, + substitute loc st sb rn u3) + end + | Usequence(u1, u2) -> + Usequence(substitute loc st sb rn u1, substitute loc st sb rn u2) + | Uwhile(u1, u2) -> + Uwhile(substitute loc st sb rn u1, substitute loc st sb rn u2) + | Ufor(id, u1, u2, dir, u3) -> + let id' = VP.rename id in + Ufor(id', substitute loc st sb rn u1, substitute loc st sb rn u2, dir, + substitute loc st + (V.Map.add (VP.var id) (Uvar (VP.var id')) sb) rn u3) + | Uassign(id, u) -> + let id' = + try + match V.Map.find id sb with Uvar i -> i | _ -> assert false + with Not_found -> + id in + Uassign(id', substitute loc st sb rn u) + | Usend(k, u1, u2, ul, dbg) -> + let dbg = subst_debuginfo loc dbg in + Usend(k, substitute loc st sb rn u1, substitute loc st sb rn u2, + List.map (substitute loc st sb rn) ul, dbg) + | Uunreachable -> + Uunreachable + +(* Perform an inline expansion *) + +let is_simple_argument = function + | Uvar _ | Uconst _ -> true + | _ -> false + +let no_effects = function + | Uclosure _ -> true + | u -> is_pure u + +let rec bind_params_rec loc fpc subst params args body = + match (params, args) with + ([], []) -> substitute loc fpc subst (Some Int.Map.empty) body + | (p1 :: pl, a1 :: al) -> + if is_simple_argument a1 then + bind_params_rec loc fpc (V.Map.add (VP.var p1) a1 subst) + pl al body + else begin + let p1' = VP.rename p1 in + let u1, u2 = + match VP.name p1, a1 with + | "*opt*", Uprim(P.Pmakeblock(0, Immutable, kind), [a], dbg) -> + a, Uprim(P.Pmakeblock(0, Immutable, kind), + [Uvar (VP.var p1')], dbg) + | _ -> + a1, Uvar (VP.var p1') + in + let body' = + bind_params_rec loc fpc (V.Map.add (VP.var p1) u2 subst) + pl al body in + if occurs_var (VP.var p1) body then + Ulet(Immutable, Pgenval, p1', u1, body') + else if no_effects a1 then body' + else Usequence(a1, body') + end + | (_, _) -> assert false + +let bind_params loc fpc params args body = + (* Reverse parameters and arguments to preserve right-to-left + evaluation order (PR#2910). *) + bind_params_rec loc fpc V.Map.empty (List.rev params) (List.rev args) body + +(* Check if a lambda term is ``pure'', + that is without side-effects *and* not containing function definitions *) + +let warning_if_forced_inline ~loc ~attribute warning = + if attribute = Always_inline then + Location.prerr_warning loc + (Warnings.Inlining_impossible warning) + +(* Generate a direct application *) + +let direct_apply ~backend fundesc ufunct uargs ~loc ~attribute = + let app_args = + if fundesc.fun_closed then uargs else uargs @ [ufunct] in + let app = + match fundesc.fun_inline, attribute with + | _, Never_inline | None, _ -> + let dbg = Debuginfo.from_location loc in + warning_if_forced_inline ~loc ~attribute + "Function information unavailable"; + Udirect_apply(fundesc.fun_label, app_args, dbg) + | Some(params, body), _ -> + bind_params loc (backend, fundesc.fun_float_const_prop) params app_args + body + in + (* If ufunct can contain side-effects or function definitions, + we must make sure that it is evaluated exactly once. + If the function is not closed, we evaluate ufunct as part of the + arguments. + If the function is closed, we force the evaluation of ufunct first. *) + if not fundesc.fun_closed || is_pure ufunct + then app + else Usequence(ufunct, app) + +(* Add [Value_integer] or [Value_constptr] info to the approximation + of an application *) + +let strengthen_approx appl approx = + match approx_ulam appl with + (Value_const _) as intapprox -> + intapprox + | _ -> approx + +(* If a term has approximation Value_integer or Value_constptr and is pure, + replace it by an integer constant *) + +let check_constant_result ulam approx = + match approx with + Value_const c when is_pure ulam -> make_const c + | Value_global_field (id, i) when is_pure ulam -> + begin match ulam with + | Uprim(P.Pfield _, [Uprim(P.Pread_symbol _, _, _)], _) -> (ulam, approx) + | _ -> + let glb = + Uprim(P.Pread_symbol id, [], Debuginfo.none) + in + Uprim(P.Pfield i, [glb], Debuginfo.none), approx + end + | _ -> (ulam, approx) + +(* Evaluate an expression with known value for its side effects only, + or discard it if it's pure *) + +let sequence_constant_expr ulam1 (ulam2, approx2 as res2) = + if is_pure ulam1 then res2 else (Usequence(ulam1, ulam2), approx2) + +(* Maintain the approximation of the global structure being defined *) + +let global_approx = ref([||] : value_approximation array) + +(* Maintain the nesting depth for functions *) + +let function_nesting_depth = ref 0 +let excessive_function_nesting_depth = 5 + +(* Uncurry an expression and explicitate closures. + Also return the approximation of the expression. + The approximation environment [fenv] maps idents to approximations. + Idents not bound in [fenv] approximate to [Value_unknown]. + The closure environment [cenv] maps idents to [ulambda] terms. + It is used to substitute environment accesses for free identifiers. *) + +exception NotClosed + +type env = { + backend : (module Backend_intf.S); + cenv : ulambda V.Map.t; + fenv : value_approximation V.Map.t; +} + +let close_approx_var { fenv; cenv } id = + let approx = try V.Map.find id fenv with Not_found -> Value_unknown in + match approx with + Value_const c -> make_const c + | approx -> + let subst = try V.Map.find id cenv with Not_found -> Uvar id in + (subst, approx) + +let close_var env id = + let (ulam, _app) = close_approx_var env id in ulam + +let rec close ({ backend; fenv; cenv } as env) lam = + let module B = (val backend : Backend_intf.S) in + match lam with + | Lvar id -> + close_approx_var env id + | Lconst cst -> + let str ?(shared = true) cst = + let name = + Compilenv.new_structured_constant cst ~shared + in + Uconst_ref (name, Some cst) + in + let rec transl = function + | Const_base(Const_int n) -> Uconst_int n + | Const_base(Const_char c) -> Uconst_int (Char.code c) + | Const_pointer n -> Uconst_ptr n + | Const_block (tag, fields) -> + str (Uconst_block (tag, List.map transl fields)) + | Const_float_array sl -> + (* constant float arrays are really immutable *) + str (Uconst_float_array (List.map float_of_string sl)) + | Const_immstring s -> + str (Uconst_string s) + | Const_base (Const_string (s, _)) -> + (* Strings (even literal ones) must be assumed to be mutable... + except when OCaml has been configured with + -safe-string. Passing -safe-string at compilation + time is not enough, since the unit could be linked + with another one compiled without -safe-string, and + that one could modify our string literal. *) + str ~shared:Config.safe_string (Uconst_string s) + | Const_base(Const_float x) -> str (Uconst_float (float_of_string x)) + | Const_base(Const_int32 x) -> str (Uconst_int32 x) + | Const_base(Const_int64 x) -> str (Uconst_int64 x) + | Const_base(Const_nativeint x) -> str (Uconst_nativeint x) + in + make_const (transl cst) + | Lfunction _ as funct -> + close_one_function env (Ident.create_local "fun") funct + + (* We convert [f a] to [let a' = a in let f' = f in fun b c -> f' a' b c] + when fun_arity > nargs *) + | Lapply{ap_func = funct; ap_args = args; ap_loc = loc; + ap_inlined = attribute} -> + let nargs = List.length args in + begin match (close env funct, close_list env args) with + ((ufunct, Value_closure(fundesc, approx_res)), + [Uprim(P.Pmakeblock _, uargs, _)]) + when List.length uargs = - fundesc.fun_arity -> + let app = + direct_apply ~backend ~loc ~attribute fundesc ufunct uargs in + (app, strengthen_approx app approx_res) + | ((ufunct, Value_closure(fundesc, approx_res)), uargs) + when nargs = fundesc.fun_arity -> + let app = + direct_apply ~backend ~loc ~attribute fundesc ufunct uargs in + (app, strengthen_approx app approx_res) + + | ((ufunct, (Value_closure(fundesc, _) as fapprox)), uargs) + when nargs < fundesc.fun_arity -> + let first_args = List.map (fun arg -> + (V.create_local "arg", arg) ) uargs in + let final_args = + Array.to_list (Array.init (fundesc.fun_arity - nargs) + (fun _ -> V.create_local "arg")) in + let rec iter args body = + match args with + [] -> body + | (arg1, arg2) :: args -> + iter args + (Ulet (Immutable, Pgenval, VP.create arg1, arg2, body)) + in + let internal_args = + (List.map (fun (arg1, _arg2) -> Lvar arg1) first_args) + @ (List.map (fun arg -> Lvar arg ) final_args) + in + let funct_var = V.create_local "funct" in + let fenv = V.Map.add funct_var fapprox fenv in + let (new_fun, approx) = close { backend; fenv; cenv } + (Lfunction{ + kind = Curried; + return = Pgenval; + params = List.map (fun v -> v, Pgenval) final_args; + body = Lapply{ap_should_be_tailcall=false; + ap_loc=loc; + ap_func=(Lvar funct_var); + ap_args=internal_args; + ap_inlined=Default_inline; + ap_specialised=Default_specialise}; + loc; + attr = default_function_attribute}) + in + let new_fun = + iter first_args + (Ulet (Immutable, Pgenval, VP.create funct_var, ufunct, new_fun)) + in + warning_if_forced_inline ~loc ~attribute "Partial application"; + (new_fun, approx) + + | ((ufunct, Value_closure(fundesc, _approx_res)), uargs) + when fundesc.fun_arity > 0 && nargs > fundesc.fun_arity -> + let args = List.map (fun arg -> V.create_local "arg", arg) uargs in + let (first_args, rem_args) = split_list fundesc.fun_arity args in + let first_args = List.map (fun (id, _) -> Uvar id) first_args in + let rem_args = List.map (fun (id, _) -> Uvar id) rem_args in + let dbg = Debuginfo.from_location loc in + warning_if_forced_inline ~loc ~attribute "Over-application"; + let body = + Ugeneric_apply(direct_apply ~backend ~loc ~attribute + fundesc ufunct first_args, + rem_args, dbg) + in + let result = + List.fold_left (fun body (id, defining_expr) -> + Ulet (Immutable, Pgenval, VP.create id, defining_expr, body)) + body + args + in + result, Value_unknown + | ((ufunct, _), uargs) -> + let dbg = Debuginfo.from_location loc in + warning_if_forced_inline ~loc ~attribute "Unknown function"; + (Ugeneric_apply(ufunct, uargs, dbg), Value_unknown) + end + | Lsend(kind, met, obj, args, loc) -> + let (umet, _) = close env met in + let (uobj, _) = close env obj in + let dbg = Debuginfo.from_location loc in + (Usend(kind, umet, uobj, close_list env args, dbg), + Value_unknown) + | Llet(str, kind, id, lam, body) -> + let (ulam, alam) = close_named env id lam in + begin match (str, alam) with + (Variable, _) -> + let (ubody, abody) = close env body in + (Ulet(Mutable, kind, VP.create id, ulam, ubody), abody) + | (_, Value_const _) + when str = Alias || is_pure ulam -> + close { backend; fenv = (V.Map.add id alam fenv); cenv } body + | (_, _) -> + let (ubody, abody) = + close { backend; fenv = (V.Map.add id alam fenv); cenv } body + in + (Ulet(Immutable, kind, VP.create id, ulam, ubody), abody) + end + | Lletrec(defs, body) -> + if List.for_all + (function (_id, Lfunction _) -> true | _ -> false) + defs + then begin + (* Simple case: only function definitions *) + let (clos, infos) = close_functions env defs in + let clos_ident = V.create_local "clos" in + let fenv_body = + List.fold_right + (fun (id, _pos, approx) fenv -> V.Map.add id approx fenv) + infos fenv in + let (ubody, approx) = close { backend; fenv = fenv_body; cenv } body in + let sb = + List.fold_right + (fun (id, pos, _approx) sb -> + V.Map.add id (Uoffset(Uvar clos_ident, pos)) sb) + infos V.Map.empty in + (Ulet(Immutable, Pgenval, VP.create clos_ident, clos, + substitute Location.none (backend, !Clflags.float_const_prop) sb + None ubody), + approx) + end else begin + (* General case: recursive definition of values *) + let rec clos_defs = function + [] -> ([], fenv) + | (id, lam) :: rem -> + let (udefs, fenv_body) = clos_defs rem in + let (ulam, approx) = close_named env id lam in + ((VP.create id, ulam) :: udefs, V.Map.add id approx fenv_body) in + let (udefs, fenv_body) = clos_defs defs in + let (ubody, approx) = close { backend; fenv = fenv_body; cenv } body in + (Uletrec(udefs, ubody), approx) + end + (* Compile-time constants *) + | Lprim(Pctconst c, [arg], _loc) -> + let cst, approx = + match c with + | Big_endian -> make_const_bool B.big_endian + | Word_size -> make_const_int (8*B.size_int) + | Int_size -> make_const_int (8*B.size_int - 1) + | Max_wosize -> make_const_int ((1 lsl ((8*B.size_int) - 10)) - 1 ) + | Ostype_unix -> make_const_bool (Sys.os_type = "Unix") + | Ostype_win32 -> make_const_bool (Sys.os_type = "Win32") + | Ostype_cygwin -> make_const_bool (Sys.os_type = "Cygwin") + | Backend_type -> + make_const_ptr 0 (* tag 0 is the same as Native here *) + in + let arg, _approx = close env arg in + let id = Ident.create_local "dummy" in + Ulet(Immutable, Pgenval, VP.create id, arg, cst), approx + | Lprim(Pignore, [arg], _loc) -> + let expr, approx = make_const_ptr 0 in + Usequence(fst (close env arg), expr), approx + | Lprim((Pidentity | Pbytes_to_string | Pbytes_of_string), [arg], _loc) -> + close env arg + | Lprim(Pdirapply,[funct;arg], loc) + | Lprim(Prevapply,[arg;funct], loc) -> + close env (Lapply{ap_should_be_tailcall=false; + ap_loc=loc; + ap_func=funct; + ap_args=[arg]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise}) + | Lprim(Pgetglobal id, [], loc) -> + let dbg = Debuginfo.from_location loc in + check_constant_result (getglobal dbg id) + (Compilenv.global_approx id) + | Lprim(Pfield n, [lam], loc) -> + let (ulam, approx) = close env lam in + let dbg = Debuginfo.from_location loc in + check_constant_result (Uprim(P.Pfield n, [ulam], dbg)) + (field_approx n approx) + | Lprim(Psetfield(n, is_ptr, init), [Lprim(Pgetglobal id, [], _); lam], loc)-> + let (ulam, approx) = close env lam in + if approx <> Value_unknown then + (!global_approx).(n) <- approx; + let dbg = Debuginfo.from_location loc in + (Uprim(P.Psetfield(n, is_ptr, init), [getglobal dbg id; ulam], dbg), + Value_unknown) + | Lprim(Praise k, [arg], loc) -> + let (ulam, _approx) = close env arg in + let dbg = Debuginfo.from_location loc in + (Uprim(P.Praise k, [ulam], dbg), + Value_unknown) + | Lprim (Pmakearray _, [], _loc) -> make_const_ref (Uconst_block (0, [])) + | Lprim(p, args, loc) -> + let p = Convert_primitives.convert p in + let dbg = Debuginfo.from_location loc in + simplif_prim ~backend !Clflags.float_const_prop + p (close_list_approx env args) dbg + | Lswitch(arg, sw, dbg) -> + let fn fail = + let (uarg, _) = close env arg in + let const_index, const_actions, fconst = + close_switch env sw.sw_consts sw.sw_numconsts fail + and block_index, block_actions, fblock = + close_switch env sw.sw_blocks sw.sw_numblocks fail in + let ulam = + Uswitch + (uarg, + {us_index_consts = const_index; + us_actions_consts = const_actions; + us_index_blocks = block_index; + us_actions_blocks = block_actions}, + Debuginfo.from_location dbg) + in + (fconst (fblock ulam),Value_unknown) in +(* NB: failaction might get copied, thus it should be some Lstaticraise *) + let fail = sw.sw_failaction in + begin match fail with + | None|Some (Lstaticraise (_,_)) -> fn fail + | Some lamfail -> + if + (sw.sw_numconsts - List.length sw.sw_consts) + + (sw.sw_numblocks - List.length sw.sw_blocks) > 1 + then + let i = next_raise_count () in + let ubody,_ = fn (Some (Lstaticraise (i,[]))) + and uhandler,_ = close env lamfail in + Ucatch (i,[],ubody,uhandler),Value_unknown + else fn fail + end + | Lstringswitch(arg,sw,d,_) -> + let uarg,_ = close env arg in + let usw = + List.map + (fun (s,act) -> + let uact,_ = close env act in + s,uact) + sw in + let ud = + Misc.may_map + (fun d -> + let ud,_ = close env d in + ud) d in + Ustringswitch (uarg,usw,ud),Value_unknown + | Lstaticraise (i, args) -> + (Ustaticfail (i, close_list env args), Value_unknown) + | Lstaticcatch(body, (i, vars), handler) -> + let (ubody, _) = close env body in + let (uhandler, _) = close env handler in + let vars = List.map (fun (var, k) -> VP.create var, k) vars in + (Ucatch(i, vars, ubody, uhandler), Value_unknown) + | Ltrywith(body, id, handler) -> + let (ubody, _) = close env body in + let (uhandler, _) = close env handler in + (Utrywith(ubody, VP.create id, uhandler), Value_unknown) + | Lifthenelse(arg, ifso, ifnot) -> + begin match close env arg with + (uarg, Value_const (Uconst_ptr n)) -> + sequence_constant_expr uarg + (close env (if n = 0 then ifnot else ifso)) + | (uarg, _ ) -> + let (uifso, _) = close env ifso in + let (uifnot, _) = close env ifnot in + (Uifthenelse(uarg, uifso, uifnot), Value_unknown) + end + | Lsequence(lam1, lam2) -> + let (ulam1, _) = close env lam1 in + let (ulam2, approx) = close env lam2 in + (Usequence(ulam1, ulam2), approx) + | Lwhile(cond, body) -> + let (ucond, _) = close env cond in + let (ubody, _) = close env body in + (Uwhile(ucond, ubody), Value_unknown) + | Lfor(id, lo, hi, dir, body) -> + let (ulo, _) = close env lo in + let (uhi, _) = close env hi in + let (ubody, _) = close env body in + (Ufor(VP.create id, ulo, uhi, dir, ubody), Value_unknown) + | Lassign(id, lam) -> + let (ulam, _) = close env lam in + (Uassign(id, ulam), Value_unknown) + | Levent(lam, _) -> + close env lam + | Lifused _ -> + assert false + +and close_list env = function + [] -> [] + | lam :: rem -> + let (ulam, _) = close env lam in + ulam :: close_list env rem + +and close_list_approx env = function + [] -> ([], []) + | lam :: rem -> + let (ulam, approx) = close env lam in + let (ulams, approxs) = close_list_approx env rem in + (ulam :: ulams, approx :: approxs) + +and close_named env id = function + Lfunction _ as funct -> + close_one_function env id funct + | lam -> + close env lam + +(* Build a shared closure for a set of mutually recursive functions *) + +and close_functions { backend; fenv; cenv } fun_defs = + let fun_defs = + List.flatten + (List.map + (function + | (id, Lfunction{kind; params; return; body; attr; loc}) -> + Simplif.split_default_wrapper ~id ~kind ~params + ~body ~attr ~loc ~return + | _ -> assert false + ) + fun_defs) + in + let inline_attribute = match fun_defs with + | [_, Lfunction{attr = { inline; }}] -> inline + | _ -> Default_inline (* recursive functions can't be inlined *) + in + (* Update and check nesting depth *) + incr function_nesting_depth; + let initially_closed = + !function_nesting_depth < excessive_function_nesting_depth in + (* Determine the free variables of the functions *) + let fv = + V.Set.elements (free_variables (Lletrec(fun_defs, lambda_unit))) in + (* Build the function descriptors for the functions. + Initially all functions are assumed not to need their environment + parameter. *) + let uncurried_defs = + List.map + (function + (id, Lfunction{kind; params; return; body; loc}) -> + let label = Compilenv.make_symbol (Some (V.unique_name id)) in + let arity = List.length params in + let fundesc = + {fun_label = label; + fun_arity = (if kind = Tupled then -arity else arity); + fun_closed = initially_closed; + fun_inline = None; + fun_float_const_prop = !Clflags.float_const_prop } in + let dbg = Debuginfo.from_location loc in + (id, params, return, body, fundesc, dbg) + | (_, _) -> fatal_error "Closure.close_functions") + fun_defs in + (* Build an approximate fenv for compiling the functions *) + let fenv_rec = + List.fold_right + (fun (id, _params, _return, _body, fundesc, _dbg) fenv -> + V.Map.add id (Value_closure(fundesc, Value_unknown)) fenv) + uncurried_defs fenv in + (* Determine the offsets of each function's closure in the shared block *) + let env_pos = ref (-1) in + let clos_offsets = + List.map + (fun (_id, _params, _return, _body, fundesc, _dbg) -> + let pos = !env_pos + 1 in + env_pos := !env_pos + 1 + (if fundesc.fun_arity <> 1 then 3 else 2); + pos) + uncurried_defs in + let fv_pos = !env_pos in + (* This reference will be set to false if the hypothesis that a function + does not use its environment parameter is invalidated. *) + let useless_env = ref initially_closed in + (* Translate each function definition *) + let clos_fundef (id, params, return, body, fundesc, dbg) env_pos = + let env_param = V.create_local "env" in + let cenv_fv = + build_closure_env env_param (fv_pos - env_pos) fv in + let cenv_body = + List.fold_right2 + (fun (id, _params, _return, _body, _fundesc, _dbg) pos env -> + V.Map.add id (Uoffset(Uvar env_param, pos - env_pos)) env) + uncurried_defs clos_offsets cenv_fv in + let (ubody, approx) = + close { backend; fenv = fenv_rec; cenv = cenv_body } body + in + if !useless_env && occurs_var env_param ubody then raise NotClosed; + let fun_params = + if !useless_env + then params + else params @ [env_param, Pgenval] + in + let f = + { + label = fundesc.fun_label; + arity = fundesc.fun_arity; + params = List.map (fun (var, kind) -> VP.create var, kind) fun_params; + return; + body = ubody; + dbg; + env = Some env_param; + } + in + (* give more chance of function with default parameters (i.e. + their wrapper functions) to be inlined *) + let n = + List.fold_left + (fun n (id, _) -> n + if V.name id = "*opt*" then 8 else 1) + 0 + fun_params + in + let threshold = + match inline_attribute with + | Default_inline -> + let inline_threshold = + Clflags.Float_arg_helper.get ~key:0 !Clflags.inline_threshold + in + let magic_scale_constant = 8. in + int_of_float (inline_threshold *. magic_scale_constant) + n + | Always_inline -> max_int + | Never_inline -> min_int + | Unroll _ -> assert false + in + let fun_params = List.map (fun (var, _) -> VP.create var) fun_params in + if lambda_smaller ubody threshold + then fundesc.fun_inline <- Some(fun_params, ubody); + + (f, (id, env_pos, Value_closure(fundesc, approx))) in + (* Translate all function definitions. *) + let clos_info_list = + if initially_closed then begin + let snap = Compilenv.snapshot () in + try List.map2 clos_fundef uncurried_defs clos_offsets + with NotClosed -> + (* If the hypothesis that the environment parameters are useless has been + invalidated, then set [fun_closed] to false in all descriptions and + recompile *) + Compilenv.backtrack snap; (* PR#6337 *) + List.iter + (fun (_id, _params, _return, _body, fundesc, _dbg) -> + fundesc.fun_closed <- false; + fundesc.fun_inline <- None; + ) + uncurried_defs; + useless_env := false; + List.map2 clos_fundef uncurried_defs clos_offsets + end else + (* Excessive closure nesting: assume environment parameter is used *) + List.map2 clos_fundef uncurried_defs clos_offsets + in + (* Update nesting depth *) + decr function_nesting_depth; + (* Return the Uclosure node and the list of all identifiers defined, + with offsets and approximations. *) + let (clos, infos) = List.split clos_info_list in + let fv = if !useless_env then [] else fv in + (Uclosure(clos, List.map (close_var { backend; fenv; cenv }) fv), infos) + +(* Same, for one non-recursive function *) + +and close_one_function env id funct = + match close_functions env [id, funct] with + | (clos, (i, _, approx) :: _) when id = i -> (clos, approx) + | _ -> fatal_error "Closure.close_one_function" + +(* Close a switch *) + +and close_switch env cases num_keys default = + let ncases = List.length cases in + let index = Array.make num_keys 0 + and store = Storer.mk_store () in + + (* First default case *) + begin match default with + | Some def when ncases < num_keys -> + assert (store.act_store () def = 0) + | _ -> () + end ; + (* Then all other cases *) + List.iter + (fun (key,lam) -> + index.(key) <- store.act_store () lam) + cases ; + + (* Explicit sharing with catch/exit, as switcher compilation may + later unshare *) + let acts = store.act_get_shared () in + let hs = ref (fun e -> e) in + + (* Compile actions *) + let actions = + Array.map + (function + | Single lam|Shared (Lstaticraise (_,[]) as lam) -> + let ulam,_ = close env lam in + ulam + | Shared lam -> + let ulam,_ = close env lam in + let i = next_raise_count () in +(* + let string_of_lambda e = + Printlambda.lambda Format.str_formatter e ; + Format.flush_str_formatter () in + Printf.eprintf "SHARE CLOSURE %i [%s]\n%s\n" i + (string_of_lambda arg) + (string_of_lambda lam) ; +*) + let ohs = !hs in + hs := (fun e -> Ucatch (i,[],ohs e,ulam)) ; + Ustaticfail (i,[])) + acts in + match actions with + | [| |] -> [| |], [| |], !hs (* May happen when default is None *) + | _ -> index, actions, !hs + + +(* Collect exported symbols for structured constants *) + +let collect_exported_structured_constants a = + let rec approx = function + | Value_closure (fd, a) -> + approx a; + begin match fd.fun_inline with + | Some (_, u) -> ulam u + | None -> () + end + | Value_tuple a -> Array.iter approx a + | Value_const c -> const c + | Value_unknown | Value_global_field _ -> () + and const = function + | Uconst_ref (s, (Some c)) -> + Compilenv.add_exported_constant s; + structured_constant c + | Uconst_ref (_s, None) -> assert false (* Cannot be generated *) + | Uconst_int _ | Uconst_ptr _ -> () + and structured_constant = function + | Uconst_block (_, ul) -> List.iter const ul + | Uconst_float _ | Uconst_int32 _ + | Uconst_int64 _ | Uconst_nativeint _ + | Uconst_float_array _ | Uconst_string _ -> () + | Uconst_closure _ -> assert false (* Cannot be generated *) + and ulam = function + | Uvar _ -> () + | Uconst c -> const c + | Udirect_apply (_, ul, _) -> List.iter ulam ul + | Ugeneric_apply (u, ul, _) -> ulam u; List.iter ulam ul + | Uclosure (fl, ul) -> + List.iter (fun f -> ulam f.body) fl; + List.iter ulam ul + | Uoffset(u, _) -> ulam u + | Ulet (_str, _kind, _, u1, u2) -> ulam u1; ulam u2 + | Uphantom_let _ -> no_phantom_lets () + | Uletrec (l, u) -> List.iter (fun (_, u) -> ulam u) l; ulam u + | Uprim (_, ul, _) -> List.iter ulam ul + | Uswitch (u, sl, _dbg) -> + ulam u; + Array.iter ulam sl.us_actions_consts; + Array.iter ulam sl.us_actions_blocks + | Ustringswitch (u,sw,d) -> + ulam u ; + List.iter (fun (_,act) -> ulam act) sw ; + Misc.may ulam d + | Ustaticfail (_, ul) -> List.iter ulam ul + | Ucatch (_, _, u1, u2) + | Utrywith (u1, _, u2) + | Usequence (u1, u2) + | Uwhile (u1, u2) -> ulam u1; ulam u2 + | Uifthenelse (u1, u2, u3) + | Ufor (_, u1, u2, _, u3) -> ulam u1; ulam u2; ulam u3 + | Uassign (_, u) -> ulam u + | Usend (_, u1, u2, ul, _) -> ulam u1; ulam u2; List.iter ulam ul + | Uunreachable -> () + in + approx a + +let reset () = + global_approx := [||]; + function_nesting_depth := 0 + +(* The entry point *) + +let intro ~backend ~size lam = + reset (); + let id = Compilenv.make_symbol None in + global_approx := Array.init size (fun i -> Value_global_field (id, i)); + Compilenv.set_global_approx(Value_tuple !global_approx); + let (ulam, _approx) = + close { backend; fenv = V.Map.empty; cenv = V.Map.empty } lam + in + let opaque = + !Clflags.opaque + || Env.is_imported_opaque (Compilenv.current_unit_name ()) + in + if opaque + then Compilenv.set_global_approx(Value_unknown) + else collect_exported_structured_constants (Value_tuple !global_approx); + global_approx := [||]; + ulam diff --git a/middle_end/closure/closure.mli b/middle_end/closure/closure.mli new file mode 100644 index 0000000000..92c74732b2 --- /dev/null +++ b/middle_end/closure/closure.mli @@ -0,0 +1,24 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Introduction of closures, uncurrying, recognition of direct calls *) + +val intro + : backend:(module Backend_intf.S) + -> size:int + -> Lambda.lambda + -> Clambda.ulambda + +val reset : unit -> unit diff --git a/middle_end/closure_conversion.ml b/middle_end/closure_conversion.ml deleted file mode 100644 index 9bdd30ead9..0000000000 --- a/middle_end/closure_conversion.ml +++ /dev/null @@ -1,737 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -module Env = Closure_conversion_aux.Env -module Function_decls = Closure_conversion_aux.Function_decls -module Function_decl = Function_decls.Function_decl -module Names = Internal_variable_names - -let name_expr = Flambda_utils.name_expr -let name_expr_from_var = Flambda_utils.name_expr_from_var - -type t = { - current_unit_id : Ident.t; - symbol_for_global' : (Ident.t -> Symbol.t); - filename : string; - backend : (module Backend_intf.S); - mutable imported_symbols : Symbol.Set.t; - mutable declared_symbols : (Symbol.t * Flambda.constant_defining_value) list; -} - -let add_default_argument_wrappers lam = - let defs_are_all_functions (defs : (_ * Lambda.lambda) list) = - List.for_all (function (_, Lambda.Lfunction _) -> true | _ -> false) defs - in - let f (lam : Lambda.lambda) : Lambda.lambda = - match lam with - | Llet (( Strict | Alias | StrictOpt), _k, id, - Lfunction {kind; params; body = fbody; attr; loc}, body) -> - begin match - Simplif.split_default_wrapper ~id ~kind ~params - ~body:fbody ~return:Pgenval ~attr ~loc - with - | [fun_id, def] -> Llet (Alias, Pgenval, fun_id, def, body) - | [fun_id, def; inner_fun_id, def_inner] -> - Llet (Alias, Pgenval, inner_fun_id, def_inner, - Llet (Alias, Pgenval, fun_id, def, body)) - | _ -> assert false - end - | Lletrec (defs, body) as lam -> - if defs_are_all_functions defs then - let defs = - List.flatten - (List.map - (function - | (id, Lambda.Lfunction {kind; params; body; attr; loc}) -> - Simplif.split_default_wrapper ~id ~kind ~params ~body - ~return:Pgenval ~attr ~loc - | _ -> assert false) - defs) - in - Lletrec (defs, body) - else lam - | lam -> lam - in - Lambda.map f lam - -(** Generate a wrapper ("stub") function that accepts a tuple argument and - calls another function with arguments extracted in the obvious - manner from the tuple. *) -let tupled_function_call_stub original_params unboxed_version ~closure_bound_var - : Flambda.function_declaration = - let tuple_param_var = Variable.rename unboxed_version in - let params = List.map (fun p -> Variable.rename p) original_params in - let call : Flambda.t = - Apply ({ - func = unboxed_version; - args = params; - (* CR-someday mshinwell for mshinwell: investigate if there is some - redundancy here (func is also unboxed_version) *) - kind = Direct (Closure_id.wrap unboxed_version); - dbg = Debuginfo.none; - inline = Default_inline; - specialise = Default_specialise; - }) - in - let _, body = - List.fold_left (fun (pos, body) param -> - let lam : Flambda.named = - Prim (Pfield pos, [tuple_param_var], Debuginfo.none) - in - pos + 1, Flambda.create_let param lam body) - (0, call) params - in - let tuple_param = Parameter.wrap tuple_param_var in - Flambda.create_function_declaration ~params:[tuple_param] - ~body ~stub:true ~dbg:Debuginfo.none ~inline:Default_inline - ~specialise:Default_specialise ~is_a_functor:false - ~closure_origin:(Closure_origin.create (Closure_id.wrap closure_bound_var)) - -let register_const t (constant:Flambda.constant_defining_value) name - : Flambda.constant_defining_value_block_field * Internal_variable_names.t = - let var = Variable.create name in - let symbol = Symbol.of_variable var in - t.declared_symbols <- (symbol, constant) :: t.declared_symbols; - Symbol symbol, name - -let rec declare_const t (const : Lambda.structured_constant) - : Flambda.constant_defining_value_block_field * Internal_variable_names.t = - match const with - | Const_base (Const_int c) -> (Const (Int c), Names.const_int) - | Const_base (Const_char c) -> (Const (Char c), Names.const_char) - | Const_base (Const_string (s, _)) -> - let const, name = - if Config.safe_string then - (Flambda.Allocated_const (Immutable_string s), - Names.const_immstring) - else - (Flambda.Allocated_const (String s), - Names.const_string) - in - register_const t const name - | Const_base (Const_float c) -> - register_const t - (Allocated_const (Float (float_of_string c))) - Names.const_float - | Const_base (Const_int32 c) -> - register_const t (Allocated_const (Int32 c)) - Names.const_int32 - | Const_base (Const_int64 c) -> - register_const t (Allocated_const (Int64 c)) - Names.const_int64 - | Const_base (Const_nativeint c) -> - register_const t (Allocated_const (Nativeint c)) Names.const_nativeint - | Const_pointer c -> Const (Const_pointer c), Names.const_ptr - | Const_immstring c -> - register_const t (Allocated_const (Immutable_string c)) - Names.const_immstring - | Const_float_array c -> - register_const t - (Allocated_const (Immutable_float_array (List.map float_of_string c))) - Names.const_float_array - | Const_block (tag, consts) -> - let const : Flambda.constant_defining_value = - Block (Tag.create_exn tag, - List.map (fun c -> fst (declare_const t c)) consts) - in - register_const t const Names.const_block - -let close_const t (const : Lambda.structured_constant) - : Flambda.named * Internal_variable_names.t = - match declare_const t const with - | Const c, name -> - Const c, name - | Symbol s, name -> - Symbol s, name - -let lambda_const_bool b : Lambda.structured_constant = - if b then - Const_pointer 1 - else - Const_pointer 0 - -let lambda_const_int i : Lambda.structured_constant = - Const_base (Const_int i) - -let rec close t env (lam : Lambda.lambda) : Flambda.t = - match lam with - | Lvar id -> - begin match Env.find_var_exn env id with - | var -> Var var - | exception Not_found -> - match Env.find_mutable_var_exn env id with - | mut_var -> - name_expr (Read_mutable mut_var) ~name:Names.read_mutable - | exception Not_found -> - Misc.fatal_errorf "Closure_conversion.close: unbound identifier %a" - Ident.print id - end - | Lconst cst -> - let cst, name = close_const t cst in - name_expr cst ~name - | Llet ((Strict | Alias | StrictOpt), _value_kind, id, defining_expr, body) -> - (* TODO: keep value_kind in flambda *) - let var = Variable.create_with_same_name_as_ident id in - let defining_expr = - close_let_bound_expression t var env defining_expr - in - let body = close t (Env.add_var env id var) body in - Flambda.create_let var defining_expr body - | Llet (Variable, block_kind, id, defining_expr, body) -> - let mut_var = Mutable_variable.create_with_same_name_as_ident id in - let var = Variable.create_with_same_name_as_ident id in - let defining_expr = - close_let_bound_expression t var env defining_expr - in - let body = close t (Env.add_mutable_var env id mut_var) body in - Flambda.create_let var defining_expr - (Let_mutable - { var = mut_var; - initial_value = var; - body; - contents_kind = block_kind }) - | Lfunction { kind; params; body; attr; loc; } -> - let name = Names.anon_fn_with_loc loc in - let closure_bound_var = Variable.create name in - (* CR-soon mshinwell: some of this is now very similar to the let rec case - below *) - let set_of_closures_var = Variable.create Names.set_of_closures in - let set_of_closures = - let decl = - Function_decl.create ~let_rec_ident:None ~closure_bound_var ~kind - ~params:(List.map fst params) ~body ~attr ~loc - in - close_functions t env (Function_decls.create [decl]) - in - let project_closure : Flambda.project_closure = - { set_of_closures = set_of_closures_var; - closure_id = Closure_id.wrap closure_bound_var; - } - in - Flambda.create_let set_of_closures_var set_of_closures - (name_expr (Project_closure (project_closure)) ~name) - | Lapply { ap_func; ap_args; ap_loc; ap_should_be_tailcall = _; - ap_inlined; ap_specialised; } -> - Lift_code.lifting_helper (close_list t env ap_args) - ~evaluation_order:`Right_to_left - ~name:Names.apply_arg - ~create_body:(fun args -> - let func = close t env ap_func in - let func_var = Variable.create Names.apply_funct in - Flambda.create_let func_var (Expr func) - (Apply ({ - func = func_var; - args; - kind = Indirect; - dbg = Debuginfo.from_location ap_loc; - inline = ap_inlined; - specialise = ap_specialised; - }))) - | Lletrec (defs, body) -> - let env = - List.fold_right (fun (id, _) env -> - Env.add_var env id (Variable.create_with_same_name_as_ident id)) - defs env - in - let function_declarations = - (* Identify any bindings in the [let rec] that are functions. These - will be named after the corresponding identifier in the [let rec]. *) - List.map (function - | (let_rec_ident, - Lambda.Lfunction { kind; params; body; attr; loc }) -> - let closure_bound_var = - Variable.create_with_same_name_as_ident let_rec_ident - in - let function_declaration = - Function_decl.create ~let_rec_ident:(Some let_rec_ident) - ~closure_bound_var ~kind ~params:(List.map fst params) ~body - ~attr ~loc - in - Some function_declaration - | _ -> None) - defs - in - begin match - Misc.Stdlib.List.some_if_all_elements_are_some function_declarations - with - | Some function_declarations -> - (* When all the bindings are (syntactically) functions, we can - eliminate the [let rec] construction, instead producing a normal - [Let] that binds a set of closures containing all of the functions. - *) - (* CR-someday lwhite: This is a very syntactic criteria. Adding an - unused value to a set of recursive bindings changes how - functions are represented at runtime. *) - let set_of_closures_var = Variable.create (Names.set_of_closures) in - let set_of_closures = - close_functions t env (Function_decls.create function_declarations) - in - let body = - List.fold_left (fun body decl -> - let let_rec_ident = Function_decl.let_rec_ident decl in - let closure_bound_var = Function_decl.closure_bound_var decl in - let let_bound_var = Env.find_var env let_rec_ident in - (* Inside the body of the [let], each function is referred to by - a [Project_closure] expression, which projects from the set of - closures. *) - (Flambda.create_let let_bound_var - (Project_closure { - set_of_closures = set_of_closures_var; - closure_id = Closure_id.wrap closure_bound_var; - }) - body)) - (close t env body) function_declarations - in - Flambda.create_let set_of_closures_var set_of_closures body - | None -> - (* If the condition above is not satisfied, we build a [Let_rec] - expression; any functions bound by it will have their own - individual closures. *) - let defs = - List.map (fun (id, def) -> - let var = Env.find_var env id in - var, close_let_bound_expression t ~let_rec_ident:id var env def) - defs - in - Let_rec (defs, close t env body) - end - | Lsend (kind, meth, obj, args, loc) -> - let meth_var = Variable.create Names.meth in - let obj_var = Variable.create Names.obj in - let dbg = Debuginfo.from_location loc in - Flambda.create_let meth_var (Expr (close t env meth)) - (Flambda.create_let obj_var (Expr (close t env obj)) - (Lift_code.lifting_helper (close_list t env args) - ~evaluation_order:`Right_to_left - ~name:Names.send_arg - ~create_body:(fun args -> - Send { kind; meth = meth_var; obj = obj_var; args; dbg; }))) - | Lprim ((Pdivint Safe | Pmodint Safe - | Pdivbint { is_safe = Safe } | Pmodbint { is_safe = Safe }) as prim, - [arg1; arg2], loc) - when not !Clflags.unsafe -> - let arg2 = close t env arg2 in - let arg1 = close t env arg1 in - let numerator = Variable.create Names.numerator in - let denominator = Variable.create Names.denominator in - let zero = Variable.create Names.zero in - let is_zero = Variable.create Names.is_zero in - let exn = Variable.create Names.division_by_zero in - let exn_symbol = - t.symbol_for_global' Predef.ident_division_by_zero - in - let dbg = Debuginfo.from_location loc in - let zero_const : Flambda.named = - match prim with - | Pdivint _ | Pmodint _ -> - Const (Int 0) - | Pdivbint { size = Pint32 } | Pmodbint { size = Pint32 } -> - Allocated_const (Int32 0l) - | Pdivbint { size = Pint64 } | Pmodbint { size = Pint64 } -> - Allocated_const (Int64 0L) - | Pdivbint { size = Pnativeint } | Pmodbint { size = Pnativeint } -> - Allocated_const (Nativeint 0n) - | _ -> assert false - in - let prim : Clambda_primitives.primitive = - match prim with - | Pdivint _ -> Pdivint Unsafe - | Pmodint _ -> Pmodint Unsafe - | Pdivbint { size } -> Pdivbint { size; is_safe = Unsafe } - | Pmodbint { size } -> Pmodbint { size; is_safe = Unsafe } - | _ -> assert false - in - let comparison : Clambda_primitives.primitive = - match prim with - | Pdivint _ | Pmodint _ -> Pintcomp Ceq - | Pdivbint { size } | Pmodbint { size } -> Pbintcomp (size,Ceq) - | _ -> assert false - in - t.imported_symbols <- Symbol.Set.add exn_symbol t.imported_symbols; - Flambda.create_let zero zero_const - (Flambda.create_let exn (Symbol exn_symbol) - (Flambda.create_let denominator (Expr arg2) - (Flambda.create_let numerator (Expr arg1) - (Flambda.create_let is_zero - (Prim (comparison, [zero; denominator], dbg)) - (If_then_else (is_zero, - name_expr (Prim (Praise Raise_regular, [exn], dbg)) - ~name:Names.dummy, - (* CR-someday pchambart: find the right event. - mshinwell: I briefly looked at this, and couldn't - figure it out. - lwhite: I don't think any of the existing events - are suitable. I had to add a new one for a similar - case in the array data types work. - mshinwell: deferred CR *) - name_expr ~name:Names.result - (Prim (prim, [numerator; denominator], dbg)))))))) - | Lprim ((Pdivint Safe | Pmodint Safe - | Pdivbint { is_safe = Safe } | Pmodbint { is_safe = Safe }), _, _) - when not !Clflags.unsafe -> - Misc.fatal_error "Pdivint / Pmodint must have exactly two arguments" - | Lprim (Psequor, [arg1; arg2], _) -> - let arg1 = close t env arg1 in - let arg2 = close t env arg2 in - let const_true = Variable.create Names.const_true in - let cond = Variable.create Names.cond_sequor in - Flambda.create_let const_true (Const (Const_pointer 1)) - (Flambda.create_let cond (Expr arg1) - (If_then_else (cond, Var const_true, arg2))) - | Lprim (Psequand, [arg1; arg2], _) -> - let arg1 = close t env arg1 in - let arg2 = close t env arg2 in - let const_false = Variable.create Names.const_false in - let cond = Variable.create Names.const_sequand in - Flambda.create_let const_false (Const (Const_pointer 0)) - (Flambda.create_let cond (Expr arg1) - (If_then_else (cond, arg2, Var const_false))) - | Lprim ((Psequand | Psequor), _, _) -> - Misc.fatal_error "Psequand / Psequor must have exactly two arguments" - | Lprim ((Pidentity | Pbytes_to_string | Pbytes_of_string), [arg], _) -> - close t env arg - | Lprim (Pignore, [arg], _) -> - let var = Variable.create Names.ignore in - let defining_expr = - close_let_bound_expression t var env arg - in - Flambda.create_let var defining_expr - (name_expr (Const (Const_pointer 0)) ~name:Names.unit) - | Lprim (Pdirapply, [funct; arg], loc) - | Lprim (Prevapply, [arg; funct], loc) -> - let apply : Lambda.lambda_apply = - { ap_func = funct; - ap_args = [arg]; - ap_loc = loc; - ap_should_be_tailcall = false; - (* CR-someday lwhite: it would be nice to be able to give - inlined attributes to functions applied with the application - operators. *) - ap_inlined = Default_inline; - ap_specialised = Default_specialise; - } - in - close t env (Lambda.Lapply apply) - | Lprim (Praise kind, [arg], loc) -> - let arg_var = Variable.create Names.raise_arg in - let dbg = Debuginfo.from_location loc in - Flambda.create_let arg_var (Expr (close t env arg)) - (name_expr - (Prim (Praise kind, [arg_var], dbg)) - ~name:Names.raise) - | Lprim (Pctconst c, [arg], _loc) -> - let module Backend = (val t.backend) in - let const = - begin match c with - | Big_endian -> lambda_const_bool Backend.big_endian - | Word_size -> lambda_const_int (8*Backend.size_int) - | Int_size -> lambda_const_int (8*Backend.size_int - 1) - | Max_wosize -> - lambda_const_int ((1 lsl ((8*Backend.size_int) - 10)) - 1) - | Ostype_unix -> lambda_const_bool (String.equal Sys.os_type "Unix") - | Ostype_win32 -> lambda_const_bool (String.equal Sys.os_type "Win32") - | Ostype_cygwin -> lambda_const_bool (String.equal Sys.os_type "Cygwin") - | Backend_type -> - Lambda.Const_pointer 0 (* tag 0 is the same as Native *) - end - in - close t env - (Lambda.Llet(Strict, Pgenval, Ident.create_local "dummy", - arg, Lconst const)) - | Lprim (Pfield _, [Lprim (Pgetglobal id, [],_)], _) - when Ident.same id t.current_unit_id -> - Misc.fatal_errorf "[Pfield (Pgetglobal ...)] for the current compilation \ - unit is forbidden upon entry to the middle end" - | Lprim (Psetfield (_, _, _), [Lprim (Pgetglobal _, [], _); _], _) -> - Misc.fatal_errorf "[Psetfield (Pgetglobal ...)] is \ - forbidden upon entry to the middle end" - | Lprim (Pgetglobal id, [], _) when Ident.is_predef id -> - let symbol = t.symbol_for_global' id in - t.imported_symbols <- Symbol.Set.add symbol t.imported_symbols; - name_expr (Symbol symbol) ~name:Names.predef_exn - | Lprim (Pgetglobal id, [], _) -> - assert (not (Ident.same id t.current_unit_id)); - let symbol = t.symbol_for_global' id in - t.imported_symbols <- Symbol.Set.add symbol t.imported_symbols; - name_expr (Symbol symbol) ~name:Names.pgetglobal - | Lprim (lambda_p, args, loc) -> - (* One of the important consequences of the ANF-like representation - here is that we obtain names corresponding to the components of - blocks being made (with [Pmakeblock]). This information can be used - by the simplification pass to increase the likelihood of eliminating - the allocation, since some field accesses can be tracked back to known - field values. *) - let dbg = Debuginfo.from_location loc in - let p = Convert_primitives.convert lambda_p in - Lift_code.lifting_helper (close_list t env args) - ~evaluation_order:`Right_to_left - ~name:(Names.of_primitive_arg lambda_p) - ~create_body:(fun args -> - name_expr (Prim (p, args, dbg)) - ~name:(Names.of_primitive lambda_p)) - | Lswitch (arg, sw, _loc) -> - let scrutinee = Variable.create Names.switch in - let aux (i, lam) = i, close t env lam in - let nums sw_num cases default = - let module I = Numbers.Int in - match default with - | Some _ -> - I.zero_to_n (sw_num - 1) - | None -> - List.fold_left (fun set (i, _) -> I.Set.add i set) I.Set.empty cases - in - Flambda.create_let scrutinee (Expr (close t env arg)) - (Switch (scrutinee, - { numconsts = nums sw.sw_numconsts sw.sw_consts sw.sw_failaction; - consts = List.map aux sw.sw_consts; - numblocks = nums sw.sw_numblocks sw.sw_blocks sw.sw_failaction; - blocks = List.map aux sw.sw_blocks; - failaction = Misc.may_map (close t env) sw.sw_failaction; - })) - | Lstringswitch (arg, sw, def, _) -> - let scrutinee = Variable.create Names.string_switch in - Flambda.create_let scrutinee (Expr (close t env arg)) - (String_switch (scrutinee, - List.map (fun (s, e) -> s, close t env e) sw, - Misc.may_map (close t env) def)) - | Lstaticraise (i, args) -> - Lift_code.lifting_helper (close_list t env args) - ~evaluation_order:`Right_to_left - ~name:Names.staticraise_arg - ~create_body:(fun args -> - let static_exn = Env.find_static_exception env i in - Static_raise (static_exn, args)) - | Lstaticcatch (body, (i, ids), handler) -> - let st_exn = Static_exception.create () in - let env = Env.add_static_exception env i st_exn in - let ids = List.map fst ids in - let vars = List.map Variable.create_with_same_name_as_ident ids in - Static_catch (st_exn, vars, close t env body, - close t (Env.add_vars env ids vars) handler) - | Ltrywith (body, id, handler) -> - let var = Variable.create_with_same_name_as_ident id in - Try_with (close t env body, var, close t (Env.add_var env id var) handler) - | Lifthenelse (cond, ifso, ifnot) -> - let cond = close t env cond in - let cond_var = Variable.create Names.cond in - Flambda.create_let cond_var (Expr cond) - (If_then_else (cond_var, close t env ifso, close t env ifnot)) - | Lsequence (lam1, lam2) -> - let var = Variable.create Names.sequence in - let lam1 = Flambda.Expr (close t env lam1) in - let lam2 = close t env lam2 in - Flambda.create_let var lam1 lam2 - | Lwhile (cond, body) -> While (close t env cond, close t env body) - | Lfor (id, lo, hi, direction, body) -> - let bound_var = Variable.create_with_same_name_as_ident id in - let from_value = Variable.create Names.for_from in - let to_value = Variable.create Names.for_to in - let body = close t (Env.add_var env id bound_var) body in - Flambda.create_let from_value (Expr (close t env lo)) - (Flambda.create_let to_value (Expr (close t env hi)) - (For { bound_var; from_value; to_value; direction; body; })) - | Lassign (id, new_value) -> - let being_assigned = - match Env.find_mutable_var_exn env id with - | being_assigned -> being_assigned - | exception Not_found -> - Misc.fatal_errorf "Closure_conversion.close: unbound mutable \ - variable %s in assignment" - (Ident.unique_name id) - in - let new_value_var = Variable.create Names.new_value in - Flambda.create_let new_value_var (Expr (close t env new_value)) - (Assign { being_assigned; new_value = new_value_var; }) - | Levent (lam, _) -> close t env lam - | Lifused _ -> - (* [Lifused] is used to mark that this expression should be alive only if - an identifier is. Every use should have been removed by - [Simplif.simplify_lets], either by replacing by the inner expression, - or by completely removing it (replacing by unit). *) - Misc.fatal_error "[Lifused] should have been removed by \ - [Simplif.simplify_lets]" - -(** Perform closure conversion on a set of function declarations, returning a - set of closures. (The set will often only contain a single function; - the only case where it cannot is for "let rec".) *) -and close_functions t external_env function_declarations : Flambda.named = - let closure_env_without_parameters = - Function_decls.closure_env_without_parameters - external_env function_declarations - in - let all_free_idents = Function_decls.all_free_idents function_declarations in - let close_one_function map decl = - let body = Function_decl.body decl in - let loc = Function_decl.loc decl in - let dbg = Debuginfo.from_location loc in - let params = Function_decl.params decl in - (* Create fresh variables for the elements of the closure (cf. - the comment on [Function_decl.closure_env_without_parameters], above). - This induces a renaming on [Function_decl.free_idents]; the results of - that renaming are stored in [free_variables]. *) - let closure_env = - List.fold_right (fun id env -> - Env.add_var env id (Variable.create_with_same_name_as_ident id)) - params closure_env_without_parameters - in - (* If the function is the wrapper for a function with an optional - argument with a default value, make sure it always gets inlined. - CR-someday pchambart: eta-expansion wrapper for a primitive are - not marked as stub but certainly should *) - let stub = Function_decl.stub decl in - let param_vars = List.map (Env.find_var closure_env) params in - let params = List.map Parameter.wrap param_vars in - let closure_bound_var = Function_decl.closure_bound_var decl in - let unboxed_version = Variable.rename closure_bound_var in - let body = close t closure_env body in - let closure_origin = - Closure_origin.create (Closure_id.wrap unboxed_version) - in - let fun_decl = - Flambda.create_function_declaration ~params ~body ~stub ~dbg - ~inline:(Function_decl.inline decl) - ~specialise:(Function_decl.specialise decl) - ~is_a_functor:(Function_decl.is_a_functor decl) - ~closure_origin - in - match Function_decl.kind decl with - | Curried -> Variable.Map.add closure_bound_var fun_decl map - | Tupled -> - let unboxed_version = Variable.rename closure_bound_var in - let generic_function_stub = - tupled_function_call_stub param_vars unboxed_version ~closure_bound_var - in - Variable.Map.add unboxed_version fun_decl - (Variable.Map.add closure_bound_var generic_function_stub map) - in - let function_decls = - let is_classic_mode = !Clflags.classic_inlining in - let funs = - List.fold_left close_one_function Variable.Map.empty - (Function_decls.to_list function_declarations) - in - Flambda.create_function_declarations ~is_classic_mode ~funs - in - (* The closed representation of a set of functions is a "set of closures". - (For avoidance of doubt, the runtime representation of the *whole set* is - a single block with tag [Closure_tag].) *) - let set_of_closures = - let free_vars = - Ident.Set.fold (fun var map -> - let internal_var = - Env.find_var closure_env_without_parameters var - in - let external_var : Flambda.specialised_to = - { var = Env.find_var external_env var; - projection = None; - } - in - Variable.Map.add internal_var external_var map) - all_free_idents Variable.Map.empty - in - Flambda.create_set_of_closures ~function_decls ~free_vars - ~specialised_args:Variable.Map.empty - ~direct_call_surrogates:Variable.Map.empty - in - Set_of_closures set_of_closures - -and close_list t sb l = List.map (close t sb) l - -and close_let_bound_expression t ?let_rec_ident let_bound_var env - (lam : Lambda.lambda) : Flambda.named = - match lam with - | Lfunction { kind; params; body; attr; loc; } -> - (* Ensure that [let] and [let rec]-bound functions have appropriate - names. *) - let closure_bound_var = Variable.rename let_bound_var in - let decl = - Function_decl.create ~let_rec_ident ~closure_bound_var ~kind - ~params:(List.map fst params) ~body ~attr ~loc - in - let set_of_closures_var = Variable.rename let_bound_var in - let set_of_closures = - close_functions t env (Function_decls.create [decl]) - in - let project_closure : Flambda.project_closure = - { set_of_closures = set_of_closures_var; - closure_id = Closure_id.wrap closure_bound_var; - } - in - Expr (Flambda.create_let set_of_closures_var set_of_closures - (name_expr_from_var (Project_closure (project_closure)) - ~var:let_bound_var)) - | lam -> Expr (close t env lam) - -let lambda_to_flambda ~backend ~module_ident ~size ~filename lam - : Flambda.program = - let lam = add_default_argument_wrappers lam in - let module Backend = (val backend : Backend_intf.S) in - let compilation_unit = Compilation_unit.get_current_exn () in - let t = - { current_unit_id = Compilation_unit.get_persistent_ident compilation_unit; - symbol_for_global' = Backend.symbol_for_global'; - filename; - backend; - imported_symbols = Symbol.Set.empty; - declared_symbols = []; - } - in - let module_symbol = Backend.symbol_for_global' module_ident in - let block_symbol = - let var = Variable.create Internal_variable_names.module_as_block in - Symbol.of_variable var - in - (* The global module block is built by accessing the fields of all the - introduced symbols. *) - (* CR-soon mshinwell for mshinwell: Add a comment describing how modules are - compiled. *) - let fields = - Array.init size (fun pos -> - let sym_v = Variable.create Names.block_symbol in - let result_v = Variable.create Names.block_symbol_get in - let value_v = Variable.create Names.block_symbol_get_field in - Flambda.create_let - sym_v (Symbol block_symbol) - (Flambda.create_let result_v - (Prim (Pfield 0, [sym_v], Debuginfo.none)) - (Flambda.create_let value_v - (Prim (Pfield pos, [result_v], Debuginfo.none)) - (Var value_v)))) - in - let module_initializer : Flambda.program_body = - Initialize_symbol ( - block_symbol, - Tag.create_exn 0, - [close t Env.empty lam], - Initialize_symbol ( - module_symbol, - Tag.create_exn 0, - Array.to_list fields, - End module_symbol)) - in - let program_body = - List.fold_left - (fun program_body (symbol, constant) : Flambda.program_body -> - Let_symbol (symbol, constant, program_body)) - module_initializer - t.declared_symbols - in - { imported_symbols = t.imported_symbols; - program_body; - } diff --git a/middle_end/closure_conversion.mli b/middle_end/closure_conversion.mli deleted file mode 100644 index f5fab0a7ed..0000000000 --- a/middle_end/closure_conversion.mli +++ /dev/null @@ -1,53 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -(** Generation of [Flambda] intermediate language code from [Lambda] code - by performing a form of closure conversion. - - Function declarations (which may bind one or more variables identifying - functions, possibly with mutual recursion) are transformed to - [Set_of_closures] expressions. [Project_closure] expressions are then - used to select a closure for a particular function from a [Set_of_closures] - expression. The [Set_of_closures] expressions say nothing about the - actual runtime layout of the closures; this is handled when [Flambda] code - is translated to [Clambda] code. - - The following transformations are also performed during closure - conversion: - - Constant blocks (by which is meant things wrapped in [Lambda.Const_block]) - are converted to applications of the [Pmakeblock] primitive. - - [Levent] debugging event nodes are removed and the information within - them attached to function, method and [raise] calls. - - Tuplified functions are converted to curried functions and a stub - function emitted to call the curried version. For example: - let rec f (x, y) = f (x + 1, y + 1) - is transformed to: - let rec internal_f x y = f (x + 1,y + 1) - and f (x, y) = internal_f x y (* [f] is marked as a stub function *) - - The [Pdirapply] and [Prevapply] application primitives are removed and - converted to normal [Flambda] application nodes. - - The [lambda_to_flambda] function is not re-entrant. -*) -val lambda_to_flambda - : backend:(module Backend_intf.S) - -> module_ident:Ident.t - -> size:int - -> filename:string - -> Lambda.lambda - -> Flambda.program diff --git a/middle_end/closure_conversion_aux.ml b/middle_end/closure_conversion_aux.ml deleted file mode 100644 index cfcaf34d1b..0000000000 --- a/middle_end/closure_conversion_aux.ml +++ /dev/null @@ -1,184 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -module Env = struct - type t = { - variables : Variable.t Ident.tbl; - mutable_variables : Mutable_variable.t Ident.tbl; - static_exceptions : Static_exception.t Numbers.Int.Map.t; - globals : Symbol.t Numbers.Int.Map.t; - at_toplevel : bool; - } - - let empty = { - variables = Ident.empty; - mutable_variables = Ident.empty; - static_exceptions = Numbers.Int.Map.empty; - globals = Numbers.Int.Map.empty; - at_toplevel = true; - } - - let clear_local_bindings env = - { empty with globals = env.globals } - - let add_var t id var = { t with variables = Ident.add id var t.variables } - let add_vars t ids vars = List.fold_left2 add_var t ids vars - - let find_var t id = - try Ident.find_same id t.variables - with Not_found -> - Misc.fatal_errorf "Closure_conversion.Env.find_var: %s@ %s" - (Ident.unique_name id) - (Printexc.raw_backtrace_to_string (Printexc.get_callstack 42)) - - let find_var_exn t id = - Ident.find_same id t.variables - - let add_mutable_var t id mutable_var = - { t with mutable_variables = Ident.add id mutable_var t.mutable_variables } - - let find_mutable_var_exn t id = - Ident.find_same id t.mutable_variables - - let add_static_exception t st_exn fresh_st_exn = - { t with - static_exceptions = - Numbers.Int.Map.add st_exn fresh_st_exn t.static_exceptions } - - let find_static_exception t st_exn = - try Numbers.Int.Map.find st_exn t.static_exceptions - with Not_found -> - Misc.fatal_error ("Closure_conversion.Env.find_static_exception: exn " - ^ Int.to_string st_exn) - - let add_global t pos symbol = - { t with globals = Numbers.Int.Map.add pos symbol t.globals } - - let find_global t pos = - try Numbers.Int.Map.find pos t.globals - with Not_found -> - Misc.fatal_error ("Closure_conversion.Env.find_global: global " - ^ Int.to_string pos) - - let at_toplevel t = t.at_toplevel - - let not_at_toplevel t = { t with at_toplevel = false; } -end - -module Function_decls = struct - module Function_decl = struct - type t = { - let_rec_ident : Ident.t; - closure_bound_var : Variable.t; - kind : Lambda.function_kind; - params : Ident.t list; - body : Lambda.lambda; - free_idents_of_body : Ident.Set.t; - attr : Lambda.function_attribute; - loc : Location.t; - } - - let create ~let_rec_ident ~closure_bound_var ~kind ~params ~body - ~attr ~loc = - let let_rec_ident = - match let_rec_ident with - | None -> Ident.create_local "unnamed_function" - | Some let_rec_ident -> let_rec_ident - in - { let_rec_ident; - closure_bound_var; - kind; - params; - body; - free_idents_of_body = Lambda.free_variables body; - attr; - loc; - } - - let let_rec_ident t = t.let_rec_ident - let closure_bound_var t = t.closure_bound_var - let kind t = t.kind - let params t = t.params - let body t = t.body - let free_idents t = t.free_idents_of_body - let inline t = t.attr.inline - let specialise t = t.attr.specialise - let is_a_functor t = t.attr.is_a_functor - let stub t = t.attr.stub - let loc t = t.loc - - end - - type t = { - function_decls : Function_decl.t list; - all_free_idents : Ident.Set.t; - } - - (* All identifiers free in the bodies of the given function declarations, - indexed by the identifiers corresponding to the functions themselves. *) - let free_idents_by_function function_decls = - List.fold_right (fun decl map -> - Variable.Map.add (Function_decl.closure_bound_var decl) - (Function_decl.free_idents decl) map) - function_decls Variable.Map.empty - - let all_free_idents function_decls = - Variable.Map.fold (fun _ -> Ident.Set.union) - (free_idents_by_function function_decls) Ident.Set.empty - - (* All identifiers of simultaneously-defined functions in [ts]. *) - let let_rec_idents function_decls = - List.map Function_decl.let_rec_ident function_decls - - (* All parameters of functions in [ts]. *) - let all_params function_decls = - List.concat (List.map Function_decl.params function_decls) - - let set_diff (from : Ident.Set.t) (idents : Ident.t list) = - List.fold_right Ident.Set.remove idents from - - (* CR-someday lwhite: use a different name from above or explain the - difference *) - let all_free_idents function_decls = - set_diff (set_diff (all_free_idents function_decls) - (all_params function_decls)) - (let_rec_idents function_decls) - - let create function_decls = - { function_decls; - all_free_idents = all_free_idents function_decls; - } - - let to_list t = t.function_decls - - let all_free_idents t = t.all_free_idents - - let closure_env_without_parameters external_env t = - let closure_env = - (* For "let rec"-bound functions. *) - List.fold_right (fun function_decl env -> - Env.add_var env (Function_decl.let_rec_ident function_decl) - (Function_decl.closure_bound_var function_decl)) - t.function_decls (Env.clear_local_bindings external_env) - in - (* For free variables. *) - Ident.Set.fold (fun id env -> - Env.add_var env id (Variable.create_with_same_name_as_ident id)) - t.all_free_idents closure_env -end diff --git a/middle_end/closure_conversion_aux.mli b/middle_end/closure_conversion_aux.mli deleted file mode 100644 index f16f05f0d7..0000000000 --- a/middle_end/closure_conversion_aux.mli +++ /dev/null @@ -1,94 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -(** Environments and auxiliary structures used during closure conversion. *) - -(** Used to remember which [Variable.t] values correspond to which - [Ident.t] values during closure conversion, and similarly for - static exception identifiers. *) -module Env : sig - type t - - val empty : t - - val add_var : t -> Ident.t -> Variable.t -> t - val add_vars : t -> Ident.t list -> Variable.t list -> t - - val find_var : t -> Ident.t -> Variable.t - val find_var_exn : t -> Ident.t -> Variable.t - - val add_mutable_var : t -> Ident.t -> Mutable_variable.t -> t - val find_mutable_var_exn : t -> Ident.t -> Mutable_variable.t - - val add_static_exception : t -> int -> Static_exception.t -> t - val find_static_exception : t -> int -> Static_exception.t - - val add_global : t -> int -> Symbol.t -> t - val find_global : t -> int -> Symbol.t - - val at_toplevel : t -> bool - val not_at_toplevel : t -> t -end - -(** Used to represent information about a set of function declarations - during closure conversion. (The only case in which such a set may - contain more than one declaration is when processing "let rec".) *) -module Function_decls : sig - module Function_decl : sig - type t - - val create - : let_rec_ident:Ident.t option - -> closure_bound_var:Variable.t - -> kind:Lambda.function_kind - -> params:Ident.t list - -> body:Lambda.lambda - -> attr:Lambda.function_attribute - -> loc:Location.t - -> t - - val let_rec_ident : t -> Ident.t - val closure_bound_var : t -> Variable.t - val kind : t -> Lambda.function_kind - val params : t -> Ident.t list - val body : t -> Lambda.lambda - val inline : t -> Lambda.inline_attribute - val specialise : t -> Lambda.specialise_attribute - val is_a_functor : t -> bool - val stub : t -> bool - val loc : t -> Location.t - - (* Like [all_free_idents], but for just one function. *) - val free_idents : t -> Ident.Set.t - end - - type t - - val create : Function_decl.t list -> t - val to_list : t -> Function_decl.t list - - (* All identifiers free in the given function declarations after the binding - of parameters and function identifiers has been performed. *) - val all_free_idents : t -> Ident.Set.t - - (* A map from identifiers to their corresponding [Variable.t]s whose domain - is the set of all identifiers free in the bodies of the declarations that - are not bound as parameters. - It also contains the globals bindings of the provided environment. *) - val closure_env_without_parameters : Env.t -> t -> Env.t -end diff --git a/middle_end/compilation_unit.ml b/middle_end/compilation_unit.ml new file mode 100644 index 0000000000..7fb48167bc --- /dev/null +++ b/middle_end/compilation_unit.ml @@ -0,0 +1,78 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +type t = { + id : Ident.t; + linkage_name : Linkage_name.t; + hash : int; +} + +let string_for_printing t = Ident.name t.id + +include Identifiable.Make (struct + type nonrec t = t + + (* Multiple units can have the same [id] if they come from different packs. + To distinguish these we also keep the linkage name, which contains the + name of the pack. *) + let compare v1 v2 = + if v1 == v2 then 0 + else + let c = compare v1.hash v2.hash in + if c = 0 then + let v1_id = Ident.name v1.id in + let v2_id = Ident.name v2.id in + let c = String.compare v1_id v2_id in + if c = 0 then + Linkage_name.compare v1.linkage_name v2.linkage_name + else + c + else c + + let equal x y = + if x == y then true + else compare x y = 0 + + let print ppf t = Format.pp_print_string ppf (string_for_printing t) + + let output oc x = output_string oc (Ident.name x.id) + let hash x = x.hash +end) + +let create (id : Ident.t) linkage_name = + if not (Ident.persistent id) then begin + Misc.fatal_error "Compilation_unit.create with non-persistent Ident.t" + end; + { id; linkage_name; hash = Hashtbl.hash (Ident.name id); } + +let get_persistent_ident cu = cu.id +let get_linkage_name cu = cu.linkage_name + +let current = ref None +let is_current arg = + match !current with + | None -> Misc.fatal_error "Current compilation unit is not set!" + | Some cur -> equal cur arg +let set_current t = current := Some t +let get_current () = !current +let get_current_exn () = + match !current with + | Some current -> current + | None -> Misc.fatal_error "Compilation_unit.get_current_exn" +let get_current_id_exn () = get_persistent_ident (get_current_exn ()) diff --git a/middle_end/compilation_unit.mli b/middle_end/compilation_unit.mli new file mode 100644 index 0000000000..fc7d3bfded --- /dev/null +++ b/middle_end/compilation_unit.mli @@ -0,0 +1,34 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +include Identifiable.S + +(* The [Ident.t] must be persistent. This function raises an exception + if that is not the case. *) +val create : Ident.t -> Linkage_name.t -> t + +val get_persistent_ident : t -> Ident.t +val get_linkage_name : t -> Linkage_name.t + +val is_current : t -> bool +val set_current : t -> unit +val get_current : unit -> t option +val get_current_exn : unit -> t +val get_current_id_exn : unit -> Ident.t + +val string_for_printing : t -> string diff --git a/middle_end/compilenv.ml b/middle_end/compilenv.ml new file mode 100644 index 0000000000..add4e90e57 --- /dev/null +++ b/middle_end/compilenv.ml @@ -0,0 +1,452 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2010 Institut National de Recherche en Informatique et *) +(* en Automatique *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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. *) +(* *) +(**************************************************************************) + +(* Compilation environments for compilation units *) + +[@@@ocaml.warning "+a-4-9-40-41-42"] + +open Config +open Cmx_format + +type error = + Not_a_unit_info of string + | Corrupted_unit_info of string + | Illegal_renaming of string * string * string + +exception Error of error + +let global_infos_table = + (Hashtbl.create 17 : (string, unit_infos option) Hashtbl.t) +let export_infos_table = + (Hashtbl.create 10 : (string, Export_info.t) Hashtbl.t) + +let imported_sets_of_closures_table = + (Set_of_closures_id.Tbl.create 10 + : Simple_value_approx.function_declarations option + Set_of_closures_id.Tbl.t) + +module CstMap = + Map.Make(struct + type t = Clambda.ustructured_constant + let compare = Clambda.compare_structured_constants + (* PR#6442: it is incorrect to use Stdlib.compare on values of type t + because it compares "0.0" and "-0.0" equal. *) + end) + +type structured_constants = + { + strcst_shared: string CstMap.t; + strcst_all: (string * Clambda.ustructured_constant) list; + } + +let structured_constants_empty = + { + strcst_shared = CstMap.empty; + strcst_all = []; + } + +let structured_constants = ref structured_constants_empty + + +let exported_constants = Hashtbl.create 17 + +let merged_environment = ref Export_info.empty + +let default_ui_export_info = + if Config.flambda then + Cmx_format.Flambda Export_info.empty + else + Cmx_format.Clambda Value_unknown + +let current_unit = + { ui_name = ""; + ui_symbol = ""; + ui_defines = []; + ui_imports_cmi = []; + ui_imports_cmx = []; + ui_curry_fun = []; + ui_apply_fun = []; + ui_send_fun = []; + ui_force_link = false; + ui_export_info = default_ui_export_info } + +let symbolname_for_pack pack name = + match pack with + | None -> name + | Some p -> + let b = Buffer.create 64 in + for i = 0 to String.length p - 1 do + match p.[i] with + | '.' -> Buffer.add_string b "__" + | c -> Buffer.add_char b c + done; + Buffer.add_string b "__"; + Buffer.add_string b name; + Buffer.contents b + +let unit_id_from_name name = Ident.create_persistent name + +let concat_symbol unitname id = + unitname ^ "__" ^ id + +let make_symbol ?(unitname = current_unit.ui_symbol) idopt = + let prefix = "caml" ^ unitname in + match idopt with + | None -> prefix + | Some id -> concat_symbol prefix id + +let current_unit_linkage_name () = + Linkage_name.create (make_symbol ~unitname:current_unit.ui_symbol None) + +let reset ?packname name = + Hashtbl.clear global_infos_table; + Set_of_closures_id.Tbl.clear imported_sets_of_closures_table; + let symbol = symbolname_for_pack packname name in + current_unit.ui_name <- name; + current_unit.ui_symbol <- symbol; + current_unit.ui_defines <- [symbol]; + current_unit.ui_imports_cmi <- []; + current_unit.ui_imports_cmx <- []; + current_unit.ui_curry_fun <- []; + current_unit.ui_apply_fun <- []; + current_unit.ui_send_fun <- []; + current_unit.ui_force_link <- !Clflags.link_everything; + Hashtbl.clear exported_constants; + structured_constants := structured_constants_empty; + current_unit.ui_export_info <- default_ui_export_info; + merged_environment := Export_info.empty; + Hashtbl.clear export_infos_table; + let compilation_unit = + Compilation_unit.create + (Ident.create_persistent name) + (current_unit_linkage_name ()) + in + Compilation_unit.set_current compilation_unit + +let current_unit_infos () = + current_unit + +let current_unit_name () = + current_unit.ui_name + +let symbol_in_current_unit name = + let prefix = "caml" ^ current_unit.ui_symbol in + name = prefix || + (let lp = String.length prefix in + String.length name >= 2 + lp + && String.sub name 0 lp = prefix + && name.[lp] = '_' + && name.[lp + 1] = '_') + +let read_unit_info filename = + let ic = open_in_bin filename in + try + let buffer = really_input_string ic (String.length cmx_magic_number) in + if buffer <> cmx_magic_number then begin + close_in ic; + raise(Error(Not_a_unit_info filename)) + end; + let ui = (input_value ic : unit_infos) in + let crc = Digest.input ic in + close_in ic; + (ui, crc) + with End_of_file | Failure _ -> + close_in ic; + raise(Error(Corrupted_unit_info(filename))) + +let read_library_info filename = + let ic = open_in_bin filename in + let buffer = really_input_string ic (String.length cmxa_magic_number) in + if buffer <> cmxa_magic_number then + raise(Error(Not_a_unit_info filename)); + let infos = (input_value ic : library_infos) in + close_in ic; + infos + + +(* Read and cache info on global identifiers *) + +let get_global_info global_ident = ( + let modname = Ident.name global_ident in + if modname = current_unit.ui_name then + Some current_unit + else begin + try + Hashtbl.find global_infos_table modname + with Not_found -> + let (infos, crc) = + if Env.is_imported_opaque modname then (None, None) + else begin + try + let filename = + Load_path.find_uncap (modname ^ ".cmx") in + let (ui, crc) = read_unit_info filename in + if ui.ui_name <> modname then + raise(Error(Illegal_renaming(modname, ui.ui_name, filename))); + (Some ui, Some crc) + with Not_found -> + let warn = Warnings.No_cmx_file modname in + Location.prerr_warning Location.none warn; + (None, None) + end + in + current_unit.ui_imports_cmx <- + (modname, crc) :: current_unit.ui_imports_cmx; + Hashtbl.add global_infos_table modname infos; + infos + end +) + +let cache_unit_info ui = + Hashtbl.add global_infos_table ui.ui_name (Some ui) + +(* Return the approximation of a global identifier *) + +let get_clambda_approx ui = + assert(not Config.flambda); + match ui.ui_export_info with + | Flambda _ -> assert false + | Clambda approx -> approx + +let toplevel_approx : + (string, Clambda.value_approximation) Hashtbl.t = Hashtbl.create 16 + +let record_global_approx_toplevel () = + Hashtbl.add toplevel_approx current_unit.ui_name + (get_clambda_approx current_unit) + +let global_approx id = + if Ident.is_predef id then Clambda.Value_unknown + else try Hashtbl.find toplevel_approx (Ident.name id) + with Not_found -> + match get_global_info id with + | None -> Clambda.Value_unknown + | Some ui -> get_clambda_approx ui + +(* Return the symbol used to refer to a global identifier *) + +let symbol_for_global id = + if Ident.is_predef id then + "caml_exn_" ^ Ident.name id + else begin + let unitname = Ident.name id in + match + try ignore (Hashtbl.find toplevel_approx unitname); None + with Not_found -> get_global_info id + with + | None -> make_symbol ~unitname:(Ident.name id) None + | Some ui -> make_symbol ~unitname:ui.ui_symbol None + end + +(* Register the approximation of the module being compiled *) + +let unit_for_global id = + let sym_label = Linkage_name.create (symbol_for_global id) in + Compilation_unit.create id sym_label + +let predefined_exception_compilation_unit = + Compilation_unit.create (Ident.create_persistent "__dummy__") + (Linkage_name.create "__dummy__") + +let is_predefined_exception sym = + Compilation_unit.equal + predefined_exception_compilation_unit + (Symbol.compilation_unit sym) + +let symbol_for_global' id = + let sym_label = Linkage_name.create (symbol_for_global id) in + if Ident.is_predef id then + Symbol.of_global_linkage predefined_exception_compilation_unit sym_label + else + Symbol.of_global_linkage (unit_for_global id) sym_label + +let set_global_approx approx = + assert(not Config.flambda); + current_unit.ui_export_info <- Clambda approx + +(* Exporting and importing cross module information *) + +let get_flambda_export_info ui = + assert(Config.flambda); + match ui.ui_export_info with + | Clambda _ -> assert false + | Flambda ei -> ei + +let set_export_info export_info = + assert(Config.flambda); + current_unit.ui_export_info <- Flambda export_info + +let approx_for_global comp_unit = + let id = Compilation_unit.get_persistent_ident comp_unit in + if (Compilation_unit.equal + predefined_exception_compilation_unit + comp_unit) + || Ident.is_predef id + || not (Ident.global id) + then invalid_arg (Format.asprintf "approx_for_global %a" Ident.print id); + let modname = Ident.name id in + match Hashtbl.find export_infos_table modname with + | otherwise -> Some otherwise + | exception Not_found -> + match get_global_info id with + | None -> None + | Some ui -> + let exported = get_flambda_export_info ui in + Hashtbl.add export_infos_table modname exported; + merged_environment := Export_info.merge !merged_environment exported; + Some exported + +let approx_env () = !merged_environment + +(* Record that a currying function or application function is needed *) + +let need_curry_fun n = + if not (List.mem n current_unit.ui_curry_fun) then + current_unit.ui_curry_fun <- n :: current_unit.ui_curry_fun + +let need_apply_fun n = + assert(n > 0); + if not (List.mem n current_unit.ui_apply_fun) then + current_unit.ui_apply_fun <- n :: current_unit.ui_apply_fun + +let need_send_fun n = + if not (List.mem n current_unit.ui_send_fun) then + current_unit.ui_send_fun <- n :: current_unit.ui_send_fun + +(* Write the description of the current unit *) + +let write_unit_info info filename = + let oc = open_out_bin filename in + output_string oc cmx_magic_number; + output_value oc info; + flush oc; + let crc = Digest.file filename in + Digest.output oc crc; + close_out oc + +let save_unit_info filename = + current_unit.ui_imports_cmi <- Env.imports(); + write_unit_info current_unit filename + +let current_unit () = + match Compilation_unit.get_current () with + | Some current_unit -> current_unit + | None -> Misc.fatal_error "Compilenv.current_unit" + +let current_unit_symbol () = + Symbol.of_global_linkage (current_unit ()) (current_unit_linkage_name ()) + +let const_label = ref 0 + +let new_const_symbol () = + incr const_label; + make_symbol (Some (Int.to_string !const_label)) + +let snapshot () = !structured_constants +let backtrack s = structured_constants := s + +let new_structured_constant cst ~shared = + let {strcst_shared; strcst_all} = !structured_constants in + if shared then + try + CstMap.find cst strcst_shared + with Not_found -> + let lbl = new_const_symbol() in + structured_constants := + { + strcst_shared = CstMap.add cst lbl strcst_shared; + strcst_all = (lbl, cst) :: strcst_all; + }; + lbl + else + let lbl = new_const_symbol() in + structured_constants := + { + strcst_shared; + strcst_all = (lbl, cst) :: strcst_all; + }; + lbl + +let add_exported_constant s = + Hashtbl.replace exported_constants s () + +let clear_structured_constants () = + structured_constants := structured_constants_empty + +let structured_constants () = + let provenance : Clambda.usymbol_provenance = + { original_idents = []; + module_path = + Path.Pident (Ident.create_persistent (current_unit_name ())); + } + in + List.map + (fun (symbol, definition) -> + { + Clambda.symbol; + exported = Hashtbl.mem exported_constants symbol; + definition; + provenance = Some provenance; + }) + (!structured_constants).strcst_all + +let closure_symbol fv = + let compilation_unit = Closure_id.get_compilation_unit fv in + let unitname = + Linkage_name.to_string (Compilation_unit.get_linkage_name compilation_unit) + in + let linkage_name = + concat_symbol unitname ((Closure_id.unique_name fv) ^ "_closure") + in + Symbol.of_global_linkage compilation_unit (Linkage_name.create linkage_name) + +let function_label fv = + let compilation_unit = Closure_id.get_compilation_unit fv in + let unitname = + Linkage_name.to_string + (Compilation_unit.get_linkage_name compilation_unit) + in + (concat_symbol unitname (Closure_id.unique_name fv)) + +let require_global global_ident = + if not (Ident.is_predef global_ident) then + ignore (get_global_info global_ident : Cmx_format.unit_infos option) + +(* Error report *) + +open Format + +let report_error ppf = function + | Not_a_unit_info filename -> + fprintf ppf "%a@ is not a compilation unit description." + Location.print_filename filename + | Corrupted_unit_info filename -> + fprintf ppf "Corrupted compilation unit description@ %a" + Location.print_filename filename + | Illegal_renaming(name, modname, filename) -> + fprintf ppf "%a@ contains the description for unit\ + @ %s when %s was expected" + Location.print_filename filename name modname + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) diff --git a/middle_end/compilenv.mli b/middle_end/compilenv.mli new file mode 100644 index 0000000000..569d51ea08 --- /dev/null +++ b/middle_end/compilenv.mli @@ -0,0 +1,153 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2010 Institut National de Recherche en Informatique et *) +(* en Automatique *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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. *) +(* *) +(**************************************************************************) + +(* Compilation environments for compilation units *) + +open Cmx_format + +(* CR-soon mshinwell: this is a bit ugly + mshinwell: deferred CR, this has been addressed in the export info + improvement feature. +*) +val imported_sets_of_closures_table + : Simple_value_approx.function_declarations option Set_of_closures_id.Tbl.t + (* flambda-only *) + +val reset: ?packname:string -> string -> unit + (* Reset the environment and record the name of the unit being + compiled (arg). Optional argument is [-for-pack] prefix. *) + +val unit_id_from_name: string -> Ident.t + (* flambda-only *) + +val current_unit_infos: unit -> unit_infos + (* Return the infos for the unit being compiled *) + +val current_unit_name: unit -> string + (* Return the name of the unit being compiled + clambda-only *) + +val current_unit_linkage_name: unit -> Linkage_name.t + (* Return the linkage_name of the unit being compiled. + flambda-only *) + +val current_unit: unit -> Compilation_unit.t + (* flambda-only *) + +val current_unit_symbol: unit -> Symbol.t + (* flambda-only *) + +val make_symbol: ?unitname:string -> string option -> string + (* [make_symbol ~unitname:u None] returns the asm symbol that + corresponds to the compilation unit [u] (default: the current unit). + [make_symbol ~unitname:u (Some id)] returns the asm symbol that + corresponds to symbol [id] in the compilation unit [u] + (or the current unit). *) + +val symbol_in_current_unit: string -> bool + (* Return true if the given asm symbol belongs to the + current compilation unit, false otherwise. *) + +val is_predefined_exception: Symbol.t -> bool + (* flambda-only *) + +val unit_for_global: Ident.t -> Compilation_unit.t + (* flambda-only *) + +val symbol_for_global: Ident.t -> string + (* Return the asm symbol that refers to the given global identifier + flambda-only *) +val symbol_for_global': Ident.t -> Symbol.t + (* flambda-only *) +val global_approx: Ident.t -> Clambda.value_approximation + (* Return the approximation for the given global identifier + clambda-only *) +val set_global_approx: Clambda.value_approximation -> unit + (* Record the approximation of the unit being compiled + clambda-only *) +val record_global_approx_toplevel: unit -> unit + (* Record the current approximation for the current toplevel phrase + clambda-only *) + +val set_export_info: Export_info.t -> unit + (* Record the information of the unit being compiled + flambda-only *) +val approx_env: unit -> Export_info.t + (* Returns all the information loaded from external compilation units + flambda-only *) +val approx_for_global: Compilation_unit.t -> Export_info.t option + (* Loads the exported information declaring the compilation_unit + flambda-only *) + +val need_curry_fun: int -> unit +val need_apply_fun: int -> unit +val need_send_fun: int -> unit + (* Record the need of a currying (resp. application, + message sending) function with the given arity *) + +val new_const_symbol : unit -> string +val closure_symbol : Closure_id.t -> Symbol.t + (* Symbol of a function if the function is + closed (statically allocated) + flambda-only *) +val function_label : Closure_id.t -> string + (* linkage name of the code of a function + flambda-only *) + +val new_structured_constant: + Clambda.ustructured_constant -> + shared:bool -> (* can be shared with another structurally equal constant *) + string +val structured_constants: + unit -> Clambda.preallocated_constant list +val clear_structured_constants: unit -> unit +val add_exported_constant: string -> unit + (* clambda-only *) +type structured_constants + (* clambda-only *) +val snapshot: unit -> structured_constants + (* clambda-only *) +val backtrack: structured_constants -> unit + (* clambda-only *) + +val read_unit_info: string -> unit_infos * Digest.t + (* Read infos and MD5 from a [.cmx] file. *) +val write_unit_info: unit_infos -> string -> unit + (* Save the given infos in the given file *) +val save_unit_info: string -> unit + (* Save the infos for the current unit in the given file *) +val cache_unit_info: unit_infos -> unit + (* Enter the given infos in the cache. The infos will be + honored by [symbol_for_global] and [global_approx] + without looking at the corresponding .cmx file. *) + +val require_global: Ident.t -> unit + (* Enforce a link dependency of the current compilation + unit to the required module *) + +val read_library_info: string -> library_infos + +type error = + Not_a_unit_info of string + | Corrupted_unit_info of string + | Illegal_renaming of string * string * string + +exception Error of error + +val report_error: Format.formatter -> error -> unit diff --git a/middle_end/convert_primitives.ml b/middle_end/convert_primitives.ml new file mode 100644 index 0000000000..17d17ea8af --- /dev/null +++ b/middle_end/convert_primitives.ml @@ -0,0 +1,153 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2017 OCamlPro SAS *) +(* Copyright 2017 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-4-9-30-40-41-42"] + +let convert_unsafety is_unsafe : Clambda_primitives.is_safe = + if is_unsafe then + Unsafe + else + Safe + +let convert (prim : Lambda.primitive) : Clambda_primitives.primitive = + match prim with + | Pmakeblock (tag, mutability, shape) -> + Pmakeblock (tag, mutability, shape) + | Pfield field -> Pfield field + | Pfield_computed -> Pfield_computed + | Psetfield (field, imm_or_pointer, init_or_assign) -> + Psetfield (field, imm_or_pointer, init_or_assign) + | Psetfield_computed (imm_or_pointer, init_or_assign) -> + Psetfield_computed (imm_or_pointer, init_or_assign) + | Pfloatfield field -> Pfloatfield field + | Psetfloatfield (field, init_or_assign) -> + Psetfloatfield (field, init_or_assign) + | Pduprecord (repr, size) -> Pduprecord (repr, size) + | Pccall prim -> Pccall prim + | Praise kind -> Praise kind + | Psequand -> Psequand + | Psequor -> Psequor + | Pnot -> Pnot + | Pnegint -> Pnegint + | Paddint -> Paddint + | Psubint -> Psubint + | Pmulint -> Pmulint + | Pdivint is_safe -> Pdivint is_safe + | Pmodint is_safe -> Pmodint is_safe + | Pandint -> Pandint + | Porint -> Porint + | Pxorint -> Pxorint + | Plslint -> Plslint + | Plsrint -> Plsrint + | Pasrint -> Pasrint + | Pintcomp comp -> Pintcomp comp + | Poffsetint offset -> Poffsetint offset + | Poffsetref offset -> Poffsetref offset + | Pintoffloat -> Pintoffloat + | Pfloatofint -> Pfloatofint + | Pnegfloat -> Pnegfloat + | Pabsfloat -> Pabsfloat + | Paddfloat -> Paddfloat + | Psubfloat -> Psubfloat + | Pmulfloat -> Pmulfloat + | Pdivfloat -> Pdivfloat + | Pfloatcomp comp -> Pfloatcomp comp + | Pstringlength -> Pstringlength + | Pstringrefu -> Pstringrefu + | Pstringrefs -> Pstringrefs + | Pbyteslength -> Pbyteslength + | Pbytesrefu -> Pbytesrefu + | Pbytessetu -> Pbytessetu + | Pbytesrefs -> Pbytesrefs + | Pbytessets -> Pbytessets + | Pmakearray (kind, mutability) -> Pmakearray (kind, mutability) + | Pduparray (kind, mutability) -> Pduparray (kind, mutability) + | Parraylength kind -> Parraylength kind + | Parrayrefu kind -> Parrayrefu kind + | Parraysetu kind -> Parraysetu kind + | Parrayrefs kind -> Parrayrefs kind + | Parraysets kind -> Parraysets kind + | Pisint -> Pisint + | Pisout -> Pisout + | Pcvtbint (src, dest) -> Pcvtbint (src, dest) + | Pnegbint bi -> Pnegbint bi + | Paddbint bi -> Paddbint bi + | Psubbint bi -> Psubbint bi + | Pmulbint bi -> Pmulbint bi + | Pbintofint bi -> Pbintofint bi + | Pintofbint bi -> Pintofbint bi + | Pandbint bi -> Pandbint bi + | Porbint bi -> Porbint bi + | Pxorbint bi -> Pxorbint bi + | Plslbint bi -> Plslbint bi + | Plsrbint bi -> Plsrbint bi + | Pasrbint bi -> Pasrbint bi + | Pbbswap bi -> Pbbswap bi + | Pdivbint { size; is_safe } -> Pdivbint { size; is_safe } + | Pmodbint { size; is_safe } -> Pmodbint { size; is_safe } + | Pbintcomp (bi, comp) -> Pbintcomp (bi, comp) + | Pbigarrayref (safe, dims, kind, layout) -> + Pbigarrayref (safe, dims, kind, layout) + | Pbigarrayset (safe, dims, kind, layout) -> + Pbigarrayset (safe, dims, kind, layout) + | Pstring_load_16 is_unsafe -> + Pstring_load (Sixteen, convert_unsafety is_unsafe) + | Pstring_load_32 is_unsafe -> + Pstring_load (Thirty_two, convert_unsafety is_unsafe) + | Pstring_load_64 is_unsafe -> + Pstring_load (Sixty_four, convert_unsafety is_unsafe) + | Pbytes_load_16 is_unsafe -> + Pbytes_load (Sixteen, convert_unsafety is_unsafe) + | Pbytes_load_32 is_unsafe -> + Pbytes_load (Thirty_two, convert_unsafety is_unsafe) + | Pbytes_load_64 is_unsafe -> + Pbytes_load (Sixty_four, convert_unsafety is_unsafe) + | Pbytes_set_16 is_unsafe -> + Pbytes_set (Sixteen, convert_unsafety is_unsafe) + | Pbytes_set_32 is_unsafe -> + Pbytes_set (Thirty_two, convert_unsafety is_unsafe) + | Pbytes_set_64 is_unsafe -> + Pbytes_set (Sixty_four, convert_unsafety is_unsafe) + | Pbigstring_load_16 is_unsafe -> + Pbigstring_load (Sixteen, convert_unsafety is_unsafe) + | Pbigstring_load_32 is_unsafe -> + Pbigstring_load (Thirty_two, convert_unsafety is_unsafe) + | Pbigstring_load_64 is_unsafe -> + Pbigstring_load (Sixty_four, convert_unsafety is_unsafe) + | Pbigstring_set_16 is_unsafe -> + Pbigstring_set (Sixteen, convert_unsafety is_unsafe) + | Pbigstring_set_32 is_unsafe -> + Pbigstring_set (Thirty_two, convert_unsafety is_unsafe) + | Pbigstring_set_64 is_unsafe -> + Pbigstring_set (Sixty_four, convert_unsafety is_unsafe) + | Pbigarraydim dim -> Pbigarraydim dim + | Pbswap16 -> Pbswap16 + | Pint_as_pointer -> Pint_as_pointer + | Popaque -> Popaque + + | Pbytes_to_string + | Pbytes_of_string + | Pctconst _ + | Pignore + | Prevapply + | Pdirapply + | Pidentity + | Pgetglobal _ + | Psetglobal _ + -> + Misc.fatal_errorf "lambda primitive %a can't be converted to \ + clambda primitive" + Printlambda.primitive prim diff --git a/middle_end/convert_primitives.mli b/middle_end/convert_primitives.mli new file mode 100644 index 0000000000..8c3691268a --- /dev/null +++ b/middle_end/convert_primitives.mli @@ -0,0 +1,17 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2017 OCamlPro SAS *) +(* Copyright 2017 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. *) +(* *) +(**************************************************************************) + +val convert : Lambda.primitive -> Clambda_primitives.primitive diff --git a/middle_end/debuginfo.ml b/middle_end/debuginfo.ml deleted file mode 100644 index 7a33902222..0000000000 --- a/middle_end/debuginfo.ml +++ /dev/null @@ -1,145 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* 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. *) -(* *) -(**************************************************************************) - -open! Int_replace_polymorphic_compare -open Lexing -open Location - -type item = { - dinfo_file: string; - dinfo_line: int; - dinfo_char_start: int; - dinfo_char_end: int; - dinfo_start_bol: int; - dinfo_end_bol: int; - dinfo_end_line: int; -} - -type t = item list - -let none = [] - -let is_none = function - | [] -> true - | _ :: _ -> false - -let to_string dbg = - match dbg with - | [] -> "" - | ds -> - let items = - List.map - (fun d -> - Printf.sprintf "%s:%d,%d-%d" - d.dinfo_file d.dinfo_line d.dinfo_char_start d.dinfo_char_end) - ds - in - "{" ^ String.concat ";" items ^ "}" - -let item_from_location loc = - let valid_endpos = - String.equal loc.loc_end.pos_fname loc.loc_start.pos_fname in - { dinfo_file = loc.loc_start.pos_fname; - dinfo_line = loc.loc_start.pos_lnum; - dinfo_char_start = loc.loc_start.pos_cnum - loc.loc_start.pos_bol; - dinfo_char_end = - if valid_endpos - then loc.loc_end.pos_cnum - loc.loc_start.pos_bol - else loc.loc_start.pos_cnum - loc.loc_start.pos_bol; - dinfo_start_bol = loc.loc_start.pos_bol; - dinfo_end_bol = - if valid_endpos then loc.loc_end.pos_bol - else loc.loc_start.pos_bol; - dinfo_end_line = - if valid_endpos then loc.loc_end.pos_lnum - else loc.loc_start.pos_lnum; - } - -let from_location loc = - if loc == Location.none then [] else [item_from_location loc] - -let to_location = function - | [] -> Location.none - | d :: _ -> - let loc_start = - { pos_fname = d.dinfo_file; - pos_lnum = d.dinfo_line; - pos_bol = d.dinfo_start_bol; - pos_cnum = d.dinfo_start_bol + d.dinfo_char_start; - } in - let loc_end = - { pos_fname = d.dinfo_file; - pos_lnum = d.dinfo_end_line; - pos_bol = d.dinfo_end_bol; - pos_cnum = d.dinfo_start_bol + d.dinfo_char_end; - } in - { loc_ghost = false; loc_start; loc_end; } - -let inline loc t = - if loc == Location.none then t - else (item_from_location loc) :: t - -let concat dbg1 dbg2 = - dbg1 @ dbg2 - -(* CR-someday afrisch: FWIW, the current compare function does not seem very - good, since it reverses the two lists. I don't know how long the lists are, - nor if the specific currently implemented ordering is useful in other - contexts, but if one wants to use Map, a more efficient comparison should - be considered. *) -let compare dbg1 dbg2 = - let rec loop ds1 ds2 = - match ds1, ds2 with - | [], [] -> 0 - | _ :: _, [] -> 1 - | [], _ :: _ -> -1 - | d1 :: ds1, d2 :: ds2 -> - let c = String.compare d1.dinfo_file d2.dinfo_file in - if c <> 0 then c else - let c = compare d1.dinfo_line d2.dinfo_line in - if c <> 0 then c else - let c = compare d1.dinfo_char_end d2.dinfo_char_end in - if c <> 0 then c else - let c = compare d1.dinfo_char_start d2.dinfo_char_start in - if c <> 0 then c else - let c = compare d1.dinfo_start_bol d2.dinfo_start_bol in - if c <> 0 then c else - let c = compare d1.dinfo_end_bol d2.dinfo_end_bol in - if c <> 0 then c else - let c = compare d1.dinfo_end_line d2.dinfo_end_line in - if c <> 0 then c else - loop ds1 ds2 - in - loop (List.rev dbg1) (List.rev dbg2) - -let hash t = - List.fold_left (fun hash item -> Hashtbl.hash (hash, item)) 0 t - -let rec print_compact ppf t = - let print_item item = - Format.fprintf ppf "%a:%i" - Location.print_filename item.dinfo_file - item.dinfo_line; - if item.dinfo_char_start >= 0 then begin - Format.fprintf ppf ",%i--%i" item.dinfo_char_start item.dinfo_char_end - end - in - match t with - | [] -> () - | [item] -> print_item item - | item::t -> - print_item item; - Format.fprintf ppf ";"; - print_compact ppf t diff --git a/middle_end/debuginfo.mli b/middle_end/debuginfo.mli deleted file mode 100644 index 4dc5e59906..0000000000 --- a/middle_end/debuginfo.mli +++ /dev/null @@ -1,46 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) -(* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* 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. *) -(* *) -(**************************************************************************) - -type item = private { - dinfo_file: string; - dinfo_line: int; - dinfo_char_start: int; - dinfo_char_end: int; - dinfo_start_bol: int; - dinfo_end_bol: int; - dinfo_end_line: int; -} - -type t = item list - -val none : t - -val is_none : t -> bool - -val to_string : t -> string - -val from_location : Location.t -> t - -val to_location : t -> Location.t - -val concat: t -> t -> t - -val inline: Location.t -> t -> t - -val compare : t -> t -> int - -val hash : t -> int - -val print_compact : Format.formatter -> t -> unit diff --git a/middle_end/effect_analysis.ml b/middle_end/effect_analysis.ml deleted file mode 100644 index d0cbd44180..0000000000 --- a/middle_end/effect_analysis.ml +++ /dev/null @@ -1,60 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -let no_effects_prim (prim : Clambda_primitives.primitive) = - match Semantics_of_primitives.for_primitive prim with - | (No_effects | Only_generative_effects), (No_coeffects | Has_coeffects) -> - true - | _ -> false - -let rec no_effects (flam : Flambda.t) = - match flam with - | Var _ -> true - | Let { defining_expr; body; _ } -> - no_effects_named defining_expr && no_effects body - | Let_mutable { body } -> no_effects body - | Let_rec (defs, body) -> - no_effects body - && List.for_all (fun (_, def) -> no_effects_named def) defs - | If_then_else (_, ifso, ifnot) -> no_effects ifso && no_effects ifnot - | Switch (_, sw) -> - let aux (_, flam) = no_effects flam in - List.for_all aux sw.blocks - && List.for_all aux sw.consts - && Misc.Stdlib.Option.value_default no_effects sw.failaction - ~default:true - | String_switch (_, sw, def) -> - List.for_all (fun (_, lam) -> no_effects lam) sw - && Misc.Stdlib.Option.value_default no_effects def - ~default:true - | Static_catch (_, _, body, _) | Try_with (body, _, _) -> - (* If there is a [raise] in [body], the whole [Try_with] may have an - effect, so there is no need to test the handler. *) - no_effects body - | While _ | For _ | Apply _ | Send _ | Assign _ | Static_raise _ -> false - | Proved_unreachable -> true - -and no_effects_named (named : Flambda.named) = - match named with - | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ - | Read_symbol_field _ - | Set_of_closures _ | Project_closure _ | Project_var _ - | Move_within_set_of_closures _ -> true - | Prim (prim, _, _) -> no_effects_prim prim - | Expr flam -> no_effects flam diff --git a/middle_end/effect_analysis.mli b/middle_end/effect_analysis.mli deleted file mode 100644 index b025bf0f87..0000000000 --- a/middle_end/effect_analysis.mli +++ /dev/null @@ -1,27 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -(** Simple side effect analysis. *) - -(* CR-someday pchambart: Replace by call to [Purity] module. - mshinwell: Where is the [Purity] module? *) -(** Conservative approximation as to whether a given Flambda expression may - have any side effects. *) -val no_effects : Flambda.t -> bool - -val no_effects_named : Flambda.named -> bool diff --git a/middle_end/extract_projections.ml b/middle_end/extract_projections.ml deleted file mode 100644 index 33cd473ecd..0000000000 --- a/middle_end/extract_projections.ml +++ /dev/null @@ -1,190 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -module A = Simple_value_approx -module E = Inline_and_simplify_aux.Env - -(* CR-soon pchambart: should we restrict only to cases - when the field is aliased to a variable outside - of the closure (i.e. when we can certainly remove - the allocation of the block) ? - Note that this may prevent cases with imbricated - closures from benefiting from this transformations. - mshinwell: What word was "imbricated" supposed to be? - (The code this referred to has been deleted, but the same thing is - probably still happening). -*) - -let known_valid_projections ~env ~projections ~which_variables = - Projection.Set.filter (fun projection -> - let from = Projection.projecting_from projection in - let outer_var = - match Variable.Map.find from which_variables with - | exception Not_found -> assert false - | (outer_var : Flambda.specialised_to) -> - Freshening.apply_variable (E.freshening env) outer_var.var - in - let approx = E.find_exn env outer_var in - match projection with - | Project_var project_var -> - begin match A.check_approx_for_closure approx with - | Ok (_value_closure, _approx_var, _approx_sym, - value_set_of_closures) -> - Var_within_closure.Map.mem project_var.var - value_set_of_closures.bound_vars - | Wrong -> false - end - | Project_closure project_closure -> - begin match A.strict_check_approx_for_set_of_closures approx with - | Ok (_var, value_set_of_closures) -> - Variable.Set.mem (Closure_id.unwrap project_closure.closure_id) - (Variable.Map.keys value_set_of_closures.function_decls.funs) - | Wrong -> false - end - | Move_within_set_of_closures move -> - begin match A.check_approx_for_closure approx with - | Ok (value_closure, _approx_var, _approx_sym, - _value_set_of_closures) -> - (* We could check that [move.move_to] is in [value_set_of_closures], - but this is unnecessary, since [Closure_id]s are unique. *) - Closure_id.equal value_closure.closure_id move.start_from - | Wrong -> false - end - | Field (field_index, _) -> - match A.check_approx_for_block approx with - | Wrong -> false - | Ok (_tag, fields) -> - field_index >= 0 && field_index < Array.length fields) - projections - -let rec analyse_expr ~which_variables expr = - let projections = ref Projection.Set.empty in - let used_which_variables = ref Variable.Set.empty in - let check_free_variable var = - if Variable.Map.mem var which_variables then begin - used_which_variables := Variable.Set.add var !used_which_variables - end - in - let for_expr (expr : Flambda.expr) = - match expr with - | Var var - | Let_mutable { initial_value = var } -> - check_free_variable var - (* CR-soon mshinwell: We don't handle [Apply] for the moment to - avoid disabling unboxing optimizations whenever we see a recursive - call. We should improve this analysis. Leo says this can be - done by a similar thing to the unused argument analysis. *) - | Apply _ -> () - | Send { meth; obj; args; _ } -> - check_free_variable meth; - check_free_variable obj; - List.iter check_free_variable args - | Assign { new_value; _ } -> - check_free_variable new_value - | If_then_else (var, _, _) - | Switch (var, _) - | String_switch (var, _, _) -> - check_free_variable var - | Static_raise (_, args) -> - List.iter check_free_variable args - | For { from_value; to_value; _ } -> - check_free_variable from_value; - check_free_variable to_value - | Let _ | Let_rec _ | Static_catch _ | While _ | Try_with _ - | Proved_unreachable -> () - in - let for_named (named : Flambda.named) = - match named with - | Project_var project_var - when Variable.Map.mem project_var.closure which_variables -> - projections := - Projection.Set.add (Project_var project_var) !projections - | Project_closure project_closure - when Variable.Map.mem project_closure.set_of_closures - which_variables -> - projections := - Projection.Set.add (Project_closure project_closure) !projections - | Move_within_set_of_closures move - when Variable.Map.mem move.closure which_variables -> - projections := - Projection.Set.add (Move_within_set_of_closures move) !projections - | Prim (Pfield field_index, [var], _dbg) - when Variable.Map.mem var which_variables -> - projections := - Projection.Set.add (Field (field_index, var)) !projections - | Set_of_closures set_of_closures -> - let aliasing_free_vars = - Variable.Map.filter (fun _ (spec_to : Flambda.specialised_to) -> - Variable.Map.mem spec_to.var which_variables) - set_of_closures.free_vars - in - let aliasing_specialised_args = - Variable.Map.filter (fun _ (spec_to : Flambda.specialised_to) -> - Variable.Map.mem spec_to.var which_variables) - set_of_closures.specialised_args - in - let aliasing_vars = - Variable.Map.disjoint_union - aliasing_free_vars aliasing_specialised_args - in - if not (Variable.Map.is_empty aliasing_vars) then begin - Variable.Map.iter (fun _ (fun_decl : Flambda.function_declaration) -> - (* We ignore projections from within nested sets of closures. *) - let _, used = - analyse_expr fun_decl.body ~which_variables:aliasing_vars - in - Variable.Set.iter (fun var -> - match Variable.Map.find var aliasing_vars with - | exception Not_found -> assert false - | spec_to -> check_free_variable spec_to.var) - used) - set_of_closures.function_decls.funs - end - | Prim (_, vars, _) -> - List.iter check_free_variable vars - | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ - | Read_symbol_field _ | Project_var _ | Project_closure _ - | Move_within_set_of_closures _ - | Expr _ -> () - in - Flambda_iterators.iter_toplevel for_expr for_named expr; - let projections = !projections in - let used_which_variables = !used_which_variables in - projections, used_which_variables - -let from_function_decl ~env ~which_variables - ~(function_decl : Flambda.function_declaration) = - let projections, used_which_variables = - analyse_expr ~which_variables function_decl.body - in - (* We must use approximation information to determine which projections - are actually valid in the current environment, other we might lift - expressions too far. *) - let projections = - known_valid_projections ~env ~projections ~which_variables - in - (* Don't extract projections whose [projecting_from] variable is also - used boxed. We could in the future consider being more sophisticated - about this based on the uses in the body, but given we are not doing - that yet, it seems safest in performance terms not to (e.g.) unbox a - specialised argument whose boxed version is used. *) - Projection.Set.filter (fun projection -> - let projecting_from = Projection.projecting_from projection in - not (Variable.Set.mem projecting_from used_which_variables)) - projections diff --git a/middle_end/extract_projections.mli b/middle_end/extract_projections.mli deleted file mode 100644 index 47456bda0a..0000000000 --- a/middle_end/extract_projections.mli +++ /dev/null @@ -1,33 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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. *) -(* *) -(**************************************************************************) - -(** Identify projections from variables used in function bodies (free - variables or specialised args, for example, according to [which_variables] - below). Projections from variables that are also used boxed are not - returned. *) - -(** [which_variables] maps (existing) inner variables to (existing) outer - variables in the manner of [free_vars] and [specialised_args] in - [Flambda.set_of_closures]. - - The returned projections are [projecting_from] (cf. projection.mli) - the "existing inner vars". -*) -val from_function_decl - : env:Inline_and_simplify_aux.Env.t - -> which_variables:Flambda.specialised_to Variable.Map.t - -> function_decl:Flambda.function_declaration - -> Projection.Set.t diff --git a/middle_end/find_recursive_functions.ml b/middle_end/find_recursive_functions.ml deleted file mode 100644 index e69433039f..0000000000 --- a/middle_end/find_recursive_functions.ml +++ /dev/null @@ -1,34 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -let in_function_declarations (function_decls : Flambda.function_declarations) - ~backend = - let module VCC = Strongly_connected_components.Make (Variable) in - let directed_graph = - let module B = (val backend : Backend_intf.S) in - Flambda_utils.fun_vars_referenced_in_decls function_decls - ~closure_symbol:B.closure_symbol - in - let connected_components = - VCC.connected_components_sorted_from_roots_to_leaf directed_graph - in - Array.fold_left (fun rec_fun -> function - | VCC.No_loop _ -> rec_fun - | VCC.Has_loop elts -> List.fold_right Variable.Set.add elts rec_fun) - Variable.Set.empty connected_components diff --git a/middle_end/find_recursive_functions.mli b/middle_end/find_recursive_functions.mli deleted file mode 100644 index 3c2dd5b1fb..0000000000 --- a/middle_end/find_recursive_functions.mli +++ /dev/null @@ -1,37 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -(** "Recursive functions" are those functions [f] that might call either: - - themselves, or - - another function that in turn might call [f]. - - For example in the following simultaneous definition of [f] [g] and [h], - [f] and [g] are recursive functions, but not [h]: - [let rec f x = g x - and g x = f x - and h x = g x] -*) - -(** Determine the recursive functions, if any, bound by the given set of - function declarations. - This is only intended to be used by [Flambda.create_function_declarations]. -*) -val in_function_declarations - : Flambda.function_declarations - -> backend:(module Backend_intf.S) - -> Variable.Set.t diff --git a/middle_end/flambda.ml b/middle_end/flambda.ml deleted file mode 100644 index 243e2e3f9c..0000000000 --- a/middle_end/flambda.ml +++ /dev/null @@ -1,1272 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -type call_kind = - | Indirect - | Direct of Closure_id.t - -type const = - | Int of int - | Char of char - | Const_pointer of int - -type apply = { - func : Variable.t; - args : Variable.t list; - kind : call_kind; - dbg : Debuginfo.t; - inline : Lambda.inline_attribute; - specialise : Lambda.specialise_attribute; -} - -type assign = { - being_assigned : Mutable_variable.t; - new_value : Variable.t; -} - -type send = { - kind : Lambda.meth_kind; - meth : Variable.t; - obj : Variable.t; - args : Variable.t list; - dbg : Debuginfo.t; -} - -type project_closure = Projection.project_closure -type move_within_set_of_closures = Projection.move_within_set_of_closures -type project_var = Projection.project_var - -type specialised_to = { - var : Variable.t; - projection : Projection.t option; -} - -type t = - | Var of Variable.t - | Let of let_expr - | Let_mutable of let_mutable - | Let_rec of (Variable.t * named) list * t - | Apply of apply - | Send of send - | Assign of assign - | If_then_else of Variable.t * t * t - | Switch of Variable.t * switch - | String_switch of Variable.t * (string * t) list * t option - | Static_raise of Static_exception.t * Variable.t list - | Static_catch of Static_exception.t * Variable.t list * t * t - | Try_with of t * Variable.t * t - | While of t * t - | For of for_loop - | Proved_unreachable - -and named = - | Symbol of Symbol.t - | Const of const - | Allocated_const of Allocated_const.t - | Read_mutable of Mutable_variable.t - | Read_symbol_field of Symbol.t * int - | Set_of_closures of set_of_closures - | Project_closure of project_closure - | Move_within_set_of_closures of move_within_set_of_closures - | Project_var of project_var - | Prim of Clambda_primitives.primitive * Variable.t list * Debuginfo.t - | Expr of t - -and let_expr = { - var : Variable.t; - defining_expr : named; - body : t; - free_vars_of_defining_expr : Variable.Set.t; - free_vars_of_body : Variable.Set.t; -} - -and let_mutable = { - var : Mutable_variable.t; - initial_value : Variable.t; - contents_kind : Lambda.value_kind; - body : t; -} - -and set_of_closures = { - function_decls : function_declarations; - free_vars : specialised_to Variable.Map.t; - specialised_args : specialised_to Variable.Map.t; - direct_call_surrogates : Variable.t Variable.Map.t; -} - -and function_declarations = { - is_classic_mode : bool; - set_of_closures_id : Set_of_closures_id.t; - set_of_closures_origin : Set_of_closures_origin.t; - funs : function_declaration Variable.Map.t; -} - -and function_declaration = { - closure_origin: Closure_origin.t; - params : Parameter.t list; - body : t; - free_variables : Variable.Set.t; - free_symbols : Symbol.Set.t; - stub : bool; - dbg : Debuginfo.t; - inline : Lambda.inline_attribute; - specialise : Lambda.specialise_attribute; - is_a_functor : bool; -} - -and switch = { - numconsts : Numbers.Int.Set.t; - consts : (int * t) list; - numblocks : Numbers.Int.Set.t; - blocks : (int * t) list; - failaction : t option; -} - -and for_loop = { - bound_var : Variable.t; - from_value : Variable.t; - to_value : Variable.t; - direction : Asttypes.direction_flag; - body : t -} - -and constant_defining_value = - | Allocated_const of Allocated_const.t - | Block of Tag.t * constant_defining_value_block_field list - | Set_of_closures of set_of_closures (* [free_vars] must be empty *) - | Project_closure of Symbol.t * Closure_id.t - -and constant_defining_value_block_field = - | Symbol of Symbol.t - | Const of const - -type expr = t - -type program_body = - | Let_symbol of Symbol.t * constant_defining_value * program_body - | Let_rec_symbol of (Symbol.t * constant_defining_value) list * program_body - | Initialize_symbol of Symbol.t * Tag.t * t list * program_body - | Effect of t * program_body - | End of Symbol.t - -type program = { - imported_symbols : Symbol.Set.t; - program_body : program_body; -} - -let fprintf = Format.fprintf -module Int = Numbers.Int - -let print_specialised_to ppf (spec_to : specialised_to) = - match spec_to.projection with - | None -> fprintf ppf "%a" Variable.print spec_to.var - | Some projection -> - fprintf ppf "%a(= %a)" - Variable.print spec_to.var - Projection.print projection - -(* CR-soon mshinwell: delete uses of old names *) -let print_project_var = Projection.print_project_var -let print_move_within_set_of_closures = - Projection.print_move_within_set_of_closures -let print_project_closure = Projection.print_project_closure - -(** CR-someday lwhite: use better name than this *) -let rec lam ppf (flam : t) = - match flam with - | Var (id) -> - Variable.print ppf id - | Apply({func; args; kind; inline; dbg}) -> - let direct ppf () = - match kind with - | Indirect -> () - | Direct closure_id -> fprintf ppf "*[%a]" Closure_id.print closure_id - in - let inline ppf () = - match inline with - | Always_inline -> fprintf ppf "" - | Never_inline -> fprintf ppf "" - | Unroll i -> fprintf ppf "" i - | Default_inline -> () - in - fprintf ppf "@[<2>(apply%a%a<%s>@ %a%a)@]" direct () inline () - (Debuginfo.to_string dbg) - Variable.print func Variable.print_list args - | Assign { being_assigned; new_value; } -> - fprintf ppf "@[<2>(assign@ %a@ %a)@]" - Mutable_variable.print being_assigned - Variable.print new_value - | Send { kind; meth; obj; args; dbg = _; } -> - let print_args ppf args = - List.iter (fun l -> fprintf ppf "@ %a" Variable.print l) args - in - let kind = - match kind with - | Self -> "self" - | Public -> "public" - | Cached -> "cached" - in - fprintf ppf "@[<2>(send%s@ %a@ %a%a)@]" kind - Variable.print obj Variable.print meth - print_args args - | Proved_unreachable -> - fprintf ppf "unreachable" - | Let { var = id; defining_expr = arg; body; _ } -> - let rec letbody (ul : t) = - match ul with - | Let { var = id; defining_expr = arg; body; _ } -> - fprintf ppf "@ @[<2>%a@ %a@]" Variable.print id print_named arg; - letbody body - | _ -> ul - in - fprintf ppf "@[<2>(let@ @[(@[<2>%a@ %a@]" - Variable.print id print_named arg; - let expr = letbody body in - fprintf ppf ")@]@ %a)@]" lam expr - | Let_mutable { var = mut_var; initial_value = var; body; contents_kind } -> - let print_kind ppf (kind : Lambda.value_kind) = - match kind with - | Pgenval -> () - | _ -> Format.fprintf ppf " %a" Printlambda.value_kind kind - in - fprintf ppf "@[<2>(let_mutable%a@ @[<2>%a@ %a@]@ %a)@]" - print_kind contents_kind - Mutable_variable.print mut_var - Variable.print var - lam body - | Let_rec(id_arg_list, body) -> - let bindings ppf id_arg_list = - let spc = ref false in - List.iter - (fun (id, l) -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[<2>%a@ %a@]" Variable.print id print_named l) - id_arg_list in - fprintf ppf - "@[<2>(letrec@ (@[%a@])@ %a)@]" bindings id_arg_list lam body - | Switch(larg, sw) -> - let switch ppf (sw : switch) = - let spc = ref false in - List.iter - (fun (n, l) -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[case int %i:@ %a@]" n lam l) - sw.consts; - List.iter - (fun (n, l) -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[case tag %i:@ %a@]" n lam l) - sw.blocks ; - begin match sw.failaction with - | None -> () - | Some l -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[default:@ %a@]" lam l - end in - fprintf ppf - "@[<1>(%s(%i,%i) %a@ @[%a@])@]" - (match sw.failaction with None -> "switch*" | _ -> "switch") - (Int.Set.cardinal sw.numconsts) - (Int.Set.cardinal sw.numblocks) - Variable.print larg switch sw - | String_switch(arg, cases, default) -> - let switch ppf cases = - let spc = ref false in - List.iter - (fun (s, l) -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[case \"%s\":@ %a@]" (String.escaped s) lam l) - cases; - begin match default with - | Some default -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[default:@ %a@]" lam default - | None -> () - end in - fprintf ppf - "@[<1>(stringswitch %a@ @[%a@])@]" Variable.print arg switch cases - | Static_raise (i, ls) -> - let lams ppf largs = - List.iter (fun l -> fprintf ppf "@ %a" Variable.print l) largs in - fprintf ppf "@[<2>(exit@ %a%a)@]" Static_exception.print i lams ls; - | Static_catch(i, vars, lbody, lhandler) -> - fprintf ppf "@[<2>(catch@ %a@;<1 -1>with (%a%a)@ %a)@]" - lam lbody Static_exception.print i - (fun ppf vars -> match vars with - | [] -> () - | _ -> - List.iter - (fun x -> fprintf ppf " %a" Variable.print x) - vars) - vars - lam lhandler - | Try_with(lbody, param, lhandler) -> - fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]" - lam lbody Variable.print param lam lhandler - | If_then_else(lcond, lif, lelse) -> - fprintf ppf "@[<2>(if@ %a@ then begin@ %a@ end else begin@ %a@ end)@]" - Variable.print lcond - lam lif lam lelse - | While(lcond, lbody) -> - fprintf ppf "@[<2>(while@ %a@ %a)@]" lam lcond lam lbody - | For { bound_var; from_value; to_value; direction; body; } -> - fprintf ppf "@[<2>(for %a@ %a@ %s@ %a@ %a)@]" - Variable.print bound_var Variable.print from_value - (match direction with - Asttypes.Upto -> "to" | Asttypes.Downto -> "downto") - Variable.print to_value lam body -and print_named ppf (named : named) = - match named with - | Symbol (symbol) -> Symbol.print ppf symbol - | Const (cst) -> fprintf ppf "Const(%a)" print_const cst - | Allocated_const (cst) -> fprintf ppf "Aconst(%a)" Allocated_const.print cst - | Read_mutable mut_var -> - fprintf ppf "Read_mut(%a)" Mutable_variable.print mut_var - | Read_symbol_field (symbol, field) -> - fprintf ppf "%a.(%d)" Symbol.print symbol field - | Project_closure (project_closure) -> - print_project_closure ppf project_closure - | Project_var (project_var) -> print_project_var ppf project_var - | Move_within_set_of_closures (move_within_set_of_closures) -> - print_move_within_set_of_closures ppf move_within_set_of_closures - | Set_of_closures (set_of_closures) -> - print_set_of_closures ppf set_of_closures - | Prim(prim, args, dbg) -> - fprintf ppf "@[<2>(%a<%s>%a)@]" Printclambda_primitives.primitive prim - (Debuginfo.to_string dbg) - Variable.print_list args - | Expr expr -> - fprintf ppf "*%a" lam expr - (* lam ppf expr *) - -and print_function_declaration ppf var (f : function_declaration) = - let param ppf p = - Variable.print ppf (Parameter.var p) - in - let params ppf = - List.iter (fprintf ppf "@ %a" param) in - let stub = - if f.stub then - " *stub*" - else - "" - in - let is_a_functor = - if f.is_a_functor then - " *functor*" - else - "" - in - let inline = - match f.inline with - | Always_inline -> " *inline*" - | Never_inline -> " *never_inline*" - | Unroll _ -> " *unroll*" - | Default_inline -> "" - in - let specialise = - match f.specialise with - | Always_specialise -> " *specialise*" - | Never_specialise -> " *never_specialise*" - | Default_specialise -> "" - in - fprintf ppf "@[<2>(%a%s%s%s%s@ =@ fun@[<2>%a@] ->@ @[<2>%a@])@]@ " - Variable.print var stub is_a_functor inline specialise - params f.params lam f.body - -and print_set_of_closures ppf (set_of_closures : set_of_closures) = - match set_of_closures with - | { function_decls; free_vars; specialised_args} -> - let funs ppf = - Variable.Map.iter (print_function_declaration ppf) - in - let vars ppf = - Variable.Map.iter (fun id v -> - fprintf ppf "@ %a -rename-> %a" - Variable.print id print_specialised_to v) - in - let spec ppf spec_args = - if not (Variable.Map.is_empty spec_args) - then begin - fprintf ppf "@ "; - Variable.Map.iter (fun id (spec_to : specialised_to) -> - fprintf ppf "@ %a := %a" - Variable.print id print_specialised_to spec_to) - spec_args - end - in - fprintf ppf "@[<2>(set_of_closures id=%a@ %a@ @[<2>free_vars={%a@ }@]@ \ - @[<2>specialised_args={%a})@]@ \ - @[<2>direct_call_surrogates=%a@]@ \ - @[<2>set_of_closures_origin=%a@]@]]" - Set_of_closures_id.print function_decls.set_of_closures_id - funs function_decls.funs - vars free_vars - spec specialised_args - (Variable.Map.print Variable.print) - set_of_closures.direct_call_surrogates - Set_of_closures_origin.print function_decls.set_of_closures_origin - -and print_const ppf (c : const) = - match c with - | Int n -> fprintf ppf "%i" n - | Char c -> fprintf ppf "%C" c - | Const_pointer n -> fprintf ppf "%ia" n - -let print_function_declarations ppf (fd : function_declarations) = - let funs ppf = - Variable.Map.iter (print_function_declaration ppf) - in - fprintf ppf "@[<2>(%a)(origin = %a)@]" funs fd.funs - Set_of_closures_origin.print fd.set_of_closures_origin - -let print ppf flam = - fprintf ppf "%a@." lam flam - -let print_function_declaration ppf (var, decl) = - print_function_declaration ppf var decl - -let print_constant_defining_value ppf (const : constant_defining_value) = - match const with - | Allocated_const const -> - fprintf ppf "(Allocated_const %a)" Allocated_const.print const - | Block (tag, []) -> fprintf ppf "(Atom (tag %d))" (Tag.to_int tag) - | Block (tag, fields) -> - let print_field ppf (field : constant_defining_value_block_field) = - match field with - | Symbol symbol -> Symbol.print ppf symbol - | Const const -> print_const ppf const - in - let print_fields ppf = - List.iter (fprintf ppf "@ %a" print_field) - in - fprintf ppf "(Block (tag %d, %a))" (Tag.to_int tag) - print_fields fields - | Set_of_closures set_of_closures -> - fprintf ppf "@[<2>(Set_of_closures (@ %a))@]" print_set_of_closures - set_of_closures - | Project_closure (set_of_closures, closure_id) -> - fprintf ppf "(Project_closure (%a, %a))" Symbol.print set_of_closures - Closure_id.print closure_id - -let rec print_program_body ppf (program : program_body) = - let symbol_binding ppf (symbol, constant_defining_value) = - fprintf ppf "@[<2>(%a@ %a)@]" - Symbol.print symbol - print_constant_defining_value constant_defining_value - in - match program with - | Let_symbol (symbol, constant_defining_value, body) -> - let rec extract acc (ul : program_body) = - match ul with - | Let_symbol (symbol, constant_defining_value, body) -> - extract ((symbol, constant_defining_value) :: acc) body - | _ -> - List.rev acc, ul - in - let defs, program = extract [symbol, constant_defining_value] body in - fprintf ppf - "@[<2>let_symbol@ @[%a@]@]@." - (Format.pp_print_list symbol_binding) defs; - print_program_body ppf program - | Let_rec_symbol (defs, program) -> - fprintf ppf - "@[<2>let_rec_symbol@ @[%a@]@]@." - (Format.pp_print_list symbol_binding) defs; - print_program_body ppf program - | Initialize_symbol (symbol, tag, fields, program) -> - fprintf ppf "@[<2>initialize_symbol@ (@[<2>%a@ %a@ %a@])@]@." - Symbol.print symbol - Tag.print tag - (Format.pp_print_list lam) fields; - print_program_body ppf program - | Effect (expr, program) -> - fprintf ppf "@[<2>effect@ %a@]@." - lam expr; - print_program_body ppf program; - | End root -> fprintf ppf "End %a" Symbol.print root - -let print_program ppf program = - Symbol.Set.iter (fun symbol -> - fprintf ppf "@[import_symbol@ %a@]@." Symbol.print symbol) - program.imported_symbols; - print_program_body ppf program.program_body - -let rec variables_usage ?ignore_uses_as_callee ?ignore_uses_as_argument - ?ignore_uses_in_project_var ~all_used_variables tree = - match tree with - | Var var -> Variable.Set.singleton var - | _ -> - let free = ref Variable.Set.empty in - let bound = ref Variable.Set.empty in - let free_variables ids = free := Variable.Set.union ids !free in - let free_variable fv = free := Variable.Set.add fv !free in - let bound_variable id = bound := Variable.Set.add id !bound in - (* N.B. This function assumes that all bound identifiers are distinct. *) - let rec aux (flam : t) : unit = - match flam with - | Var var -> free_variable var - | Apply { func; args; kind = _; dbg = _} -> - begin match ignore_uses_as_callee with - | None -> free_variable func - | Some () -> () - end; - begin match ignore_uses_as_argument with - | None -> List.iter free_variable args - | Some () -> () - end - | Let { var; free_vars_of_defining_expr; free_vars_of_body; - defining_expr; body; _ } -> - bound_variable var; - if all_used_variables - || Option.is_some ignore_uses_as_callee - || Option.is_some ignore_uses_as_argument - || Option.is_some ignore_uses_in_project_var - then begin - (* In these cases we can't benefit from the pre-computed free - variable sets. *) - free_variables - (variables_usage_named ?ignore_uses_in_project_var - ?ignore_uses_as_callee ?ignore_uses_as_argument - ~all_used_variables defining_expr); - aux body - end else begin - free_variables free_vars_of_defining_expr; - free_variables free_vars_of_body - end - | Let_mutable { initial_value = var; body; _ } -> - free_variable var; - aux body - | Let_rec (bindings, body) -> - List.iter (fun (var, defining_expr) -> - bound_variable var; - free_variables - (variables_usage_named ?ignore_uses_in_project_var - ~all_used_variables defining_expr)) - bindings; - aux body - | Switch (scrutinee, switch) -> - free_variable scrutinee; - List.iter (fun (_, e) -> aux e) switch.consts; - List.iter (fun (_, e) -> aux e) switch.blocks; - Misc.may aux switch.failaction - | String_switch (scrutinee, cases, failaction) -> - free_variable scrutinee; - List.iter (fun (_, e) -> aux e) cases; - Misc.may aux failaction - | Static_raise (_, es) -> - List.iter free_variable es - | Static_catch (_, vars, e1, e2) -> - List.iter bound_variable vars; - aux e1; - aux e2 - | Try_with (e1, var, e2) -> - aux e1; - bound_variable var; - aux e2 - | If_then_else (var, e1, e2) -> - free_variable var; - aux e1; - aux e2 - | While (e1, e2) -> - aux e1; - aux e2 - | For { bound_var; from_value; to_value; direction = _; body; } -> - bound_variable bound_var; - free_variable from_value; - free_variable to_value; - aux body - | Assign { being_assigned = _; new_value; } -> - free_variable new_value - | Send { kind = _; meth; obj; args; dbg = _ } -> - free_variable meth; - free_variable obj; - List.iter free_variable args; - | Proved_unreachable -> () - in - aux tree; - if all_used_variables then - !free - else - Variable.Set.diff !free !bound - -and variables_usage_named ?ignore_uses_in_project_var - ?ignore_uses_as_callee ?ignore_uses_as_argument - ~all_used_variables named = - let free = ref Variable.Set.empty in - let free_variable fv = free := Variable.Set.add fv !free in - begin match named with - | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ - | Read_symbol_field _ -> () - | Set_of_closures { free_vars; specialised_args; _ } -> - (* Sets of closures are, well, closed---except for the free variable and - specialised argument lists, which may identify variables currently in - scope outside of the closure. *) - Variable.Map.iter (fun _ (renamed_to : specialised_to) -> - (* We don't need to do anything with [renamed_to.projectee.var], if - it is present, since it would only be another free variable - in the same set of closures. *) - free_variable renamed_to.var) - free_vars; - Variable.Map.iter (fun _ (spec_to : specialised_to) -> - (* We don't need to do anything with [spec_to.projectee.var], if - it is present, since it would only be another specialised arg - in the same set of closures. *) - free_variable spec_to.var) - specialised_args - | Project_closure { set_of_closures; closure_id = _ } -> - free_variable set_of_closures - | Project_var { closure; closure_id = _; var = _ } -> - begin match ignore_uses_in_project_var with - | None -> free_variable closure - | Some () -> () - end - | Move_within_set_of_closures { closure; start_from = _; move_to = _ } -> - free_variable closure - | Prim (_, args, _) -> List.iter free_variable args - | Expr flam -> - free := Variable.Set.union - (variables_usage ?ignore_uses_as_callee ?ignore_uses_as_argument - ~all_used_variables flam) !free - end; - !free - -let free_variables ?ignore_uses_as_callee ?ignore_uses_as_argument - ?ignore_uses_in_project_var tree = - variables_usage ?ignore_uses_as_callee ?ignore_uses_as_argument - ?ignore_uses_in_project_var ~all_used_variables:false tree - -let free_variables_named ?ignore_uses_in_project_var named = - variables_usage_named ?ignore_uses_in_project_var - ~all_used_variables:false named - -let used_variables ?ignore_uses_as_callee ?ignore_uses_as_argument - ?ignore_uses_in_project_var tree = - variables_usage ?ignore_uses_as_callee ?ignore_uses_as_argument - ?ignore_uses_in_project_var ~all_used_variables:true tree - -let used_variables_named ?ignore_uses_in_project_var named = - variables_usage_named ?ignore_uses_in_project_var - ~all_used_variables:true named - -let create_let var defining_expr body : t = - begin match !Clflags.dump_flambda_let with - | None -> () - | Some stamp -> - Variable.debug_when_stamp_matches var ~stamp ~f:(fun () -> - Printf.eprintf "Creation of [Let] with stamp %d:\n%s\n%!" - stamp - (Printexc.raw_backtrace_to_string (Printexc.get_callstack max_int))) - end; - let defining_expr, free_vars_of_defining_expr = - match defining_expr with - | Expr (Let { var = var1; defining_expr; body = Var var2; - free_vars_of_defining_expr; _ }) when Variable.equal var1 var2 -> - defining_expr, free_vars_of_defining_expr - | _ -> defining_expr, free_variables_named defining_expr - in - Let { - var; - defining_expr; - body; - free_vars_of_defining_expr; - free_vars_of_body = free_variables body; - } - -let map_defining_expr_of_let let_expr ~f = - let defining_expr = f let_expr.defining_expr in - if defining_expr == let_expr.defining_expr then - Let let_expr - else - let free_vars_of_defining_expr = - free_variables_named defining_expr - in - Let { - var = let_expr.var; - defining_expr; - body = let_expr.body; - free_vars_of_defining_expr; - free_vars_of_body = let_expr.free_vars_of_body; - } - -let iter_lets t ~for_defining_expr ~for_last_body ~for_each_let = - let rec loop (t : t) = - match t with - | Let { var; defining_expr; body; _ } -> - for_each_let t; - for_defining_expr var defining_expr; - loop body - | t -> - for_last_body t - in - loop t - -let map_lets t ~for_defining_expr ~for_last_body ~after_rebuild = - let rec loop (t : t) ~rev_lets = - match t with - | Let { var; defining_expr; body; _ } -> - let new_defining_expr = - for_defining_expr var defining_expr - in - let original = - if new_defining_expr == defining_expr then - Some t - else - None - in - let rev_lets = (var, new_defining_expr, original) :: rev_lets in - loop body ~rev_lets - | t -> - let last_body = for_last_body t in - (* As soon as we see a change, we have to rebuild that [Let] and every - outer one. *) - let seen_change = ref (not (last_body == t)) in - List.fold_left (fun t (var, defining_expr, original) -> - let let_expr = - match original with - | Some original when not !seen_change -> original - | Some _ | None -> - seen_change := true; - create_let var defining_expr t - in - let new_let = after_rebuild let_expr in - if not (new_let == let_expr) then begin - seen_change := true - end; - new_let) - last_body - rev_lets - in - loop t ~rev_lets:[] - -(** CR-someday lwhite: Why not use two functions? *) -type maybe_named = - | Is_expr of t - | Is_named of named - -let iter_general ~toplevel f f_named maybe_named = - let rec aux (t : t) = - match t with - | Let _ -> - iter_lets t - ~for_defining_expr:(fun _var named -> aux_named named) - ~for_last_body:aux - ~for_each_let:f - | _ -> - f t; - match t with - | Var _ | Apply _ | Assign _ | Send _ | Proved_unreachable - | Static_raise _ -> () - | Let _ -> assert false - | Let_mutable { body; _ } -> - aux body - | Let_rec (defs, body) -> - List.iter (fun (_,l) -> aux_named l) defs; - aux body - | Try_with (f1,_,f2) - | While (f1,f2) - | Static_catch (_,_,f1,f2) -> - aux f1; aux f2 - | For { body; _ } -> aux body - | If_then_else (_, f1, f2) -> - aux f1; aux f2 - | Switch (_, sw) -> - List.iter (fun (_,l) -> aux l) sw.consts; - List.iter (fun (_,l) -> aux l) sw.blocks; - Misc.may aux sw.failaction - | String_switch (_, sw, def) -> - List.iter (fun (_,l) -> aux l) sw; - Misc.may aux def - and aux_named (named : named) = - f_named named; - match named with - | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ - | Read_symbol_field _ - | Project_closure _ | Project_var _ | Move_within_set_of_closures _ - | Prim _ -> () - | Set_of_closures ({ function_decls = funcs; free_vars = _; - specialised_args = _}) -> - if not toplevel then begin - Variable.Map.iter (fun _ (decl : function_declaration) -> - aux decl.body) - funcs.funs - end - | Expr flam -> aux flam - in - match maybe_named with - | Is_expr expr -> aux expr - | Is_named named -> aux_named named - -module With_free_variables = struct - type 'a t = - | Expr : expr * Variable.Set.t -> expr t - | Named : named * Variable.Set.t -> named t - - let of_defining_expr_of_let let_expr = - Named (let_expr.defining_expr, let_expr.free_vars_of_defining_expr) - - let of_body_of_let let_expr = - Expr (let_expr.body, let_expr.free_vars_of_body) - - let of_expr expr = - Expr (expr, free_variables expr) - - let of_named named = - Named (named, free_variables_named named) - - let create_let_reusing_defining_expr var (t : named t) body = - match t with - | Named (defining_expr, free_vars_of_defining_expr) -> - Let { - var; - defining_expr; - body; - free_vars_of_defining_expr; - free_vars_of_body = free_variables body; - } - - let create_let_reusing_body var defining_expr (t : expr t) = - match t with - | Expr (body, free_vars_of_body) -> - Let { - var; - defining_expr; - body; - free_vars_of_defining_expr = free_variables_named defining_expr; - free_vars_of_body; - } - - let create_let_reusing_both var (t1 : named t) (t2 : expr t) = - match t1, t2 with - | Named (defining_expr, free_vars_of_defining_expr), - Expr (body, free_vars_of_body) -> - Let { - var; - defining_expr; - body; - free_vars_of_defining_expr; - free_vars_of_body; - } - - let expr (t : expr t) = - match t with - | Expr (expr, free_vars) -> Named (Expr expr, free_vars) - - let contents (type a) (t : a t) : a = - match t with - | Expr (expr, _) -> expr - | Named (named, _) -> named - - let free_variables (type a) (t : a t) = - match t with - | Expr (_, free_vars) -> free_vars - | Named (_, free_vars) -> free_vars -end - -let fold_lets_option - t ~init - ~(for_defining_expr:('a -> Variable.t -> named -> 'a * Variable.t * named)) - ~for_last_body - ~(filter_defining_expr:('b -> Variable.t -> named -> Variable.Set.t -> - 'b * Variable.t * named option)) = - let finish ~last_body ~acc ~rev_lets = - let module W = With_free_variables in - let acc, t = - List.fold_left (fun (acc, t) (var, defining_expr) -> - let free_vars_of_body = W.free_variables t in - let acc, var, defining_expr = - filter_defining_expr acc var defining_expr free_vars_of_body - in - match defining_expr with - | None -> acc, t - | Some defining_expr -> - let let_expr = - W.create_let_reusing_body var defining_expr t - in - acc, W.of_expr let_expr) - (acc, W.of_expr last_body) - rev_lets - in - W.contents t, acc - in - let rec loop (t : t) ~acc ~rev_lets = - match t with - | Let { var; defining_expr; body; _ } -> - let acc, var, defining_expr = - for_defining_expr acc var defining_expr - in - let rev_lets = (var, defining_expr) :: rev_lets in - loop body ~acc ~rev_lets - | t -> - let last_body, acc = for_last_body acc t in - finish ~last_body ~acc ~rev_lets - in - loop t ~acc:init ~rev_lets:[] - -let free_symbols_helper symbols (named : named) = - match named with - | Symbol symbol - | Read_symbol_field (symbol, _) -> symbols := Symbol.Set.add symbol !symbols - | Set_of_closures set_of_closures -> - Variable.Map.iter (fun _ (function_decl : function_declaration) -> - symbols := Symbol.Set.union function_decl.free_symbols !symbols) - set_of_closures.function_decls.funs - | _ -> () - -let free_symbols expr = - let symbols = ref Symbol.Set.empty in - iter_general ~toplevel:true - (fun (_ : t) -> ()) - (fun (named : named) -> free_symbols_helper symbols named) - (Is_expr expr); - !symbols - -let free_symbols_named named = - let symbols = ref Symbol.Set.empty in - iter_general ~toplevel:true - (fun (_ : t) -> ()) - (fun (named : named) -> free_symbols_helper symbols named) - (Is_named named); - !symbols - -let free_symbols_allocated_constant_helper symbols - (const : constant_defining_value) = - match const with - | Allocated_const _ -> () - | Block (_, fields) -> - List.iter - (function - | (Symbol s : constant_defining_value_block_field) -> - symbols := Symbol.Set.add s !symbols - | (Const _ : constant_defining_value_block_field) -> ()) - fields - | Set_of_closures set_of_closures -> - symbols := Symbol.Set.union !symbols - (free_symbols_named (Set_of_closures set_of_closures)) - | Project_closure (s, _) -> - symbols := Symbol.Set.add s !symbols - -let free_symbols_program (program : program) = - let symbols = ref Symbol.Set.empty in - let rec loop (program : program_body) = - match program with - | Let_symbol (_, const, program) -> - free_symbols_allocated_constant_helper symbols const; - loop program - | Let_rec_symbol (defs, program) -> - List.iter (fun (_, const) -> - free_symbols_allocated_constant_helper symbols const) - defs; - loop program - | Initialize_symbol (_, _, fields, program) -> - List.iter (fun field -> - symbols := Symbol.Set.union !symbols (free_symbols field)) - fields; - loop program - | Effect (expr, program) -> - symbols := Symbol.Set.union !symbols (free_symbols expr); - loop program - | End symbol -> symbols := Symbol.Set.add symbol !symbols - in - (* Note that there is no need to count the [imported_symbols]. *) - loop program.program_body; - !symbols - -let update_body_of_function_declaration (func_decl: function_declaration) - ~body : function_declaration = - { closure_origin = func_decl.closure_origin; - params = func_decl.params; - body; - free_variables = free_variables body; - free_symbols = free_symbols body; - stub = func_decl.stub; - dbg = func_decl.dbg; - inline = func_decl.inline; - specialise = func_decl.specialise; - is_a_functor = func_decl.is_a_functor; - } - -let update_function_decl's_params_and_body - (func_decl : function_declaration) ~params ~body = - { closure_origin = func_decl.closure_origin; - params; - body; - free_variables = free_variables body; - free_symbols = free_symbols body; - stub = func_decl.stub; - dbg = func_decl.dbg; - inline = func_decl.inline; - specialise = func_decl.specialise; - is_a_functor = func_decl.is_a_functor; - } - - -let create_function_declaration ~params ~body ~stub ~dbg - ~(inline : Lambda.inline_attribute) - ~(specialise : Lambda.specialise_attribute) ~is_a_functor - ~closure_origin - : function_declaration = - begin match stub, inline with - | true, (Never_inline | Default_inline) - | false, (Never_inline | Default_inline | Always_inline | Unroll _) -> () - | true, (Always_inline | Unroll _) -> - Misc.fatal_errorf - "Stubs may not be annotated as [Always_inline] or [Unroll]: %a" - print body - end; - begin match stub, specialise with - | true, (Never_specialise | Default_specialise) - | false, (Never_specialise | Default_specialise | Always_specialise) -> () - | true, Always_specialise -> - Misc.fatal_errorf - "Stubs may not be annotated as [Always_specialise]: %a" - print body - end; - { closure_origin; - params; - body; - free_variables = free_variables body; - free_symbols = free_symbols body; - stub; - dbg; - inline; - specialise; - is_a_functor; - } - -let update_function_declaration fun_decl ~params ~body = - let free_variables = free_variables body in - let free_symbols = free_symbols body in - { fun_decl with params; body; free_variables; free_symbols } - -let create_function_declarations ~is_classic_mode ~funs = - let compilation_unit = Compilation_unit.get_current_exn () in - let set_of_closures_id = Set_of_closures_id.create compilation_unit in - let set_of_closures_origin = - Set_of_closures_origin.create set_of_closures_id - in - { is_classic_mode; - set_of_closures_id; - set_of_closures_origin; - funs; - } - -let create_function_declarations_with_origin - ~is_classic_mode ~funs ~set_of_closures_origin = - let compilation_unit = Compilation_unit.get_current_exn () in - let set_of_closures_id = Set_of_closures_id.create compilation_unit in - { is_classic_mode; - set_of_closures_id; - set_of_closures_origin; - funs; - } - -let update_function_declarations function_decls ~funs = - let is_classic_mode = function_decls.is_classic_mode in - let compilation_unit = Compilation_unit.get_current_exn () in - let set_of_closures_id = Set_of_closures_id.create compilation_unit in - let set_of_closures_origin = function_decls.set_of_closures_origin in - { is_classic_mode; - set_of_closures_id; - set_of_closures_origin; - funs; - } - -let create_function_declarations_with_closures_origin - ~is_classic_mode ~funs ~set_of_closures_origin = - let compilation_unit = Compilation_unit.get_current_exn () in - let set_of_closures_id = Set_of_closures_id.create compilation_unit in - { is_classic_mode; - set_of_closures_id; - set_of_closures_origin; - funs - } - -let import_function_declarations_for_pack function_decls - import_set_of_closures_id import_set_of_closures_origin = - let is_classic_mode = function_decls.is_classic_mode in - let set_of_closures_id = - import_set_of_closures_id function_decls.set_of_closures_id - in - let set_of_closures_origin = - import_set_of_closures_origin function_decls.set_of_closures_origin - in - let funs = function_decls.funs in - { is_classic_mode; - set_of_closures_id; - set_of_closures_origin; - funs; - } - -let create_set_of_closures ~function_decls ~free_vars ~specialised_args - ~direct_call_surrogates = - if !Clflags.flambda_invariant_checks then begin - let all_fun_vars = Variable.Map.keys function_decls.funs in - let expected_free_vars = - Variable.Map.fold (fun _fun_var function_decl expected_free_vars -> - let free_vars = - Variable.Set.diff function_decl.free_variables - (Variable.Set.union (Parameter.Set.vars function_decl.params) - all_fun_vars) - in - Variable.Set.union free_vars expected_free_vars) - function_decls.funs - Variable.Set.empty - in - (* CR-soon pchambart: We do not seem to be able to maintain the - invariant that if a variable is not used inside the closure, it - is not used outside either. This would be a nice property for - better dead code elimination during inline_and_simplify, but it - is not obvious how to ensure that. - - This would be true when the function is known never to have - been inlined. - - Note that something like that may maybe enforcable in - inline_and_simplify, but there is no way to do that on other - passes. - - mshinwell: see CR in Flambda_invariants about this too - *) - let free_vars_domain = Variable.Map.keys free_vars in - if not (Variable.Set.subset expected_free_vars free_vars_domain) then begin - Misc.fatal_errorf "create_set_of_closures: [free_vars] mapping of \ - variables bound by the closure(s) is wrong. (Must map at least \ - %a but only maps %a.)@ \nfunction_decls:@ %a" - Variable.Set.print expected_free_vars - Variable.Set.print free_vars_domain - print_function_declarations function_decls - end; - let all_params = - Variable.Map.fold (fun _fun_var function_decl all_params -> - Variable.Set.union (Parameter.Set.vars function_decl.params) - all_params) - function_decls.funs - Variable.Set.empty - in - let spec_args_domain = Variable.Map.keys specialised_args in - if not (Variable.Set.subset spec_args_domain all_params) then begin - Misc.fatal_errorf "create_set_of_closures: [specialised_args] \ - maps variable(s) that are not parameters of the given function \ - declarations. specialised_args domain=%a all_params=%a \n\ - function_decls:@ %a" - Variable.Set.print spec_args_domain - Variable.Set.print all_params - print_function_declarations function_decls - end - end; - { function_decls; - free_vars; - specialised_args; - direct_call_surrogates; - } - -let used_params function_decl = - Variable.Set.filter - (fun param -> Variable.Set.mem param function_decl.free_variables) - (Parameter.Set.vars function_decl.params) - -let compare_const (c1:const) (c2:const) = - match c1, c2 with - | Int i1, Int i2 -> compare i1 i2 - | Char i1, Char i2 -> Char.compare i1 i2 - | Const_pointer i1, Const_pointer i2 -> compare i1 i2 - | Int _, (Char _ | Const_pointer _) -> -1 - | (Char _ | Const_pointer _), Int _ -> 1 - | Char _, Const_pointer _ -> -1 - | Const_pointer _, Char _ -> 1 - -let compare_constant_defining_value_block_field - (c1:constant_defining_value_block_field) - (c2:constant_defining_value_block_field) = - match c1, c2 with - | Symbol s1, Symbol s2 -> Symbol.compare s1 s2 - | Const c1, Const c2 -> compare_const c1 c2 - | Symbol _, Const _ -> -1 - | Const _, Symbol _ -> 1 - -module Constant_defining_value = struct - type t = constant_defining_value - - include Identifiable.Make (struct - type nonrec t = t - - let compare (t1 : t) (t2 : t) = - match t1, t2 with - | Allocated_const c1, Allocated_const c2 -> - Allocated_const.compare c1 c2 - | Block (tag1, fields1), Block (tag2, fields2) -> - let c = Tag.compare tag1 tag2 in - if c <> 0 then c - else - Misc.Stdlib.List.compare compare_constant_defining_value_block_field - fields1 fields2 - | Set_of_closures set1, Set_of_closures set2 -> - Set_of_closures_id.compare set1.function_decls.set_of_closures_id - set2.function_decls.set_of_closures_id - | Project_closure (set1, closure_id1), - Project_closure (set2, closure_id2) -> - let c = Symbol.compare set1 set2 in - if c <> 0 then c - else Closure_id.compare closure_id1 closure_id2 - | Allocated_const _, Block _ -> -1 - | Allocated_const _, Set_of_closures _ -> -1 - | Allocated_const _, Project_closure _ -> -1 - | Block _, Allocated_const _ -> 1 - | Block _, Set_of_closures _ -> -1 - | Block _, Project_closure _ -> -1 - | Set_of_closures _, Allocated_const _ -> 1 - | Set_of_closures _, Block _ -> 1 - | Set_of_closures _, Project_closure _ -> -1 - | Project_closure _, Allocated_const _ -> 1 - | Project_closure _, Block _ -> 1 - | Project_closure _, Set_of_closures _ -> 1 - - let equal t1 t2 = - t1 == t2 || compare t1 t2 = 0 - - let hash = Hashtbl.hash - - let print = print_constant_defining_value - - let output o v = - output_string o (Format.asprintf "%a" print v) - end) -end - -let equal_call_kind (call_kind1 : call_kind) (call_kind2 : call_kind) = - match call_kind1, call_kind2 with - | Indirect, Indirect -> true - | Direct cid1, Direct cid2 -> Closure_id.equal cid1 cid2 - | (Indirect | Direct _), _ -> false - -let equal_specialised_to (spec_to1 : specialised_to) - (spec_to2 : specialised_to) = - Variable.equal spec_to1.var spec_to2.var - && begin - match spec_to1.projection, spec_to2.projection with - | None, None -> true - | Some _, None | None, Some _ -> false - | Some proj1, Some proj2 -> Projection.equal proj1 proj2 - end - -let compare_project_var = Projection.compare_project_var -let compare_project_closure = Projection.compare_project_closure -let compare_move_within_set_of_closures = - Projection.compare_move_within_set_of_closures diff --git a/middle_end/flambda.mli b/middle_end/flambda.mli deleted file mode 100644 index 325c15ee1c..0000000000 --- a/middle_end/flambda.mli +++ /dev/null @@ -1,713 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -(** Intermediate language used for tree-based analysis and optimization. *) - -(** Whether the callee in a function application is known at compile time. *) -type call_kind = - | Indirect - | Direct of Closure_id.t - -(** Simple constants. ("Structured constants" are rewritten to invocations - of [Pmakeblock] so that they easily take part in optimizations.) *) -type const = - | Int of int - | Char of char - (** [Char] is kept separate from [Int] to improve printing *) - | Const_pointer of int - (** [Const_pointer] is an immediate value of a type whose values may be - boxed (typically a variant type with both constant and non-constant - constructors). *) - -(** The application of a function to a list of arguments. *) -type apply = { - (* CR-soon mshinwell: rename func -> callee, and - lhs_of_application -> callee *) - func : Variable.t; - args : Variable.t list; - kind : call_kind; - dbg : Debuginfo.t; - inline : Lambda.inline_attribute; - (** Instructions from the source code as to whether the callee should - be inlined. *) - specialise : Lambda.specialise_attribute; - (** Instructions from the source code as to whether the callee should - be specialised. *) -} - -(** The update of a mutable variable. Mutable variables are distinct from - immutable variables in Flambda. *) -type assign = { - being_assigned : Mutable_variable.t; - new_value : Variable.t; -} - -(** The invocation of a method. *) -type send = { - kind : Lambda.meth_kind; - meth : Variable.t; - obj : Variable.t; - args : Variable.t list; - dbg : Debuginfo.t; -} - -(** For details on these types, see projection.mli. *) -type project_closure = Projection.project_closure -type move_within_set_of_closures = Projection.move_within_set_of_closures -type project_var = Projection.project_var - -(** See [free_vars] and [specialised_args], below. *) -(* CR-someday mshinwell: move to separate module and make [Identifiable]. - (Or maybe nearly Identifiable; having a special map that enforces invariants - might be good.) *) -type specialised_to = { - var : Variable.t; - (** The "outer variable". *) - projection : Projection.t option; - (** The [projecting_from] value (see projection.mli) of any [projection] - must be another free variable or specialised argument (depending on - whether this record type is involved in [free_vars] or - [specialised_args] respectively) in the same set of closures. - As such, this field describes a relation of projections between - either the [free_vars] or the [specialised_args]. *) -} - -(** Flambda terms are partitioned in a pseudo-ANF manner; many terms are - required to be [let]-bound. This in particular ensures there is always - a variable name for an expression that may be lifted out (for example - if it is found to be constant). - Note: All bound variables in Flambda terms must be distinct. - [Flambda_invariants] verifies this. *) -type t = - | Var of Variable.t - | Let of let_expr - | Let_mutable of let_mutable - | Let_rec of (Variable.t * named) list * t - (** CR-someday lwhite: give Let_rec the same fields as Let. *) - | Apply of apply - | Send of send - | Assign of assign - | If_then_else of Variable.t * t * t - | Switch of Variable.t * switch - | String_switch of Variable.t * (string * t) list * t option - (** Restrictions on [Lambda.Lstringswitch] also apply to [String_switch]. *) - | Static_raise of Static_exception.t * Variable.t list - | Static_catch of Static_exception.t * Variable.t list * t * t - | Try_with of t * Variable.t * t - | While of t * t - | For of for_loop - | Proved_unreachable - -(** Values of type [named] will always be [let]-bound to a [Variable.t]. *) -and named = - | Symbol of Symbol.t - | Const of const - | Allocated_const of Allocated_const.t - | Read_mutable of Mutable_variable.t - | Read_symbol_field of Symbol.t * int - (** During the lifting of [let] bindings to [program] constructions after - closure conversion, we generate symbols and their corresponding - definitions (which may or may not be constant), together with field - accesses to such symbols. We would like it to be the case that such - field accesses are simplified to the relevant component of the - symbol concerned. (The rationale is to generate efficient code and - share constants as expected: see e.g. tests/asmcomp/staticalloc.ml.) - The components of the symbol would be identified by other symbols. - This sort of access pattern is feasible because the top-level structure - of symbols is statically allocated and fixed at compile time. - It may seem that [Prim (Pfield, ...)] expressions could be used to - perform the field accesses. However for simplicity, to avoid having to - keep track of properties of individual fields of blocks, - [Inconstant_idents] never deems a [Prim (Pfield, ...)] expression to be - constant. This would in general prevent field accesses to symbols from - being simplified in the way we would like, since [Lift_constants] would - not assign new symbols (i.e. the things we would like to simplify to) - to the various projections from the symbols in question. - To circumvent this problem we use [Read_symbol_field] when generating - projections from the top level of symbols. Owing to the properties of - symbols described above, such expressions may be eligible for declaration - as constant by [Inconstant_idents] (and thus themselves lifted to another - symbol), without any further complication. - [Read_symbol_field] may only be used when the definition of the symbol - is in scope in the [program]. For external unresolved symbols, [Pfield] - may still be used; it will be changed to [Read_symbol_field] by - [Inline_and_simplify] when (and if) the symbol is imported. *) - | Set_of_closures of set_of_closures - | Project_closure of project_closure - | Move_within_set_of_closures of move_within_set_of_closures - | Project_var of project_var - | Prim of Clambda_primitives.primitive * Variable.t list * Debuginfo.t - | Expr of t (** ANF escape hatch. *) - -(* CR-someday mshinwell: use [letcont]-style construct to remove e.g. - [While] and [For]. *) -(* CR-someday mshinwell: try to produce a tighter definition of a "switch" - (and translate to that earlier) so that middle- and back-end code for - these can be reduced. *) -(* CR-someday mshinwell: remove [Expr], but to do this easily would probably - require a continuation-binding construct. *) -(* CR-someday mshinwell: Since we lack expression identifiers on every term, - we should probably introduce [Mutable_var] into [named] if we introduce - more complicated analyses on these in the future. Alternatively, maybe - consider removing mutable variables altogether. *) - -and let_expr = private { - var : Variable.t; - defining_expr : named; - body : t; - (* CR-someday mshinwell: we could consider having these be keys into some - kind of global cache, to reduce memory usage. *) - free_vars_of_defining_expr : Variable.Set.t; - (** A cache of the free variables in the defining expression of the [let]. *) - free_vars_of_body : Variable.Set.t; - (** A cache of the free variables of the body of the [let]. This is an - important optimization. *) -} - -and let_mutable = { - var : Mutable_variable.t; - initial_value : Variable.t; - contents_kind : Lambda.value_kind; - body : t; -} - -(** The representation of a set of function declarations (possibly mutually - recursive). Such a set encapsulates the declarations themselves, - information about their defining environment, and information used - specifically for optimization. - Before a function can be applied it must be "projected" from a set of - closures to yield a "closure". This is done using [Project_closure] - (see above). Given a closure, not only can it be applied, but information - about its defining environment can be retrieved (using [Project_var], - see above). - At runtime, a [set_of_closures] corresponds to an OCaml value with tag - [Closure_tag] (possibly with inline [Infix_tag](s)). As an optimization, - an operation ([Move_within_set_of_closures]) is provided (see above) - which enables one closure within a set to be located given another - closure in the same set. This avoids keeping a pointer to the whole set - of closures alive when compiling, for example, mutually-recursive - functions. -*) -and set_of_closures = private { - function_decls : function_declarations; - (* CR-soon mshinwell: consider renaming [free_vars]. Also, it's still really - confusing which side of this map to use when. "Vars bound by the - closure" is the domain. - Another example of when this is confusing: - let bound_vars_approx = - Variable.Map.map (Env.find_approx env) set.free_vars - in - in [Build_export_info]. *) - (* CR-soon mshinwell: I'd like to arrange these maps so that it's impossible - to put invalid projection information into them (in particular, so that - we enforce that the relation stays within the domain of the map). *) - free_vars : specialised_to Variable.Map.t; - (** Mapping from all variables free in the body of the [function_decls] to - variables in scope at the definition point of the [set_of_closures]. - The domain of this map is sometimes known as the "variables bound by - the closure". *) - specialised_args : specialised_to Variable.Map.t; - (** Parameters whose corresponding arguments are known to always alias a - particular value. These are the only parameters that may, during - [Inline_and_simplify], have non-unknown approximations. - - An argument may only be specialised to a variable in the scope of the - corresponding set of closures declaration. Usually, that variable - itself also appears in the position of the specialised argument at - all call sites of the function. However it may also be the case (for - example in code generated as a result of [Augment_specialised_args]) - that the various call sites of such a function have differing - variables in the position of the specialised argument. This is - permissible *so long as it is certain they all alias the same value*. - Great care must be taken in transformations that result in this - situation since there are no invariant checks for correctness. - - As an example, supposing all call sites of f are represented here: - [let x = ... in - let f a b c = ... in - let y = ... in - f x y 1; - f x y 1] - the specialised arguments of f can (but does not necessarily) contain - the association [a] -> [x], but cannot contain [b] -> [y] because [f] - is not in the scope of [y]. If f were the recursive function - [let rec f a b c = f a 1 2 in], [a] -> [x] would still be a valid - specialised argument because all recursive calls maintain the invariant. - - This information is used for optimization purposes, if such a binding is - known, it is possible to specialise the body of the function according - to its parameter. This is usually introduced when specialising a - recursive function, for instance. - [let rec map f = function - | [] -> [] - | h :: t -> f h :: map f t - let map_succ l = - let succ x = x + 1 in - map succ l] - [map] can be duplicated in [map_succ] to be specialised for the argument - [f]. This will result in - [let map_succ l = - let succ x = x + 1 in - let rec map f = function - | [] -> [] - | h :: t -> f h :: map f t in - map succ l] - with map having [f] -> [succ] in its [specialised_args] field. - - Specialised argument information for arguments that are used must - never be erased. This ensures that specialised arguments whose - approximations describe closures maintain those approximations, which - is essential to transport the closure freshening information to the - point of use (e.g. a [Project_var] from such an argument). - *) - direct_call_surrogates : Variable.t Variable.Map.t; - (** If [direct_call_surrogates] maps [fun_var1] to [fun_var2] then direct - calls to [fun_var1] should be redirected to [fun_var2]. This is used - to reduce the overhead of transformations that introduce wrapper - functions (which will be inlined at direct call sites, but will - penalise indirect call sites). - [direct_call_surrogates] may not be transitively closed. *) -} - -and function_declarations = private { - is_classic_mode: bool; - (** Indicates whether this [function_declarations] was compiled - with -Oclassic. *) - set_of_closures_id : Set_of_closures_id.t; - (** An identifier (unique across all Flambda trees currently in memory) - of the set of closures associated with this set of function - declarations. *) - set_of_closures_origin : Set_of_closures_origin.t; - (** An identifier of the original set of closures on which this set of - function declarations is based. Used to prevent different - specialisations of the same functions from being inlined/specialised - within each other. *) - funs : function_declaration Variable.Map.t; - (** The function(s) defined by the set of function declarations. The - keys of this map are often referred to in the code as "fun_var"s. *) -} - -and function_declaration = private { - closure_origin: Closure_origin.t; - params : Parameter.t list; - body : t; - (* CR-soon mshinwell: inconsistent naming free_variables/free_vars here and - above *) - free_variables : Variable.Set.t; - (** All variables free in the *body* of the function. For example, a - variable that is bound as one of the function's parameters will still - be included in this set. This field is present as an optimization. *) - free_symbols : Symbol.Set.t; - (** All symbols that occur in the function's body. (Symbols can never be - bound in a function's body; the only thing that binds symbols is the - [program] constructions below.) *) - stub : bool; - (** A stub function is a generated function used to prepare arguments or - return values to allow indirect calls to functions with a special calling - convention. For instance indirect calls to tuplified functions must go - through a stub. Stubs will be unconditionally inlined. *) - dbg : Debuginfo.t; - (** Debug info for the function declaration. *) - inline : Lambda.inline_attribute; - (** Inlining requirements from the source code. *) - specialise : Lambda.specialise_attribute; - (** Specialising requirements from the source code. *) - is_a_functor : bool; - (** Whether the function is known definitively to be a functor. *) -} - -(** Equivalent to the similar type in [Lambda]. *) -and switch = { - numconsts : Numbers.Int.Set.t; (** Integer cases *) - consts : (int * t) list; (** Integer cases *) - numblocks : Numbers.Int.Set.t; (** Number of tag block cases *) - blocks : (int * t) list; (** Tag block cases *) - failaction : t option; (** Action to take if none matched *) -} - -(** Equivalent to the similar type in [Lambda]. *) -and for_loop = { - bound_var : Variable.t; - from_value : Variable.t; - to_value : Variable.t; - direction : Asttypes.direction_flag; - body : t -} - -(** Like a subset of [Flambda.named], except that instead of [Variable.t]s we - have [Symbol.t]s, and everything is a constant (i.e. with a fixed value - known at compile time). Values of this type describe constants that will - be directly assigned to symbols in the object file (see below). *) -and constant_defining_value = - | Allocated_const of Allocated_const.t - (** A single constant. These are never "simple constants" (type [const]) - but instead more complicated constructions. *) - | Block of Tag.t * constant_defining_value_block_field list - (** A pre-allocated block full of constants (either simple constants - or references to other constants, see below). *) - | Set_of_closures of set_of_closures - (** A closed (and thus constant) set of closures. (That is to say, - [free_vars] must be empty.) *) - | Project_closure of Symbol.t * Closure_id.t - (** Selection of one closure from a constant set of closures. - Analogous to the equivalent operation on expressions. *) - -and constant_defining_value_block_field = - | Symbol of Symbol.t - | Const of const - -module Constant_defining_value : - Identifiable.S with type t = constant_defining_value - -type expr = t - -(** A "program" is the contents of one compilation unit. It describes the - various values that are assigned to symbols (and in some cases fields of - such symbols) in the object file. As such, it is closely related to - the compilation of toplevel modules. *) -type program_body = - | Let_symbol of Symbol.t * constant_defining_value * program_body - (** Define the given symbol to have the given constant value. *) - | Let_rec_symbol of (Symbol.t * constant_defining_value) list * program_body - (** As for [Let_symbol], but recursive. This is needed to treat examples - like this, where a constant set of closures is lifted to toplevel: - - let rec f x = f x - - After lifting this produces (in pseudo-Flambda): - - Let_rec_symbol set_of_closures_symbol = - (Set_of_closures { f x -> - let applied_function = Symbol f_closure in - Apply (applied_function, x) }) - and f_closure = Project_closure (set_of_closures_symbol, f) - - Use of [Let_rec_symbol], by virtue of the special handling in - [Inline_and_simplify.define_let_rec_symbol_approx], enables the - approximation of the set of closures to be present in order to - correctly simplify the [Project_closure] construction. (See - [Inline_and_simplify.simplify_project_closure] for that part.) *) - | Initialize_symbol of Symbol.t * Tag.t * t list * program_body - (** Define the given symbol as a constant block of the given size and - tag; but with a possibly non-constant initializer. The initializer - will be executed at most once (from the entry point of the compilation - unit). *) - | Effect of t * program_body - (** Cause the given expression, which may have a side effect, to be - executed. The resulting value is discarded. [Effect] constructions - are never re-ordered. *) - | End of Symbol.t - (** [End] accepts the root symbol: the only symbol that can never be - eliminated. *) - -type program = { - imported_symbols : Symbol.Set.t; - program_body : program_body; -} - -(** Compute the free variables of a term. (This is O(1) for [Let]s). - If [ignore_uses_as_callee], all free variables inside [Apply] expressions - are ignored. Likewise [ignore_uses_in_project_var] for [Project_var] - expressions. -*) -val free_variables - : ?ignore_uses_as_callee:unit - -> ?ignore_uses_as_argument:unit - -> ?ignore_uses_in_project_var:unit - -> t - -> Variable.Set.t - -(** Compute the free variables of a named expression. *) -val free_variables_named - : ?ignore_uses_in_project_var:unit - -> named - -> Variable.Set.t - -(** Compute _all_ variables occurring inside an expression. *) -val used_variables - : ?ignore_uses_as_callee:unit - -> ?ignore_uses_as_argument:unit - -> ?ignore_uses_in_project_var:unit - -> t - -> Variable.Set.t - -(** Compute _all_ variables occurring inside a named expression. *) -val used_variables_named - : ?ignore_uses_in_project_var:unit - -> named - -> Variable.Set.t - -val free_symbols : expr -> Symbol.Set.t - -val free_symbols_named : named -> Symbol.Set.t - -val free_symbols_program : program -> Symbol.Set.t - -(** Used to avoid exceeding the stack limit when handling expressions with - multiple consecutive nested [Let]-expressions. This saves rewriting large - simplification functions in CPS. This function provides for the - rewriting or elimination of expressions during the fold. *) -val fold_lets_option - : t - -> init:'a - -> for_defining_expr:('a -> Variable.t -> named -> 'a * Variable.t * named) - -> for_last_body:('a -> t -> t * 'b) - (* CR-someday mshinwell: consider making [filter_defining_expr] - optional *) - -> filter_defining_expr:('b -> Variable.t -> named -> Variable.Set.t -> - 'b * Variable.t * named option) - -> t * 'b - -(** Like [fold_lets_option], but just a map. *) -val map_lets - : t - -> for_defining_expr:(Variable.t -> named -> named) - -> for_last_body:(t -> t) - -> after_rebuild:(t -> t) - -> t - -(** Like [map_lets], but just an iterator. *) -val iter_lets - : t - -> for_defining_expr:(Variable.t -> named -> unit) - -> for_last_body:(t -> unit) - -> for_each_let:(t -> unit) - -> unit - -(** Creates a [Let] expression. (This computes the free variables of the - defining expression and the body.) *) -val create_let : Variable.t -> named -> t -> t - -(** Apply the specified function [f] to the defining expression of the given - [Let]-expression, returning a new [Let]. *) -val map_defining_expr_of_let : let_expr -> f:(named -> named) -> t - -(** A module for the manipulation of terms where the recomputation of free - variable sets is to be kept to a minimum. *) -module With_free_variables : sig - type 'a t - - (** O(1) time. *) - val of_defining_expr_of_let : let_expr -> named t - - (** O(1) time. *) - val of_body_of_let : let_expr -> expr t - - (** Takes the time required to calculate the free variables of the given - term (proportional to the size of the term, except that the calculation - for [Let] is O(1)). *) - val of_expr : expr -> expr t - - val of_named : named -> named t - - (** Takes the time required to calculate the free variables of the given - [expr]. *) - val create_let_reusing_defining_expr - : Variable.t - -> named t - -> expr - -> expr - - (** Takes the time required to calculate the free variables of the given - [named]. *) - val create_let_reusing_body - : Variable.t - -> named - -> expr t - -> expr - - (** O(1) time. *) - val create_let_reusing_both - : Variable.t - -> named t - -> expr t - -> expr - - (** The equivalent of the [Expr] constructor. *) - val expr : expr t -> named t - - val contents : 'a t -> 'a - - (** O(1) time. *) - val free_variables : _ t -> Variable.Set.t -end - -(** Create a function declaration. This calculates the free variables and - symbols occurring in the specified [body]. *) -val create_function_declaration - : params:Parameter.t list - -> body:t - -> stub:bool - -> dbg:Debuginfo.t - -> inline:Lambda.inline_attribute - -> specialise:Lambda.specialise_attribute - -> is_a_functor:bool - -> closure_origin:Closure_origin.t - -> function_declaration - -(** Create a function declaration based on another function declaration *) -val update_function_declaration - : function_declaration - -> params:Parameter.t list - -> body:t - -> function_declaration - -(** Create a set of function declarations given the individual declarations. *) -val create_function_declarations - : is_classic_mode:bool - -> funs:function_declaration Variable.Map.t - -> function_declarations - -(** Create a set of function declarations with a given set of closures - origin. *) -val create_function_declarations_with_origin - : is_classic_mode:bool - -> funs:function_declaration Variable.Map.t - -> set_of_closures_origin:Set_of_closures_origin.t - -> function_declarations - -(** Change only the code of a function declaration. *) -val update_body_of_function_declaration - : function_declaration - -> body:expr - -> function_declaration - -(** Change only the code and parameters of a function declaration. *) -(* CR-soon mshinwell: rename this to match new update function above *) -val update_function_decl's_params_and_body - : function_declaration - -> params:Parameter.t list - -> body:expr - -> function_declaration - -(** Create a set of function declarations based on another set of function - declarations. *) -val update_function_declarations - : function_declarations - -> funs:function_declaration Variable.Map.t - -> function_declarations - -val create_function_declarations_with_closures_origin - : is_classic_mode: bool - -> funs:function_declaration Variable.Map.t - -> set_of_closures_origin:Set_of_closures_origin.t - -> function_declarations - -val import_function_declarations_for_pack - : function_declarations - -> (Set_of_closures_id.t -> Set_of_closures_id.t) - -> (Set_of_closures_origin.t -> Set_of_closures_origin.t) - -> function_declarations - -(** Create a set of closures. Checks are made to ensure that [free_vars] - and [specialised_args] are reasonable. *) -val create_set_of_closures - : function_decls:function_declarations - -> free_vars:specialised_to Variable.Map.t - -> specialised_args:specialised_to Variable.Map.t - -> direct_call_surrogates:Variable.t Variable.Map.t - -> set_of_closures - -(** Given a function declaration, find which of its parameters (if any) - are used in the body. *) -val used_params : function_declaration -> Variable.Set.t - -type maybe_named = - | Is_expr of t - | Is_named of named - -(** This function is designed for the internal use of [Flambda_iterators]. - See that module for iterators to be used over Flambda terms. *) -val iter_general - : toplevel:bool - -> (t -> unit) - -> (named -> unit) - -> maybe_named - -> unit - -val print : Format.formatter -> t -> unit - -val print_named : Format.formatter -> named -> unit - -val print_program : Format.formatter -> program -> unit - -val print_const : Format.formatter -> const -> unit - -val print_constant_defining_value - : Format.formatter - -> constant_defining_value - -> unit - -val print_function_declaration - : Format.formatter - -> Variable.t * function_declaration - -> unit - -val print_function_declarations - : Format.formatter - -> function_declarations - -> unit - -val print_project_closure - : Format.formatter - -> project_closure - -> unit - -val print_move_within_set_of_closures - : Format.formatter - -> move_within_set_of_closures - -> unit - -val print_project_var - : Format.formatter - -> project_var - -> unit - -val print_set_of_closures - : Format.formatter - -> set_of_closures - -> unit - -val print_specialised_to - : Format.formatter - -> specialised_to - -> unit - -val equal_call_kind - : call_kind - -> call_kind - -> bool - -val equal_specialised_to - : specialised_to - -> specialised_to - -> bool - -val compare_const - : const - -> const - -> int - -val compare_project_var : project_var -> project_var -> int - -val compare_move_within_set_of_closures - : move_within_set_of_closures - -> move_within_set_of_closures - -> int - -val compare_project_closure : project_closure -> project_closure -> int diff --git a/middle_end/flambda/alias_analysis.ml b/middle_end/flambda/alias_analysis.ml new file mode 100644 index 0000000000..fe97a36f51 --- /dev/null +++ b/middle_end/flambda/alias_analysis.ml @@ -0,0 +1,168 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +type allocation_point = + | Symbol of Symbol.t + | Variable of Variable.t + +type allocated_const = + | Normal of Allocated_const.t + | Array of Lambda.array_kind * Asttypes.mutable_flag * Variable.t list + | Duplicate_array of Lambda.array_kind * Asttypes.mutable_flag * Variable.t + +type constant_defining_value = + | Allocated_const of allocated_const + | Block of Tag.t * Variable.t list + | Set_of_closures of Flambda.set_of_closures + | Project_closure of Flambda.project_closure + | Move_within_set_of_closures of Flambda.move_within_set_of_closures + | Project_var of Flambda.project_var + | Field of Variable.t * int + | Symbol_field of Symbol.t * int + | Const of Flambda.const + | Symbol of Symbol.t + | Variable of Variable.t + +type initialize_symbol_field = Variable.t option + +type definitions = { + variable : constant_defining_value Variable.Tbl.t; + initialize_symbol : initialize_symbol_field list Symbol.Tbl.t; + symbol : Flambda.constant_defining_value Symbol.Tbl.t; +} + +let print_constant_defining_value ppf = function + | Allocated_const (Normal const) -> Allocated_const.print ppf const + | Allocated_const (Array (_, _, vars)) -> + Format.fprintf ppf "[| %a |]" + (Format.pp_print_list Variable.print) vars + | Allocated_const (Duplicate_array (_, _, var)) -> + Format.fprintf ppf "dup_array(%a)" Variable.print var + | Block (tag, vars) -> + Format.fprintf ppf "[|%a: %a|]" + Tag.print tag + (Format.pp_print_list Variable.print) vars + | Set_of_closures set -> Flambda.print_set_of_closures ppf set + | Project_closure project -> Flambda.print_project_closure ppf project + | Move_within_set_of_closures move -> + Flambda.print_move_within_set_of_closures ppf move + | Project_var project -> Flambda.print_project_var ppf project + | Field (var, field) -> Format.fprintf ppf "%a.(%d)" Variable.print var field + | Symbol_field (sym, field) -> + Format.fprintf ppf "%a.(%d)" Symbol.print sym field + | Const const -> Flambda.print_const ppf const + | Symbol symbol -> Symbol.print ppf symbol + | Variable var -> Variable.print ppf var + +let rec resolve_definition + (definitions: definitions) + (var: Variable.t) + (def: constant_defining_value) + ~the_dead_constant : allocation_point = + match def with + | Allocated_const _ + | Block _ + | Set_of_closures _ + | Project_closure _ + | Const _ + | Move_within_set_of_closures _ -> + Variable var + | Project_var {var} -> + fetch_variable definitions (Var_within_closure.unwrap var) + ~the_dead_constant + | Variable v -> + fetch_variable definitions v + ~the_dead_constant + | Symbol sym -> Symbol sym + | Field (v, n) -> + begin match fetch_variable definitions v ~the_dead_constant with + | Symbol s -> + fetch_symbol_field definitions s n ~the_dead_constant + | Variable v -> + fetch_variable_field definitions v n ~the_dead_constant + end + | Symbol_field (symbol, field) -> + fetch_symbol_field definitions symbol field ~the_dead_constant + +and fetch_variable + (definitions: definitions) + (var: Variable.t) + ~the_dead_constant : allocation_point = + match Variable.Tbl.find definitions.variable var with + | exception Not_found -> Variable var + | def -> resolve_definition definitions var def ~the_dead_constant + +and fetch_variable_field + (definitions: definitions) + (var: Variable.t) + (field: int) + ~the_dead_constant : allocation_point = + match Variable.Tbl.find definitions.variable var with + | Block (_, fields) -> + begin match List.nth fields field with + | exception Not_found -> Symbol the_dead_constant + | v -> fetch_variable definitions v ~the_dead_constant + end + | exception Not_found -> + Misc.fatal_errorf "No definition for field access to %a" Variable.print var + | Symbol _ | Variable _ | Project_var _ | Field _ | Symbol_field _ -> + (* Must have been resolved *) + assert false + | Const _ | Allocated_const _ + | Set_of_closures _ | Project_closure _ | Move_within_set_of_closures _ -> + Symbol the_dead_constant + +and fetch_symbol_field + (definitions: definitions) + (sym: Symbol.t) + (field: int) + ~the_dead_constant : allocation_point = + match Symbol.Tbl.find definitions.symbol sym with + | Block (_, fields) -> + begin match List.nth fields field with + | exception Not_found -> Symbol the_dead_constant + | Symbol s -> Symbol s + | Const _ -> Symbol sym + end + | exception Not_found -> + begin match Symbol.Tbl.find definitions.initialize_symbol sym with + | fields -> + begin match List.nth fields field with + | None -> + Misc.fatal_errorf "Constant field access to an inconstant %a" + Symbol.print sym + | Some v -> + fetch_variable definitions v ~the_dead_constant + end + | exception Not_found -> + Misc.fatal_errorf "No definition for field access to %a" + Symbol.print sym + end + | Allocated_const _ | Set_of_closures _ | Project_closure _ -> + Symbol the_dead_constant + +let run variable initialize_symbol symbol ~the_dead_constant = + let definitions = { variable; initialize_symbol; symbol; } in + Variable.Tbl.fold (fun var definition result -> + let definition = + resolve_definition definitions var definition ~the_dead_constant + in + Variable.Map.add var definition result) + definitions.variable + Variable.Map.empty diff --git a/middle_end/flambda/alias_analysis.mli b/middle_end/flambda/alias_analysis.mli new file mode 100644 index 0000000000..515daeffa3 --- /dev/null +++ b/middle_end/flambda/alias_analysis.mli @@ -0,0 +1,63 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +type allocation_point = + | Symbol of Symbol.t + | Variable of Variable.t + +type allocated_const = + | Normal of Allocated_const.t + | Array of Lambda.array_kind * Asttypes.mutable_flag * Variable.t list + | Duplicate_array of Lambda.array_kind * Asttypes.mutable_flag * Variable.t + +type constant_defining_value = + | Allocated_const of allocated_const + | Block of Tag.t * Variable.t list + | Set_of_closures of Flambda.set_of_closures + | Project_closure of Flambda.project_closure + | Move_within_set_of_closures of Flambda.move_within_set_of_closures + | Project_var of Flambda.project_var + | Field of Variable.t * int + | Symbol_field of Symbol.t * int + | Const of Flambda.const + | Symbol of Symbol.t + | Variable of Variable.t + +type initialize_symbol_field = Variable.t option + +(** Simple alias analysis working over information about which + symbols have been assigned to variables; and which constants have + been assigned to symbols. The return value gives the assignment + of the defining values of constants to variables. + Also see comments for [Lift_constants], whose input feeds this + pass. + + Variables found to be ill-typed accesses to other constants, for + example arising from dead code, will be pointed at [the_dead_constant]. +*) +val run + : constant_defining_value Variable.Tbl.t + -> initialize_symbol_field list Symbol.Tbl.t + -> Flambda.constant_defining_value Symbol.Tbl.t + -> the_dead_constant:Symbol.t + -> allocation_point Variable.Map.t + +val print_constant_defining_value + : Format.formatter + -> constant_defining_value + -> unit diff --git a/middle_end/flambda/allocated_const.ml b/middle_end/flambda/allocated_const.ml new file mode 100644 index 0000000000..78dc4ee103 --- /dev/null +++ b/middle_end/flambda/allocated_const.ml @@ -0,0 +1,86 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +type t = + | Float of float + | Int32 of int32 + | Int64 of int64 + | Nativeint of nativeint + | Float_array of float list + | Immutable_float_array of float list + | String of string + | Immutable_string of string + +let compare_floats x1 x2 = + (* It is important to compare the bit patterns here, so as not to + be subject to bugs such as GPR#295. *) + Int64.compare (Int64.bits_of_float x1) (Int64.bits_of_float x2) + +let compare (x : t) (y : t) = + let rec compare_float_lists l1 l2 = + match l1, l2 with + | [], [] -> 0 + | [], _::_ -> -1 + | _::_, [] -> 1 + | h1::t1, h2::t2 -> + let c = compare_floats h1 h2 in + if c <> 0 then c else compare_float_lists t1 t2 + in + match x, y with + | Float x, Float y -> compare_floats x y + | Int32 x, Int32 y -> Int32.compare x y + | Int64 x, Int64 y -> Int64.compare x y + | Nativeint x, Nativeint y -> Nativeint.compare x y + | Float_array x, Float_array y -> compare_float_lists x y + | Immutable_float_array x, Immutable_float_array y -> compare_float_lists x y + | String x, String y -> String.compare x y + | Immutable_string x, Immutable_string y -> String.compare x y + | Float _, _ -> -1 + | _, Float _ -> 1 + | Int32 _, _ -> -1 + | _, Int32 _ -> 1 + | Int64 _, _ -> -1 + | _, Int64 _ -> 1 + | Nativeint _, _ -> -1 + | _, Nativeint _ -> 1 + | Float_array _, _ -> -1 + | _, Float_array _ -> 1 + | Immutable_float_array _, _ -> -1 + | _, Immutable_float_array _ -> 1 + | String _, _ -> -1 + | _, String _ -> 1 + +let print ppf (t : t) = + let fprintf = Format.fprintf in + let floats ppf fl = + List.iter (fun f -> fprintf ppf "@ %f" f) fl + in + match t with + | String s -> fprintf ppf "%S" s + | Immutable_string s -> fprintf ppf "#%S" s + | Int32 n -> fprintf ppf "%lil" n + | Int64 n -> fprintf ppf "%LiL" n + | Nativeint n -> fprintf ppf "%nin" n + | Float f -> fprintf ppf "%f" f + | Float_array [] -> fprintf ppf "[| |]" + | Float_array (f1 :: fl) -> + fprintf ppf "@[<1>[|@[%f%a@]|]@]" f1 floats fl + | Immutable_float_array [] -> fprintf ppf "[|# |]" + | Immutable_float_array (f1 :: fl) -> + fprintf ppf "@[<1>[|# @[%f%a@]|]@]" f1 floats fl diff --git a/middle_end/flambda/allocated_const.mli b/middle_end/flambda/allocated_const.mli new file mode 100644 index 0000000000..0bdbe49ec4 --- /dev/null +++ b/middle_end/flambda/allocated_const.mli @@ -0,0 +1,38 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(** Constants that are always allocated (possibly statically). Blocks + are not included here since they are always encoded using + [Prim (Pmakeblock, ...)]. *) + +type t = + | Float of float + | Int32 of int32 + | Int64 of int64 + | Nativeint of nativeint + (* CR-someday mshinwell: consider using "float array" *) + | Float_array of float list + | Immutable_float_array of float list + | String of string + | Immutable_string of string + +val compare_floats : float -> float -> int + +val compare : t -> t -> int + +val print : Format.formatter -> t -> unit diff --git a/middle_end/flambda/augment_specialised_args.ml b/middle_end/flambda/augment_specialised_args.ml new file mode 100644 index 0000000000..c3a3078512 --- /dev/null +++ b/middle_end/flambda/augment_specialised_args.ml @@ -0,0 +1,762 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +module E = Inline_and_simplify_aux.Env +module B = Inlining_cost.Benefit + +module Definition = struct + type t = + | Existing_inner_free_var of Variable.t + | Projection_from_existing_specialised_arg of Projection.t + + include Identifiable.Make (struct + type nonrec t = t + + let compare t1 t2 = + match t1, t2 with + | Existing_inner_free_var var1, Existing_inner_free_var var2 -> + Variable.compare var1 var2 + | Projection_from_existing_specialised_arg proj1, + Projection_from_existing_specialised_arg proj2 -> + Projection.compare proj1 proj2 + | Existing_inner_free_var _, _ -> -1 + | _, Existing_inner_free_var _ -> 1 + + let equal t1 t2 = + (compare t1 t2) = 0 + + let hash = Hashtbl.hash + + let print ppf t = + match t with + | Existing_inner_free_var var -> + Format.fprintf ppf "Existing_inner_free_var %a" + Variable.print var + | Projection_from_existing_specialised_arg projection -> + Format.fprintf ppf "Projection_from_existing_specialised_arg %a" + Projection.print projection + + let output _ _ = failwith "Definition.output not yet implemented" + end) +end + +module What_to_specialise = struct + type t = { + (* [definitions] is indexed by (fun_var, group) *) + definitions : Definition.t list Variable.Pair.Map.t; + set_of_closures : Flambda.set_of_closures; + make_direct_call_surrogates_for : Variable.Set.t; + } + + let create ~set_of_closures = + { definitions = Variable.Pair.Map.empty; + set_of_closures; + make_direct_call_surrogates_for = Variable.Set.empty; + } + + let new_specialised_arg t ~fun_var ~group ~definition = + let key = fun_var, group in + let definitions = + match Variable.Pair.Map.find key t.definitions with + | exception Not_found -> [] + | definitions -> definitions + in + let definitions = + Variable.Pair.Map.add (fun_var, group) (definition :: definitions) + t.definitions + in + { t with definitions; } + + let make_direct_call_surrogate_for t ~fun_var = + match Variable.Map.find fun_var t.set_of_closures.function_decls.funs with + | exception Not_found -> + Misc.fatal_errorf "use_direct_call_surrogate_for: %a is not a fun_var \ + from the given set of closures" + Variable.print fun_var + | _ -> + { t with + make_direct_call_surrogates_for = + Variable.Set.add fun_var t.make_direct_call_surrogates_for; + } +end + +module W = What_to_specialise + +module type S = sig + val pass_name : string + + val what_to_specialise + : env:Inline_and_simplify_aux.Env.t + -> set_of_closures:Flambda.set_of_closures + -> What_to_specialise.t +end + +module Processed_what_to_specialise = struct + type for_one_function = { + fun_var : Variable.t; + function_decl : Flambda.function_declaration; + make_direct_call_surrogates : bool; + new_definitions_indexed_by_new_inner_vars : Definition.t Variable.Map.t; + all_new_definitions : Definition.Set.t; + new_inner_to_new_outer_vars : Variable.t Variable.Map.t; + total_number_of_args : int; + existing_specialised_args : Flambda.specialised_to Variable.Map.t; + } + + type t = { + set_of_closures : Flambda.set_of_closures; + existing_definitions_via_spec_args_indexed_by_fun_var + : Definition.Set.t Variable.Map.t; + (* The following two maps' definitions have already been rewritten + into their lifted form (i.e. they reference outer rather than inner + variables). *) + new_lifted_defns_indexed_by_new_outer_vars : Projection.t Variable.Map.t; + new_outer_vars_indexed_by_new_lifted_defns : Variable.t Projection.Map.t; + functions : for_one_function Variable.Map.t; + make_direct_call_surrogates_for : Variable.Set.t; + } + + let lift_projection t ~(projection : Projection.t) = + (* The lifted definition must be in terms of outer variables, + not inner variables. *) + let find_outer_var inner_var = + match Variable.Map.find inner_var t.set_of_closures.specialised_args with + | (outer_var : Flambda.specialised_to) -> outer_var.var + | exception Not_found -> + Misc.fatal_errorf "find_outer_var: expected %a \ + to be in [specialised_args], but it is \ + not. The projection was: %a. Set of closures: %a" + Variable.print inner_var + Projection.print projection + Flambda.print_set_of_closures t.set_of_closures + in + Projection.map_projecting_from projection ~f:find_outer_var + + let really_add_new_specialised_arg t ~group ~(definition : Definition.t) + ~(for_one_function : for_one_function) = + let fun_var = for_one_function.fun_var in + (* We know here that a new specialised argument must be added. This + needs a "new inner var" and a "new outer var". However if there + is already a lifted projection being introduced around the set + of closures (corresponding to another new specialised argument), + we should re-use its "new outer var" to avoid duplication of + projection definitions. Likewise if the definition is just + [Existing_inner_free_var], in which case we can use the + corresponding existing outer free variable. *) + let new_outer_var, t = + let existing_outer_var = + match definition with + | Existing_inner_free_var _ -> None + | Projection_from_existing_specialised_arg projection -> + let projection = lift_projection t ~projection in + match + Projection.Map.find projection + t.new_outer_vars_indexed_by_new_lifted_defns + with + | new_outer_var -> Some new_outer_var + | exception Not_found -> None + in + match existing_outer_var with + | Some existing_outer_var -> existing_outer_var, t + | None -> + match definition with + | Existing_inner_free_var existing_inner_var -> + begin match + Variable.Map.find existing_inner_var + t.set_of_closures.free_vars + with + | exception Not_found -> + Misc.fatal_errorf "really_add_new_specialised_arg: \ + Existing_inner_free_var %a is not an inner free variable \ + of %a in %a" + Variable.print existing_inner_var + Variable.print fun_var + Flambda.print_set_of_closures t.set_of_closures + | existing_outer_var -> existing_outer_var.var, t + end + | Projection_from_existing_specialised_arg projection -> + let new_outer_var = Variable.rename group in + let projection = lift_projection t ~projection in + let new_outer_vars_indexed_by_new_lifted_defns = + Projection.Map.add + projection new_outer_var + t.new_outer_vars_indexed_by_new_lifted_defns + in + let new_lifted_defns_indexed_by_new_outer_vars = + Variable.Map.add + new_outer_var projection + t.new_lifted_defns_indexed_by_new_outer_vars + in + let t = + { t with + new_outer_vars_indexed_by_new_lifted_defns; + new_lifted_defns_indexed_by_new_outer_vars; + } + in + new_outer_var, t + in + let new_inner_var = Variable.rename group in + let new_inner_to_new_outer_vars = + Variable.Map.add new_inner_var new_outer_var + for_one_function.new_inner_to_new_outer_vars + in + let for_one_function : for_one_function = + { for_one_function with + new_definitions_indexed_by_new_inner_vars = + Variable.Map.add new_inner_var definition + for_one_function.new_definitions_indexed_by_new_inner_vars; + all_new_definitions = + Definition.Set.add definition + for_one_function.all_new_definitions; + new_inner_to_new_outer_vars; + total_number_of_args = for_one_function.total_number_of_args + 1; + } + in + { t with + functions = Variable.Map.add fun_var for_one_function t.functions; + } + + let new_specialised_arg t ~fun_var ~group ~definition = + let for_one_function : for_one_function = + match Variable.Map.find fun_var t.functions with + | exception Not_found -> + begin + match Variable.Map.find fun_var t.set_of_closures.function_decls.funs + with + | exception Not_found -> assert false + | (function_decl : Flambda.function_declaration) -> + let params = Parameter.Set.vars function_decl.params in + let existing_specialised_args = + Variable.Map.filter (fun inner_var _spec_to -> + Variable.Set.mem inner_var params) + t.set_of_closures.specialised_args + in + let make_direct_call_surrogates = + Variable.Set.mem fun_var t.make_direct_call_surrogates_for + in + { fun_var; + function_decl; + make_direct_call_surrogates; + new_definitions_indexed_by_new_inner_vars = Variable.Map.empty; + all_new_definitions = Definition.Set.empty; + new_inner_to_new_outer_vars = Variable.Map.empty; + (* The "+ 1" is just in case there is a closure environment + parameter added later. *) + total_number_of_args = List.length function_decl.params + 1; + existing_specialised_args; + } + end + | for_one_function -> for_one_function + in + (* Determine whether there already exists an existing specialised argument + that is known to be equal to the one proposed to this function. If so, + use that instead. (Note that we also desire to dedup against any + new specialised arguments added to the current function; but that + happens automatically since [Extract_projections] returns a set.) *) + let exists_already = + match + Variable.Map.find fun_var + t.existing_definitions_via_spec_args_indexed_by_fun_var + with + | exception Not_found -> false + | definitions -> Definition.Set.mem definition definitions + in + if exists_already then t + else really_add_new_specialised_arg t ~group ~definition ~for_one_function + + let create ~env ~(what_to_specialise : W.t) = + let existing_definitions_via_spec_args_indexed_by_fun_var = + Variable.Map.map (fun (function_decl : Flambda.function_declaration) -> + if function_decl.stub then + Definition.Set.empty + else + let params = Parameter.Set.vars function_decl.params in + Variable.Map.fold (fun inner_var + (spec_to : Flambda.specialised_to) definitions -> + if not (Variable.Set.mem inner_var params) then + definitions + else + let definition : Definition.t = + match spec_to.projection with + | None -> Existing_inner_free_var inner_var + | Some projection -> + Projection_from_existing_specialised_arg projection + in + Definition.Set.add definition definitions) + what_to_specialise.set_of_closures.specialised_args + Definition.Set.empty) + what_to_specialise.set_of_closures.function_decls.funs + in + let t : t = + { set_of_closures = what_to_specialise.set_of_closures; + existing_definitions_via_spec_args_indexed_by_fun_var; + new_lifted_defns_indexed_by_new_outer_vars = Variable.Map.empty; + new_outer_vars_indexed_by_new_lifted_defns = Projection.Map.empty; + functions = Variable.Map.empty; + make_direct_call_surrogates_for = + what_to_specialise.make_direct_call_surrogates_for; + } + in + (* It is important to limit the number of arguments added: if arguments + end up being passed on the stack, tail call optimization will be + disabled (see asmcomp/selectgen.ml). + For each group of new specialised args provided by [T], either all or + none of them will be added. (This is to avoid the situation where we + add extra arguments but yet fail to eliminate an original one by + stopping part-way through the specialised args addition.) *) + let by_group = + Variable.Pair.Map.fold (fun (fun_var, group) definitions by_group -> + let fun_vars_and_definitions = + match Variable.Map.find group by_group with + | exception Not_found -> [] + | fun_vars_and_definitions -> fun_vars_and_definitions + in + Variable.Map.add group + ((fun_var, definitions)::fun_vars_and_definitions) + by_group) + what_to_specialise.definitions + Variable.Map.empty + in + let module Backend = (val (E.backend env) : Backend_intf.S) in + Variable.Map.fold (fun group fun_vars_and_definitions t -> + let original_t = t in + let t = + (* Try adding all specialised args in the current group. *) + List.fold_left (fun t (fun_var, definitions) -> + List.fold_left (fun t definition -> + new_specialised_arg t ~fun_var ~group ~definition) + t + definitions) + t + fun_vars_and_definitions + in + let some_function_has_too_many_args = + Variable.Map.exists (fun _ (for_one_function : for_one_function) -> + for_one_function.total_number_of_args + > Backend.max_sensible_number_of_arguments) + t.functions + in + if some_function_has_too_many_args then + original_t (* drop this group *) + else + t) + by_group + t +end + +module P = Processed_what_to_specialise + +let check_invariants ~pass_name ~(set_of_closures : Flambda.set_of_closures) + ~original_set_of_closures = + if !Clflags.flambda_invariant_checks then begin + Variable.Map.iter (fun fun_var + (function_decl : Flambda.function_declaration) -> + let params = Parameter.Set.vars function_decl.params in + Variable.Map.iter (fun inner_var + (outer_var : Flambda.specialised_to) -> + if Variable.Set.mem inner_var params then begin + assert (not (Variable.Set.mem outer_var.var + function_decl.free_variables)); + match outer_var.projection with + | None -> () + | Some projection -> + let from = Projection.projecting_from projection in + if not (Variable.Set.mem from params) then begin + Misc.fatal_errorf "Augment_specialised_args (%s): \ + specialised argument (%a -> %a) references a \ + projection variable that is not a specialised \ + argument of the function %a. @ The set of closures \ + before the transformation was:@ %a. @ The set of \ + closures after the transformation was:@ %a." + pass_name + Variable.print inner_var + Flambda.print_specialised_to outer_var + Variable.print fun_var + Flambda.print_set_of_closures original_set_of_closures + Flambda.print_set_of_closures set_of_closures + end + end) + set_of_closures.specialised_args) + set_of_closures.function_decls.funs + end + +module Make (T : S) = struct + let () = Pass_wrapper.register ~pass_name:T.pass_name + + let rename_function_and_parameters ~fun_var + ~(function_decl : Flambda.function_declaration) = + let new_fun_var = Variable.rename fun_var in + let params_renaming_list = + List.map (fun param -> + let new_param = Parameter.rename param in + param, new_param) + function_decl.params + in + let renamed_params = List.map snd params_renaming_list in + let params_renaming = + Variable.Map.of_list + (List.map (fun (param, new_param) -> + Parameter.var param, Parameter.var new_param) + params_renaming_list) + in + new_fun_var, params_renaming, renamed_params + + let create_wrapper ~(for_one_function : P.for_one_function) ~benefit = + let fun_var = for_one_function.fun_var in + let function_decl = for_one_function.function_decl in + (* To avoid increasing the free variables of the wrapper, for + general cleanliness, we restate the definitions of the + newly-specialised arguments in the wrapper itself in terms of the + original specialised arguments. The variables bound to these + definitions are called the "specialised args bound in the wrapper". + Note that the domain of [params_renaming] is a (non-strict) superset + of the "inner vars" of the original specialised args. *) + let params = Parameter.Set.vars function_decl.params in + let new_fun_var, params_renaming, wrapper_params = + rename_function_and_parameters ~fun_var ~function_decl + in + let find_wrapper_param param = + assert (Variable.Set.mem param params); + match Variable.Map.find param params_renaming with + | wrapper_param -> wrapper_param + | exception Not_found -> + Misc.fatal_errorf "find_wrapper_param: expected %a \ + to be in [params_renaming], but it is not." + Variable.print param + in + let new_inner_vars_to_spec_args_bound_in_the_wrapper_renaming = + Variable.Map.mapi (fun new_inner_var _ -> + Variable.rename new_inner_var) + for_one_function.new_definitions_indexed_by_new_inner_vars + in + let spec_args_bound_in_the_wrapper = + (* N.B.: in the order matching the new specialised argument parameters + to the main function. *) + Variable.Map.data + new_inner_vars_to_spec_args_bound_in_the_wrapper_renaming + in + (* New definitions that project from existing specialised args need + to be rewritten to use the corresponding specialised args of + the wrapper. Definitions that are just equality to existing + inner free variables do not need to be changed. Once this has + been done the wrapper body can be constructed. + We also need to rewrite definitions for any existing specialised + args; these now have corresponding wrapper parameters that must + also be specialised. *) + let wrapper_body, benefit = + let apply : Flambda.expr = + Apply { + func = new_fun_var; + args = + (Parameter.List.vars wrapper_params) @ + spec_args_bound_in_the_wrapper; + kind = Direct (Closure_id.wrap new_fun_var); + dbg = Debuginfo.none; + inline = Default_inline; + specialise = Default_specialise; + } + in + Variable.Map.fold (fun new_inner_var definition (wrapper_body, benefit) -> + let definition : Definition.t = + match (definition : Definition.t) with + | Existing_inner_free_var _ -> definition + | Projection_from_existing_specialised_arg projection -> + Projection_from_existing_specialised_arg + (Projection.map_projecting_from projection + ~f:find_wrapper_param) + in + let benefit = + match (definition : Definition.t) with + | Existing_inner_free_var _ -> benefit + | Projection_from_existing_specialised_arg projection -> + B.add_projection projection benefit + in + match + Variable.Map.find new_inner_var + new_inner_vars_to_spec_args_bound_in_the_wrapper_renaming + with + | exception Not_found -> assert false + | new_inner_var_of_wrapper -> + let named : Flambda.named = + match definition with + | Existing_inner_free_var existing_inner_var -> + Expr (Var existing_inner_var) + | Projection_from_existing_specialised_arg projection -> + Flambda_utils.projection_to_named projection + in + let wrapper_body = + Flambda.create_let new_inner_var_of_wrapper named wrapper_body + in + (wrapper_body, benefit)) + for_one_function.new_definitions_indexed_by_new_inner_vars + (apply, benefit) + in + let rewritten_existing_specialised_args = + Variable.Map.fold (fun inner_var (spec_to : Flambda.specialised_to) + result -> + let inner_var = find_wrapper_param inner_var in + let projection = + match spec_to.projection with + | None -> None + | Some projection -> + Some (Projection.map_projecting_from projection + ~f:find_wrapper_param) + in + let spec_to : Flambda.specialised_to = + { var = spec_to.var; + projection; + } + in + Variable.Map.add inner_var spec_to result) + for_one_function.existing_specialised_args + Variable.Map.empty + in + let new_function_decl = + Flambda.create_function_declaration + ~params:wrapper_params + ~body:wrapper_body + ~stub:true + ~dbg:Debuginfo.none + ~inline:Default_inline + ~specialise:Default_specialise + ~is_a_functor:false + ~closure_origin:function_decl.closure_origin + in + new_fun_var, new_function_decl, rewritten_existing_specialised_args, + benefit + + let rewrite_function_decl (t : P.t) ~env ~duplicate_function + ~(for_one_function : P.for_one_function) ~benefit = + let set_of_closures = t.set_of_closures in + let fun_var = for_one_function.fun_var in + let function_decl = for_one_function.function_decl in + let num_definitions = + Variable.Map.cardinal for_one_function. + new_definitions_indexed_by_new_inner_vars + in + if function_decl.stub + || num_definitions < 1 + || Variable.Map.mem fun_var set_of_closures.direct_call_surrogates + then + None + else + let new_fun_var, wrapper, rewritten_existing_specialised_args, benefit = + create_wrapper ~for_one_function ~benefit + in + let new_specialised_args = + Variable.Map.mapi (fun new_inner_var (definition : Definition.t) + : Flambda.specialised_to -> + assert (not (Variable.Map.mem new_inner_var + set_of_closures.specialised_args)); + match + Variable.Map.find new_inner_var + for_one_function.new_inner_to_new_outer_vars + with + | exception Not_found -> assert false + | new_outer_var -> + match definition with + | Existing_inner_free_var _ -> + { var = new_outer_var; + projection = None; + } + | Projection_from_existing_specialised_arg projection -> + let projecting_from = Projection.projecting_from projection in + assert (Variable.Map.mem projecting_from + set_of_closures.specialised_args); + assert (Variable.Set.mem projecting_from + (Parameter.Set.vars function_decl.params)); + { var = new_outer_var; + projection = Some projection; + }) + for_one_function.new_definitions_indexed_by_new_inner_vars + in + let specialised_args = + Variable.Map.disjoint_union rewritten_existing_specialised_args + new_specialised_args + in + let specialised_args, existing_function_decl = + if not for_one_function.make_direct_call_surrogates then + specialised_args, None + else + let function_decl, new_specialised_args = + duplicate_function ~env ~set_of_closures ~fun_var ~new_fun_var + in + let specialised_args = + Variable.Map.disjoint_union specialised_args new_specialised_args + in + specialised_args, Some function_decl + in + let all_params = + let new_params = + Variable.Set.elements (Variable.Map.keys + for_one_function.new_inner_to_new_outer_vars) + in + let new_params = + List.map Parameter.wrap new_params + in + function_decl.params @ new_params + in + let closure_origin = + Closure_origin.create (Closure_id.wrap new_fun_var) + in + let rewritten_function_decl = + Flambda.create_function_declaration + ~params:all_params + ~body:function_decl.body + ~stub:function_decl.stub + ~dbg:function_decl.dbg + ~inline:function_decl.inline + ~specialise:function_decl.specialise + ~is_a_functor:function_decl.is_a_functor + ~closure_origin + in + let funs, direct_call_surrogates = + if for_one_function.make_direct_call_surrogates then + let surrogate = Variable.rename fun_var in + let funs = + (* In this case, the original function declaration remains + untouched up to alpha-equivalence. Direct calls to it + (including inside the rewritten original function) will be + replaced by calls to the surrogate (i.e. the wrapper) which + will then be inlined. *) + let existing_function_decl = + match existing_function_decl with + | Some decl -> decl + | None -> assert false + in + Variable.Map.add new_fun_var rewritten_function_decl + (Variable.Map.add surrogate wrapper + (Variable.Map.add fun_var existing_function_decl + Variable.Map.empty)) + in + let direct_call_surrogates = + Variable.Map.add fun_var surrogate Variable.Map.empty + in + funs, direct_call_surrogates + else + let funs = + Variable.Map.add new_fun_var rewritten_function_decl + (Variable.Map.add fun_var wrapper Variable.Map.empty) + in + funs, Variable.Map.empty + in + let free_vars = Variable.Map.empty in + Some (funs, free_vars, specialised_args, direct_call_surrogates, benefit) + + let add_lifted_projections_around_set_of_closures + ~(set_of_closures : Flambda.set_of_closures) ~benefit + ~new_lifted_defns_indexed_by_new_outer_vars = + let body = + Flambda_utils.name_expr + ~name:Internal_variable_names.set_of_closures + (Set_of_closures set_of_closures) + in + Variable.Map.fold (fun new_outer_var (projection : Projection.t) + (expr, benefit) -> + let named = Flambda_utils.projection_to_named projection in + let benefit = B.add_projection projection benefit in + let expr = Flambda.create_let new_outer_var named expr in + expr, benefit) + new_lifted_defns_indexed_by_new_outer_vars + (body, benefit) + + let rewrite_set_of_closures_core ~env ~duplicate_function ~benefit + ~(set_of_closures : Flambda.set_of_closures) = + let what_to_specialise = + P.create ~env + ~what_to_specialise:(T.what_to_specialise ~env ~set_of_closures) + in + let original_set_of_closures = set_of_closures in + let funs, free_vars, specialised_args, direct_call_surrogates, + done_something, benefit = + Variable.Map.fold (fun fun_var function_decl + (funs, free_vars, specialised_args, direct_call_surrogates, + done_something, benefit) -> + match Variable.Map.find fun_var what_to_specialise.functions with + | exception Not_found -> + let funs = Variable.Map.add fun_var function_decl funs in + funs, free_vars, specialised_args, direct_call_surrogates, + done_something, benefit + | (for_one_function : P.for_one_function) -> + assert (Variable.equal fun_var for_one_function.fun_var); + match + rewrite_function_decl what_to_specialise ~env + ~duplicate_function ~for_one_function ~benefit + with + | None -> + let function_decl = for_one_function.function_decl in + let funs = Variable.Map.add fun_var function_decl funs in + funs, free_vars, specialised_args, direct_call_surrogates, + done_something, benefit + | Some (funs', free_vars', specialised_args', + direct_call_surrogates', benefit) -> + let funs = Variable.Map.disjoint_union funs funs' in + let direct_call_surrogates = + Variable.Map.disjoint_union direct_call_surrogates + direct_call_surrogates' + in + let free_vars = + Variable.Map.disjoint_union free_vars free_vars' + in + let specialised_args = + Variable.Map.disjoint_union specialised_args specialised_args' + in + funs, free_vars, specialised_args, direct_call_surrogates, true, + benefit) + set_of_closures.function_decls.funs + (Variable.Map.empty, set_of_closures.free_vars, + set_of_closures.specialised_args, + set_of_closures.direct_call_surrogates, false, benefit) + in + if not done_something then + None + else + let function_decls = + Flambda.update_function_declarations set_of_closures.function_decls + ~funs + in + assert (Variable.Map.cardinal specialised_args + >= Variable.Map.cardinal original_set_of_closures.specialised_args); + let set_of_closures = + Flambda.create_set_of_closures + ~function_decls + ~free_vars + ~specialised_args + ~direct_call_surrogates + in + if !Clflags.flambda_invariant_checks then begin + check_invariants ~set_of_closures ~original_set_of_closures + ~pass_name:T.pass_name + end; + let expr, benefit = + add_lifted_projections_around_set_of_closures ~set_of_closures ~benefit + ~new_lifted_defns_indexed_by_new_outer_vars: + what_to_specialise.new_lifted_defns_indexed_by_new_outer_vars + in + Some (expr, benefit) + + let rewrite_set_of_closures ~env ~duplicate_function ~set_of_closures = + Pass_wrapper.with_dump ~ppf_dump:(Inline_and_simplify_aux.Env.ppf_dump env) + ~pass_name:T.pass_name ~input:set_of_closures + ~print_input:Flambda.print_set_of_closures + ~print_output:(fun ppf (expr, _) -> Flambda.print ppf expr) + ~f:(fun () -> + rewrite_set_of_closures_core ~env ~duplicate_function + ~benefit:B.zero ~set_of_closures) +end diff --git a/middle_end/flambda/augment_specialised_args.mli b/middle_end/flambda/augment_specialised_args.mli new file mode 100644 index 0000000000..5c48a12652 --- /dev/null +++ b/middle_end/flambda/augment_specialised_args.mli @@ -0,0 +1,65 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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. *) +(* *) +(**************************************************************************) + +(** Helper module for adding specialised arguments to sets of closures. *) + +module Definition : sig + type t = + | Existing_inner_free_var of Variable.t + | Projection_from_existing_specialised_arg of Projection.t +end + +module What_to_specialise : sig + type t + + val create + : set_of_closures:Flambda.set_of_closures + -> t + + val new_specialised_arg + : t + -> fun_var:Variable.t + -> group:Variable.t + -> definition:Definition.t (* [projecting_from] "existing inner vars" *) + -> t + + val make_direct_call_surrogate_for : t -> fun_var:Variable.t -> t +end + +module type S = sig + val pass_name : string + + val what_to_specialise + : env:Inline_and_simplify_aux.Env.t + -> set_of_closures:Flambda.set_of_closures + -> What_to_specialise.t +end + +module Make (T : S) : sig + (** [duplicate_function] should be + [Inline_and_simplify.duplicate_function]. *) + val rewrite_set_of_closures + : env:Inline_and_simplify_aux.Env.t + -> duplicate_function:( + env:Inline_and_simplify_aux.Env.t + -> set_of_closures:Flambda.set_of_closures + -> fun_var:Variable.t + -> new_fun_var:Variable.t + -> Flambda.function_declaration + * Flambda.specialised_to Variable.Map.t) + -> set_of_closures:Flambda.set_of_closures + -> (Flambda.expr * Inlining_cost.Benefit.t) option +end diff --git a/middle_end/flambda/base_types/closure_element.ml b/middle_end/flambda/base_types/closure_element.ml new file mode 100644 index 0000000000..561e080396 --- /dev/null +++ b/middle_end/flambda/base_types/closure_element.ml @@ -0,0 +1,26 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +include Variable + +let wrap t = t +let unwrap t = t + +let wrap_map t = t +let unwrap_set t = t diff --git a/middle_end/flambda/base_types/closure_element.mli b/middle_end/flambda/base_types/closure_element.mli new file mode 100644 index 0000000000..d78dd9b369 --- /dev/null +++ b/middle_end/flambda/base_types/closure_element.mli @@ -0,0 +1,32 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +include Identifiable.S + +val wrap : Variable.t -> t +val unwrap : t -> Variable.t + +val wrap_map : 'a Variable.Map.t -> 'a Map.t +val unwrap_set : Set.t -> Variable.Set.t + +val in_compilation_unit : t -> Compilation_unit.t -> bool +val get_compilation_unit : t -> Compilation_unit.t + +val unique_name : t -> string + +val output_full : out_channel -> t -> unit diff --git a/middle_end/flambda/base_types/closure_id.ml b/middle_end/flambda/base_types/closure_id.ml new file mode 100644 index 0000000000..466f59a237 --- /dev/null +++ b/middle_end/flambda/base_types/closure_id.ml @@ -0,0 +1,20 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +include Closure_element diff --git a/middle_end/flambda/base_types/closure_id.mli b/middle_end/flambda/base_types/closure_id.mli new file mode 100644 index 0000000000..853a07f7f4 --- /dev/null +++ b/middle_end/flambda/base_types/closure_id.mli @@ -0,0 +1,27 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(** CR-someday lwhite: "Closure_id" is quite a generic name. I wonder + whether something like "Closure_label" would better capture that it is + the label of a projection. *) + +(** An identifier, unique across the whole program (not just one compilation + unit), that identifies a closure within a particular set of closures + (viz. [Project_closure]). *) + +include module type of Closure_element diff --git a/middle_end/flambda/base_types/closure_origin.ml b/middle_end/flambda/base_types/closure_origin.ml new file mode 100644 index 0000000000..2285c687e3 --- /dev/null +++ b/middle_end/flambda/base_types/closure_origin.ml @@ -0,0 +1,22 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell, Leo White and Fu Yong Quah, Jane Street Europe *) +(* *) +(* Copyright 2013--2017 OCamlPro SAS *) +(* Copyright 2014--2017 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +include Closure_id + +let create t = t diff --git a/middle_end/flambda/base_types/closure_origin.mli b/middle_end/flambda/base_types/closure_origin.mli new file mode 100644 index 0000000000..86fcd56cc6 --- /dev/null +++ b/middle_end/flambda/base_types/closure_origin.mli @@ -0,0 +1,21 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell, Leo White and Fu Yong Quah, Jane Street Europe *) +(* *) +(* Copyright 2013--2017 OCamlPro SAS *) +(* Copyright 2014--2017 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. *) +(* *) +(**************************************************************************) + +include Identifiable.S + +val create : Closure_id.t -> t + +val get_compilation_unit : t -> Compilation_unit.t diff --git a/middle_end/flambda/base_types/export_id.ml b/middle_end/flambda/base_types/export_id.ml new file mode 100644 index 0000000000..681ac955af --- /dev/null +++ b/middle_end/flambda/base_types/export_id.ml @@ -0,0 +1,29 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +module Id : Id_types.Id = Id_types.Id (struct end) +module Unit_id = Id_types.UnitId (Id) (Compilation_unit) + +type t = Unit_id.t + +include Identifiable.Make (Unit_id) + +let create = Unit_id.create +let get_compilation_unit = Unit_id.unit +let name = Unit_id.name diff --git a/middle_end/flambda/base_types/export_id.mli b/middle_end/flambda/base_types/export_id.mli new file mode 100644 index 0000000000..54c14418e4 --- /dev/null +++ b/middle_end/flambda/base_types/export_id.mli @@ -0,0 +1,28 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(* Keys representing value descriptions that may be written into + intermediate files and loaded by a dependent compilation unit. + These keys are used to ensure maximal sharing of value descriptions, + which may be substantial. *) + +include Identifiable.S + +val create : ?name:string -> Compilation_unit.t -> t +val name : t -> string option +val get_compilation_unit : t -> Compilation_unit.t diff --git a/middle_end/flambda/base_types/id_types.ml b/middle_end/flambda/base_types/id_types.ml new file mode 100644 index 0000000000..6d2e274311 --- /dev/null +++ b/middle_end/flambda/base_types/id_types.ml @@ -0,0 +1,93 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +module type BaseId = sig + type t + val equal : t -> t -> bool + val compare : t -> t -> int + val hash : t -> int + val name : t -> string option + val to_string : t -> string + val output : out_channel -> t -> unit + val print : Format.formatter -> t -> unit +end + +module type Id = sig + include BaseId + val create : ?name:string -> unit -> t +end + +module type UnitId = sig + module Compilation_unit : Identifiable.Thing + include BaseId + val create : ?name:string -> Compilation_unit.t -> t + val unit : t -> Compilation_unit.t +end + +module Id(E:sig end) : Id = struct + type t = int * string + let empty_string = "" + let create = let r = ref 0 in + fun ?(name=empty_string) () -> incr r; !r, name + let equal (t1,_) (t2,_) = (t1:int) = t2 + let compare (t1,_) (t2,_) = t1 - t2 + let hash (t,_) = t + let name (_,name) = + if name == empty_string + then None + else Some name + let to_string (t,name) = + if name == empty_string + then Int.to_string t + else Printf.sprintf "%s_%i" name t + let output fd t = output_string fd (to_string t) + let print ppf v = Format.pp_print_string ppf (to_string v) +end + +module UnitId(Innerid:Id)(Compilation_unit:Identifiable.Thing) : + UnitId with module Compilation_unit := Compilation_unit = struct + type t = { + id : Innerid.t; + unit : Compilation_unit.t; + } + let compare x y = + let c = Innerid.compare x.id y.id in + if c <> 0 + then c + else Compilation_unit.compare x.unit y.unit + let output oc x = + Printf.fprintf oc "%a.%a" + Compilation_unit.output x.unit + Innerid.output x.id + let print ppf x = + Format.fprintf ppf "%a.%a" + Compilation_unit.print x.unit + Innerid.print x.id + let hash off = Hashtbl.hash off + let equal o1 o2 = compare o1 o2 = 0 + let name o = Innerid.name o.id + let to_string x = + Format.asprintf "%a.%a" + Compilation_unit.print x.unit + Innerid.print x.id + let create ?name unit = + let id = Innerid.create ?name () in + { id; unit } + let unit x = x.unit +end diff --git a/middle_end/flambda/base_types/id_types.mli b/middle_end/flambda/base_types/id_types.mli new file mode 100644 index 0000000000..48ca037caf --- /dev/null +++ b/middle_end/flambda/base_types/id_types.mli @@ -0,0 +1,56 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(* CR-soon mshinwell: This module should be removed. *) + +(** Generic identifier type *) +module type BaseId = +sig + type t + val equal : t -> t -> bool + val compare : t -> t -> int + val hash : t -> int + val name : t -> string option + val to_string : t -> string + val output : out_channel -> t -> unit + val print : Format.formatter -> t -> unit +end + +module type Id = +sig + include BaseId + val create : ?name:string -> unit -> t +end + +(** Fully qualified identifiers *) +module type UnitId = +sig + module Compilation_unit : Identifiable.Thing + include BaseId + val create : ?name:string -> Compilation_unit.t -> t + val unit : t -> Compilation_unit.t +end + +(** If applied generatively, i.e. [Id(struct end)], creates a new type + of identifiers. *) +module Id : functor (E : sig end) -> Id + +module UnitId : + functor (Id : Id) -> + functor (Compilation_unit : Identifiable.Thing) -> + UnitId with module Compilation_unit := Compilation_unit diff --git a/middle_end/flambda/base_types/mutable_variable.ml b/middle_end/flambda/base_types/mutable_variable.ml new file mode 100644 index 0000000000..07fe3152da --- /dev/null +++ b/middle_end/flambda/base_types/mutable_variable.ml @@ -0,0 +1,22 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +include Variable + +let create_from_variable = rename diff --git a/middle_end/flambda/base_types/mutable_variable.mli b/middle_end/flambda/base_types/mutable_variable.mli new file mode 100644 index 0000000000..17fe208fe0 --- /dev/null +++ b/middle_end/flambda/base_types/mutable_variable.mli @@ -0,0 +1,47 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +include Identifiable.S + +val create + : ?current_compilation_unit:Compilation_unit.t + -> Internal_variable_names.t + -> t + +val create_with_same_name_as_ident : Ident.t -> t + +val create_from_variable + : ?current_compilation_unit:Compilation_unit.t + -> Variable.t + -> t + +val rename + : ?current_compilation_unit:Compilation_unit.t + -> t + -> t + +val in_compilation_unit : t -> Compilation_unit.t -> bool + +val name : t -> string + +val unique_name : t -> string + +val print_list : Format.formatter -> t list -> unit +val print_opt : Format.formatter -> t option -> unit + +val output_full : out_channel -> t -> unit diff --git a/middle_end/flambda/base_types/set_of_closures_id.ml b/middle_end/flambda/base_types/set_of_closures_id.ml new file mode 100644 index 0000000000..681ac955af --- /dev/null +++ b/middle_end/flambda/base_types/set_of_closures_id.ml @@ -0,0 +1,29 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +module Id : Id_types.Id = Id_types.Id (struct end) +module Unit_id = Id_types.UnitId (Id) (Compilation_unit) + +type t = Unit_id.t + +include Identifiable.Make (Unit_id) + +let create = Unit_id.create +let get_compilation_unit = Unit_id.unit +let name = Unit_id.name diff --git a/middle_end/flambda/base_types/set_of_closures_id.mli b/middle_end/flambda/base_types/set_of_closures_id.mli new file mode 100644 index 0000000000..811cb66102 --- /dev/null +++ b/middle_end/flambda/base_types/set_of_closures_id.mli @@ -0,0 +1,26 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(** An identifier, unique across the whole program, that identifies a set + of closures (viz. [Set_of_closures]). *) + +include Identifiable.S + +val create : ?name:string -> Compilation_unit.t -> t +val name : t -> string option +val get_compilation_unit : t -> Compilation_unit.t diff --git a/middle_end/flambda/base_types/set_of_closures_origin.ml b/middle_end/flambda/base_types/set_of_closures_origin.ml new file mode 100644 index 0000000000..a5ef8c7c3d --- /dev/null +++ b/middle_end/flambda/base_types/set_of_closures_origin.ml @@ -0,0 +1,23 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +include Set_of_closures_id + +let create t = t +let rename f t = f t diff --git a/middle_end/flambda/base_types/set_of_closures_origin.mli b/middle_end/flambda/base_types/set_of_closures_origin.mli new file mode 100644 index 0000000000..4c9cfdcf80 --- /dev/null +++ b/middle_end/flambda/base_types/set_of_closures_origin.mli @@ -0,0 +1,22 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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. *) +(* *) +(**************************************************************************) + +include Identifiable.S + +val create : Set_of_closures_id.t -> t + +val get_compilation_unit : t -> Compilation_unit.t +val rename : (Set_of_closures_id.t -> Set_of_closures_id.t) -> t -> t diff --git a/middle_end/flambda/base_types/static_exception.ml b/middle_end/flambda/base_types/static_exception.ml new file mode 100644 index 0000000000..6cecae6328 --- /dev/null +++ b/middle_end/flambda/base_types/static_exception.ml @@ -0,0 +1,23 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +include Numbers.Int + +let create () = Lambda.next_raise_count () +let to_int t = t diff --git a/middle_end/flambda/base_types/static_exception.mli b/middle_end/flambda/base_types/static_exception.mli new file mode 100644 index 0000000000..88f690aa10 --- /dev/null +++ b/middle_end/flambda/base_types/static_exception.mli @@ -0,0 +1,26 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(** An identifier that is used to label static exceptions. Its + uniqueness properties are unspecified. *) + +include Identifiable.S + +val create : unit -> t + +val to_int : t -> int diff --git a/middle_end/flambda/base_types/tag.ml b/middle_end/flambda/base_types/tag.ml new file mode 100644 index 0000000000..cfa51ddbb2 --- /dev/null +++ b/middle_end/flambda/base_types/tag.ml @@ -0,0 +1,35 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +type t = int + +include Identifiable.Make (Numbers.Int) + +let create_exn tag = + if tag < 0 || tag > 255 then + Misc.fatal_error (Printf.sprintf "Tag.create_exn %d" tag) + else + tag + +let to_int t = t + +let zero = 0 +let object_tag = Obj.object_tag + +let compare : t -> t -> int = Stdlib.compare diff --git a/middle_end/flambda/base_types/tag.mli b/middle_end/flambda/base_types/tag.mli new file mode 100644 index 0000000000..12ce55255c --- /dev/null +++ b/middle_end/flambda/base_types/tag.mli @@ -0,0 +1,29 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(** Tags on runtime boxed values. *) + +include Identifiable.S + +val create_exn : int -> t +val to_int : t -> int + +val zero : t +val object_tag : t + +val compare : t -> t -> int diff --git a/middle_end/flambda/base_types/var_within_closure.ml b/middle_end/flambda/base_types/var_within_closure.ml new file mode 100644 index 0000000000..466f59a237 --- /dev/null +++ b/middle_end/flambda/base_types/var_within_closure.ml @@ -0,0 +1,20 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +include Closure_element diff --git a/middle_end/flambda/base_types/var_within_closure.mli b/middle_end/flambda/base_types/var_within_closure.mli new file mode 100644 index 0000000000..56f0af0ad6 --- /dev/null +++ b/middle_end/flambda/base_types/var_within_closure.mli @@ -0,0 +1,24 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(** An identifier, unique across the whole program, that identifies a + particular variable within a particular closure. Only + [Project_var], and not [Var], nodes are tagged with these + identifiers. *) + +include module type of Closure_element diff --git a/middle_end/flambda/build_export_info.ml b/middle_end/flambda/build_export_info.ml new file mode 100644 index 0000000000..c3d811deea --- /dev/null +++ b/middle_end/flambda/build_export_info.ml @@ -0,0 +1,711 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +module Env : sig + type t + + val new_descr : t -> Export_info.descr -> Export_id.t + + val record_descr : t -> Export_id.t -> Export_info.descr -> unit + val new_value_closure_descr + : t + -> closure_id:Closure_id.t + -> set_of_closures: Export_info.value_set_of_closures + -> Export_id.t + + val get_descr : t -> Export_info.approx -> Export_info.descr option + + val add_approx : t -> Variable.t -> Export_info.approx -> t + val add_approx_maps : t -> Export_info.approx Variable.Map.t list -> t + val find_approx : t -> Variable.t -> Export_info.approx + + val get_symbol_descr : t -> Symbol.t -> Export_info.descr option + + val new_unit_descr : t -> Export_id.t + + module Global : sig + (* "Global" as in "without local variable bindings". *) + type t + + val create_empty : unit -> t + + val add_symbol : t -> Symbol.t -> Export_id.t -> t + val new_symbol : t -> Symbol.t -> Export_id.t * t + + val symbol_to_export_id_map : t -> Export_id.t Symbol.Map.t + val export_id_to_descr_map : t -> Export_info.descr Export_id.Map.t + end + + (** Creates a new environment, sharing the mapping from export IDs to + export descriptions with the given global environment. *) + val empty_of_global : Global.t -> t +end = struct + let fresh_id () = Export_id.create (Compilenv.current_unit ()) + + module Global = struct + type t = + { sym : Export_id.t Symbol.Map.t; + (* Note that [ex_table]s themselves are shared (hence [ref] and not + [mutable]). *) + ex_table : Export_info.descr Export_id.Map.t ref; + closure_table : Export_id.t Closure_id.Map.t ref; + } + + let create_empty () = + { sym = Symbol.Map.empty; + ex_table = ref Export_id.Map.empty; + closure_table = ref Closure_id.Map.empty; + } + + let add_symbol t sym export_id = + if Symbol.Map.mem sym t.sym then begin + Misc.fatal_errorf "Build_export_info.Env.Global.add_symbol: cannot \ + rebind symbol %a in environment" + Symbol.print sym + end; + { t with sym = Symbol.Map.add sym export_id t.sym } + + let new_symbol t sym = + let export_id = fresh_id () in + export_id, add_symbol t sym export_id + + let symbol_to_export_id_map t = t.sym + let export_id_to_descr_map t = !(t.ex_table) + end + + (* CR-someday mshinwell: The half-mutable nature of [t] with sharing of + the [ex_table] is kind of nasty. Consider making it immutable. *) + type t = + { var : Export_info.approx Variable.Map.t; + sym : Export_id.t Symbol.Map.t; + ex_table : Export_info.descr Export_id.Map.t ref; + closure_table: Export_id.t Closure_id.Map.t ref; + } + + let empty_of_global (env : Global.t) = + { var = Variable.Map.empty; + sym = env.sym; + ex_table = env.ex_table; + closure_table = env.closure_table; + } + + let extern_id_descr export_id = + let export = Compilenv.approx_env () in + try Some (Export_info.find_description export export_id) + with Not_found -> None + + let extern_symbol_descr sym = + if Compilenv.is_predefined_exception sym + then None + else + match + Compilenv.approx_for_global (Symbol.compilation_unit sym) + with + | None -> None + | Some export -> + try + let id = Symbol.Map.find sym export.symbol_id in + let descr = Export_info.find_description export id in + Some descr + with + | Not_found -> None + + let get_id_descr t export_id = + try Some (Export_id.Map.find export_id !(t.ex_table)) + with Not_found -> extern_id_descr export_id + + let get_symbol_descr t sym = + try + let export_id = Symbol.Map.find sym t.sym in + Some (Export_id.Map.find export_id !(t.ex_table)) + with + | Not_found -> extern_symbol_descr sym + + let get_descr t (approx : Export_info.approx) = + match approx with + | Value_unknown -> None + | Value_id export_id -> get_id_descr t export_id + | Value_symbol sym -> get_symbol_descr t sym + + let record_descr t id (descr : Export_info.descr) = + if Export_id.Map.mem id !(t.ex_table) then begin + Misc.fatal_errorf "Build_export_info.Env.record_descr: cannot rebind \ + export ID %a in environment" + Export_id.print id + end; + t.ex_table := Export_id.Map.add id descr !(t.ex_table) + + let new_descr t (descr : Export_info.descr) = + let id = fresh_id () in + record_descr t id descr; + id + + let new_value_closure_descr t ~closure_id ~set_of_closures = + match Closure_id.Map.find closure_id !(t.closure_table) with + | exception Not_found -> + let export_id = + new_descr t (Value_closure { closure_id; set_of_closures }) + in + t.closure_table := + Closure_id.Map.add closure_id export_id !(t.closure_table); + export_id + | export_id -> export_id + + let new_unit_descr t = + new_descr t (Value_constptr 0) + + let add_approx t var approx = + if Variable.Map.mem var t.var then begin + Misc.fatal_errorf "Build_export_info.Env.add_approx: cannot rebind \ + variable %a in environment" + Variable.print var + end; + { t with var = Variable.Map.add var approx t.var; } + + let add_approx_map t vars_to_approxs = + Variable.Map.fold (fun var approx t -> add_approx t var approx) + vars_to_approxs + t + + let add_approx_maps t vars_to_approxs_list = + List.fold_left add_approx_map t vars_to_approxs_list + + let find_approx t var : Export_info.approx = + try Variable.Map.find var t.var with + | Not_found -> Value_unknown +end + +let descr_of_constant (c : Flambda.const) : Export_info.descr = + match c with + (* [Const_pointer] is an immediate value of a type whose values may be + boxed (typically a variant type with both constant and non-constant + constructors). *) + | Int i -> Value_int i + | Char c -> Value_char c + | Const_pointer i -> Value_constptr i + +let descr_of_allocated_constant (c : Allocated_const.t) : Export_info.descr = + match c with + | Float f -> Value_float f + | Int32 i -> Value_boxed_int (Int32, i) + | Int64 i -> Value_boxed_int (Int64, i) + | Nativeint i -> Value_boxed_int (Nativeint, i) + | String s -> + let v_string : Export_info.value_string = + { size = String.length s; contents = Unknown_or_mutable; } + in + Value_string v_string + | Immutable_string s -> + let v_string : Export_info.value_string = + { size = String.length s; contents = Contents s; } + in + Value_string v_string + | Immutable_float_array fs -> + Value_float_array { + contents = Contents (Array.map (fun x -> Some x) (Array.of_list fs)); + size = List.length fs; + } + | Float_array fs -> + Value_float_array { + contents = Unknown_or_mutable; + size = List.length fs; + } + +let rec approx_of_expr (env : Env.t) (flam : Flambda.t) : Export_info.approx = + match flam with + | Var var -> Env.find_approx env var + | Let { var; defining_expr; body; _ } -> + let approx = descr_of_named env defining_expr in + let env = Env.add_approx env var approx in + approx_of_expr env body + | Let_mutable { body } -> + approx_of_expr env body + | Let_rec (defs, body) -> + let env = + List.fold_left (fun env (var, defining_expr) -> + let approx = descr_of_named env defining_expr in + Env.add_approx env var approx) + env defs + in + approx_of_expr env body + | Apply { func; kind; _ } -> + begin match kind with + | Indirect -> Value_unknown + | Direct closure_id' -> + match Env.get_descr env (Env.find_approx env func) with + | Some (Value_closure + { closure_id; set_of_closures = { results; _ }; }) -> + assert (Closure_id.equal closure_id closure_id'); + assert (Closure_id.Map.mem closure_id results); + Closure_id.Map.find closure_id results + | _ -> Value_unknown + end + | Assign _ -> Value_id (Env.new_unit_descr env) + | For _ -> Value_id (Env.new_unit_descr env) + | While _ -> Value_id (Env.new_unit_descr env) + | Static_raise _ | Static_catch _ | Try_with _ | If_then_else _ + | Switch _ | String_switch _ | Send _ | Proved_unreachable -> + Value_unknown + +and descr_of_named (env : Env.t) (named : Flambda.named) + : Export_info.approx = + match named with + | Expr expr -> approx_of_expr env expr + | Symbol sym -> Value_symbol sym + | Read_mutable _ -> Value_unknown + | Read_symbol_field (sym, i) -> + begin match Env.get_symbol_descr env sym with + | Some (Value_block (_, fields)) when Array.length fields > i -> fields.(i) + | _ -> Value_unknown + end + | Const const -> + Value_id (Env.new_descr env (descr_of_constant const)) + | Allocated_const const -> + Value_id (Env.new_descr env (descr_of_allocated_constant const)) + | Prim (Pmakeblock (tag, Immutable, _value_kind), args, _dbg) -> + let approxs = List.map (Env.find_approx env) args in + let descr : Export_info.descr = + Value_block (Tag.create_exn tag, Array.of_list approxs) + in + Value_id (Env.new_descr env descr) + | Prim (Pfield i, [arg], _) -> + begin match Env.get_descr env (Env.find_approx env arg) with + | Some (Value_block (_, fields)) when Array.length fields > i -> fields.(i) + | _ -> Value_unknown + end + | Prim _ -> Value_unknown + | Set_of_closures set -> + let descr : Export_info.descr = + Value_set_of_closures (describe_set_of_closures env set) + in + Value_id (Env.new_descr env descr) + | Project_closure { set_of_closures; closure_id; } -> + begin match Env.get_descr env (Env.find_approx env set_of_closures) with + | Some (Value_set_of_closures set_of_closures) -> + if not (Closure_id.Map.mem closure_id set_of_closures.results) then begin + Misc.fatal_errorf "Could not build export description for \ + [Project_closure]: closure ID %a not in set of closures" + Closure_id.print closure_id + end; + Value_id ( + Env.new_value_closure_descr env ~closure_id ~set_of_closures + ) + | _ -> + (* It would be nice if this were [assert false], but owing to the fact + that this pass may propagate less information than for example + [Inline_and_simplify], we might end up here. *) + Value_unknown + end + | Move_within_set_of_closures { closure; start_from; move_to; } -> + begin match Env.get_descr env (Env.find_approx env closure) with + | Some (Value_closure { set_of_closures; closure_id; }) -> + assert (Closure_id.equal closure_id start_from); + Value_id ( + Env.new_value_closure_descr env ~closure_id:move_to ~set_of_closures + ) + | _ -> Value_unknown + end + | Project_var { closure; closure_id = closure_id'; var; } -> + begin match Env.get_descr env (Env.find_approx env closure) with + | Some (Value_closure + { set_of_closures = { bound_vars; _ }; closure_id; }) -> + assert (Closure_id.equal closure_id closure_id'); + if not (Var_within_closure.Map.mem var bound_vars) then begin + Misc.fatal_errorf "Project_var from %a (closure ID %a) of \ + variable %a that is not bound by the closure. \ + Variables bound by the closure are: %a" + Variable.print closure + Closure_id.print closure_id + Var_within_closure.print var + (Var_within_closure.Map.print (fun _ _ -> ())) bound_vars + end; + Var_within_closure.Map.find var bound_vars + | _ -> Value_unknown + end + +and describe_set_of_closures env (set : Flambda.set_of_closures) + : Export_info.value_set_of_closures = + let bound_vars_approx = + Variable.Map.map (fun (external_var : Flambda.specialised_to) -> + Env.find_approx env external_var.var) + set.free_vars + in + let specialised_args_approx = + Variable.Map.map (fun (spec_to : Flambda.specialised_to) -> + Env.find_approx env spec_to.var) + set.specialised_args + in + let closures_approx = + (* To build an approximation of the results, we need an + approximation of the functions. The first one we can build is + one where every function returns something unknown. + *) + (* CR-someday pchambart: we could improve a bit on that by building a + recursive approximation of the closures: The value_closure + description contains a [value_set_of_closures]. We could replace + this field by a [Expr_id.t] or an [approx]. + mshinwell: Deferred for now. + *) + let initial_value_set_of_closures = + { Export_info. + set_of_closures_id = set.function_decls.set_of_closures_id; + bound_vars = Var_within_closure.wrap_map bound_vars_approx; + free_vars = set.free_vars; + results = + Closure_id.wrap_map + (Variable.Map.map (fun _ -> Export_info.Value_unknown) + set.function_decls.funs); + aliased_symbol = None; + } + in + Variable.Map.mapi (fun fun_var _function_decl -> + let export_id = + let closure_id = Closure_id.wrap fun_var in + let set_of_closures = initial_value_set_of_closures in + Env.new_value_closure_descr env ~closure_id ~set_of_closures + in + Export_info.Value_id export_id) + set.function_decls.funs + in + let closure_env = + Env.add_approx_maps env + [closures_approx; bound_vars_approx; specialised_args_approx] + in + let results = + let result_approx _var (function_decl : Flambda.function_declaration) = + approx_of_expr closure_env function_decl.body + in + Variable.Map.mapi result_approx set.function_decls.funs + in + { set_of_closures_id = set.function_decls.set_of_closures_id; + bound_vars = Var_within_closure.wrap_map bound_vars_approx; + free_vars = set.free_vars; + results = Closure_id.wrap_map results; + aliased_symbol = None; + } + +let approx_of_constant_defining_value_block_field env + (c : Flambda.constant_defining_value_block_field) : Export_info.approx = + match c with + | Symbol s -> Value_symbol s + | Const c -> Value_id (Env.new_descr env (descr_of_constant c)) + +let describe_constant_defining_value env export_id symbol + (const : Flambda.constant_defining_value) = + let env = + (* Assignments of variables to export IDs are local to each constant + defining value. *) + Env.empty_of_global env + in + match const with + | Allocated_const alloc_const -> + let descr = descr_of_allocated_constant alloc_const in + Env.record_descr env export_id descr + | Block (tag, fields) -> + let approxs = + List.map (approx_of_constant_defining_value_block_field env) fields + in + Env.record_descr env export_id (Value_block (tag, Array.of_list approxs)) + | Set_of_closures set_of_closures -> + let descr : Export_info.descr = + Value_set_of_closures + { (describe_set_of_closures env set_of_closures) with + aliased_symbol = Some symbol; + } + in + Env.record_descr env export_id descr + | Project_closure (sym, closure_id) -> + begin match Env.get_symbol_descr env sym with + | Some (Value_set_of_closures set_of_closures) -> + if not (Closure_id.Map.mem closure_id set_of_closures.results) then begin + Misc.fatal_errorf "Could not build export description for \ + [Project_closure] constant defining value: closure ID %a not in \ + set of closures" + Closure_id.print closure_id + end; + let descr = + Export_info.Value_closure + { closure_id = closure_id; set_of_closures; } + in + Env.record_descr env export_id descr + | None -> + Misc.fatal_errorf + "Cannot project symbol %a to closure_id %a. \ + No available export description@." + Symbol.print sym + Closure_id.print closure_id + | Some (Value_closure _) -> + Misc.fatal_errorf + "Cannot project symbol %a to closure_id %a. \ + The symbol is a closure instead of a set of closures.@." + Symbol.print sym + Closure_id.print closure_id + | Some _ -> + Misc.fatal_errorf + "Cannot project symbol %a to closure_id %a. \ + The symbol is not a set of closures.@." + Symbol.print sym + Closure_id.print closure_id + end + +let describe_program (env : Env.Global.t) (program : Flambda.program) = + let rec loop env (program : Flambda.program_body) = + match program with + | Let_symbol (symbol, constant_defining_value, program) -> + let id, env = Env.Global.new_symbol env symbol in + describe_constant_defining_value env id symbol constant_defining_value; + loop env program + | Let_rec_symbol (defs, program) -> + let env, defs = + List.fold_left (fun (env, defs) (symbol, def) -> + let id, env = Env.Global.new_symbol env symbol in + env, ((id, symbol, def) :: defs)) + (env, []) defs + in + (* [Project_closure]s are separated to be handled last. They are the + only values that need a description for their argument. *) + let project_closures, other_constants = + List.partition (function + | _, _, Flambda.Project_closure _ -> true + | _ -> false) + defs + in + List.iter (fun (id, symbol, def) -> + describe_constant_defining_value env id symbol def) + other_constants; + List.iter (fun (id, symbol, def) -> + describe_constant_defining_value env id symbol def) + project_closures; + loop env program + | Initialize_symbol (symbol, tag, fields, program) -> + let id = + let env = + (* Assignments of variables to export IDs are local to each + [Initialize_symbol] construction. *) + Env.empty_of_global env + in + let field_approxs = List.map (approx_of_expr env) fields in + let descr : Export_info.descr = + Value_block (tag, Array.of_list field_approxs) + in + Env.new_descr env descr + in + let env = Env.Global.add_symbol env symbol id in + loop env program + | Effect (_expr, program) -> loop env program + | End symbol -> symbol, env + in + loop env program.program_body + + +let build_transient ~(backend : (module Backend_intf.S)) + (program : Flambda.program) : Export_info.transient = + if !Clflags.opaque then + let compilation_unit = Compilenv.current_unit () in + let root_symbol = Compilenv.current_unit_symbol () in + Export_info.opaque_transient ~root_symbol ~compilation_unit + else + (* CR-soon pchambart: Should probably use that instead of the ident of + the module as global identifier. + mshinwell: Is "that" the variable "_global_symbol"? + Yes it is. We are just assuming that the symbol produced from + the identifier of the module is the right one. *) + let _global_symbol, env = + describe_program (Env.Global.create_empty ()) program + in + let sets_of_closures_map = + Flambda_utils.all_sets_of_closures_map program + in + let function_declarations_map = + let set_of_closures_approx { Flambda. function_decls; _ } = + let recursive = + lazy + (Find_recursive_functions.in_function_declarations + function_decls ~backend) + in + let keep_body = + Inline_and_simplify_aux.keep_body_check + ~is_classic_mode:function_decls.is_classic_mode ~recursive + in + Simple_value_approx.function_declarations_approx + ~keep_body function_decls + in + Set_of_closures_id.Map.map set_of_closures_approx sets_of_closures_map + in + let unnested_values = + Env.Global.export_id_to_descr_map env + in + let invariant_params = + let invariant_params = + Set_of_closures_id.Map.map + (fun { Flambda. function_decls; _ } -> + if function_decls.is_classic_mode then begin + Variable.Map.empty + end else begin + Invariant_params.invariant_params_in_recursion + ~backend function_decls + end) + (Flambda_utils.all_sets_of_closures_map program) + in + let export = Compilenv.approx_env () in + Export_id.Map.fold + (fun _eid (descr:Export_info.descr) invariant_params -> + match (descr : Export_info.descr) with + | Value_closure { set_of_closures } + | Value_set_of_closures set_of_closures -> + let { Export_info.set_of_closures_id } = set_of_closures in + begin match + Set_of_closures_id.Map.find set_of_closures_id + export.invariant_params + with + | exception Not_found -> + invariant_params + | (set : Variable.Set.t Variable.Map.t) -> + Set_of_closures_id.Map.add + set_of_closures_id set invariant_params + end + | Export_info.Value_boxed_int (_, _) + | Value_block _ + | Value_mutable_block _ + | Value_int _ + | Value_char _ + | Value_constptr _ + | Value_float _ + | Value_float_array _ + | Value_string _ + | Value_unknown_descr -> + invariant_params) + unnested_values invariant_params + in + let recursive = + let recursive = + Set_of_closures_id.Map.map + (fun { Flambda. function_decls; _ } -> + if function_decls.is_classic_mode then begin + Variable.Set.empty + end else begin + Find_recursive_functions.in_function_declarations + ~backend function_decls + end) + (Flambda_utils.all_sets_of_closures_map program) + in + let export = Compilenv.approx_env () in + Export_id.Map.fold + (fun _eid (descr:Export_info.descr) recursive -> + match (descr : Export_info.descr) with + | Value_closure { set_of_closures } + | Value_set_of_closures set_of_closures -> + let { Export_info.set_of_closures_id } = set_of_closures in + begin match + Set_of_closures_id.Map.find set_of_closures_id + export.recursive + with + | exception Not_found -> + recursive + | (set : Variable.Set.t) -> + Set_of_closures_id.Map.add + set_of_closures_id set recursive + end + | Export_info.Value_boxed_int (_, _) + | Value_block _ + | Value_mutable_block _ + | Value_int _ + | Value_char _ + | Value_constptr _ + | Value_float _ + | Value_float_array _ + | Value_string _ + | Value_unknown_descr -> + recursive) + unnested_values recursive + in + let values = Export_info.nest_eid_map unnested_values in + let symbol_id = Env.Global.symbol_to_export_id_map env in + let { Traverse_for_exported_symbols. + set_of_closure_ids = relevant_set_of_closures; + symbols = relevant_symbols; + export_ids = relevant_export_ids; + set_of_closure_ids_keep_declaration = + relevant_set_of_closures_declaration_only; + relevant_local_closure_ids; + relevant_imported_closure_ids; + relevant_local_vars_within_closure; + relevant_imported_vars_within_closure; + } = + let closure_id_to_set_of_closures_id = + Set_of_closures_id.Map.fold + (fun set_of_closure_id + (function_declarations : Simple_value_approx.function_declarations) + acc -> + Variable.Map.fold + (fun fun_var _ acc -> + let closure_id = Closure_id.wrap fun_var in + Closure_id.Map.add closure_id set_of_closure_id acc) + function_declarations.funs + acc) + function_declarations_map + Closure_id.Map.empty + in + Traverse_for_exported_symbols.traverse + ~sets_of_closures_map + ~closure_id_to_set_of_closures_id + ~function_declarations_map + ~values:(Compilation_unit.Map.find (Compilenv.current_unit ()) values) + ~symbol_id + ~root_symbol:(Compilenv.current_unit_symbol ()) + in + let sets_of_closures = + Set_of_closures_id.Map.filter_map + function_declarations_map + ~f:(fun key (fun_decls : Simple_value_approx.function_declarations) -> + if Set_of_closures_id.Set.mem key relevant_set_of_closures then + Some fun_decls + else if begin + Set_of_closures_id.Set.mem key + relevant_set_of_closures_declaration_only + end then begin + if fun_decls.is_classic_mode then + Some (Simple_value_approx.clear_function_bodies fun_decls) + else + Some fun_decls + end else begin + None + end) + in + + let values = + Compilation_unit.Map.map (fun map -> + Export_id.Map.filter (fun key _ -> + Export_id.Set.mem key relevant_export_ids) + map) + values + in + let symbol_id = + Symbol.Map.filter + (fun key _ -> Symbol.Set.mem key relevant_symbols) + symbol_id + in + Export_info.create_transient ~values + ~symbol_id + ~sets_of_closures + ~invariant_params + ~recursive + ~relevant_local_closure_ids + ~relevant_imported_closure_ids + ~relevant_local_vars_within_closure + ~relevant_imported_vars_within_closure diff --git a/middle_end/flambda/build_export_info.mli b/middle_end/flambda/build_export_info.mli new file mode 100644 index 0000000000..0380604bf8 --- /dev/null +++ b/middle_end/flambda/build_export_info.mli @@ -0,0 +1,25 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(** Construct export information, for emission into .cmx files, from an + Flambda program. *) + +val build_transient : + backend:(module Backend_intf.S) -> + Flambda.program -> + Export_info.transient diff --git a/middle_end/flambda/closure_conversion.ml b/middle_end/flambda/closure_conversion.ml new file mode 100644 index 0000000000..9bdd30ead9 --- /dev/null +++ b/middle_end/flambda/closure_conversion.ml @@ -0,0 +1,737 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +module Env = Closure_conversion_aux.Env +module Function_decls = Closure_conversion_aux.Function_decls +module Function_decl = Function_decls.Function_decl +module Names = Internal_variable_names + +let name_expr = Flambda_utils.name_expr +let name_expr_from_var = Flambda_utils.name_expr_from_var + +type t = { + current_unit_id : Ident.t; + symbol_for_global' : (Ident.t -> Symbol.t); + filename : string; + backend : (module Backend_intf.S); + mutable imported_symbols : Symbol.Set.t; + mutable declared_symbols : (Symbol.t * Flambda.constant_defining_value) list; +} + +let add_default_argument_wrappers lam = + let defs_are_all_functions (defs : (_ * Lambda.lambda) list) = + List.for_all (function (_, Lambda.Lfunction _) -> true | _ -> false) defs + in + let f (lam : Lambda.lambda) : Lambda.lambda = + match lam with + | Llet (( Strict | Alias | StrictOpt), _k, id, + Lfunction {kind; params; body = fbody; attr; loc}, body) -> + begin match + Simplif.split_default_wrapper ~id ~kind ~params + ~body:fbody ~return:Pgenval ~attr ~loc + with + | [fun_id, def] -> Llet (Alias, Pgenval, fun_id, def, body) + | [fun_id, def; inner_fun_id, def_inner] -> + Llet (Alias, Pgenval, inner_fun_id, def_inner, + Llet (Alias, Pgenval, fun_id, def, body)) + | _ -> assert false + end + | Lletrec (defs, body) as lam -> + if defs_are_all_functions defs then + let defs = + List.flatten + (List.map + (function + | (id, Lambda.Lfunction {kind; params; body; attr; loc}) -> + Simplif.split_default_wrapper ~id ~kind ~params ~body + ~return:Pgenval ~attr ~loc + | _ -> assert false) + defs) + in + Lletrec (defs, body) + else lam + | lam -> lam + in + Lambda.map f lam + +(** Generate a wrapper ("stub") function that accepts a tuple argument and + calls another function with arguments extracted in the obvious + manner from the tuple. *) +let tupled_function_call_stub original_params unboxed_version ~closure_bound_var + : Flambda.function_declaration = + let tuple_param_var = Variable.rename unboxed_version in + let params = List.map (fun p -> Variable.rename p) original_params in + let call : Flambda.t = + Apply ({ + func = unboxed_version; + args = params; + (* CR-someday mshinwell for mshinwell: investigate if there is some + redundancy here (func is also unboxed_version) *) + kind = Direct (Closure_id.wrap unboxed_version); + dbg = Debuginfo.none; + inline = Default_inline; + specialise = Default_specialise; + }) + in + let _, body = + List.fold_left (fun (pos, body) param -> + let lam : Flambda.named = + Prim (Pfield pos, [tuple_param_var], Debuginfo.none) + in + pos + 1, Flambda.create_let param lam body) + (0, call) params + in + let tuple_param = Parameter.wrap tuple_param_var in + Flambda.create_function_declaration ~params:[tuple_param] + ~body ~stub:true ~dbg:Debuginfo.none ~inline:Default_inline + ~specialise:Default_specialise ~is_a_functor:false + ~closure_origin:(Closure_origin.create (Closure_id.wrap closure_bound_var)) + +let register_const t (constant:Flambda.constant_defining_value) name + : Flambda.constant_defining_value_block_field * Internal_variable_names.t = + let var = Variable.create name in + let symbol = Symbol.of_variable var in + t.declared_symbols <- (symbol, constant) :: t.declared_symbols; + Symbol symbol, name + +let rec declare_const t (const : Lambda.structured_constant) + : Flambda.constant_defining_value_block_field * Internal_variable_names.t = + match const with + | Const_base (Const_int c) -> (Const (Int c), Names.const_int) + | Const_base (Const_char c) -> (Const (Char c), Names.const_char) + | Const_base (Const_string (s, _)) -> + let const, name = + if Config.safe_string then + (Flambda.Allocated_const (Immutable_string s), + Names.const_immstring) + else + (Flambda.Allocated_const (String s), + Names.const_string) + in + register_const t const name + | Const_base (Const_float c) -> + register_const t + (Allocated_const (Float (float_of_string c))) + Names.const_float + | Const_base (Const_int32 c) -> + register_const t (Allocated_const (Int32 c)) + Names.const_int32 + | Const_base (Const_int64 c) -> + register_const t (Allocated_const (Int64 c)) + Names.const_int64 + | Const_base (Const_nativeint c) -> + register_const t (Allocated_const (Nativeint c)) Names.const_nativeint + | Const_pointer c -> Const (Const_pointer c), Names.const_ptr + | Const_immstring c -> + register_const t (Allocated_const (Immutable_string c)) + Names.const_immstring + | Const_float_array c -> + register_const t + (Allocated_const (Immutable_float_array (List.map float_of_string c))) + Names.const_float_array + | Const_block (tag, consts) -> + let const : Flambda.constant_defining_value = + Block (Tag.create_exn tag, + List.map (fun c -> fst (declare_const t c)) consts) + in + register_const t const Names.const_block + +let close_const t (const : Lambda.structured_constant) + : Flambda.named * Internal_variable_names.t = + match declare_const t const with + | Const c, name -> + Const c, name + | Symbol s, name -> + Symbol s, name + +let lambda_const_bool b : Lambda.structured_constant = + if b then + Const_pointer 1 + else + Const_pointer 0 + +let lambda_const_int i : Lambda.structured_constant = + Const_base (Const_int i) + +let rec close t env (lam : Lambda.lambda) : Flambda.t = + match lam with + | Lvar id -> + begin match Env.find_var_exn env id with + | var -> Var var + | exception Not_found -> + match Env.find_mutable_var_exn env id with + | mut_var -> + name_expr (Read_mutable mut_var) ~name:Names.read_mutable + | exception Not_found -> + Misc.fatal_errorf "Closure_conversion.close: unbound identifier %a" + Ident.print id + end + | Lconst cst -> + let cst, name = close_const t cst in + name_expr cst ~name + | Llet ((Strict | Alias | StrictOpt), _value_kind, id, defining_expr, body) -> + (* TODO: keep value_kind in flambda *) + let var = Variable.create_with_same_name_as_ident id in + let defining_expr = + close_let_bound_expression t var env defining_expr + in + let body = close t (Env.add_var env id var) body in + Flambda.create_let var defining_expr body + | Llet (Variable, block_kind, id, defining_expr, body) -> + let mut_var = Mutable_variable.create_with_same_name_as_ident id in + let var = Variable.create_with_same_name_as_ident id in + let defining_expr = + close_let_bound_expression t var env defining_expr + in + let body = close t (Env.add_mutable_var env id mut_var) body in + Flambda.create_let var defining_expr + (Let_mutable + { var = mut_var; + initial_value = var; + body; + contents_kind = block_kind }) + | Lfunction { kind; params; body; attr; loc; } -> + let name = Names.anon_fn_with_loc loc in + let closure_bound_var = Variable.create name in + (* CR-soon mshinwell: some of this is now very similar to the let rec case + below *) + let set_of_closures_var = Variable.create Names.set_of_closures in + let set_of_closures = + let decl = + Function_decl.create ~let_rec_ident:None ~closure_bound_var ~kind + ~params:(List.map fst params) ~body ~attr ~loc + in + close_functions t env (Function_decls.create [decl]) + in + let project_closure : Flambda.project_closure = + { set_of_closures = set_of_closures_var; + closure_id = Closure_id.wrap closure_bound_var; + } + in + Flambda.create_let set_of_closures_var set_of_closures + (name_expr (Project_closure (project_closure)) ~name) + | Lapply { ap_func; ap_args; ap_loc; ap_should_be_tailcall = _; + ap_inlined; ap_specialised; } -> + Lift_code.lifting_helper (close_list t env ap_args) + ~evaluation_order:`Right_to_left + ~name:Names.apply_arg + ~create_body:(fun args -> + let func = close t env ap_func in + let func_var = Variable.create Names.apply_funct in + Flambda.create_let func_var (Expr func) + (Apply ({ + func = func_var; + args; + kind = Indirect; + dbg = Debuginfo.from_location ap_loc; + inline = ap_inlined; + specialise = ap_specialised; + }))) + | Lletrec (defs, body) -> + let env = + List.fold_right (fun (id, _) env -> + Env.add_var env id (Variable.create_with_same_name_as_ident id)) + defs env + in + let function_declarations = + (* Identify any bindings in the [let rec] that are functions. These + will be named after the corresponding identifier in the [let rec]. *) + List.map (function + | (let_rec_ident, + Lambda.Lfunction { kind; params; body; attr; loc }) -> + let closure_bound_var = + Variable.create_with_same_name_as_ident let_rec_ident + in + let function_declaration = + Function_decl.create ~let_rec_ident:(Some let_rec_ident) + ~closure_bound_var ~kind ~params:(List.map fst params) ~body + ~attr ~loc + in + Some function_declaration + | _ -> None) + defs + in + begin match + Misc.Stdlib.List.some_if_all_elements_are_some function_declarations + with + | Some function_declarations -> + (* When all the bindings are (syntactically) functions, we can + eliminate the [let rec] construction, instead producing a normal + [Let] that binds a set of closures containing all of the functions. + *) + (* CR-someday lwhite: This is a very syntactic criteria. Adding an + unused value to a set of recursive bindings changes how + functions are represented at runtime. *) + let set_of_closures_var = Variable.create (Names.set_of_closures) in + let set_of_closures = + close_functions t env (Function_decls.create function_declarations) + in + let body = + List.fold_left (fun body decl -> + let let_rec_ident = Function_decl.let_rec_ident decl in + let closure_bound_var = Function_decl.closure_bound_var decl in + let let_bound_var = Env.find_var env let_rec_ident in + (* Inside the body of the [let], each function is referred to by + a [Project_closure] expression, which projects from the set of + closures. *) + (Flambda.create_let let_bound_var + (Project_closure { + set_of_closures = set_of_closures_var; + closure_id = Closure_id.wrap closure_bound_var; + }) + body)) + (close t env body) function_declarations + in + Flambda.create_let set_of_closures_var set_of_closures body + | None -> + (* If the condition above is not satisfied, we build a [Let_rec] + expression; any functions bound by it will have their own + individual closures. *) + let defs = + List.map (fun (id, def) -> + let var = Env.find_var env id in + var, close_let_bound_expression t ~let_rec_ident:id var env def) + defs + in + Let_rec (defs, close t env body) + end + | Lsend (kind, meth, obj, args, loc) -> + let meth_var = Variable.create Names.meth in + let obj_var = Variable.create Names.obj in + let dbg = Debuginfo.from_location loc in + Flambda.create_let meth_var (Expr (close t env meth)) + (Flambda.create_let obj_var (Expr (close t env obj)) + (Lift_code.lifting_helper (close_list t env args) + ~evaluation_order:`Right_to_left + ~name:Names.send_arg + ~create_body:(fun args -> + Send { kind; meth = meth_var; obj = obj_var; args; dbg; }))) + | Lprim ((Pdivint Safe | Pmodint Safe + | Pdivbint { is_safe = Safe } | Pmodbint { is_safe = Safe }) as prim, + [arg1; arg2], loc) + when not !Clflags.unsafe -> + let arg2 = close t env arg2 in + let arg1 = close t env arg1 in + let numerator = Variable.create Names.numerator in + let denominator = Variable.create Names.denominator in + let zero = Variable.create Names.zero in + let is_zero = Variable.create Names.is_zero in + let exn = Variable.create Names.division_by_zero in + let exn_symbol = + t.symbol_for_global' Predef.ident_division_by_zero + in + let dbg = Debuginfo.from_location loc in + let zero_const : Flambda.named = + match prim with + | Pdivint _ | Pmodint _ -> + Const (Int 0) + | Pdivbint { size = Pint32 } | Pmodbint { size = Pint32 } -> + Allocated_const (Int32 0l) + | Pdivbint { size = Pint64 } | Pmodbint { size = Pint64 } -> + Allocated_const (Int64 0L) + | Pdivbint { size = Pnativeint } | Pmodbint { size = Pnativeint } -> + Allocated_const (Nativeint 0n) + | _ -> assert false + in + let prim : Clambda_primitives.primitive = + match prim with + | Pdivint _ -> Pdivint Unsafe + | Pmodint _ -> Pmodint Unsafe + | Pdivbint { size } -> Pdivbint { size; is_safe = Unsafe } + | Pmodbint { size } -> Pmodbint { size; is_safe = Unsafe } + | _ -> assert false + in + let comparison : Clambda_primitives.primitive = + match prim with + | Pdivint _ | Pmodint _ -> Pintcomp Ceq + | Pdivbint { size } | Pmodbint { size } -> Pbintcomp (size,Ceq) + | _ -> assert false + in + t.imported_symbols <- Symbol.Set.add exn_symbol t.imported_symbols; + Flambda.create_let zero zero_const + (Flambda.create_let exn (Symbol exn_symbol) + (Flambda.create_let denominator (Expr arg2) + (Flambda.create_let numerator (Expr arg1) + (Flambda.create_let is_zero + (Prim (comparison, [zero; denominator], dbg)) + (If_then_else (is_zero, + name_expr (Prim (Praise Raise_regular, [exn], dbg)) + ~name:Names.dummy, + (* CR-someday pchambart: find the right event. + mshinwell: I briefly looked at this, and couldn't + figure it out. + lwhite: I don't think any of the existing events + are suitable. I had to add a new one for a similar + case in the array data types work. + mshinwell: deferred CR *) + name_expr ~name:Names.result + (Prim (prim, [numerator; denominator], dbg)))))))) + | Lprim ((Pdivint Safe | Pmodint Safe + | Pdivbint { is_safe = Safe } | Pmodbint { is_safe = Safe }), _, _) + when not !Clflags.unsafe -> + Misc.fatal_error "Pdivint / Pmodint must have exactly two arguments" + | Lprim (Psequor, [arg1; arg2], _) -> + let arg1 = close t env arg1 in + let arg2 = close t env arg2 in + let const_true = Variable.create Names.const_true in + let cond = Variable.create Names.cond_sequor in + Flambda.create_let const_true (Const (Const_pointer 1)) + (Flambda.create_let cond (Expr arg1) + (If_then_else (cond, Var const_true, arg2))) + | Lprim (Psequand, [arg1; arg2], _) -> + let arg1 = close t env arg1 in + let arg2 = close t env arg2 in + let const_false = Variable.create Names.const_false in + let cond = Variable.create Names.const_sequand in + Flambda.create_let const_false (Const (Const_pointer 0)) + (Flambda.create_let cond (Expr arg1) + (If_then_else (cond, arg2, Var const_false))) + | Lprim ((Psequand | Psequor), _, _) -> + Misc.fatal_error "Psequand / Psequor must have exactly two arguments" + | Lprim ((Pidentity | Pbytes_to_string | Pbytes_of_string), [arg], _) -> + close t env arg + | Lprim (Pignore, [arg], _) -> + let var = Variable.create Names.ignore in + let defining_expr = + close_let_bound_expression t var env arg + in + Flambda.create_let var defining_expr + (name_expr (Const (Const_pointer 0)) ~name:Names.unit) + | Lprim (Pdirapply, [funct; arg], loc) + | Lprim (Prevapply, [arg; funct], loc) -> + let apply : Lambda.lambda_apply = + { ap_func = funct; + ap_args = [arg]; + ap_loc = loc; + ap_should_be_tailcall = false; + (* CR-someday lwhite: it would be nice to be able to give + inlined attributes to functions applied with the application + operators. *) + ap_inlined = Default_inline; + ap_specialised = Default_specialise; + } + in + close t env (Lambda.Lapply apply) + | Lprim (Praise kind, [arg], loc) -> + let arg_var = Variable.create Names.raise_arg in + let dbg = Debuginfo.from_location loc in + Flambda.create_let arg_var (Expr (close t env arg)) + (name_expr + (Prim (Praise kind, [arg_var], dbg)) + ~name:Names.raise) + | Lprim (Pctconst c, [arg], _loc) -> + let module Backend = (val t.backend) in + let const = + begin match c with + | Big_endian -> lambda_const_bool Backend.big_endian + | Word_size -> lambda_const_int (8*Backend.size_int) + | Int_size -> lambda_const_int (8*Backend.size_int - 1) + | Max_wosize -> + lambda_const_int ((1 lsl ((8*Backend.size_int) - 10)) - 1) + | Ostype_unix -> lambda_const_bool (String.equal Sys.os_type "Unix") + | Ostype_win32 -> lambda_const_bool (String.equal Sys.os_type "Win32") + | Ostype_cygwin -> lambda_const_bool (String.equal Sys.os_type "Cygwin") + | Backend_type -> + Lambda.Const_pointer 0 (* tag 0 is the same as Native *) + end + in + close t env + (Lambda.Llet(Strict, Pgenval, Ident.create_local "dummy", + arg, Lconst const)) + | Lprim (Pfield _, [Lprim (Pgetglobal id, [],_)], _) + when Ident.same id t.current_unit_id -> + Misc.fatal_errorf "[Pfield (Pgetglobal ...)] for the current compilation \ + unit is forbidden upon entry to the middle end" + | Lprim (Psetfield (_, _, _), [Lprim (Pgetglobal _, [], _); _], _) -> + Misc.fatal_errorf "[Psetfield (Pgetglobal ...)] is \ + forbidden upon entry to the middle end" + | Lprim (Pgetglobal id, [], _) when Ident.is_predef id -> + let symbol = t.symbol_for_global' id in + t.imported_symbols <- Symbol.Set.add symbol t.imported_symbols; + name_expr (Symbol symbol) ~name:Names.predef_exn + | Lprim (Pgetglobal id, [], _) -> + assert (not (Ident.same id t.current_unit_id)); + let symbol = t.symbol_for_global' id in + t.imported_symbols <- Symbol.Set.add symbol t.imported_symbols; + name_expr (Symbol symbol) ~name:Names.pgetglobal + | Lprim (lambda_p, args, loc) -> + (* One of the important consequences of the ANF-like representation + here is that we obtain names corresponding to the components of + blocks being made (with [Pmakeblock]). This information can be used + by the simplification pass to increase the likelihood of eliminating + the allocation, since some field accesses can be tracked back to known + field values. *) + let dbg = Debuginfo.from_location loc in + let p = Convert_primitives.convert lambda_p in + Lift_code.lifting_helper (close_list t env args) + ~evaluation_order:`Right_to_left + ~name:(Names.of_primitive_arg lambda_p) + ~create_body:(fun args -> + name_expr (Prim (p, args, dbg)) + ~name:(Names.of_primitive lambda_p)) + | Lswitch (arg, sw, _loc) -> + let scrutinee = Variable.create Names.switch in + let aux (i, lam) = i, close t env lam in + let nums sw_num cases default = + let module I = Numbers.Int in + match default with + | Some _ -> + I.zero_to_n (sw_num - 1) + | None -> + List.fold_left (fun set (i, _) -> I.Set.add i set) I.Set.empty cases + in + Flambda.create_let scrutinee (Expr (close t env arg)) + (Switch (scrutinee, + { numconsts = nums sw.sw_numconsts sw.sw_consts sw.sw_failaction; + consts = List.map aux sw.sw_consts; + numblocks = nums sw.sw_numblocks sw.sw_blocks sw.sw_failaction; + blocks = List.map aux sw.sw_blocks; + failaction = Misc.may_map (close t env) sw.sw_failaction; + })) + | Lstringswitch (arg, sw, def, _) -> + let scrutinee = Variable.create Names.string_switch in + Flambda.create_let scrutinee (Expr (close t env arg)) + (String_switch (scrutinee, + List.map (fun (s, e) -> s, close t env e) sw, + Misc.may_map (close t env) def)) + | Lstaticraise (i, args) -> + Lift_code.lifting_helper (close_list t env args) + ~evaluation_order:`Right_to_left + ~name:Names.staticraise_arg + ~create_body:(fun args -> + let static_exn = Env.find_static_exception env i in + Static_raise (static_exn, args)) + | Lstaticcatch (body, (i, ids), handler) -> + let st_exn = Static_exception.create () in + let env = Env.add_static_exception env i st_exn in + let ids = List.map fst ids in + let vars = List.map Variable.create_with_same_name_as_ident ids in + Static_catch (st_exn, vars, close t env body, + close t (Env.add_vars env ids vars) handler) + | Ltrywith (body, id, handler) -> + let var = Variable.create_with_same_name_as_ident id in + Try_with (close t env body, var, close t (Env.add_var env id var) handler) + | Lifthenelse (cond, ifso, ifnot) -> + let cond = close t env cond in + let cond_var = Variable.create Names.cond in + Flambda.create_let cond_var (Expr cond) + (If_then_else (cond_var, close t env ifso, close t env ifnot)) + | Lsequence (lam1, lam2) -> + let var = Variable.create Names.sequence in + let lam1 = Flambda.Expr (close t env lam1) in + let lam2 = close t env lam2 in + Flambda.create_let var lam1 lam2 + | Lwhile (cond, body) -> While (close t env cond, close t env body) + | Lfor (id, lo, hi, direction, body) -> + let bound_var = Variable.create_with_same_name_as_ident id in + let from_value = Variable.create Names.for_from in + let to_value = Variable.create Names.for_to in + let body = close t (Env.add_var env id bound_var) body in + Flambda.create_let from_value (Expr (close t env lo)) + (Flambda.create_let to_value (Expr (close t env hi)) + (For { bound_var; from_value; to_value; direction; body; })) + | Lassign (id, new_value) -> + let being_assigned = + match Env.find_mutable_var_exn env id with + | being_assigned -> being_assigned + | exception Not_found -> + Misc.fatal_errorf "Closure_conversion.close: unbound mutable \ + variable %s in assignment" + (Ident.unique_name id) + in + let new_value_var = Variable.create Names.new_value in + Flambda.create_let new_value_var (Expr (close t env new_value)) + (Assign { being_assigned; new_value = new_value_var; }) + | Levent (lam, _) -> close t env lam + | Lifused _ -> + (* [Lifused] is used to mark that this expression should be alive only if + an identifier is. Every use should have been removed by + [Simplif.simplify_lets], either by replacing by the inner expression, + or by completely removing it (replacing by unit). *) + Misc.fatal_error "[Lifused] should have been removed by \ + [Simplif.simplify_lets]" + +(** Perform closure conversion on a set of function declarations, returning a + set of closures. (The set will often only contain a single function; + the only case where it cannot is for "let rec".) *) +and close_functions t external_env function_declarations : Flambda.named = + let closure_env_without_parameters = + Function_decls.closure_env_without_parameters + external_env function_declarations + in + let all_free_idents = Function_decls.all_free_idents function_declarations in + let close_one_function map decl = + let body = Function_decl.body decl in + let loc = Function_decl.loc decl in + let dbg = Debuginfo.from_location loc in + let params = Function_decl.params decl in + (* Create fresh variables for the elements of the closure (cf. + the comment on [Function_decl.closure_env_without_parameters], above). + This induces a renaming on [Function_decl.free_idents]; the results of + that renaming are stored in [free_variables]. *) + let closure_env = + List.fold_right (fun id env -> + Env.add_var env id (Variable.create_with_same_name_as_ident id)) + params closure_env_without_parameters + in + (* If the function is the wrapper for a function with an optional + argument with a default value, make sure it always gets inlined. + CR-someday pchambart: eta-expansion wrapper for a primitive are + not marked as stub but certainly should *) + let stub = Function_decl.stub decl in + let param_vars = List.map (Env.find_var closure_env) params in + let params = List.map Parameter.wrap param_vars in + let closure_bound_var = Function_decl.closure_bound_var decl in + let unboxed_version = Variable.rename closure_bound_var in + let body = close t closure_env body in + let closure_origin = + Closure_origin.create (Closure_id.wrap unboxed_version) + in + let fun_decl = + Flambda.create_function_declaration ~params ~body ~stub ~dbg + ~inline:(Function_decl.inline decl) + ~specialise:(Function_decl.specialise decl) + ~is_a_functor:(Function_decl.is_a_functor decl) + ~closure_origin + in + match Function_decl.kind decl with + | Curried -> Variable.Map.add closure_bound_var fun_decl map + | Tupled -> + let unboxed_version = Variable.rename closure_bound_var in + let generic_function_stub = + tupled_function_call_stub param_vars unboxed_version ~closure_bound_var + in + Variable.Map.add unboxed_version fun_decl + (Variable.Map.add closure_bound_var generic_function_stub map) + in + let function_decls = + let is_classic_mode = !Clflags.classic_inlining in + let funs = + List.fold_left close_one_function Variable.Map.empty + (Function_decls.to_list function_declarations) + in + Flambda.create_function_declarations ~is_classic_mode ~funs + in + (* The closed representation of a set of functions is a "set of closures". + (For avoidance of doubt, the runtime representation of the *whole set* is + a single block with tag [Closure_tag].) *) + let set_of_closures = + let free_vars = + Ident.Set.fold (fun var map -> + let internal_var = + Env.find_var closure_env_without_parameters var + in + let external_var : Flambda.specialised_to = + { var = Env.find_var external_env var; + projection = None; + } + in + Variable.Map.add internal_var external_var map) + all_free_idents Variable.Map.empty + in + Flambda.create_set_of_closures ~function_decls ~free_vars + ~specialised_args:Variable.Map.empty + ~direct_call_surrogates:Variable.Map.empty + in + Set_of_closures set_of_closures + +and close_list t sb l = List.map (close t sb) l + +and close_let_bound_expression t ?let_rec_ident let_bound_var env + (lam : Lambda.lambda) : Flambda.named = + match lam with + | Lfunction { kind; params; body; attr; loc; } -> + (* Ensure that [let] and [let rec]-bound functions have appropriate + names. *) + let closure_bound_var = Variable.rename let_bound_var in + let decl = + Function_decl.create ~let_rec_ident ~closure_bound_var ~kind + ~params:(List.map fst params) ~body ~attr ~loc + in + let set_of_closures_var = Variable.rename let_bound_var in + let set_of_closures = + close_functions t env (Function_decls.create [decl]) + in + let project_closure : Flambda.project_closure = + { set_of_closures = set_of_closures_var; + closure_id = Closure_id.wrap closure_bound_var; + } + in + Expr (Flambda.create_let set_of_closures_var set_of_closures + (name_expr_from_var (Project_closure (project_closure)) + ~var:let_bound_var)) + | lam -> Expr (close t env lam) + +let lambda_to_flambda ~backend ~module_ident ~size ~filename lam + : Flambda.program = + let lam = add_default_argument_wrappers lam in + let module Backend = (val backend : Backend_intf.S) in + let compilation_unit = Compilation_unit.get_current_exn () in + let t = + { current_unit_id = Compilation_unit.get_persistent_ident compilation_unit; + symbol_for_global' = Backend.symbol_for_global'; + filename; + backend; + imported_symbols = Symbol.Set.empty; + declared_symbols = []; + } + in + let module_symbol = Backend.symbol_for_global' module_ident in + let block_symbol = + let var = Variable.create Internal_variable_names.module_as_block in + Symbol.of_variable var + in + (* The global module block is built by accessing the fields of all the + introduced symbols. *) + (* CR-soon mshinwell for mshinwell: Add a comment describing how modules are + compiled. *) + let fields = + Array.init size (fun pos -> + let sym_v = Variable.create Names.block_symbol in + let result_v = Variable.create Names.block_symbol_get in + let value_v = Variable.create Names.block_symbol_get_field in + Flambda.create_let + sym_v (Symbol block_symbol) + (Flambda.create_let result_v + (Prim (Pfield 0, [sym_v], Debuginfo.none)) + (Flambda.create_let value_v + (Prim (Pfield pos, [result_v], Debuginfo.none)) + (Var value_v)))) + in + let module_initializer : Flambda.program_body = + Initialize_symbol ( + block_symbol, + Tag.create_exn 0, + [close t Env.empty lam], + Initialize_symbol ( + module_symbol, + Tag.create_exn 0, + Array.to_list fields, + End module_symbol)) + in + let program_body = + List.fold_left + (fun program_body (symbol, constant) : Flambda.program_body -> + Let_symbol (symbol, constant, program_body)) + module_initializer + t.declared_symbols + in + { imported_symbols = t.imported_symbols; + program_body; + } diff --git a/middle_end/flambda/closure_conversion.mli b/middle_end/flambda/closure_conversion.mli new file mode 100644 index 0000000000..f5fab0a7ed --- /dev/null +++ b/middle_end/flambda/closure_conversion.mli @@ -0,0 +1,53 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(** Generation of [Flambda] intermediate language code from [Lambda] code + by performing a form of closure conversion. + + Function declarations (which may bind one or more variables identifying + functions, possibly with mutual recursion) are transformed to + [Set_of_closures] expressions. [Project_closure] expressions are then + used to select a closure for a particular function from a [Set_of_closures] + expression. The [Set_of_closures] expressions say nothing about the + actual runtime layout of the closures; this is handled when [Flambda] code + is translated to [Clambda] code. + + The following transformations are also performed during closure + conversion: + - Constant blocks (by which is meant things wrapped in [Lambda.Const_block]) + are converted to applications of the [Pmakeblock] primitive. + - [Levent] debugging event nodes are removed and the information within + them attached to function, method and [raise] calls. + - Tuplified functions are converted to curried functions and a stub + function emitted to call the curried version. For example: + let rec f (x, y) = f (x + 1, y + 1) + is transformed to: + let rec internal_f x y = f (x + 1,y + 1) + and f (x, y) = internal_f x y (* [f] is marked as a stub function *) + - The [Pdirapply] and [Prevapply] application primitives are removed and + converted to normal [Flambda] application nodes. + + The [lambda_to_flambda] function is not re-entrant. +*) +val lambda_to_flambda + : backend:(module Backend_intf.S) + -> module_ident:Ident.t + -> size:int + -> filename:string + -> Lambda.lambda + -> Flambda.program diff --git a/middle_end/flambda/closure_conversion_aux.ml b/middle_end/flambda/closure_conversion_aux.ml new file mode 100644 index 0000000000..cfcaf34d1b --- /dev/null +++ b/middle_end/flambda/closure_conversion_aux.ml @@ -0,0 +1,184 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +module Env = struct + type t = { + variables : Variable.t Ident.tbl; + mutable_variables : Mutable_variable.t Ident.tbl; + static_exceptions : Static_exception.t Numbers.Int.Map.t; + globals : Symbol.t Numbers.Int.Map.t; + at_toplevel : bool; + } + + let empty = { + variables = Ident.empty; + mutable_variables = Ident.empty; + static_exceptions = Numbers.Int.Map.empty; + globals = Numbers.Int.Map.empty; + at_toplevel = true; + } + + let clear_local_bindings env = + { empty with globals = env.globals } + + let add_var t id var = { t with variables = Ident.add id var t.variables } + let add_vars t ids vars = List.fold_left2 add_var t ids vars + + let find_var t id = + try Ident.find_same id t.variables + with Not_found -> + Misc.fatal_errorf "Closure_conversion.Env.find_var: %s@ %s" + (Ident.unique_name id) + (Printexc.raw_backtrace_to_string (Printexc.get_callstack 42)) + + let find_var_exn t id = + Ident.find_same id t.variables + + let add_mutable_var t id mutable_var = + { t with mutable_variables = Ident.add id mutable_var t.mutable_variables } + + let find_mutable_var_exn t id = + Ident.find_same id t.mutable_variables + + let add_static_exception t st_exn fresh_st_exn = + { t with + static_exceptions = + Numbers.Int.Map.add st_exn fresh_st_exn t.static_exceptions } + + let find_static_exception t st_exn = + try Numbers.Int.Map.find st_exn t.static_exceptions + with Not_found -> + Misc.fatal_error ("Closure_conversion.Env.find_static_exception: exn " + ^ Int.to_string st_exn) + + let add_global t pos symbol = + { t with globals = Numbers.Int.Map.add pos symbol t.globals } + + let find_global t pos = + try Numbers.Int.Map.find pos t.globals + with Not_found -> + Misc.fatal_error ("Closure_conversion.Env.find_global: global " + ^ Int.to_string pos) + + let at_toplevel t = t.at_toplevel + + let not_at_toplevel t = { t with at_toplevel = false; } +end + +module Function_decls = struct + module Function_decl = struct + type t = { + let_rec_ident : Ident.t; + closure_bound_var : Variable.t; + kind : Lambda.function_kind; + params : Ident.t list; + body : Lambda.lambda; + free_idents_of_body : Ident.Set.t; + attr : Lambda.function_attribute; + loc : Location.t; + } + + let create ~let_rec_ident ~closure_bound_var ~kind ~params ~body + ~attr ~loc = + let let_rec_ident = + match let_rec_ident with + | None -> Ident.create_local "unnamed_function" + | Some let_rec_ident -> let_rec_ident + in + { let_rec_ident; + closure_bound_var; + kind; + params; + body; + free_idents_of_body = Lambda.free_variables body; + attr; + loc; + } + + let let_rec_ident t = t.let_rec_ident + let closure_bound_var t = t.closure_bound_var + let kind t = t.kind + let params t = t.params + let body t = t.body + let free_idents t = t.free_idents_of_body + let inline t = t.attr.inline + let specialise t = t.attr.specialise + let is_a_functor t = t.attr.is_a_functor + let stub t = t.attr.stub + let loc t = t.loc + + end + + type t = { + function_decls : Function_decl.t list; + all_free_idents : Ident.Set.t; + } + + (* All identifiers free in the bodies of the given function declarations, + indexed by the identifiers corresponding to the functions themselves. *) + let free_idents_by_function function_decls = + List.fold_right (fun decl map -> + Variable.Map.add (Function_decl.closure_bound_var decl) + (Function_decl.free_idents decl) map) + function_decls Variable.Map.empty + + let all_free_idents function_decls = + Variable.Map.fold (fun _ -> Ident.Set.union) + (free_idents_by_function function_decls) Ident.Set.empty + + (* All identifiers of simultaneously-defined functions in [ts]. *) + let let_rec_idents function_decls = + List.map Function_decl.let_rec_ident function_decls + + (* All parameters of functions in [ts]. *) + let all_params function_decls = + List.concat (List.map Function_decl.params function_decls) + + let set_diff (from : Ident.Set.t) (idents : Ident.t list) = + List.fold_right Ident.Set.remove idents from + + (* CR-someday lwhite: use a different name from above or explain the + difference *) + let all_free_idents function_decls = + set_diff (set_diff (all_free_idents function_decls) + (all_params function_decls)) + (let_rec_idents function_decls) + + let create function_decls = + { function_decls; + all_free_idents = all_free_idents function_decls; + } + + let to_list t = t.function_decls + + let all_free_idents t = t.all_free_idents + + let closure_env_without_parameters external_env t = + let closure_env = + (* For "let rec"-bound functions. *) + List.fold_right (fun function_decl env -> + Env.add_var env (Function_decl.let_rec_ident function_decl) + (Function_decl.closure_bound_var function_decl)) + t.function_decls (Env.clear_local_bindings external_env) + in + (* For free variables. *) + Ident.Set.fold (fun id env -> + Env.add_var env id (Variable.create_with_same_name_as_ident id)) + t.all_free_idents closure_env +end diff --git a/middle_end/flambda/closure_conversion_aux.mli b/middle_end/flambda/closure_conversion_aux.mli new file mode 100644 index 0000000000..f16f05f0d7 --- /dev/null +++ b/middle_end/flambda/closure_conversion_aux.mli @@ -0,0 +1,94 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(** Environments and auxiliary structures used during closure conversion. *) + +(** Used to remember which [Variable.t] values correspond to which + [Ident.t] values during closure conversion, and similarly for + static exception identifiers. *) +module Env : sig + type t + + val empty : t + + val add_var : t -> Ident.t -> Variable.t -> t + val add_vars : t -> Ident.t list -> Variable.t list -> t + + val find_var : t -> Ident.t -> Variable.t + val find_var_exn : t -> Ident.t -> Variable.t + + val add_mutable_var : t -> Ident.t -> Mutable_variable.t -> t + val find_mutable_var_exn : t -> Ident.t -> Mutable_variable.t + + val add_static_exception : t -> int -> Static_exception.t -> t + val find_static_exception : t -> int -> Static_exception.t + + val add_global : t -> int -> Symbol.t -> t + val find_global : t -> int -> Symbol.t + + val at_toplevel : t -> bool + val not_at_toplevel : t -> t +end + +(** Used to represent information about a set of function declarations + during closure conversion. (The only case in which such a set may + contain more than one declaration is when processing "let rec".) *) +module Function_decls : sig + module Function_decl : sig + type t + + val create + : let_rec_ident:Ident.t option + -> closure_bound_var:Variable.t + -> kind:Lambda.function_kind + -> params:Ident.t list + -> body:Lambda.lambda + -> attr:Lambda.function_attribute + -> loc:Location.t + -> t + + val let_rec_ident : t -> Ident.t + val closure_bound_var : t -> Variable.t + val kind : t -> Lambda.function_kind + val params : t -> Ident.t list + val body : t -> Lambda.lambda + val inline : t -> Lambda.inline_attribute + val specialise : t -> Lambda.specialise_attribute + val is_a_functor : t -> bool + val stub : t -> bool + val loc : t -> Location.t + + (* Like [all_free_idents], but for just one function. *) + val free_idents : t -> Ident.Set.t + end + + type t + + val create : Function_decl.t list -> t + val to_list : t -> Function_decl.t list + + (* All identifiers free in the given function declarations after the binding + of parameters and function identifiers has been performed. *) + val all_free_idents : t -> Ident.Set.t + + (* A map from identifiers to their corresponding [Variable.t]s whose domain + is the set of all identifiers free in the bodies of the declarations that + are not bound as parameters. + It also contains the globals bindings of the provided environment. *) + val closure_env_without_parameters : Env.t -> t -> Env.t +end diff --git a/middle_end/flambda/closure_offsets.ml b/middle_end/flambda/closure_offsets.ml new file mode 100644 index 0000000000..51a09f02cb --- /dev/null +++ b/middle_end/flambda/closure_offsets.ml @@ -0,0 +1,89 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +type result = { + function_offsets : int Closure_id.Map.t; + free_variable_offsets : int Var_within_closure.Map.t; +} + +let add_closure_offsets + { function_offsets; free_variable_offsets } + ({ function_decls; free_vars } : Flambda.set_of_closures) = + (* Build the table mapping the functions declared by the set of closures + to the positions of their individual "infix" closures inside the runtime + closure block. (All of the environment entries will come afterwards.) *) + let assign_function_offset id function_decl (map, env_pos) = + let pos = env_pos + 1 in + let env_pos = + let arity = Flambda_utils.function_arity function_decl in + env_pos + + 1 (* GC header; either [Closure_tag] or [Infix_tag] *) + + 1 (* full application code pointer *) + + 1 (* arity *) + + (if arity > 1 then 1 else 0) (* partial application code pointer *) + in + let closure_id = Closure_id.wrap id in + if Closure_id.Map.mem closure_id map then begin + Misc.fatal_errorf "Closure_offsets.add_closure_offsets: function \ + offset for %a would be defined multiple times" + Closure_id.print closure_id + end; + let map = Closure_id.Map.add closure_id pos map in + (map, env_pos) + in + let function_offsets, free_variable_pos = + Variable.Map.fold assign_function_offset + function_decls.funs (function_offsets, -1) + in + (* Adds the mapping of free variables to their offset. Recall that + projections of [Var_within_closure]s are only currently used when + compiling accesses to the closure of a function from outside that + function (in particular, as a result of inlining). Accesses to + a function's own closure are compiled directly via normal [Var] + accesses. *) + (* CR-someday mshinwell: As discussed with lwhite, maybe this isn't + ideal, and the self accesses should be explicitly marked too. *) + let assign_free_variable_offset var _ (map, pos) = + let var_within_closure = Var_within_closure.wrap var in + if Var_within_closure.Map.mem var_within_closure map then begin + Misc.fatal_errorf "Closure_offsets.add_closure_offsets: free variable \ + offset for %a would be defined multiple times" + Var_within_closure.print var_within_closure + end; + let map = Var_within_closure.Map.add var_within_closure pos map in + (map, pos + 1) + in + let free_variable_offsets, _ = + Variable.Map.fold assign_free_variable_offset + free_vars (free_variable_offsets, free_variable_pos) + in + { function_offsets; + free_variable_offsets; + } + +let compute (program:Flambda.program) = + let init : result = + { function_offsets = Closure_id.Map.empty; + free_variable_offsets = Var_within_closure.Map.empty; + } + in + let r = + List.fold_left add_closure_offsets + init (Flambda_utils.all_sets_of_closures program) + in + r diff --git a/middle_end/flambda/closure_offsets.mli b/middle_end/flambda/closure_offsets.mli new file mode 100644 index 0000000000..7ecf9c276d --- /dev/null +++ b/middle_end/flambda/closure_offsets.mli @@ -0,0 +1,27 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(** Assign numerical offsets, within closure blocks, for code pointers and + environment entries. *) + +type result = private { + function_offsets : int Closure_id.Map.t; + free_variable_offsets : int Var_within_closure.Map.t; +} + +val compute : Flambda.program -> result diff --git a/middle_end/flambda/effect_analysis.ml b/middle_end/flambda/effect_analysis.ml new file mode 100644 index 0000000000..d0cbd44180 --- /dev/null +++ b/middle_end/flambda/effect_analysis.ml @@ -0,0 +1,60 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +let no_effects_prim (prim : Clambda_primitives.primitive) = + match Semantics_of_primitives.for_primitive prim with + | (No_effects | Only_generative_effects), (No_coeffects | Has_coeffects) -> + true + | _ -> false + +let rec no_effects (flam : Flambda.t) = + match flam with + | Var _ -> true + | Let { defining_expr; body; _ } -> + no_effects_named defining_expr && no_effects body + | Let_mutable { body } -> no_effects body + | Let_rec (defs, body) -> + no_effects body + && List.for_all (fun (_, def) -> no_effects_named def) defs + | If_then_else (_, ifso, ifnot) -> no_effects ifso && no_effects ifnot + | Switch (_, sw) -> + let aux (_, flam) = no_effects flam in + List.for_all aux sw.blocks + && List.for_all aux sw.consts + && Misc.Stdlib.Option.value_default no_effects sw.failaction + ~default:true + | String_switch (_, sw, def) -> + List.for_all (fun (_, lam) -> no_effects lam) sw + && Misc.Stdlib.Option.value_default no_effects def + ~default:true + | Static_catch (_, _, body, _) | Try_with (body, _, _) -> + (* If there is a [raise] in [body], the whole [Try_with] may have an + effect, so there is no need to test the handler. *) + no_effects body + | While _ | For _ | Apply _ | Send _ | Assign _ | Static_raise _ -> false + | Proved_unreachable -> true + +and no_effects_named (named : Flambda.named) = + match named with + | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ + | Read_symbol_field _ + | Set_of_closures _ | Project_closure _ | Project_var _ + | Move_within_set_of_closures _ -> true + | Prim (prim, _, _) -> no_effects_prim prim + | Expr flam -> no_effects flam diff --git a/middle_end/flambda/effect_analysis.mli b/middle_end/flambda/effect_analysis.mli new file mode 100644 index 0000000000..b025bf0f87 --- /dev/null +++ b/middle_end/flambda/effect_analysis.mli @@ -0,0 +1,27 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(** Simple side effect analysis. *) + +(* CR-someday pchambart: Replace by call to [Purity] module. + mshinwell: Where is the [Purity] module? *) +(** Conservative approximation as to whether a given Flambda expression may + have any side effects. *) +val no_effects : Flambda.t -> bool + +val no_effects_named : Flambda.named -> bool diff --git a/middle_end/flambda/export_info.ml b/middle_end/flambda/export_info.ml new file mode 100644 index 0000000000..22dbb6c583 --- /dev/null +++ b/middle_end/flambda/export_info.ml @@ -0,0 +1,555 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +module A = Simple_value_approx + +type value_string_contents = + | Contents of string + | Unknown_or_mutable + +type value_string = { + contents : value_string_contents; + size : int; +} + +type value_float_array_contents = + | Contents of float option array + | Unknown_or_mutable + +type value_float_array = { + contents : value_float_array_contents; + size : int; +} + +type descr = + | Value_block of Tag.t * approx array + | Value_mutable_block of Tag.t * int + | Value_int of int + | Value_char of char + | Value_constptr of int + | Value_float of float + | Value_float_array of value_float_array + | Value_boxed_int : 'a A.boxed_int * 'a -> descr + | Value_string of value_string + | Value_closure of value_closure + | Value_set_of_closures of value_set_of_closures + | Value_unknown_descr + +and value_closure = { + closure_id : Closure_id.t; + set_of_closures : value_set_of_closures; +} + +and value_set_of_closures = { + set_of_closures_id : Set_of_closures_id.t; + bound_vars : approx Var_within_closure.Map.t; + free_vars : Flambda.specialised_to Variable.Map.t; + results : approx Closure_id.Map.t; + aliased_symbol : Symbol.t option; +} + +and approx = + | Value_unknown + | Value_id of Export_id.t + | Value_symbol of Symbol.t + +let equal_approx (a1:approx) (a2:approx) = + match a1, a2 with + | Value_unknown, Value_unknown -> + true + | Value_id id1, Value_id id2 -> + Export_id.equal id1 id2 + | Value_symbol s1, Value_symbol s2 -> + Symbol.equal s1 s2 + | (Value_unknown | Value_symbol _ | Value_id _), + (Value_unknown | Value_symbol _ | Value_id _) -> + false + +let equal_array eq a1 a2 = + Array.length a1 = Array.length a2 && + try + Array.iteri (fun i v1 -> if not (eq a2.(i) v1) then raise Exit) a1; + true + with Exit -> false + +let equal_option eq o1 o2 = + match o1, o2 with + | None, None -> true + | Some v1, Some v2 -> eq v1 v2 + | Some _, None | None, Some _ -> false + +let equal_set_of_closures (s1:value_set_of_closures) + (s2:value_set_of_closures) = + Set_of_closures_id.equal s1.set_of_closures_id s2.set_of_closures_id && + Var_within_closure.Map.equal equal_approx s1.bound_vars s2.bound_vars && + Closure_id.Map.equal equal_approx s1.results s2.results && + equal_option Symbol.equal s1.aliased_symbol s2.aliased_symbol + +let equal_descr (d1:descr) (d2:descr) : bool = + match d1, d2 with + | Value_unknown_descr, Value_unknown_descr -> + true + | Value_block (t1, f1), Value_block (t2, f2) -> + Tag.equal t1 t2 && equal_array equal_approx f1 f2 + | Value_mutable_block (t1, s1), Value_mutable_block (t2, s2) -> + Tag.equal t1 t2 && + s1 = s2 + | Value_int i1, Value_int i2 -> + i1 = i2 + | Value_char c1, Value_char c2 -> + c1 = c2 + | Value_constptr i1, Value_constptr i2 -> + i1 = i2 + | Value_float f1, Value_float f2 -> + f1 = f2 + | Value_float_array s1, Value_float_array s2 -> + s1 = s2 + | Value_boxed_int (t1, v1), Value_boxed_int (t2, v2) -> + A.equal_boxed_int t1 v1 t2 v2 + | Value_string s1, Value_string s2 -> + s1 = s2 + | Value_closure c1, Value_closure c2 -> + Closure_id.equal c1.closure_id c2.closure_id && + equal_set_of_closures c1.set_of_closures c2.set_of_closures + | Value_set_of_closures s1, Value_set_of_closures s2 -> + equal_set_of_closures s1 s2 + | ( Value_block (_, _) | Value_mutable_block (_, _) | Value_int _ + | Value_char _ | Value_constptr _ | Value_float _ | Value_float_array _ + | Value_boxed_int _ | Value_string _ | Value_closure _ + | Value_set_of_closures _ + | Value_unknown_descr ), + ( Value_block (_, _) | Value_mutable_block (_, _) | Value_int _ + | Value_char _ | Value_constptr _ | Value_float _ | Value_float_array _ + | Value_boxed_int _ | Value_string _ | Value_closure _ + | Value_set_of_closures _ + | Value_unknown_descr ) -> + false + +type t = { + sets_of_closures : A.function_declarations Set_of_closures_id.Map.t; + values : descr Export_id.Map.t Compilation_unit.Map.t; + symbol_id : Export_id.t Symbol.Map.t; + offset_fun : int Closure_id.Map.t; + offset_fv : int Var_within_closure.Map.t; + constant_closures : Closure_id.Set.t; + invariant_params : Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t; + recursive : Variable.Set.t Set_of_closures_id.Map.t; +} + +type transient = { + sets_of_closures : A.function_declarations Set_of_closures_id.Map.t; + values : descr Export_id.Map.t Compilation_unit.Map.t; + symbol_id : Export_id.t Symbol.Map.t; + invariant_params : Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t; + recursive : Variable.Set.t Set_of_closures_id.Map.t; + relevant_local_closure_ids : Closure_id.Set.t; + relevant_imported_closure_ids : Closure_id.Set.t; + relevant_local_vars_within_closure : Var_within_closure.Set.t; + relevant_imported_vars_within_closure : Var_within_closure.Set.t; +} + +let empty : t = { + sets_of_closures = Set_of_closures_id.Map.empty; + values = Compilation_unit.Map.empty; + symbol_id = Symbol.Map.empty; + offset_fun = Closure_id.Map.empty; + offset_fv = Var_within_closure.Map.empty; + constant_closures = Closure_id.Set.empty; + invariant_params = Set_of_closures_id.Map.empty; + recursive = Set_of_closures_id.Map.empty; +} + +let opaque_transient ~compilation_unit ~root_symbol : transient = + let export_id = Export_id.create compilation_unit in + let values = + let map = Export_id.Map.singleton export_id Value_unknown_descr in + Compilation_unit.Map.singleton compilation_unit map + in + let symbol_id = Symbol.Map.singleton root_symbol export_id in + { sets_of_closures = Set_of_closures_id.Map.empty; + values; + symbol_id; + invariant_params = Set_of_closures_id.Map.empty; + recursive = Set_of_closures_id.Map.empty; + relevant_local_closure_ids = Closure_id.Set.empty; + relevant_imported_closure_ids = Closure_id.Set.empty; + relevant_local_vars_within_closure = Var_within_closure.Set.empty; + relevant_imported_vars_within_closure = Var_within_closure.Set.empty; + } + +let create ~sets_of_closures ~values ~symbol_id + ~offset_fun ~offset_fv ~constant_closures + ~invariant_params ~recursive = + { sets_of_closures; + values; + symbol_id; + offset_fun; + offset_fv; + constant_closures; + invariant_params; + recursive; + } + +let create_transient + ~sets_of_closures ~values ~symbol_id ~invariant_params ~recursive + ~relevant_local_closure_ids ~relevant_imported_closure_ids + ~relevant_local_vars_within_closure + ~relevant_imported_vars_within_closure = + { sets_of_closures; + values; + symbol_id; + invariant_params; + recursive; + relevant_local_closure_ids; + relevant_imported_closure_ids; + relevant_local_vars_within_closure; + relevant_imported_vars_within_closure; + } + +let t_of_transient transient + ~program:_ + ~local_offset_fun ~local_offset_fv + ~imported_offset_fun ~imported_offset_fv + ~constant_closures = + let offset_fun = + let fold_map set = + Closure_id.Map.fold (fun key value unchanged -> + if Closure_id.Set.mem key set then + Closure_id.Map.add key value unchanged + else + unchanged) + in + Closure_id.Map.empty + |> fold_map transient.relevant_local_closure_ids local_offset_fun + |> fold_map transient.relevant_imported_closure_ids imported_offset_fun + in + let offset_fv = + let fold_map set = + Var_within_closure.Map.fold (fun key value unchanged -> + if Var_within_closure.Set.mem key set then + Var_within_closure.Map.add key value unchanged + else + unchanged) + in + Var_within_closure.Map.empty + |> fold_map transient.relevant_local_vars_within_closure local_offset_fv + |> fold_map transient.relevant_imported_vars_within_closure + imported_offset_fv + in + { sets_of_closures = transient.sets_of_closures; + values = transient.values; + symbol_id = transient.symbol_id; + invariant_params = transient.invariant_params; + recursive = transient.recursive; + offset_fun; + offset_fv; + constant_closures; + } + +let merge (t1 : t) (t2 : t) : t = + let eidmap_disjoint_union ?eq map1 map2 = + Compilation_unit.Map.merge (fun _id map1 map2 -> + match map1, map2 with + | None, None -> None + | None, Some map + | Some map, None -> Some map + | Some map1, Some map2 -> + Some (Export_id.Map.disjoint_union ?eq map1 map2)) + map1 map2 + in + let int_eq (i : int) j = i = j in + { values = eidmap_disjoint_union ~eq:equal_descr t1.values t2.values; + sets_of_closures = + Set_of_closures_id.Map.disjoint_union t1.sets_of_closures + t2.sets_of_closures; + symbol_id = + Symbol.Map.disjoint_union ~print:Export_id.print t1.symbol_id + t2.symbol_id; + offset_fun = Closure_id.Map.disjoint_union + ~eq:int_eq t1.offset_fun t2.offset_fun; + offset_fv = Var_within_closure.Map.disjoint_union + ~eq:int_eq t1.offset_fv t2.offset_fv; + constant_closures = + Closure_id.Set.union t1.constant_closures t2.constant_closures; + invariant_params = + Set_of_closures_id.Map.disjoint_union + ~print:(Variable.Map.print Variable.Set.print) + ~eq:(Variable.Map.equal Variable.Set.equal) + t1.invariant_params t2.invariant_params; + recursive = + Set_of_closures_id.Map.disjoint_union + ~print:Variable.Set.print + ~eq:Variable.Set.equal + t1.recursive t2.recursive; + } + +let find_value eid map = + let unit_map = + Compilation_unit.Map.find (Export_id.get_compilation_unit eid) map + in + Export_id.Map.find eid unit_map + +let find_description (t : t) eid = + find_value eid t.values + +let nest_eid_map map = + let add_map eid v map = + let unit = Export_id.get_compilation_unit eid in + let m = + try Compilation_unit.Map.find unit map + with Not_found -> Export_id.Map.empty + in + Compilation_unit.Map.add unit (Export_id.Map.add eid v m) map + in + Export_id.Map.fold add_map map Compilation_unit.Map.empty + +let print_raw_approx ppf approx = + let fprintf = Format.fprintf in + match approx with + | Value_unknown -> fprintf ppf "(Unknown)" + | Value_id export_id -> fprintf ppf "(Id %a)" Export_id.print export_id + | Value_symbol symbol -> fprintf ppf "(Symbol %a)" Symbol.print symbol + +let print_value_set_of_closures ppf (t : value_set_of_closures) = + let print_bound_vars ppf bound_vars = + Format.fprintf ppf "(%a)" + (Var_within_closure.Map.print print_raw_approx) + bound_vars + in + let print_free_vars ppf free_vars = + Format.fprintf ppf "(%a)" + (Variable.Map.print Flambda.print_specialised_to) + free_vars + in + let print_results ppf results = + Format.fprintf ppf "(%a)" (Closure_id.Map.print print_raw_approx) results + in + let print_aliased_symbol ppf aliased_symbol = + match aliased_symbol with + | None -> Format.fprintf ppf "" + | Some symbol -> Format.fprintf ppf "(%a)" Symbol.print symbol + in + Format.fprintf ppf + "((set_of_closures_id %a) \ + (bound_vars %a) \ + (free_vars %a) \ + (results %a) \ + (aliased_symbol %a))" + Set_of_closures_id.print t.set_of_closures_id + print_bound_vars t.bound_vars + print_free_vars t.free_vars + print_results t.results + print_aliased_symbol t.aliased_symbol + +let print_value_closure ppf (t : value_closure) = + Format.fprintf ppf "((closure_id %a) (set_of_closures %a))" + Closure_id.print t.closure_id + print_value_set_of_closures t.set_of_closures + +let print_value_float_array_contents + ppf (value : value_float_array_contents) = + match value with + | Unknown_or_mutable -> Format.fprintf ppf "(Unknown_or_mutable)" + | Contents _ -> Format.fprintf ppf "(Contents ...)" + +let print_value_float_array ppf (value : value_float_array) = + Format.fprintf ppf "((size %d) (contents %a))" + value.size + print_value_float_array_contents value.contents + +let print_value_string_contents ppf (value : value_string_contents) = + match value with + | Unknown_or_mutable -> Format.fprintf ppf "(Unknown_or_mutable)" + | Contents _ -> Format.fprintf ppf "(Contents ...)" + +let print_value_string ppf (value : value_string) = + Format.fprintf ppf "((size %d) (contents %a))" + value.size + print_value_string_contents value.contents + +let print_raw_descr ppf descr = + let fprintf = Format.fprintf in + let print_approx_array ppf arr = + Array.iter (fun approx -> fprintf ppf "%a " print_raw_approx approx) arr + in + match descr with + | Value_block (tag, approx_array) -> + fprintf ppf "(Value_block (%a %a))" + Tag.print tag + print_approx_array approx_array + | Value_mutable_block (tag, i) -> + fprintf ppf "(Value_mutable-block (%a %d))" Tag.print tag i + | Value_int i -> fprintf ppf "(Value_int %d)" i + | Value_char c -> fprintf ppf "(Value_char %c)" c + | Value_constptr p -> fprintf ppf "(Value_constptr %d)" p + | Value_float f -> fprintf ppf "(Value_float %.3f)" f + | Value_float_array value_float_array -> + fprintf ppf "(Value_float_array %a)" + print_value_float_array value_float_array + | Value_boxed_int _ -> + fprintf ppf "(Value_Boxed_int)" + | Value_string value_string -> + fprintf ppf "(Value_string %a)" print_value_string value_string + | Value_closure value_closure -> + fprintf ppf "(Value_closure %a)" + print_value_closure value_closure + | Value_set_of_closures value_set_of_closures -> + fprintf ppf "(Value_set_of_closures %a)" + print_value_set_of_closures value_set_of_closures + | Value_unknown_descr -> fprintf ppf "(Value_unknown_descr)" + +let print_approx_components ppf ~symbol_id ~values + (root_symbols : Symbol.t list) = + let fprintf = Format.fprintf in + let printed = ref Export_id.Set.empty in + let recorded_symbol = ref Symbol.Set.empty in + let symbols_to_print = Queue.create () in + let printed_set_of_closures = ref Set_of_closures_id.Set.empty in + let rec print_approx ppf (approx : approx) = + match approx with + | Value_unknown -> fprintf ppf "?" + | Value_id id -> + if Export_id.Set.mem id !printed then + fprintf ppf "(%a: _)" Export_id.print id + else begin + try + let descr = find_value id values in + printed := Export_id.Set.add id !printed; + fprintf ppf "@[(%a:@ %a)@]" + Export_id.print id print_descr descr + with Not_found -> + fprintf ppf "(%a: Not available)" Export_id.print id + end + | Value_symbol sym -> + if not (Symbol.Set.mem sym !recorded_symbol) then begin + recorded_symbol := Symbol.Set.add sym !recorded_symbol; + Queue.push sym symbols_to_print; + end; + Symbol.print ppf sym + and print_descr ppf (descr : descr) = + match descr with + | Value_int i -> Format.pp_print_int ppf i + | Value_char c -> fprintf ppf "%c" c + | Value_constptr i -> fprintf ppf "%ip" i + | Value_block (tag, fields) -> + fprintf ppf "[%a:%a]" Tag.print tag print_fields fields + | Value_mutable_block (tag, size) -> + fprintf ppf "[mutable %a:%i]" Tag.print tag size + | Value_closure {closure_id; set_of_closures} -> + fprintf ppf "(closure %a, %a)" Closure_id.print closure_id + print_set_of_closures set_of_closures + | Value_set_of_closures set_of_closures -> + fprintf ppf "(set_of_closures %a)" print_set_of_closures set_of_closures + | Value_string { contents; size } -> + begin match contents with + | Unknown_or_mutable -> Format.fprintf ppf "string %i" size + | Contents s -> + let s = + if size > 10 + then String.sub s 0 8 ^ "..." + else s + in + Format.fprintf ppf "string %i %S" size s + end + | Value_float f -> Format.pp_print_float ppf f + | Value_float_array float_array -> + Format.fprintf ppf "float_array%s %i" + (match float_array.contents with + | Unknown_or_mutable -> "" + | Contents _ -> "_imm") + float_array.size + | Value_boxed_int (t, i) -> + begin match t with + | A.Int32 -> Format.fprintf ppf "%li" i + | A.Int64 -> Format.fprintf ppf "%Li" i + | A.Nativeint -> Format.fprintf ppf "%ni" i + end + | Value_unknown_descr -> Format.fprintf ppf "?" + and print_fields ppf fields = + Array.iter (fun approx -> fprintf ppf "%a@ " print_approx approx) fields + and print_set_of_closures ppf + { set_of_closures_id; bound_vars; aliased_symbol; results } = + if Set_of_closures_id.Set.mem set_of_closures_id !printed_set_of_closures + then fprintf ppf "%a" Set_of_closures_id.print set_of_closures_id + else begin + printed_set_of_closures := + Set_of_closures_id.Set.add set_of_closures_id !printed_set_of_closures; + let print_alias ppf = function + | None -> () + | Some symbol -> + Format.fprintf ppf "@ (alias: %a)" Symbol.print symbol + in + fprintf ppf "{%a: %a%a => %a}" + Set_of_closures_id.print set_of_closures_id + print_binding bound_vars + print_alias aliased_symbol + (Closure_id.Map.print print_approx) results + end + and print_binding ppf bound_vars = + Var_within_closure.Map.iter (fun clos_id approx -> + fprintf ppf "%a -> %a,@ " + Var_within_closure.print clos_id + print_approx approx) + bound_vars + in + let rec print_recorded_symbols () = + if not (Queue.is_empty symbols_to_print) then begin + let sym = Queue.pop symbols_to_print in + begin match Symbol.Map.find sym symbol_id with + | exception Not_found -> () + | id -> + fprintf ppf "@[%a:@ %a@];@ " + Symbol.print sym + print_approx (Value_id id) + end; + print_recorded_symbols (); + end + in + List.iter (fun s -> Queue.push s symbols_to_print) root_symbols; + fprintf ppf "@[Globals:@ "; + fprintf ppf "@]@ @[Symbols:@ "; + print_recorded_symbols (); + fprintf ppf "@]" + +let print_approx ppf ((t : t), symbols) = + let symbol_id = t.symbol_id in + let values = t.values in + print_approx_components ppf ~symbol_id ~values symbols + +let print_offsets ppf (t : t) = + Format.fprintf ppf "@[offset_fun:@ "; + Closure_id.Map.iter (fun cid off -> + Format.fprintf ppf "%a -> %i@ " + Closure_id.print cid off) t.offset_fun; + Format.fprintf ppf "@]@ @[offset_fv:@ "; + Var_within_closure.Map.iter (fun vid off -> + Format.fprintf ppf "%a -> %i@ " + Var_within_closure.print vid off) t.offset_fv; + Format.fprintf ppf "@]@ " + +let print_functions ppf (t : t) = + Set_of_closures_id.Map.print + A.print_function_declarations ppf + t.sets_of_closures + +let print_all ppf ((t, root_symbols) : t * Symbol.t list) = + let fprintf = Format.fprintf in + fprintf ppf "approxs@ %a@.@." + print_approx (t, root_symbols); + fprintf ppf "functions@ %a@.@." + print_functions t diff --git a/middle_end/flambda/export_info.mli b/middle_end/flambda/export_info.mli new file mode 100644 index 0000000000..f93698be4f --- /dev/null +++ b/middle_end/flambda/export_info.mli @@ -0,0 +1,195 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(** Exported information (that is to say, information written into a .cmx + file) about a compilation unit. *) + +module A = Simple_value_approx + +type value_string_contents = + | Contents of string + | Unknown_or_mutable + +type value_string = { + contents : value_string_contents; + size : int; +} + +type value_float_array_contents = + | Contents of float option array + | Unknown_or_mutable + +type value_float_array = { + contents : value_float_array_contents; + size : int; +} + +type descr = + | Value_block of Tag.t * approx array + | Value_mutable_block of Tag.t * int + | Value_int of int + | Value_char of char + | Value_constptr of int + | Value_float of float + | Value_float_array of value_float_array + | Value_boxed_int : 'a A.boxed_int * 'a -> descr + | Value_string of value_string + | Value_closure of value_closure + | Value_set_of_closures of value_set_of_closures + | Value_unknown_descr + +and value_closure = { + closure_id : Closure_id.t; + set_of_closures : value_set_of_closures; +} + +and value_set_of_closures = { + set_of_closures_id : Set_of_closures_id.t; + bound_vars : approx Var_within_closure.Map.t; + free_vars : Flambda.specialised_to Variable.Map.t; + results : approx Closure_id.Map.t; + aliased_symbol : Symbol.t option; +} + +(* CR-soon mshinwell: Fix the export information so we can correctly + propagate "unresolved due to..." in the manner of [Simple_value_approx]. + Unfortunately this seems to be complicated by the fact that, during + [Import_approx], resolution can fail not only due to missing symbols but + also due to missing export IDs. The argument type of + [Simple_value_approx.t] may need updating to reflect this (make the + symbol optional? It's only for debugging anyway.) *) +and approx = + | Value_unknown + | Value_id of Export_id.t + | Value_symbol of Symbol.t + +(** A structure that describes what a single compilation unit exports. *) +type t = private { + sets_of_closures : A.function_declarations Set_of_closures_id.Map.t; + (** Code of exported functions indexed by set of closures IDs. *) + values : descr Export_id.Map.t Compilation_unit.Map.t; + (** Structure of exported values. *) + symbol_id : Export_id.t Symbol.Map.t; + (** Associates symbols and values. *) + offset_fun : int Closure_id.Map.t; + (** Positions of function pointers in their closures. *) + offset_fv : int Var_within_closure.Map.t; + (** Positions of value pointers in their closures. *) + constant_closures : Closure_id.Set.t; + (* CR-soon mshinwell for pchambart: Add comment *) + invariant_params : Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t; + (* Function parameters known to be invariant (see [Invariant_params]) + indexed by set of closures ID. *) + recursive : Variable.Set.t Set_of_closures_id.Map.t; +} + +type transient = private { + sets_of_closures : A.function_declarations Set_of_closures_id.Map.t; + values : descr Export_id.Map.t Compilation_unit.Map.t; + symbol_id : Export_id.t Symbol.Map.t; + invariant_params : Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t; + recursive : Variable.Set.t Set_of_closures_id.Map.t; + relevant_local_closure_ids : Closure_id.Set.t; + relevant_imported_closure_ids : Closure_id.Set.t; + relevant_local_vars_within_closure : Var_within_closure.Set.t; + relevant_imported_vars_within_closure : Var_within_closure.Set.t; +} + +(** Export information for a compilation unit that exports nothing. *) +val empty : t + +val opaque_transient + : compilation_unit:Compilation_unit.t + -> root_symbol:Symbol.t + -> transient + +(** Create a new export information structure. *) +val create + : sets_of_closures:(A.function_declarations Set_of_closures_id.Map.t) + -> values:descr Export_id.Map.t Compilation_unit.Map.t + -> symbol_id:Export_id.t Symbol.Map.t + -> offset_fun:int Closure_id.Map.t + -> offset_fv:int Var_within_closure.Map.t + -> constant_closures:Closure_id.Set.t + -> invariant_params:Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t + -> recursive:Variable.Set.t Set_of_closures_id.Map.t + -> t + +val create_transient + : sets_of_closures:(A.function_declarations Set_of_closures_id.Map.t) + -> values:descr Export_id.Map.t Compilation_unit.Map.t + -> symbol_id:Export_id.t Symbol.Map.t + -> invariant_params:Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t + -> recursive:Variable.Set.t Set_of_closures_id.Map.t + -> relevant_local_closure_ids: Closure_id.Set.t + -> relevant_imported_closure_ids : Closure_id.Set.t + -> relevant_local_vars_within_closure : Var_within_closure.Set.t + -> relevant_imported_vars_within_closure : Var_within_closure.Set.t + -> transient + +(* CR-someday pchambart: Should we separate [t] in 2 types: one created by the + current [create] function, returned by [Build_export_info]. And + another built using t and offset_informations returned by + [flambda_to_clambda] ? + mshinwell: I think we should, but after we've done the first release. +*) +(** Record information about the layout of closures and which sets of + closures are constant. These are all worked out during the + [Flambda_to_clambda] pass. *) +val t_of_transient + : transient + -> program: Flambda.program + -> local_offset_fun:int Closure_id.Map.t + -> local_offset_fv:int Var_within_closure.Map.t + -> imported_offset_fun:int Closure_id.Map.t + -> imported_offset_fv:int Var_within_closure.Map.t + -> constant_closures:Closure_id.Set.t + -> t + +(** Union of export information. Verifies that there are no identifier + clashes. *) +val merge : t -> t -> t + +(** Look up the description of an exported value given its export ID. *) +val find_description + : t + -> Export_id.t + -> descr + +(** Partition a mapping from export IDs by compilation unit. *) +val nest_eid_map + : 'a Export_id.Map.t + -> 'a Export_id.Map.t Compilation_unit.Map.t + +(**/**) +(* Debug printing functions. *) +val print_approx_components + : Format.formatter + -> symbol_id: Export_id.t Symbol.Map.t + -> values: descr Export_id.Map.t Compilation_unit.Map.t + -> Symbol.t list + -> unit +val print_approx : Format.formatter -> t * Symbol.t list -> unit +val print_functions : Format.formatter -> t -> unit +val print_offsets : Format.formatter -> t -> unit +val print_all : Format.formatter -> t * Symbol.t list -> unit + +(** Prints approx and descr as it is, without recursively looking up + [Export_id.t] *) +val print_raw_approx : Format.formatter -> approx -> unit +val print_raw_descr : Format.formatter -> descr -> unit diff --git a/middle_end/flambda/export_info_for_pack.ml b/middle_end/flambda/export_info_for_pack.ml new file mode 100644 index 0000000000..42a8155347 --- /dev/null +++ b/middle_end/flambda/export_info_for_pack.ml @@ -0,0 +1,231 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +module A = Simple_value_approx + +let rename_id_state = Export_id.Tbl.create 100 +let rename_set_of_closures_id_state = Set_of_closures_id.Tbl.create 10 +let imported_function_declarations_table = + (Set_of_closures_id.Tbl.create 10 + : A.function_declarations Set_of_closures_id.Tbl.t) + +(* Rename export identifiers' compilation units to denote that they now + live within a pack. *) +let import_eid_for_pack units pack id = + try Export_id.Tbl.find rename_id_state id + with Not_found -> + let unit_id = Export_id.get_compilation_unit id in + let id' = + if Compilation_unit.Set.mem unit_id units + then Export_id.create ?name:(Export_id.name id) pack + else id + in + Export_id.Tbl.add rename_id_state id id'; + id' + +(* Similar to [import_eid_for_pack], but for symbols. *) +let import_symbol_for_pack units pack symbol = + let compilation_unit = Symbol.compilation_unit symbol in + if Compilation_unit.Set.mem compilation_unit units + then Symbol.import_for_pack ~pack symbol + else symbol + +let import_approx_for_pack units pack (approx : Export_info.approx) + : Export_info.approx = + match approx with + | Value_symbol sym -> Value_symbol (import_symbol_for_pack units pack sym) + | Value_id eid -> Value_id (import_eid_for_pack units pack eid) + | Value_unknown -> Value_unknown + +let import_set_of_closures_id_for_pack units pack + (set_of_closures_id : Set_of_closures_id.t) + : Set_of_closures_id.t = + let compilation_unit = + Set_of_closures_id.get_compilation_unit set_of_closures_id + in + if Compilation_unit.Set.mem compilation_unit units then + Set_of_closures_id.Tbl.memoize + rename_set_of_closures_id_state + (fun _ -> + Set_of_closures_id.create + ?name:(Set_of_closures_id.name set_of_closures_id) + pack) + set_of_closures_id + else set_of_closures_id + +let import_set_of_closures_origin_for_pack units pack + (set_of_closures_origin : Set_of_closures_origin.t) + : Set_of_closures_origin.t = + Set_of_closures_origin.rename + (import_set_of_closures_id_for_pack units pack) + set_of_closures_origin + +let import_set_of_closures units pack + (set_of_closures : Export_info.value_set_of_closures) + : Export_info.value_set_of_closures = + { set_of_closures_id = + import_set_of_closures_id_for_pack units pack + set_of_closures.set_of_closures_id; + bound_vars = + Var_within_closure.Map.map (import_approx_for_pack units pack) + set_of_closures.bound_vars; + free_vars = set_of_closures.free_vars; + results = + Closure_id.Map.map (import_approx_for_pack units pack) + set_of_closures.results; + aliased_symbol = + Misc.may_map + (import_symbol_for_pack units pack) + set_of_closures.aliased_symbol; + } + +let import_descr_for_pack units pack (descr : Export_info.descr) + : Export_info.descr = + match descr with + | Value_int _ + | Value_char _ + | Value_constptr _ + | Value_string _ + | Value_float _ + | Value_float_array _ + | Export_info.Value_boxed_int _ + | Value_mutable_block _ as desc -> desc + | Value_block (tag, fields) -> + Value_block (tag, Array.map (import_approx_for_pack units pack) fields) + | Value_closure { closure_id; set_of_closures } -> + Value_closure { + closure_id; + set_of_closures = import_set_of_closures units pack set_of_closures; + } + | Value_set_of_closures set_of_closures -> + Value_set_of_closures (import_set_of_closures units pack set_of_closures) + | Value_unknown_descr -> Value_unknown_descr + +let rec import_code_for_pack units pack expr = + Flambda_iterators.map_named (function + | Symbol sym -> Symbol (import_symbol_for_pack units pack sym) + | Read_symbol_field (sym, field) -> + Read_symbol_field (import_symbol_for_pack units pack sym, field) + | Set_of_closures set_of_closures -> + let set_of_closures = + Flambda.create_set_of_closures + ~free_vars:set_of_closures.free_vars + ~specialised_args:set_of_closures.specialised_args + ~direct_call_surrogates:set_of_closures.direct_call_surrogates + ~function_decls: + (import_function_declarations_for_pack_aux units pack + set_of_closures.function_decls) + in + Set_of_closures set_of_closures + | e -> e) + expr + +and import_function_declarations_for_pack_aux units pack + (function_decls : Flambda.function_declarations) = + let funs = + Variable.Map.map + (fun (function_decl : Flambda.function_declaration) -> + Flambda.create_function_declaration ~params:function_decl.params + ~body:(import_code_for_pack units pack function_decl.body) + ~stub:function_decl.stub ~dbg:function_decl.dbg + ~inline:function_decl.inline + ~specialise:function_decl.specialise + ~is_a_functor:function_decl.is_a_functor + ~closure_origin:function_decl.closure_origin) + function_decls.funs + in + Flambda.import_function_declarations_for_pack + (Flambda.update_function_declarations function_decls ~funs) + (import_set_of_closures_id_for_pack units pack) + (import_set_of_closures_origin_for_pack units pack) + +let import_function_declarations_for_pack_aux units pack + (function_decls : A.function_declarations) : A.function_declarations = + let funs = + Variable.Map.map + (fun (function_decl : A.function_declaration) -> + A.update_function_declaration_body function_decl + (fun body -> import_code_for_pack units pack body)) + function_decls.funs + in + A.import_function_declarations_for_pack + (A.update_function_declarations function_decls ~funs) + (import_set_of_closures_id_for_pack units pack) + (import_set_of_closures_origin_for_pack units pack) + +let import_function_declarations_approx_for_pack units pack + (function_decls: A.function_declarations) = + let original_set_of_closures_id = function_decls.set_of_closures_id in + try + Set_of_closures_id.Tbl.find imported_function_declarations_table + original_set_of_closures_id + with Not_found -> + let function_decls = + import_function_declarations_for_pack_aux units pack function_decls + in + Set_of_closures_id.Tbl.add + imported_function_declarations_table + original_set_of_closures_id + function_decls; + function_decls + +let import_eidmap_for_pack units pack f map = + Export_info.nest_eid_map + (Compilation_unit.Map.fold + (fun _ map acc -> Export_id.Map.disjoint_union map acc) + (Compilation_unit.Map.map (fun map -> + Export_id.Map.map_keys (import_eid_for_pack units pack) + (Export_id.Map.map f map)) + map) + Export_id.Map.empty) + +let import_for_pack ~pack_units ~pack (exp : Export_info.t) = + let import_sym = import_symbol_for_pack pack_units pack in + let import_descr = import_descr_for_pack pack_units pack in + let import_eid = import_eid_for_pack pack_units pack in + let import_eidmap f map = import_eidmap_for_pack pack_units pack f map in + let import_set_of_closures_id = + import_set_of_closures_id_for_pack pack_units pack + in + let import_function_declarations = + import_function_declarations_approx_for_pack pack_units pack + in + let sets_of_closures = + Set_of_closures_id.Map.map_keys import_set_of_closures_id + (Set_of_closures_id.Map.map + import_function_declarations + exp.sets_of_closures) + in + Export_info.create ~sets_of_closures + ~offset_fun:exp.offset_fun + ~offset_fv:exp.offset_fv + ~values:(import_eidmap import_descr exp.values) + ~symbol_id:(Symbol.Map.map_keys import_sym + (Symbol.Map.map import_eid exp.symbol_id)) + ~constant_closures:exp.constant_closures + ~invariant_params: + (Set_of_closures_id.Map.map_keys import_set_of_closures_id + exp.invariant_params) + ~recursive: + (Set_of_closures_id.Map.map_keys import_set_of_closures_id + exp.recursive) + +let clear_import_state () = + Set_of_closures_id.Tbl.clear imported_function_declarations_table; + Set_of_closures_id.Tbl.clear rename_set_of_closures_id_state; + Export_id.Tbl.clear rename_id_state diff --git a/middle_end/flambda/export_info_for_pack.mli b/middle_end/flambda/export_info_for_pack.mli new file mode 100644 index 0000000000..2ba3a35d8b --- /dev/null +++ b/middle_end/flambda/export_info_for_pack.mli @@ -0,0 +1,34 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(** Transformations on export information that are only used for the + building of packs. *) + +(** Transform the information from [exported] to be + suitable to be reexported as the information for a pack named [pack] + containing units [pack_units]. + It mainly changes symbols of units [pack_units] to refer to + [pack] instead. *) +val import_for_pack + : pack_units:Compilation_unit.Set.t + -> pack:Compilation_unit.t + -> Export_info.t + -> Export_info.t + +(** Drops the state after importing several units in the same pack. *) +val clear_import_state : unit -> unit diff --git a/middle_end/flambda/extract_projections.ml b/middle_end/flambda/extract_projections.ml new file mode 100644 index 0000000000..33cd473ecd --- /dev/null +++ b/middle_end/flambda/extract_projections.ml @@ -0,0 +1,190 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +module A = Simple_value_approx +module E = Inline_and_simplify_aux.Env + +(* CR-soon pchambart: should we restrict only to cases + when the field is aliased to a variable outside + of the closure (i.e. when we can certainly remove + the allocation of the block) ? + Note that this may prevent cases with imbricated + closures from benefiting from this transformations. + mshinwell: What word was "imbricated" supposed to be? + (The code this referred to has been deleted, but the same thing is + probably still happening). +*) + +let known_valid_projections ~env ~projections ~which_variables = + Projection.Set.filter (fun projection -> + let from = Projection.projecting_from projection in + let outer_var = + match Variable.Map.find from which_variables with + | exception Not_found -> assert false + | (outer_var : Flambda.specialised_to) -> + Freshening.apply_variable (E.freshening env) outer_var.var + in + let approx = E.find_exn env outer_var in + match projection with + | Project_var project_var -> + begin match A.check_approx_for_closure approx with + | Ok (_value_closure, _approx_var, _approx_sym, + value_set_of_closures) -> + Var_within_closure.Map.mem project_var.var + value_set_of_closures.bound_vars + | Wrong -> false + end + | Project_closure project_closure -> + begin match A.strict_check_approx_for_set_of_closures approx with + | Ok (_var, value_set_of_closures) -> + Variable.Set.mem (Closure_id.unwrap project_closure.closure_id) + (Variable.Map.keys value_set_of_closures.function_decls.funs) + | Wrong -> false + end + | Move_within_set_of_closures move -> + begin match A.check_approx_for_closure approx with + | Ok (value_closure, _approx_var, _approx_sym, + _value_set_of_closures) -> + (* We could check that [move.move_to] is in [value_set_of_closures], + but this is unnecessary, since [Closure_id]s are unique. *) + Closure_id.equal value_closure.closure_id move.start_from + | Wrong -> false + end + | Field (field_index, _) -> + match A.check_approx_for_block approx with + | Wrong -> false + | Ok (_tag, fields) -> + field_index >= 0 && field_index < Array.length fields) + projections + +let rec analyse_expr ~which_variables expr = + let projections = ref Projection.Set.empty in + let used_which_variables = ref Variable.Set.empty in + let check_free_variable var = + if Variable.Map.mem var which_variables then begin + used_which_variables := Variable.Set.add var !used_which_variables + end + in + let for_expr (expr : Flambda.expr) = + match expr with + | Var var + | Let_mutable { initial_value = var } -> + check_free_variable var + (* CR-soon mshinwell: We don't handle [Apply] for the moment to + avoid disabling unboxing optimizations whenever we see a recursive + call. We should improve this analysis. Leo says this can be + done by a similar thing to the unused argument analysis. *) + | Apply _ -> () + | Send { meth; obj; args; _ } -> + check_free_variable meth; + check_free_variable obj; + List.iter check_free_variable args + | Assign { new_value; _ } -> + check_free_variable new_value + | If_then_else (var, _, _) + | Switch (var, _) + | String_switch (var, _, _) -> + check_free_variable var + | Static_raise (_, args) -> + List.iter check_free_variable args + | For { from_value; to_value; _ } -> + check_free_variable from_value; + check_free_variable to_value + | Let _ | Let_rec _ | Static_catch _ | While _ | Try_with _ + | Proved_unreachable -> () + in + let for_named (named : Flambda.named) = + match named with + | Project_var project_var + when Variable.Map.mem project_var.closure which_variables -> + projections := + Projection.Set.add (Project_var project_var) !projections + | Project_closure project_closure + when Variable.Map.mem project_closure.set_of_closures + which_variables -> + projections := + Projection.Set.add (Project_closure project_closure) !projections + | Move_within_set_of_closures move + when Variable.Map.mem move.closure which_variables -> + projections := + Projection.Set.add (Move_within_set_of_closures move) !projections + | Prim (Pfield field_index, [var], _dbg) + when Variable.Map.mem var which_variables -> + projections := + Projection.Set.add (Field (field_index, var)) !projections + | Set_of_closures set_of_closures -> + let aliasing_free_vars = + Variable.Map.filter (fun _ (spec_to : Flambda.specialised_to) -> + Variable.Map.mem spec_to.var which_variables) + set_of_closures.free_vars + in + let aliasing_specialised_args = + Variable.Map.filter (fun _ (spec_to : Flambda.specialised_to) -> + Variable.Map.mem spec_to.var which_variables) + set_of_closures.specialised_args + in + let aliasing_vars = + Variable.Map.disjoint_union + aliasing_free_vars aliasing_specialised_args + in + if not (Variable.Map.is_empty aliasing_vars) then begin + Variable.Map.iter (fun _ (fun_decl : Flambda.function_declaration) -> + (* We ignore projections from within nested sets of closures. *) + let _, used = + analyse_expr fun_decl.body ~which_variables:aliasing_vars + in + Variable.Set.iter (fun var -> + match Variable.Map.find var aliasing_vars with + | exception Not_found -> assert false + | spec_to -> check_free_variable spec_to.var) + used) + set_of_closures.function_decls.funs + end + | Prim (_, vars, _) -> + List.iter check_free_variable vars + | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ + | Read_symbol_field _ | Project_var _ | Project_closure _ + | Move_within_set_of_closures _ + | Expr _ -> () + in + Flambda_iterators.iter_toplevel for_expr for_named expr; + let projections = !projections in + let used_which_variables = !used_which_variables in + projections, used_which_variables + +let from_function_decl ~env ~which_variables + ~(function_decl : Flambda.function_declaration) = + let projections, used_which_variables = + analyse_expr ~which_variables function_decl.body + in + (* We must use approximation information to determine which projections + are actually valid in the current environment, other we might lift + expressions too far. *) + let projections = + known_valid_projections ~env ~projections ~which_variables + in + (* Don't extract projections whose [projecting_from] variable is also + used boxed. We could in the future consider being more sophisticated + about this based on the uses in the body, but given we are not doing + that yet, it seems safest in performance terms not to (e.g.) unbox a + specialised argument whose boxed version is used. *) + Projection.Set.filter (fun projection -> + let projecting_from = Projection.projecting_from projection in + not (Variable.Set.mem projecting_from used_which_variables)) + projections diff --git a/middle_end/flambda/extract_projections.mli b/middle_end/flambda/extract_projections.mli new file mode 100644 index 0000000000..47456bda0a --- /dev/null +++ b/middle_end/flambda/extract_projections.mli @@ -0,0 +1,33 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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. *) +(* *) +(**************************************************************************) + +(** Identify projections from variables used in function bodies (free + variables or specialised args, for example, according to [which_variables] + below). Projections from variables that are also used boxed are not + returned. *) + +(** [which_variables] maps (existing) inner variables to (existing) outer + variables in the manner of [free_vars] and [specialised_args] in + [Flambda.set_of_closures]. + + The returned projections are [projecting_from] (cf. projection.mli) + the "existing inner vars". +*) +val from_function_decl + : env:Inline_and_simplify_aux.Env.t + -> which_variables:Flambda.specialised_to Variable.Map.t + -> function_decl:Flambda.function_declaration + -> Projection.Set.t diff --git a/middle_end/flambda/find_recursive_functions.ml b/middle_end/flambda/find_recursive_functions.ml new file mode 100644 index 0000000000..e69433039f --- /dev/null +++ b/middle_end/flambda/find_recursive_functions.ml @@ -0,0 +1,34 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +let in_function_declarations (function_decls : Flambda.function_declarations) + ~backend = + let module VCC = Strongly_connected_components.Make (Variable) in + let directed_graph = + let module B = (val backend : Backend_intf.S) in + Flambda_utils.fun_vars_referenced_in_decls function_decls + ~closure_symbol:B.closure_symbol + in + let connected_components = + VCC.connected_components_sorted_from_roots_to_leaf directed_graph + in + Array.fold_left (fun rec_fun -> function + | VCC.No_loop _ -> rec_fun + | VCC.Has_loop elts -> List.fold_right Variable.Set.add elts rec_fun) + Variable.Set.empty connected_components diff --git a/middle_end/flambda/find_recursive_functions.mli b/middle_end/flambda/find_recursive_functions.mli new file mode 100644 index 0000000000..3c2dd5b1fb --- /dev/null +++ b/middle_end/flambda/find_recursive_functions.mli @@ -0,0 +1,37 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(** "Recursive functions" are those functions [f] that might call either: + - themselves, or + - another function that in turn might call [f]. + + For example in the following simultaneous definition of [f] [g] and [h], + [f] and [g] are recursive functions, but not [h]: + [let rec f x = g x + and g x = f x + and h x = g x] +*) + +(** Determine the recursive functions, if any, bound by the given set of + function declarations. + This is only intended to be used by [Flambda.create_function_declarations]. +*) +val in_function_declarations + : Flambda.function_declarations + -> backend:(module Backend_intf.S) + -> Variable.Set.t diff --git a/middle_end/flambda/flambda.ml b/middle_end/flambda/flambda.ml new file mode 100644 index 0000000000..243e2e3f9c --- /dev/null +++ b/middle_end/flambda/flambda.ml @@ -0,0 +1,1272 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +type call_kind = + | Indirect + | Direct of Closure_id.t + +type const = + | Int of int + | Char of char + | Const_pointer of int + +type apply = { + func : Variable.t; + args : Variable.t list; + kind : call_kind; + dbg : Debuginfo.t; + inline : Lambda.inline_attribute; + specialise : Lambda.specialise_attribute; +} + +type assign = { + being_assigned : Mutable_variable.t; + new_value : Variable.t; +} + +type send = { + kind : Lambda.meth_kind; + meth : Variable.t; + obj : Variable.t; + args : Variable.t list; + dbg : Debuginfo.t; +} + +type project_closure = Projection.project_closure +type move_within_set_of_closures = Projection.move_within_set_of_closures +type project_var = Projection.project_var + +type specialised_to = { + var : Variable.t; + projection : Projection.t option; +} + +type t = + | Var of Variable.t + | Let of let_expr + | Let_mutable of let_mutable + | Let_rec of (Variable.t * named) list * t + | Apply of apply + | Send of send + | Assign of assign + | If_then_else of Variable.t * t * t + | Switch of Variable.t * switch + | String_switch of Variable.t * (string * t) list * t option + | Static_raise of Static_exception.t * Variable.t list + | Static_catch of Static_exception.t * Variable.t list * t * t + | Try_with of t * Variable.t * t + | While of t * t + | For of for_loop + | Proved_unreachable + +and named = + | Symbol of Symbol.t + | Const of const + | Allocated_const of Allocated_const.t + | Read_mutable of Mutable_variable.t + | Read_symbol_field of Symbol.t * int + | Set_of_closures of set_of_closures + | Project_closure of project_closure + | Move_within_set_of_closures of move_within_set_of_closures + | Project_var of project_var + | Prim of Clambda_primitives.primitive * Variable.t list * Debuginfo.t + | Expr of t + +and let_expr = { + var : Variable.t; + defining_expr : named; + body : t; + free_vars_of_defining_expr : Variable.Set.t; + free_vars_of_body : Variable.Set.t; +} + +and let_mutable = { + var : Mutable_variable.t; + initial_value : Variable.t; + contents_kind : Lambda.value_kind; + body : t; +} + +and set_of_closures = { + function_decls : function_declarations; + free_vars : specialised_to Variable.Map.t; + specialised_args : specialised_to Variable.Map.t; + direct_call_surrogates : Variable.t Variable.Map.t; +} + +and function_declarations = { + is_classic_mode : bool; + set_of_closures_id : Set_of_closures_id.t; + set_of_closures_origin : Set_of_closures_origin.t; + funs : function_declaration Variable.Map.t; +} + +and function_declaration = { + closure_origin: Closure_origin.t; + params : Parameter.t list; + body : t; + free_variables : Variable.Set.t; + free_symbols : Symbol.Set.t; + stub : bool; + dbg : Debuginfo.t; + inline : Lambda.inline_attribute; + specialise : Lambda.specialise_attribute; + is_a_functor : bool; +} + +and switch = { + numconsts : Numbers.Int.Set.t; + consts : (int * t) list; + numblocks : Numbers.Int.Set.t; + blocks : (int * t) list; + failaction : t option; +} + +and for_loop = { + bound_var : Variable.t; + from_value : Variable.t; + to_value : Variable.t; + direction : Asttypes.direction_flag; + body : t +} + +and constant_defining_value = + | Allocated_const of Allocated_const.t + | Block of Tag.t * constant_defining_value_block_field list + | Set_of_closures of set_of_closures (* [free_vars] must be empty *) + | Project_closure of Symbol.t * Closure_id.t + +and constant_defining_value_block_field = + | Symbol of Symbol.t + | Const of const + +type expr = t + +type program_body = + | Let_symbol of Symbol.t * constant_defining_value * program_body + | Let_rec_symbol of (Symbol.t * constant_defining_value) list * program_body + | Initialize_symbol of Symbol.t * Tag.t * t list * program_body + | Effect of t * program_body + | End of Symbol.t + +type program = { + imported_symbols : Symbol.Set.t; + program_body : program_body; +} + +let fprintf = Format.fprintf +module Int = Numbers.Int + +let print_specialised_to ppf (spec_to : specialised_to) = + match spec_to.projection with + | None -> fprintf ppf "%a" Variable.print spec_to.var + | Some projection -> + fprintf ppf "%a(= %a)" + Variable.print spec_to.var + Projection.print projection + +(* CR-soon mshinwell: delete uses of old names *) +let print_project_var = Projection.print_project_var +let print_move_within_set_of_closures = + Projection.print_move_within_set_of_closures +let print_project_closure = Projection.print_project_closure + +(** CR-someday lwhite: use better name than this *) +let rec lam ppf (flam : t) = + match flam with + | Var (id) -> + Variable.print ppf id + | Apply({func; args; kind; inline; dbg}) -> + let direct ppf () = + match kind with + | Indirect -> () + | Direct closure_id -> fprintf ppf "*[%a]" Closure_id.print closure_id + in + let inline ppf () = + match inline with + | Always_inline -> fprintf ppf "" + | Never_inline -> fprintf ppf "" + | Unroll i -> fprintf ppf "" i + | Default_inline -> () + in + fprintf ppf "@[<2>(apply%a%a<%s>@ %a%a)@]" direct () inline () + (Debuginfo.to_string dbg) + Variable.print func Variable.print_list args + | Assign { being_assigned; new_value; } -> + fprintf ppf "@[<2>(assign@ %a@ %a)@]" + Mutable_variable.print being_assigned + Variable.print new_value + | Send { kind; meth; obj; args; dbg = _; } -> + let print_args ppf args = + List.iter (fun l -> fprintf ppf "@ %a" Variable.print l) args + in + let kind = + match kind with + | Self -> "self" + | Public -> "public" + | Cached -> "cached" + in + fprintf ppf "@[<2>(send%s@ %a@ %a%a)@]" kind + Variable.print obj Variable.print meth + print_args args + | Proved_unreachable -> + fprintf ppf "unreachable" + | Let { var = id; defining_expr = arg; body; _ } -> + let rec letbody (ul : t) = + match ul with + | Let { var = id; defining_expr = arg; body; _ } -> + fprintf ppf "@ @[<2>%a@ %a@]" Variable.print id print_named arg; + letbody body + | _ -> ul + in + fprintf ppf "@[<2>(let@ @[(@[<2>%a@ %a@]" + Variable.print id print_named arg; + let expr = letbody body in + fprintf ppf ")@]@ %a)@]" lam expr + | Let_mutable { var = mut_var; initial_value = var; body; contents_kind } -> + let print_kind ppf (kind : Lambda.value_kind) = + match kind with + | Pgenval -> () + | _ -> Format.fprintf ppf " %a" Printlambda.value_kind kind + in + fprintf ppf "@[<2>(let_mutable%a@ @[<2>%a@ %a@]@ %a)@]" + print_kind contents_kind + Mutable_variable.print mut_var + Variable.print var + lam body + | Let_rec(id_arg_list, body) -> + let bindings ppf id_arg_list = + let spc = ref false in + List.iter + (fun (id, l) -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[<2>%a@ %a@]" Variable.print id print_named l) + id_arg_list in + fprintf ppf + "@[<2>(letrec@ (@[%a@])@ %a)@]" bindings id_arg_list lam body + | Switch(larg, sw) -> + let switch ppf (sw : switch) = + let spc = ref false in + List.iter + (fun (n, l) -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[case int %i:@ %a@]" n lam l) + sw.consts; + List.iter + (fun (n, l) -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[case tag %i:@ %a@]" n lam l) + sw.blocks ; + begin match sw.failaction with + | None -> () + | Some l -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[default:@ %a@]" lam l + end in + fprintf ppf + "@[<1>(%s(%i,%i) %a@ @[%a@])@]" + (match sw.failaction with None -> "switch*" | _ -> "switch") + (Int.Set.cardinal sw.numconsts) + (Int.Set.cardinal sw.numblocks) + Variable.print larg switch sw + | String_switch(arg, cases, default) -> + let switch ppf cases = + let spc = ref false in + List.iter + (fun (s, l) -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[case \"%s\":@ %a@]" (String.escaped s) lam l) + cases; + begin match default with + | Some default -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[default:@ %a@]" lam default + | None -> () + end in + fprintf ppf + "@[<1>(stringswitch %a@ @[%a@])@]" Variable.print arg switch cases + | Static_raise (i, ls) -> + let lams ppf largs = + List.iter (fun l -> fprintf ppf "@ %a" Variable.print l) largs in + fprintf ppf "@[<2>(exit@ %a%a)@]" Static_exception.print i lams ls; + | Static_catch(i, vars, lbody, lhandler) -> + fprintf ppf "@[<2>(catch@ %a@;<1 -1>with (%a%a)@ %a)@]" + lam lbody Static_exception.print i + (fun ppf vars -> match vars with + | [] -> () + | _ -> + List.iter + (fun x -> fprintf ppf " %a" Variable.print x) + vars) + vars + lam lhandler + | Try_with(lbody, param, lhandler) -> + fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]" + lam lbody Variable.print param lam lhandler + | If_then_else(lcond, lif, lelse) -> + fprintf ppf "@[<2>(if@ %a@ then begin@ %a@ end else begin@ %a@ end)@]" + Variable.print lcond + lam lif lam lelse + | While(lcond, lbody) -> + fprintf ppf "@[<2>(while@ %a@ %a)@]" lam lcond lam lbody + | For { bound_var; from_value; to_value; direction; body; } -> + fprintf ppf "@[<2>(for %a@ %a@ %s@ %a@ %a)@]" + Variable.print bound_var Variable.print from_value + (match direction with + Asttypes.Upto -> "to" | Asttypes.Downto -> "downto") + Variable.print to_value lam body +and print_named ppf (named : named) = + match named with + | Symbol (symbol) -> Symbol.print ppf symbol + | Const (cst) -> fprintf ppf "Const(%a)" print_const cst + | Allocated_const (cst) -> fprintf ppf "Aconst(%a)" Allocated_const.print cst + | Read_mutable mut_var -> + fprintf ppf "Read_mut(%a)" Mutable_variable.print mut_var + | Read_symbol_field (symbol, field) -> + fprintf ppf "%a.(%d)" Symbol.print symbol field + | Project_closure (project_closure) -> + print_project_closure ppf project_closure + | Project_var (project_var) -> print_project_var ppf project_var + | Move_within_set_of_closures (move_within_set_of_closures) -> + print_move_within_set_of_closures ppf move_within_set_of_closures + | Set_of_closures (set_of_closures) -> + print_set_of_closures ppf set_of_closures + | Prim(prim, args, dbg) -> + fprintf ppf "@[<2>(%a<%s>%a)@]" Printclambda_primitives.primitive prim + (Debuginfo.to_string dbg) + Variable.print_list args + | Expr expr -> + fprintf ppf "*%a" lam expr + (* lam ppf expr *) + +and print_function_declaration ppf var (f : function_declaration) = + let param ppf p = + Variable.print ppf (Parameter.var p) + in + let params ppf = + List.iter (fprintf ppf "@ %a" param) in + let stub = + if f.stub then + " *stub*" + else + "" + in + let is_a_functor = + if f.is_a_functor then + " *functor*" + else + "" + in + let inline = + match f.inline with + | Always_inline -> " *inline*" + | Never_inline -> " *never_inline*" + | Unroll _ -> " *unroll*" + | Default_inline -> "" + in + let specialise = + match f.specialise with + | Always_specialise -> " *specialise*" + | Never_specialise -> " *never_specialise*" + | Default_specialise -> "" + in + fprintf ppf "@[<2>(%a%s%s%s%s@ =@ fun@[<2>%a@] ->@ @[<2>%a@])@]@ " + Variable.print var stub is_a_functor inline specialise + params f.params lam f.body + +and print_set_of_closures ppf (set_of_closures : set_of_closures) = + match set_of_closures with + | { function_decls; free_vars; specialised_args} -> + let funs ppf = + Variable.Map.iter (print_function_declaration ppf) + in + let vars ppf = + Variable.Map.iter (fun id v -> + fprintf ppf "@ %a -rename-> %a" + Variable.print id print_specialised_to v) + in + let spec ppf spec_args = + if not (Variable.Map.is_empty spec_args) + then begin + fprintf ppf "@ "; + Variable.Map.iter (fun id (spec_to : specialised_to) -> + fprintf ppf "@ %a := %a" + Variable.print id print_specialised_to spec_to) + spec_args + end + in + fprintf ppf "@[<2>(set_of_closures id=%a@ %a@ @[<2>free_vars={%a@ }@]@ \ + @[<2>specialised_args={%a})@]@ \ + @[<2>direct_call_surrogates=%a@]@ \ + @[<2>set_of_closures_origin=%a@]@]]" + Set_of_closures_id.print function_decls.set_of_closures_id + funs function_decls.funs + vars free_vars + spec specialised_args + (Variable.Map.print Variable.print) + set_of_closures.direct_call_surrogates + Set_of_closures_origin.print function_decls.set_of_closures_origin + +and print_const ppf (c : const) = + match c with + | Int n -> fprintf ppf "%i" n + | Char c -> fprintf ppf "%C" c + | Const_pointer n -> fprintf ppf "%ia" n + +let print_function_declarations ppf (fd : function_declarations) = + let funs ppf = + Variable.Map.iter (print_function_declaration ppf) + in + fprintf ppf "@[<2>(%a)(origin = %a)@]" funs fd.funs + Set_of_closures_origin.print fd.set_of_closures_origin + +let print ppf flam = + fprintf ppf "%a@." lam flam + +let print_function_declaration ppf (var, decl) = + print_function_declaration ppf var decl + +let print_constant_defining_value ppf (const : constant_defining_value) = + match const with + | Allocated_const const -> + fprintf ppf "(Allocated_const %a)" Allocated_const.print const + | Block (tag, []) -> fprintf ppf "(Atom (tag %d))" (Tag.to_int tag) + | Block (tag, fields) -> + let print_field ppf (field : constant_defining_value_block_field) = + match field with + | Symbol symbol -> Symbol.print ppf symbol + | Const const -> print_const ppf const + in + let print_fields ppf = + List.iter (fprintf ppf "@ %a" print_field) + in + fprintf ppf "(Block (tag %d, %a))" (Tag.to_int tag) + print_fields fields + | Set_of_closures set_of_closures -> + fprintf ppf "@[<2>(Set_of_closures (@ %a))@]" print_set_of_closures + set_of_closures + | Project_closure (set_of_closures, closure_id) -> + fprintf ppf "(Project_closure (%a, %a))" Symbol.print set_of_closures + Closure_id.print closure_id + +let rec print_program_body ppf (program : program_body) = + let symbol_binding ppf (symbol, constant_defining_value) = + fprintf ppf "@[<2>(%a@ %a)@]" + Symbol.print symbol + print_constant_defining_value constant_defining_value + in + match program with + | Let_symbol (symbol, constant_defining_value, body) -> + let rec extract acc (ul : program_body) = + match ul with + | Let_symbol (symbol, constant_defining_value, body) -> + extract ((symbol, constant_defining_value) :: acc) body + | _ -> + List.rev acc, ul + in + let defs, program = extract [symbol, constant_defining_value] body in + fprintf ppf + "@[<2>let_symbol@ @[%a@]@]@." + (Format.pp_print_list symbol_binding) defs; + print_program_body ppf program + | Let_rec_symbol (defs, program) -> + fprintf ppf + "@[<2>let_rec_symbol@ @[%a@]@]@." + (Format.pp_print_list symbol_binding) defs; + print_program_body ppf program + | Initialize_symbol (symbol, tag, fields, program) -> + fprintf ppf "@[<2>initialize_symbol@ (@[<2>%a@ %a@ %a@])@]@." + Symbol.print symbol + Tag.print tag + (Format.pp_print_list lam) fields; + print_program_body ppf program + | Effect (expr, program) -> + fprintf ppf "@[<2>effect@ %a@]@." + lam expr; + print_program_body ppf program; + | End root -> fprintf ppf "End %a" Symbol.print root + +let print_program ppf program = + Symbol.Set.iter (fun symbol -> + fprintf ppf "@[import_symbol@ %a@]@." Symbol.print symbol) + program.imported_symbols; + print_program_body ppf program.program_body + +let rec variables_usage ?ignore_uses_as_callee ?ignore_uses_as_argument + ?ignore_uses_in_project_var ~all_used_variables tree = + match tree with + | Var var -> Variable.Set.singleton var + | _ -> + let free = ref Variable.Set.empty in + let bound = ref Variable.Set.empty in + let free_variables ids = free := Variable.Set.union ids !free in + let free_variable fv = free := Variable.Set.add fv !free in + let bound_variable id = bound := Variable.Set.add id !bound in + (* N.B. This function assumes that all bound identifiers are distinct. *) + let rec aux (flam : t) : unit = + match flam with + | Var var -> free_variable var + | Apply { func; args; kind = _; dbg = _} -> + begin match ignore_uses_as_callee with + | None -> free_variable func + | Some () -> () + end; + begin match ignore_uses_as_argument with + | None -> List.iter free_variable args + | Some () -> () + end + | Let { var; free_vars_of_defining_expr; free_vars_of_body; + defining_expr; body; _ } -> + bound_variable var; + if all_used_variables + || Option.is_some ignore_uses_as_callee + || Option.is_some ignore_uses_as_argument + || Option.is_some ignore_uses_in_project_var + then begin + (* In these cases we can't benefit from the pre-computed free + variable sets. *) + free_variables + (variables_usage_named ?ignore_uses_in_project_var + ?ignore_uses_as_callee ?ignore_uses_as_argument + ~all_used_variables defining_expr); + aux body + end else begin + free_variables free_vars_of_defining_expr; + free_variables free_vars_of_body + end + | Let_mutable { initial_value = var; body; _ } -> + free_variable var; + aux body + | Let_rec (bindings, body) -> + List.iter (fun (var, defining_expr) -> + bound_variable var; + free_variables + (variables_usage_named ?ignore_uses_in_project_var + ~all_used_variables defining_expr)) + bindings; + aux body + | Switch (scrutinee, switch) -> + free_variable scrutinee; + List.iter (fun (_, e) -> aux e) switch.consts; + List.iter (fun (_, e) -> aux e) switch.blocks; + Misc.may aux switch.failaction + | String_switch (scrutinee, cases, failaction) -> + free_variable scrutinee; + List.iter (fun (_, e) -> aux e) cases; + Misc.may aux failaction + | Static_raise (_, es) -> + List.iter free_variable es + | Static_catch (_, vars, e1, e2) -> + List.iter bound_variable vars; + aux e1; + aux e2 + | Try_with (e1, var, e2) -> + aux e1; + bound_variable var; + aux e2 + | If_then_else (var, e1, e2) -> + free_variable var; + aux e1; + aux e2 + | While (e1, e2) -> + aux e1; + aux e2 + | For { bound_var; from_value; to_value; direction = _; body; } -> + bound_variable bound_var; + free_variable from_value; + free_variable to_value; + aux body + | Assign { being_assigned = _; new_value; } -> + free_variable new_value + | Send { kind = _; meth; obj; args; dbg = _ } -> + free_variable meth; + free_variable obj; + List.iter free_variable args; + | Proved_unreachable -> () + in + aux tree; + if all_used_variables then + !free + else + Variable.Set.diff !free !bound + +and variables_usage_named ?ignore_uses_in_project_var + ?ignore_uses_as_callee ?ignore_uses_as_argument + ~all_used_variables named = + let free = ref Variable.Set.empty in + let free_variable fv = free := Variable.Set.add fv !free in + begin match named with + | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ + | Read_symbol_field _ -> () + | Set_of_closures { free_vars; specialised_args; _ } -> + (* Sets of closures are, well, closed---except for the free variable and + specialised argument lists, which may identify variables currently in + scope outside of the closure. *) + Variable.Map.iter (fun _ (renamed_to : specialised_to) -> + (* We don't need to do anything with [renamed_to.projectee.var], if + it is present, since it would only be another free variable + in the same set of closures. *) + free_variable renamed_to.var) + free_vars; + Variable.Map.iter (fun _ (spec_to : specialised_to) -> + (* We don't need to do anything with [spec_to.projectee.var], if + it is present, since it would only be another specialised arg + in the same set of closures. *) + free_variable spec_to.var) + specialised_args + | Project_closure { set_of_closures; closure_id = _ } -> + free_variable set_of_closures + | Project_var { closure; closure_id = _; var = _ } -> + begin match ignore_uses_in_project_var with + | None -> free_variable closure + | Some () -> () + end + | Move_within_set_of_closures { closure; start_from = _; move_to = _ } -> + free_variable closure + | Prim (_, args, _) -> List.iter free_variable args + | Expr flam -> + free := Variable.Set.union + (variables_usage ?ignore_uses_as_callee ?ignore_uses_as_argument + ~all_used_variables flam) !free + end; + !free + +let free_variables ?ignore_uses_as_callee ?ignore_uses_as_argument + ?ignore_uses_in_project_var tree = + variables_usage ?ignore_uses_as_callee ?ignore_uses_as_argument + ?ignore_uses_in_project_var ~all_used_variables:false tree + +let free_variables_named ?ignore_uses_in_project_var named = + variables_usage_named ?ignore_uses_in_project_var + ~all_used_variables:false named + +let used_variables ?ignore_uses_as_callee ?ignore_uses_as_argument + ?ignore_uses_in_project_var tree = + variables_usage ?ignore_uses_as_callee ?ignore_uses_as_argument + ?ignore_uses_in_project_var ~all_used_variables:true tree + +let used_variables_named ?ignore_uses_in_project_var named = + variables_usage_named ?ignore_uses_in_project_var + ~all_used_variables:true named + +let create_let var defining_expr body : t = + begin match !Clflags.dump_flambda_let with + | None -> () + | Some stamp -> + Variable.debug_when_stamp_matches var ~stamp ~f:(fun () -> + Printf.eprintf "Creation of [Let] with stamp %d:\n%s\n%!" + stamp + (Printexc.raw_backtrace_to_string (Printexc.get_callstack max_int))) + end; + let defining_expr, free_vars_of_defining_expr = + match defining_expr with + | Expr (Let { var = var1; defining_expr; body = Var var2; + free_vars_of_defining_expr; _ }) when Variable.equal var1 var2 -> + defining_expr, free_vars_of_defining_expr + | _ -> defining_expr, free_variables_named defining_expr + in + Let { + var; + defining_expr; + body; + free_vars_of_defining_expr; + free_vars_of_body = free_variables body; + } + +let map_defining_expr_of_let let_expr ~f = + let defining_expr = f let_expr.defining_expr in + if defining_expr == let_expr.defining_expr then + Let let_expr + else + let free_vars_of_defining_expr = + free_variables_named defining_expr + in + Let { + var = let_expr.var; + defining_expr; + body = let_expr.body; + free_vars_of_defining_expr; + free_vars_of_body = let_expr.free_vars_of_body; + } + +let iter_lets t ~for_defining_expr ~for_last_body ~for_each_let = + let rec loop (t : t) = + match t with + | Let { var; defining_expr; body; _ } -> + for_each_let t; + for_defining_expr var defining_expr; + loop body + | t -> + for_last_body t + in + loop t + +let map_lets t ~for_defining_expr ~for_last_body ~after_rebuild = + let rec loop (t : t) ~rev_lets = + match t with + | Let { var; defining_expr; body; _ } -> + let new_defining_expr = + for_defining_expr var defining_expr + in + let original = + if new_defining_expr == defining_expr then + Some t + else + None + in + let rev_lets = (var, new_defining_expr, original) :: rev_lets in + loop body ~rev_lets + | t -> + let last_body = for_last_body t in + (* As soon as we see a change, we have to rebuild that [Let] and every + outer one. *) + let seen_change = ref (not (last_body == t)) in + List.fold_left (fun t (var, defining_expr, original) -> + let let_expr = + match original with + | Some original when not !seen_change -> original + | Some _ | None -> + seen_change := true; + create_let var defining_expr t + in + let new_let = after_rebuild let_expr in + if not (new_let == let_expr) then begin + seen_change := true + end; + new_let) + last_body + rev_lets + in + loop t ~rev_lets:[] + +(** CR-someday lwhite: Why not use two functions? *) +type maybe_named = + | Is_expr of t + | Is_named of named + +let iter_general ~toplevel f f_named maybe_named = + let rec aux (t : t) = + match t with + | Let _ -> + iter_lets t + ~for_defining_expr:(fun _var named -> aux_named named) + ~for_last_body:aux + ~for_each_let:f + | _ -> + f t; + match t with + | Var _ | Apply _ | Assign _ | Send _ | Proved_unreachable + | Static_raise _ -> () + | Let _ -> assert false + | Let_mutable { body; _ } -> + aux body + | Let_rec (defs, body) -> + List.iter (fun (_,l) -> aux_named l) defs; + aux body + | Try_with (f1,_,f2) + | While (f1,f2) + | Static_catch (_,_,f1,f2) -> + aux f1; aux f2 + | For { body; _ } -> aux body + | If_then_else (_, f1, f2) -> + aux f1; aux f2 + | Switch (_, sw) -> + List.iter (fun (_,l) -> aux l) sw.consts; + List.iter (fun (_,l) -> aux l) sw.blocks; + Misc.may aux sw.failaction + | String_switch (_, sw, def) -> + List.iter (fun (_,l) -> aux l) sw; + Misc.may aux def + and aux_named (named : named) = + f_named named; + match named with + | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ + | Read_symbol_field _ + | Project_closure _ | Project_var _ | Move_within_set_of_closures _ + | Prim _ -> () + | Set_of_closures ({ function_decls = funcs; free_vars = _; + specialised_args = _}) -> + if not toplevel then begin + Variable.Map.iter (fun _ (decl : function_declaration) -> + aux decl.body) + funcs.funs + end + | Expr flam -> aux flam + in + match maybe_named with + | Is_expr expr -> aux expr + | Is_named named -> aux_named named + +module With_free_variables = struct + type 'a t = + | Expr : expr * Variable.Set.t -> expr t + | Named : named * Variable.Set.t -> named t + + let of_defining_expr_of_let let_expr = + Named (let_expr.defining_expr, let_expr.free_vars_of_defining_expr) + + let of_body_of_let let_expr = + Expr (let_expr.body, let_expr.free_vars_of_body) + + let of_expr expr = + Expr (expr, free_variables expr) + + let of_named named = + Named (named, free_variables_named named) + + let create_let_reusing_defining_expr var (t : named t) body = + match t with + | Named (defining_expr, free_vars_of_defining_expr) -> + Let { + var; + defining_expr; + body; + free_vars_of_defining_expr; + free_vars_of_body = free_variables body; + } + + let create_let_reusing_body var defining_expr (t : expr t) = + match t with + | Expr (body, free_vars_of_body) -> + Let { + var; + defining_expr; + body; + free_vars_of_defining_expr = free_variables_named defining_expr; + free_vars_of_body; + } + + let create_let_reusing_both var (t1 : named t) (t2 : expr t) = + match t1, t2 with + | Named (defining_expr, free_vars_of_defining_expr), + Expr (body, free_vars_of_body) -> + Let { + var; + defining_expr; + body; + free_vars_of_defining_expr; + free_vars_of_body; + } + + let expr (t : expr t) = + match t with + | Expr (expr, free_vars) -> Named (Expr expr, free_vars) + + let contents (type a) (t : a t) : a = + match t with + | Expr (expr, _) -> expr + | Named (named, _) -> named + + let free_variables (type a) (t : a t) = + match t with + | Expr (_, free_vars) -> free_vars + | Named (_, free_vars) -> free_vars +end + +let fold_lets_option + t ~init + ~(for_defining_expr:('a -> Variable.t -> named -> 'a * Variable.t * named)) + ~for_last_body + ~(filter_defining_expr:('b -> Variable.t -> named -> Variable.Set.t -> + 'b * Variable.t * named option)) = + let finish ~last_body ~acc ~rev_lets = + let module W = With_free_variables in + let acc, t = + List.fold_left (fun (acc, t) (var, defining_expr) -> + let free_vars_of_body = W.free_variables t in + let acc, var, defining_expr = + filter_defining_expr acc var defining_expr free_vars_of_body + in + match defining_expr with + | None -> acc, t + | Some defining_expr -> + let let_expr = + W.create_let_reusing_body var defining_expr t + in + acc, W.of_expr let_expr) + (acc, W.of_expr last_body) + rev_lets + in + W.contents t, acc + in + let rec loop (t : t) ~acc ~rev_lets = + match t with + | Let { var; defining_expr; body; _ } -> + let acc, var, defining_expr = + for_defining_expr acc var defining_expr + in + let rev_lets = (var, defining_expr) :: rev_lets in + loop body ~acc ~rev_lets + | t -> + let last_body, acc = for_last_body acc t in + finish ~last_body ~acc ~rev_lets + in + loop t ~acc:init ~rev_lets:[] + +let free_symbols_helper symbols (named : named) = + match named with + | Symbol symbol + | Read_symbol_field (symbol, _) -> symbols := Symbol.Set.add symbol !symbols + | Set_of_closures set_of_closures -> + Variable.Map.iter (fun _ (function_decl : function_declaration) -> + symbols := Symbol.Set.union function_decl.free_symbols !symbols) + set_of_closures.function_decls.funs + | _ -> () + +let free_symbols expr = + let symbols = ref Symbol.Set.empty in + iter_general ~toplevel:true + (fun (_ : t) -> ()) + (fun (named : named) -> free_symbols_helper symbols named) + (Is_expr expr); + !symbols + +let free_symbols_named named = + let symbols = ref Symbol.Set.empty in + iter_general ~toplevel:true + (fun (_ : t) -> ()) + (fun (named : named) -> free_symbols_helper symbols named) + (Is_named named); + !symbols + +let free_symbols_allocated_constant_helper symbols + (const : constant_defining_value) = + match const with + | Allocated_const _ -> () + | Block (_, fields) -> + List.iter + (function + | (Symbol s : constant_defining_value_block_field) -> + symbols := Symbol.Set.add s !symbols + | (Const _ : constant_defining_value_block_field) -> ()) + fields + | Set_of_closures set_of_closures -> + symbols := Symbol.Set.union !symbols + (free_symbols_named (Set_of_closures set_of_closures)) + | Project_closure (s, _) -> + symbols := Symbol.Set.add s !symbols + +let free_symbols_program (program : program) = + let symbols = ref Symbol.Set.empty in + let rec loop (program : program_body) = + match program with + | Let_symbol (_, const, program) -> + free_symbols_allocated_constant_helper symbols const; + loop program + | Let_rec_symbol (defs, program) -> + List.iter (fun (_, const) -> + free_symbols_allocated_constant_helper symbols const) + defs; + loop program + | Initialize_symbol (_, _, fields, program) -> + List.iter (fun field -> + symbols := Symbol.Set.union !symbols (free_symbols field)) + fields; + loop program + | Effect (expr, program) -> + symbols := Symbol.Set.union !symbols (free_symbols expr); + loop program + | End symbol -> symbols := Symbol.Set.add symbol !symbols + in + (* Note that there is no need to count the [imported_symbols]. *) + loop program.program_body; + !symbols + +let update_body_of_function_declaration (func_decl: function_declaration) + ~body : function_declaration = + { closure_origin = func_decl.closure_origin; + params = func_decl.params; + body; + free_variables = free_variables body; + free_symbols = free_symbols body; + stub = func_decl.stub; + dbg = func_decl.dbg; + inline = func_decl.inline; + specialise = func_decl.specialise; + is_a_functor = func_decl.is_a_functor; + } + +let update_function_decl's_params_and_body + (func_decl : function_declaration) ~params ~body = + { closure_origin = func_decl.closure_origin; + params; + body; + free_variables = free_variables body; + free_symbols = free_symbols body; + stub = func_decl.stub; + dbg = func_decl.dbg; + inline = func_decl.inline; + specialise = func_decl.specialise; + is_a_functor = func_decl.is_a_functor; + } + + +let create_function_declaration ~params ~body ~stub ~dbg + ~(inline : Lambda.inline_attribute) + ~(specialise : Lambda.specialise_attribute) ~is_a_functor + ~closure_origin + : function_declaration = + begin match stub, inline with + | true, (Never_inline | Default_inline) + | false, (Never_inline | Default_inline | Always_inline | Unroll _) -> () + | true, (Always_inline | Unroll _) -> + Misc.fatal_errorf + "Stubs may not be annotated as [Always_inline] or [Unroll]: %a" + print body + end; + begin match stub, specialise with + | true, (Never_specialise | Default_specialise) + | false, (Never_specialise | Default_specialise | Always_specialise) -> () + | true, Always_specialise -> + Misc.fatal_errorf + "Stubs may not be annotated as [Always_specialise]: %a" + print body + end; + { closure_origin; + params; + body; + free_variables = free_variables body; + free_symbols = free_symbols body; + stub; + dbg; + inline; + specialise; + is_a_functor; + } + +let update_function_declaration fun_decl ~params ~body = + let free_variables = free_variables body in + let free_symbols = free_symbols body in + { fun_decl with params; body; free_variables; free_symbols } + +let create_function_declarations ~is_classic_mode ~funs = + let compilation_unit = Compilation_unit.get_current_exn () in + let set_of_closures_id = Set_of_closures_id.create compilation_unit in + let set_of_closures_origin = + Set_of_closures_origin.create set_of_closures_id + in + { is_classic_mode; + set_of_closures_id; + set_of_closures_origin; + funs; + } + +let create_function_declarations_with_origin + ~is_classic_mode ~funs ~set_of_closures_origin = + let compilation_unit = Compilation_unit.get_current_exn () in + let set_of_closures_id = Set_of_closures_id.create compilation_unit in + { is_classic_mode; + set_of_closures_id; + set_of_closures_origin; + funs; + } + +let update_function_declarations function_decls ~funs = + let is_classic_mode = function_decls.is_classic_mode in + let compilation_unit = Compilation_unit.get_current_exn () in + let set_of_closures_id = Set_of_closures_id.create compilation_unit in + let set_of_closures_origin = function_decls.set_of_closures_origin in + { is_classic_mode; + set_of_closures_id; + set_of_closures_origin; + funs; + } + +let create_function_declarations_with_closures_origin + ~is_classic_mode ~funs ~set_of_closures_origin = + let compilation_unit = Compilation_unit.get_current_exn () in + let set_of_closures_id = Set_of_closures_id.create compilation_unit in + { is_classic_mode; + set_of_closures_id; + set_of_closures_origin; + funs + } + +let import_function_declarations_for_pack function_decls + import_set_of_closures_id import_set_of_closures_origin = + let is_classic_mode = function_decls.is_classic_mode in + let set_of_closures_id = + import_set_of_closures_id function_decls.set_of_closures_id + in + let set_of_closures_origin = + import_set_of_closures_origin function_decls.set_of_closures_origin + in + let funs = function_decls.funs in + { is_classic_mode; + set_of_closures_id; + set_of_closures_origin; + funs; + } + +let create_set_of_closures ~function_decls ~free_vars ~specialised_args + ~direct_call_surrogates = + if !Clflags.flambda_invariant_checks then begin + let all_fun_vars = Variable.Map.keys function_decls.funs in + let expected_free_vars = + Variable.Map.fold (fun _fun_var function_decl expected_free_vars -> + let free_vars = + Variable.Set.diff function_decl.free_variables + (Variable.Set.union (Parameter.Set.vars function_decl.params) + all_fun_vars) + in + Variable.Set.union free_vars expected_free_vars) + function_decls.funs + Variable.Set.empty + in + (* CR-soon pchambart: We do not seem to be able to maintain the + invariant that if a variable is not used inside the closure, it + is not used outside either. This would be a nice property for + better dead code elimination during inline_and_simplify, but it + is not obvious how to ensure that. + + This would be true when the function is known never to have + been inlined. + + Note that something like that may maybe enforcable in + inline_and_simplify, but there is no way to do that on other + passes. + + mshinwell: see CR in Flambda_invariants about this too + *) + let free_vars_domain = Variable.Map.keys free_vars in + if not (Variable.Set.subset expected_free_vars free_vars_domain) then begin + Misc.fatal_errorf "create_set_of_closures: [free_vars] mapping of \ + variables bound by the closure(s) is wrong. (Must map at least \ + %a but only maps %a.)@ \nfunction_decls:@ %a" + Variable.Set.print expected_free_vars + Variable.Set.print free_vars_domain + print_function_declarations function_decls + end; + let all_params = + Variable.Map.fold (fun _fun_var function_decl all_params -> + Variable.Set.union (Parameter.Set.vars function_decl.params) + all_params) + function_decls.funs + Variable.Set.empty + in + let spec_args_domain = Variable.Map.keys specialised_args in + if not (Variable.Set.subset spec_args_domain all_params) then begin + Misc.fatal_errorf "create_set_of_closures: [specialised_args] \ + maps variable(s) that are not parameters of the given function \ + declarations. specialised_args domain=%a all_params=%a \n\ + function_decls:@ %a" + Variable.Set.print spec_args_domain + Variable.Set.print all_params + print_function_declarations function_decls + end + end; + { function_decls; + free_vars; + specialised_args; + direct_call_surrogates; + } + +let used_params function_decl = + Variable.Set.filter + (fun param -> Variable.Set.mem param function_decl.free_variables) + (Parameter.Set.vars function_decl.params) + +let compare_const (c1:const) (c2:const) = + match c1, c2 with + | Int i1, Int i2 -> compare i1 i2 + | Char i1, Char i2 -> Char.compare i1 i2 + | Const_pointer i1, Const_pointer i2 -> compare i1 i2 + | Int _, (Char _ | Const_pointer _) -> -1 + | (Char _ | Const_pointer _), Int _ -> 1 + | Char _, Const_pointer _ -> -1 + | Const_pointer _, Char _ -> 1 + +let compare_constant_defining_value_block_field + (c1:constant_defining_value_block_field) + (c2:constant_defining_value_block_field) = + match c1, c2 with + | Symbol s1, Symbol s2 -> Symbol.compare s1 s2 + | Const c1, Const c2 -> compare_const c1 c2 + | Symbol _, Const _ -> -1 + | Const _, Symbol _ -> 1 + +module Constant_defining_value = struct + type t = constant_defining_value + + include Identifiable.Make (struct + type nonrec t = t + + let compare (t1 : t) (t2 : t) = + match t1, t2 with + | Allocated_const c1, Allocated_const c2 -> + Allocated_const.compare c1 c2 + | Block (tag1, fields1), Block (tag2, fields2) -> + let c = Tag.compare tag1 tag2 in + if c <> 0 then c + else + Misc.Stdlib.List.compare compare_constant_defining_value_block_field + fields1 fields2 + | Set_of_closures set1, Set_of_closures set2 -> + Set_of_closures_id.compare set1.function_decls.set_of_closures_id + set2.function_decls.set_of_closures_id + | Project_closure (set1, closure_id1), + Project_closure (set2, closure_id2) -> + let c = Symbol.compare set1 set2 in + if c <> 0 then c + else Closure_id.compare closure_id1 closure_id2 + | Allocated_const _, Block _ -> -1 + | Allocated_const _, Set_of_closures _ -> -1 + | Allocated_const _, Project_closure _ -> -1 + | Block _, Allocated_const _ -> 1 + | Block _, Set_of_closures _ -> -1 + | Block _, Project_closure _ -> -1 + | Set_of_closures _, Allocated_const _ -> 1 + | Set_of_closures _, Block _ -> 1 + | Set_of_closures _, Project_closure _ -> -1 + | Project_closure _, Allocated_const _ -> 1 + | Project_closure _, Block _ -> 1 + | Project_closure _, Set_of_closures _ -> 1 + + let equal t1 t2 = + t1 == t2 || compare t1 t2 = 0 + + let hash = Hashtbl.hash + + let print = print_constant_defining_value + + let output o v = + output_string o (Format.asprintf "%a" print v) + end) +end + +let equal_call_kind (call_kind1 : call_kind) (call_kind2 : call_kind) = + match call_kind1, call_kind2 with + | Indirect, Indirect -> true + | Direct cid1, Direct cid2 -> Closure_id.equal cid1 cid2 + | (Indirect | Direct _), _ -> false + +let equal_specialised_to (spec_to1 : specialised_to) + (spec_to2 : specialised_to) = + Variable.equal spec_to1.var spec_to2.var + && begin + match spec_to1.projection, spec_to2.projection with + | None, None -> true + | Some _, None | None, Some _ -> false + | Some proj1, Some proj2 -> Projection.equal proj1 proj2 + end + +let compare_project_var = Projection.compare_project_var +let compare_project_closure = Projection.compare_project_closure +let compare_move_within_set_of_closures = + Projection.compare_move_within_set_of_closures diff --git a/middle_end/flambda/flambda.mli b/middle_end/flambda/flambda.mli new file mode 100644 index 0000000000..325c15ee1c --- /dev/null +++ b/middle_end/flambda/flambda.mli @@ -0,0 +1,713 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(** Intermediate language used for tree-based analysis and optimization. *) + +(** Whether the callee in a function application is known at compile time. *) +type call_kind = + | Indirect + | Direct of Closure_id.t + +(** Simple constants. ("Structured constants" are rewritten to invocations + of [Pmakeblock] so that they easily take part in optimizations.) *) +type const = + | Int of int + | Char of char + (** [Char] is kept separate from [Int] to improve printing *) + | Const_pointer of int + (** [Const_pointer] is an immediate value of a type whose values may be + boxed (typically a variant type with both constant and non-constant + constructors). *) + +(** The application of a function to a list of arguments. *) +type apply = { + (* CR-soon mshinwell: rename func -> callee, and + lhs_of_application -> callee *) + func : Variable.t; + args : Variable.t list; + kind : call_kind; + dbg : Debuginfo.t; + inline : Lambda.inline_attribute; + (** Instructions from the source code as to whether the callee should + be inlined. *) + specialise : Lambda.specialise_attribute; + (** Instructions from the source code as to whether the callee should + be specialised. *) +} + +(** The update of a mutable variable. Mutable variables are distinct from + immutable variables in Flambda. *) +type assign = { + being_assigned : Mutable_variable.t; + new_value : Variable.t; +} + +(** The invocation of a method. *) +type send = { + kind : Lambda.meth_kind; + meth : Variable.t; + obj : Variable.t; + args : Variable.t list; + dbg : Debuginfo.t; +} + +(** For details on these types, see projection.mli. *) +type project_closure = Projection.project_closure +type move_within_set_of_closures = Projection.move_within_set_of_closures +type project_var = Projection.project_var + +(** See [free_vars] and [specialised_args], below. *) +(* CR-someday mshinwell: move to separate module and make [Identifiable]. + (Or maybe nearly Identifiable; having a special map that enforces invariants + might be good.) *) +type specialised_to = { + var : Variable.t; + (** The "outer variable". *) + projection : Projection.t option; + (** The [projecting_from] value (see projection.mli) of any [projection] + must be another free variable or specialised argument (depending on + whether this record type is involved in [free_vars] or + [specialised_args] respectively) in the same set of closures. + As such, this field describes a relation of projections between + either the [free_vars] or the [specialised_args]. *) +} + +(** Flambda terms are partitioned in a pseudo-ANF manner; many terms are + required to be [let]-bound. This in particular ensures there is always + a variable name for an expression that may be lifted out (for example + if it is found to be constant). + Note: All bound variables in Flambda terms must be distinct. + [Flambda_invariants] verifies this. *) +type t = + | Var of Variable.t + | Let of let_expr + | Let_mutable of let_mutable + | Let_rec of (Variable.t * named) list * t + (** CR-someday lwhite: give Let_rec the same fields as Let. *) + | Apply of apply + | Send of send + | Assign of assign + | If_then_else of Variable.t * t * t + | Switch of Variable.t * switch + | String_switch of Variable.t * (string * t) list * t option + (** Restrictions on [Lambda.Lstringswitch] also apply to [String_switch]. *) + | Static_raise of Static_exception.t * Variable.t list + | Static_catch of Static_exception.t * Variable.t list * t * t + | Try_with of t * Variable.t * t + | While of t * t + | For of for_loop + | Proved_unreachable + +(** Values of type [named] will always be [let]-bound to a [Variable.t]. *) +and named = + | Symbol of Symbol.t + | Const of const + | Allocated_const of Allocated_const.t + | Read_mutable of Mutable_variable.t + | Read_symbol_field of Symbol.t * int + (** During the lifting of [let] bindings to [program] constructions after + closure conversion, we generate symbols and their corresponding + definitions (which may or may not be constant), together with field + accesses to such symbols. We would like it to be the case that such + field accesses are simplified to the relevant component of the + symbol concerned. (The rationale is to generate efficient code and + share constants as expected: see e.g. tests/asmcomp/staticalloc.ml.) + The components of the symbol would be identified by other symbols. + This sort of access pattern is feasible because the top-level structure + of symbols is statically allocated and fixed at compile time. + It may seem that [Prim (Pfield, ...)] expressions could be used to + perform the field accesses. However for simplicity, to avoid having to + keep track of properties of individual fields of blocks, + [Inconstant_idents] never deems a [Prim (Pfield, ...)] expression to be + constant. This would in general prevent field accesses to symbols from + being simplified in the way we would like, since [Lift_constants] would + not assign new symbols (i.e. the things we would like to simplify to) + to the various projections from the symbols in question. + To circumvent this problem we use [Read_symbol_field] when generating + projections from the top level of symbols. Owing to the properties of + symbols described above, such expressions may be eligible for declaration + as constant by [Inconstant_idents] (and thus themselves lifted to another + symbol), without any further complication. + [Read_symbol_field] may only be used when the definition of the symbol + is in scope in the [program]. For external unresolved symbols, [Pfield] + may still be used; it will be changed to [Read_symbol_field] by + [Inline_and_simplify] when (and if) the symbol is imported. *) + | Set_of_closures of set_of_closures + | Project_closure of project_closure + | Move_within_set_of_closures of move_within_set_of_closures + | Project_var of project_var + | Prim of Clambda_primitives.primitive * Variable.t list * Debuginfo.t + | Expr of t (** ANF escape hatch. *) + +(* CR-someday mshinwell: use [letcont]-style construct to remove e.g. + [While] and [For]. *) +(* CR-someday mshinwell: try to produce a tighter definition of a "switch" + (and translate to that earlier) so that middle- and back-end code for + these can be reduced. *) +(* CR-someday mshinwell: remove [Expr], but to do this easily would probably + require a continuation-binding construct. *) +(* CR-someday mshinwell: Since we lack expression identifiers on every term, + we should probably introduce [Mutable_var] into [named] if we introduce + more complicated analyses on these in the future. Alternatively, maybe + consider removing mutable variables altogether. *) + +and let_expr = private { + var : Variable.t; + defining_expr : named; + body : t; + (* CR-someday mshinwell: we could consider having these be keys into some + kind of global cache, to reduce memory usage. *) + free_vars_of_defining_expr : Variable.Set.t; + (** A cache of the free variables in the defining expression of the [let]. *) + free_vars_of_body : Variable.Set.t; + (** A cache of the free variables of the body of the [let]. This is an + important optimization. *) +} + +and let_mutable = { + var : Mutable_variable.t; + initial_value : Variable.t; + contents_kind : Lambda.value_kind; + body : t; +} + +(** The representation of a set of function declarations (possibly mutually + recursive). Such a set encapsulates the declarations themselves, + information about their defining environment, and information used + specifically for optimization. + Before a function can be applied it must be "projected" from a set of + closures to yield a "closure". This is done using [Project_closure] + (see above). Given a closure, not only can it be applied, but information + about its defining environment can be retrieved (using [Project_var], + see above). + At runtime, a [set_of_closures] corresponds to an OCaml value with tag + [Closure_tag] (possibly with inline [Infix_tag](s)). As an optimization, + an operation ([Move_within_set_of_closures]) is provided (see above) + which enables one closure within a set to be located given another + closure in the same set. This avoids keeping a pointer to the whole set + of closures alive when compiling, for example, mutually-recursive + functions. +*) +and set_of_closures = private { + function_decls : function_declarations; + (* CR-soon mshinwell: consider renaming [free_vars]. Also, it's still really + confusing which side of this map to use when. "Vars bound by the + closure" is the domain. + Another example of when this is confusing: + let bound_vars_approx = + Variable.Map.map (Env.find_approx env) set.free_vars + in + in [Build_export_info]. *) + (* CR-soon mshinwell: I'd like to arrange these maps so that it's impossible + to put invalid projection information into them (in particular, so that + we enforce that the relation stays within the domain of the map). *) + free_vars : specialised_to Variable.Map.t; + (** Mapping from all variables free in the body of the [function_decls] to + variables in scope at the definition point of the [set_of_closures]. + The domain of this map is sometimes known as the "variables bound by + the closure". *) + specialised_args : specialised_to Variable.Map.t; + (** Parameters whose corresponding arguments are known to always alias a + particular value. These are the only parameters that may, during + [Inline_and_simplify], have non-unknown approximations. + + An argument may only be specialised to a variable in the scope of the + corresponding set of closures declaration. Usually, that variable + itself also appears in the position of the specialised argument at + all call sites of the function. However it may also be the case (for + example in code generated as a result of [Augment_specialised_args]) + that the various call sites of such a function have differing + variables in the position of the specialised argument. This is + permissible *so long as it is certain they all alias the same value*. + Great care must be taken in transformations that result in this + situation since there are no invariant checks for correctness. + + As an example, supposing all call sites of f are represented here: + [let x = ... in + let f a b c = ... in + let y = ... in + f x y 1; + f x y 1] + the specialised arguments of f can (but does not necessarily) contain + the association [a] -> [x], but cannot contain [b] -> [y] because [f] + is not in the scope of [y]. If f were the recursive function + [let rec f a b c = f a 1 2 in], [a] -> [x] would still be a valid + specialised argument because all recursive calls maintain the invariant. + + This information is used for optimization purposes, if such a binding is + known, it is possible to specialise the body of the function according + to its parameter. This is usually introduced when specialising a + recursive function, for instance. + [let rec map f = function + | [] -> [] + | h :: t -> f h :: map f t + let map_succ l = + let succ x = x + 1 in + map succ l] + [map] can be duplicated in [map_succ] to be specialised for the argument + [f]. This will result in + [let map_succ l = + let succ x = x + 1 in + let rec map f = function + | [] -> [] + | h :: t -> f h :: map f t in + map succ l] + with map having [f] -> [succ] in its [specialised_args] field. + + Specialised argument information for arguments that are used must + never be erased. This ensures that specialised arguments whose + approximations describe closures maintain those approximations, which + is essential to transport the closure freshening information to the + point of use (e.g. a [Project_var] from such an argument). + *) + direct_call_surrogates : Variable.t Variable.Map.t; + (** If [direct_call_surrogates] maps [fun_var1] to [fun_var2] then direct + calls to [fun_var1] should be redirected to [fun_var2]. This is used + to reduce the overhead of transformations that introduce wrapper + functions (which will be inlined at direct call sites, but will + penalise indirect call sites). + [direct_call_surrogates] may not be transitively closed. *) +} + +and function_declarations = private { + is_classic_mode: bool; + (** Indicates whether this [function_declarations] was compiled + with -Oclassic. *) + set_of_closures_id : Set_of_closures_id.t; + (** An identifier (unique across all Flambda trees currently in memory) + of the set of closures associated with this set of function + declarations. *) + set_of_closures_origin : Set_of_closures_origin.t; + (** An identifier of the original set of closures on which this set of + function declarations is based. Used to prevent different + specialisations of the same functions from being inlined/specialised + within each other. *) + funs : function_declaration Variable.Map.t; + (** The function(s) defined by the set of function declarations. The + keys of this map are often referred to in the code as "fun_var"s. *) +} + +and function_declaration = private { + closure_origin: Closure_origin.t; + params : Parameter.t list; + body : t; + (* CR-soon mshinwell: inconsistent naming free_variables/free_vars here and + above *) + free_variables : Variable.Set.t; + (** All variables free in the *body* of the function. For example, a + variable that is bound as one of the function's parameters will still + be included in this set. This field is present as an optimization. *) + free_symbols : Symbol.Set.t; + (** All symbols that occur in the function's body. (Symbols can never be + bound in a function's body; the only thing that binds symbols is the + [program] constructions below.) *) + stub : bool; + (** A stub function is a generated function used to prepare arguments or + return values to allow indirect calls to functions with a special calling + convention. For instance indirect calls to tuplified functions must go + through a stub. Stubs will be unconditionally inlined. *) + dbg : Debuginfo.t; + (** Debug info for the function declaration. *) + inline : Lambda.inline_attribute; + (** Inlining requirements from the source code. *) + specialise : Lambda.specialise_attribute; + (** Specialising requirements from the source code. *) + is_a_functor : bool; + (** Whether the function is known definitively to be a functor. *) +} + +(** Equivalent to the similar type in [Lambda]. *) +and switch = { + numconsts : Numbers.Int.Set.t; (** Integer cases *) + consts : (int * t) list; (** Integer cases *) + numblocks : Numbers.Int.Set.t; (** Number of tag block cases *) + blocks : (int * t) list; (** Tag block cases *) + failaction : t option; (** Action to take if none matched *) +} + +(** Equivalent to the similar type in [Lambda]. *) +and for_loop = { + bound_var : Variable.t; + from_value : Variable.t; + to_value : Variable.t; + direction : Asttypes.direction_flag; + body : t +} + +(** Like a subset of [Flambda.named], except that instead of [Variable.t]s we + have [Symbol.t]s, and everything is a constant (i.e. with a fixed value + known at compile time). Values of this type describe constants that will + be directly assigned to symbols in the object file (see below). *) +and constant_defining_value = + | Allocated_const of Allocated_const.t + (** A single constant. These are never "simple constants" (type [const]) + but instead more complicated constructions. *) + | Block of Tag.t * constant_defining_value_block_field list + (** A pre-allocated block full of constants (either simple constants + or references to other constants, see below). *) + | Set_of_closures of set_of_closures + (** A closed (and thus constant) set of closures. (That is to say, + [free_vars] must be empty.) *) + | Project_closure of Symbol.t * Closure_id.t + (** Selection of one closure from a constant set of closures. + Analogous to the equivalent operation on expressions. *) + +and constant_defining_value_block_field = + | Symbol of Symbol.t + | Const of const + +module Constant_defining_value : + Identifiable.S with type t = constant_defining_value + +type expr = t + +(** A "program" is the contents of one compilation unit. It describes the + various values that are assigned to symbols (and in some cases fields of + such symbols) in the object file. As such, it is closely related to + the compilation of toplevel modules. *) +type program_body = + | Let_symbol of Symbol.t * constant_defining_value * program_body + (** Define the given symbol to have the given constant value. *) + | Let_rec_symbol of (Symbol.t * constant_defining_value) list * program_body + (** As for [Let_symbol], but recursive. This is needed to treat examples + like this, where a constant set of closures is lifted to toplevel: + + let rec f x = f x + + After lifting this produces (in pseudo-Flambda): + + Let_rec_symbol set_of_closures_symbol = + (Set_of_closures { f x -> + let applied_function = Symbol f_closure in + Apply (applied_function, x) }) + and f_closure = Project_closure (set_of_closures_symbol, f) + + Use of [Let_rec_symbol], by virtue of the special handling in + [Inline_and_simplify.define_let_rec_symbol_approx], enables the + approximation of the set of closures to be present in order to + correctly simplify the [Project_closure] construction. (See + [Inline_and_simplify.simplify_project_closure] for that part.) *) + | Initialize_symbol of Symbol.t * Tag.t * t list * program_body + (** Define the given symbol as a constant block of the given size and + tag; but with a possibly non-constant initializer. The initializer + will be executed at most once (from the entry point of the compilation + unit). *) + | Effect of t * program_body + (** Cause the given expression, which may have a side effect, to be + executed. The resulting value is discarded. [Effect] constructions + are never re-ordered. *) + | End of Symbol.t + (** [End] accepts the root symbol: the only symbol that can never be + eliminated. *) + +type program = { + imported_symbols : Symbol.Set.t; + program_body : program_body; +} + +(** Compute the free variables of a term. (This is O(1) for [Let]s). + If [ignore_uses_as_callee], all free variables inside [Apply] expressions + are ignored. Likewise [ignore_uses_in_project_var] for [Project_var] + expressions. +*) +val free_variables + : ?ignore_uses_as_callee:unit + -> ?ignore_uses_as_argument:unit + -> ?ignore_uses_in_project_var:unit + -> t + -> Variable.Set.t + +(** Compute the free variables of a named expression. *) +val free_variables_named + : ?ignore_uses_in_project_var:unit + -> named + -> Variable.Set.t + +(** Compute _all_ variables occurring inside an expression. *) +val used_variables + : ?ignore_uses_as_callee:unit + -> ?ignore_uses_as_argument:unit + -> ?ignore_uses_in_project_var:unit + -> t + -> Variable.Set.t + +(** Compute _all_ variables occurring inside a named expression. *) +val used_variables_named + : ?ignore_uses_in_project_var:unit + -> named + -> Variable.Set.t + +val free_symbols : expr -> Symbol.Set.t + +val free_symbols_named : named -> Symbol.Set.t + +val free_symbols_program : program -> Symbol.Set.t + +(** Used to avoid exceeding the stack limit when handling expressions with + multiple consecutive nested [Let]-expressions. This saves rewriting large + simplification functions in CPS. This function provides for the + rewriting or elimination of expressions during the fold. *) +val fold_lets_option + : t + -> init:'a + -> for_defining_expr:('a -> Variable.t -> named -> 'a * Variable.t * named) + -> for_last_body:('a -> t -> t * 'b) + (* CR-someday mshinwell: consider making [filter_defining_expr] + optional *) + -> filter_defining_expr:('b -> Variable.t -> named -> Variable.Set.t -> + 'b * Variable.t * named option) + -> t * 'b + +(** Like [fold_lets_option], but just a map. *) +val map_lets + : t + -> for_defining_expr:(Variable.t -> named -> named) + -> for_last_body:(t -> t) + -> after_rebuild:(t -> t) + -> t + +(** Like [map_lets], but just an iterator. *) +val iter_lets + : t + -> for_defining_expr:(Variable.t -> named -> unit) + -> for_last_body:(t -> unit) + -> for_each_let:(t -> unit) + -> unit + +(** Creates a [Let] expression. (This computes the free variables of the + defining expression and the body.) *) +val create_let : Variable.t -> named -> t -> t + +(** Apply the specified function [f] to the defining expression of the given + [Let]-expression, returning a new [Let]. *) +val map_defining_expr_of_let : let_expr -> f:(named -> named) -> t + +(** A module for the manipulation of terms where the recomputation of free + variable sets is to be kept to a minimum. *) +module With_free_variables : sig + type 'a t + + (** O(1) time. *) + val of_defining_expr_of_let : let_expr -> named t + + (** O(1) time. *) + val of_body_of_let : let_expr -> expr t + + (** Takes the time required to calculate the free variables of the given + term (proportional to the size of the term, except that the calculation + for [Let] is O(1)). *) + val of_expr : expr -> expr t + + val of_named : named -> named t + + (** Takes the time required to calculate the free variables of the given + [expr]. *) + val create_let_reusing_defining_expr + : Variable.t + -> named t + -> expr + -> expr + + (** Takes the time required to calculate the free variables of the given + [named]. *) + val create_let_reusing_body + : Variable.t + -> named + -> expr t + -> expr + + (** O(1) time. *) + val create_let_reusing_both + : Variable.t + -> named t + -> expr t + -> expr + + (** The equivalent of the [Expr] constructor. *) + val expr : expr t -> named t + + val contents : 'a t -> 'a + + (** O(1) time. *) + val free_variables : _ t -> Variable.Set.t +end + +(** Create a function declaration. This calculates the free variables and + symbols occurring in the specified [body]. *) +val create_function_declaration + : params:Parameter.t list + -> body:t + -> stub:bool + -> dbg:Debuginfo.t + -> inline:Lambda.inline_attribute + -> specialise:Lambda.specialise_attribute + -> is_a_functor:bool + -> closure_origin:Closure_origin.t + -> function_declaration + +(** Create a function declaration based on another function declaration *) +val update_function_declaration + : function_declaration + -> params:Parameter.t list + -> body:t + -> function_declaration + +(** Create a set of function declarations given the individual declarations. *) +val create_function_declarations + : is_classic_mode:bool + -> funs:function_declaration Variable.Map.t + -> function_declarations + +(** Create a set of function declarations with a given set of closures + origin. *) +val create_function_declarations_with_origin + : is_classic_mode:bool + -> funs:function_declaration Variable.Map.t + -> set_of_closures_origin:Set_of_closures_origin.t + -> function_declarations + +(** Change only the code of a function declaration. *) +val update_body_of_function_declaration + : function_declaration + -> body:expr + -> function_declaration + +(** Change only the code and parameters of a function declaration. *) +(* CR-soon mshinwell: rename this to match new update function above *) +val update_function_decl's_params_and_body + : function_declaration + -> params:Parameter.t list + -> body:expr + -> function_declaration + +(** Create a set of function declarations based on another set of function + declarations. *) +val update_function_declarations + : function_declarations + -> funs:function_declaration Variable.Map.t + -> function_declarations + +val create_function_declarations_with_closures_origin + : is_classic_mode: bool + -> funs:function_declaration Variable.Map.t + -> set_of_closures_origin:Set_of_closures_origin.t + -> function_declarations + +val import_function_declarations_for_pack + : function_declarations + -> (Set_of_closures_id.t -> Set_of_closures_id.t) + -> (Set_of_closures_origin.t -> Set_of_closures_origin.t) + -> function_declarations + +(** Create a set of closures. Checks are made to ensure that [free_vars] + and [specialised_args] are reasonable. *) +val create_set_of_closures + : function_decls:function_declarations + -> free_vars:specialised_to Variable.Map.t + -> specialised_args:specialised_to Variable.Map.t + -> direct_call_surrogates:Variable.t Variable.Map.t + -> set_of_closures + +(** Given a function declaration, find which of its parameters (if any) + are used in the body. *) +val used_params : function_declaration -> Variable.Set.t + +type maybe_named = + | Is_expr of t + | Is_named of named + +(** This function is designed for the internal use of [Flambda_iterators]. + See that module for iterators to be used over Flambda terms. *) +val iter_general + : toplevel:bool + -> (t -> unit) + -> (named -> unit) + -> maybe_named + -> unit + +val print : Format.formatter -> t -> unit + +val print_named : Format.formatter -> named -> unit + +val print_program : Format.formatter -> program -> unit + +val print_const : Format.formatter -> const -> unit + +val print_constant_defining_value + : Format.formatter + -> constant_defining_value + -> unit + +val print_function_declaration + : Format.formatter + -> Variable.t * function_declaration + -> unit + +val print_function_declarations + : Format.formatter + -> function_declarations + -> unit + +val print_project_closure + : Format.formatter + -> project_closure + -> unit + +val print_move_within_set_of_closures + : Format.formatter + -> move_within_set_of_closures + -> unit + +val print_project_var + : Format.formatter + -> project_var + -> unit + +val print_set_of_closures + : Format.formatter + -> set_of_closures + -> unit + +val print_specialised_to + : Format.formatter + -> specialised_to + -> unit + +val equal_call_kind + : call_kind + -> call_kind + -> bool + +val equal_specialised_to + : specialised_to + -> specialised_to + -> bool + +val compare_const + : const + -> const + -> int + +val compare_project_var : project_var -> project_var -> int + +val compare_move_within_set_of_closures + : move_within_set_of_closures + -> move_within_set_of_closures + -> int + +val compare_project_closure : project_closure -> project_closure -> int diff --git a/middle_end/flambda/flambda_invariants.ml b/middle_end/flambda/flambda_invariants.ml new file mode 100644 index 0000000000..250a2e9af7 --- /dev/null +++ b/middle_end/flambda/flambda_invariants.ml @@ -0,0 +1,800 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +type flambda_kind = + | Normal + | Lifted + +(* Explicit "ignore" functions. We name every pattern variable, avoiding + underscores, to try to avoid accidentally failing to handle (for example) + a particular variable. + We also avoid explicit record field access during the checking functions, + preferring instead to use exhaustive record matches. +*) +(* CR-someday pchambart: for sum types, we should probably add an exhaustive + pattern in ignores functions to be reminded if a type change *) +let already_added_bound_variable_to_env (_ : Variable.t) = () +let will_traverse_named_expression_later (_ : Flambda.named) = () +let ignore_variable (_ : Variable.t) = () +let ignore_call_kind (_ : Flambda.call_kind) = () +let ignore_debuginfo (_ : Debuginfo.t) = () +let ignore_meth_kind (_ : Lambda.meth_kind) = () +let ignore_int (_ : int) = () +let ignore_int_set (_ : Numbers.Int.Set.t) = () +let ignore_bool (_ : bool) = () +let ignore_string (_ : string) = () +let ignore_static_exception (_ : Static_exception.t) = () +let ignore_direction_flag (_ : Asttypes.direction_flag) = () +let ignore_primitive ( _ : Clambda_primitives.primitive) = () +let ignore_const (_ : Flambda.const) = () +let ignore_allocated_const (_ : Allocated_const.t) = () +let ignore_set_of_closures_id (_ : Set_of_closures_id.t) = () +let ignore_set_of_closures_origin (_ : Set_of_closures_origin.t) = () +let ignore_closure_id (_ : Closure_id.t) = () +let ignore_var_within_closure (_ : Var_within_closure.t) = () +let ignore_tag (_ : Tag.t) = () +let ignore_inline_attribute (_ : Lambda.inline_attribute) = () +let ignore_specialise_attribute (_ : Lambda.specialise_attribute) = () +let ignore_value_kind (_ : Lambda.value_kind) = () + +exception Binding_occurrence_not_from_current_compilation_unit of Variable.t +exception Mutable_binding_occurrence_not_from_current_compilation_unit of + Mutable_variable.t +exception Binding_occurrence_of_variable_already_bound of Variable.t +exception Binding_occurrence_of_mutable_variable_already_bound of + Mutable_variable.t +exception Binding_occurrence_of_symbol_already_bound of Symbol.t +exception Unbound_variable of Variable.t +exception Unbound_mutable_variable of Mutable_variable.t +exception Unbound_symbol of Symbol.t +exception Vars_in_function_body_not_bound_by_closure_or_params of + Variable.Set.t * Flambda.set_of_closures * Variable.t +exception Function_decls_have_overlapping_parameters of Variable.Set.t +exception Specialised_arg_that_is_not_a_parameter of Variable.t +exception Projection_must_be_a_free_var of Projection.t +exception Projection_must_be_a_specialised_arg of Projection.t +exception Free_variables_set_is_lying of + Variable.t * Variable.Set.t * Variable.Set.t * Flambda.function_declaration +exception Set_of_closures_free_vars_map_has_wrong_range of Variable.Set.t +exception Static_exception_not_caught of Static_exception.t +exception Static_exception_caught_in_multiple_places of Static_exception.t +exception Sequential_logical_operator_primitives_must_be_expanded of + Clambda_primitives.primitive +exception Var_within_closure_bound_multiple_times of Var_within_closure.t +exception Declared_closure_from_another_unit of Compilation_unit.t +exception Closure_id_is_bound_multiple_times of Closure_id.t +exception Set_of_closures_id_is_bound_multiple_times of Set_of_closures_id.t +exception Unbound_closure_ids of Closure_id.Set.t +exception Unbound_vars_within_closures of Var_within_closure.Set.t +exception Move_to_a_closure_not_in_the_free_variables + of Variable.t * Variable.Set.t + +exception Flambda_invariants_failed + +(* CR-someday mshinwell: We should make "direct applications should not have + overapplication" be an invariant throughout. At the moment I think this is + only true after [Inline_and_simplify] has split overapplications. *) + +(* CR-someday mshinwell: What about checks for shadowed variables and + symbols? *) + +let variable_and_symbol_invariants (program : Flambda.program) = + let all_declared_variables = ref Variable.Set.empty in + let declare_variable var = + if Variable.Set.mem var !all_declared_variables then + raise (Binding_occurrence_of_variable_already_bound var); + all_declared_variables := Variable.Set.add var !all_declared_variables + in + let declare_variables vars = + Variable.Set.iter declare_variable vars + in + let all_declared_mutable_variables = ref Mutable_variable.Set.empty in + let declare_mutable_variable mut_var = + if Mutable_variable.Set.mem mut_var !all_declared_mutable_variables then + raise (Binding_occurrence_of_mutable_variable_already_bound mut_var); + all_declared_mutable_variables := + Mutable_variable.Set.add mut_var !all_declared_mutable_variables + in + let add_binding_occurrence (var_env, mut_var_env, sym_env) var = + let compilation_unit = Compilation_unit.get_current_exn () in + if not (Variable.in_compilation_unit var compilation_unit) then + raise (Binding_occurrence_not_from_current_compilation_unit var); + declare_variable var; + Variable.Set.add var var_env, mut_var_env, sym_env + in + let add_mutable_binding_occurrence (var_env, mut_var_env, sym_env) mut_var = + let compilation_unit = Compilation_unit.get_current_exn () in + if not (Mutable_variable.in_compilation_unit mut_var compilation_unit) then + raise (Mutable_binding_occurrence_not_from_current_compilation_unit + mut_var); + declare_mutable_variable mut_var; + var_env, Mutable_variable.Set.add mut_var mut_var_env, sym_env + in + let add_binding_occurrence_of_symbol (var_env, mut_var_env, sym_env) sym = + if Symbol.Set.mem sym sym_env then + raise (Binding_occurrence_of_symbol_already_bound sym) + else + var_env, mut_var_env, Symbol.Set.add sym sym_env + in + let add_binding_occurrences env vars = + List.fold_left (fun env var -> add_binding_occurrence env var) env vars + in + let check_variable_is_bound (var_env, _, _) var = + if not (Variable.Set.mem var var_env) then raise (Unbound_variable var) + in + let check_symbol_is_bound (_, _, sym_env) sym = + if not (Symbol.Set.mem sym sym_env) then raise (Unbound_symbol sym) + in + let check_variables_are_bound env vars = + List.iter (check_variable_is_bound env) vars + in + let check_mutable_variable_is_bound (_, mut_var_env, _) mut_var = + if not (Mutable_variable.Set.mem mut_var mut_var_env) then begin + raise (Unbound_mutable_variable mut_var) + end + in + let rec loop env (flam : Flambda.t) = + match flam with + (* Expressions that can bind [Variable.t]s: *) + | Let { var; defining_expr; body; _ } -> + loop_named env defining_expr; + loop (add_binding_occurrence env var) body + | Let_mutable { var = mut_var; initial_value = var; + body; contents_kind } -> + ignore_value_kind contents_kind; + check_variable_is_bound env var; + loop (add_mutable_binding_occurrence env mut_var) body + | Let_rec (defs, body) -> + let env = + List.fold_left (fun env (var, def) -> + will_traverse_named_expression_later def; + add_binding_occurrence env var) + env defs + in + List.iter (fun (var, def) -> + already_added_bound_variable_to_env var; + loop_named env def) defs; + loop env body + | For { bound_var; from_value; to_value; direction; body; } -> + ignore_direction_flag direction; + check_variable_is_bound env from_value; + check_variable_is_bound env to_value; + loop (add_binding_occurrence env bound_var) body + | Static_catch (static_exn, vars, body, handler) -> + ignore_static_exception static_exn; + loop env body; + loop (add_binding_occurrences env vars) handler + | Try_with (body, var, handler) -> + loop env body; + loop (add_binding_occurrence env var) handler + (* Everything else: *) + | Var var -> check_variable_is_bound env var + | Apply { func; args; kind; dbg; inline; specialise; } -> + check_variable_is_bound env func; + check_variables_are_bound env args; + ignore_call_kind kind; + ignore_debuginfo dbg; + ignore_inline_attribute inline; + ignore_specialise_attribute specialise + | Assign { being_assigned; new_value; } -> + check_mutable_variable_is_bound env being_assigned; + check_variable_is_bound env new_value + | Send { kind; meth; obj; args; dbg; } -> + ignore_meth_kind kind; + check_variable_is_bound env meth; + check_variable_is_bound env obj; + check_variables_are_bound env args; + ignore_debuginfo dbg + | If_then_else (cond, ifso, ifnot) -> + check_variable_is_bound env cond; + loop env ifso; + loop env ifnot + | Switch (arg, { numconsts; consts; numblocks; blocks; failaction; }) -> + check_variable_is_bound env arg; + ignore_int_set numconsts; + ignore_int_set numblocks; + List.iter (fun (n, e) -> + ignore_int n; + loop env e) + (consts @ blocks); + Misc.may (loop env) failaction + | String_switch (arg, cases, e_opt) -> + check_variable_is_bound env arg; + List.iter (fun (label, case) -> + ignore_string label; + loop env case) + cases; + Misc.may (loop env) e_opt + | Static_raise (static_exn, es) -> + ignore_static_exception static_exn; + List.iter (check_variable_is_bound env) es + | While (e1, e2) -> + loop env e1; + loop env e2 + | Proved_unreachable -> () + and loop_named env (named : Flambda.named) = + match named with + | Symbol symbol -> check_symbol_is_bound env symbol + | Const const -> ignore_const const + | Allocated_const const -> ignore_allocated_const const + | Read_mutable mut_var -> + check_mutable_variable_is_bound env mut_var + | Read_symbol_field (symbol, index) -> + check_symbol_is_bound env symbol; + assert (index >= 0) (* CR-someday mshinwell: add proper error *) + | Set_of_closures set_of_closures -> + loop_set_of_closures env set_of_closures + | Project_closure { set_of_closures; closure_id; } -> + check_variable_is_bound env set_of_closures; + ignore_closure_id closure_id + | Move_within_set_of_closures { closure; start_from; move_to; } -> + check_variable_is_bound env closure; + ignore_closure_id start_from; + ignore_closure_id move_to; + | Project_var { closure; closure_id; var; } -> + check_variable_is_bound env closure; + ignore_closure_id closure_id; + ignore_var_within_closure var + | Prim (prim, args, dbg) -> + ignore_primitive prim; + check_variables_are_bound env args; + ignore_debuginfo dbg + | Expr expr -> + loop env expr + and loop_set_of_closures env + ({ Flambda.function_decls; free_vars; specialised_args; + direct_call_surrogates = _; } as set_of_closures) = + (* CR-soon mshinwell: check [direct_call_surrogates] *) + let { Flambda. is_classic_mode; + set_of_closures_id; set_of_closures_origin; funs; } = + function_decls + in + ignore (is_classic_mode : bool); + ignore_set_of_closures_id set_of_closures_id; + ignore_set_of_closures_origin set_of_closures_origin; + let functions_in_closure = Variable.Map.keys funs in + let variables_in_closure = + Variable.Map.fold (fun var (var_in_closure : Flambda.specialised_to) + variables_in_closure -> + (* [var] may occur in the body, but will effectively be renamed + to [var_in_closure], so the latter is what we check to make + sure it's bound. *) + ignore_variable var; + check_variable_is_bound env var_in_closure.var; + Variable.Set.add var variables_in_closure) + free_vars Variable.Set.empty + in + let all_params, all_free_vars = + Variable.Map.fold (fun fun_var function_decl acc -> + let all_params, all_free_vars = acc in + (* CR-soon mshinwell: check function_decl.all_symbols *) + let { Flambda.params; body; free_variables; stub; dbg; _ } = + function_decl + in + assert (Variable.Set.mem fun_var functions_in_closure); + ignore_bool stub; + ignore_debuginfo dbg; + (* Check that [free_variables], which is only present as an + optimization, is not lying. *) + let free_variables' = Flambda.free_variables body in + if not (Variable.Set.subset free_variables' free_variables) then + raise (Free_variables_set_is_lying (fun_var, + free_variables, free_variables', function_decl)); + (* Check that every variable free in the body of the function is + bound by either the set of closures or the parameter list. *) + let acceptable_free_variables = + Variable.Set.union + (Variable.Set.union variables_in_closure functions_in_closure) + (Parameter.Set.vars params) + in + let bad = + Variable.Set.diff free_variables acceptable_free_variables + in + if not (Variable.Set.is_empty bad) then begin + raise (Vars_in_function_body_not_bound_by_closure_or_params + (bad, set_of_closures, fun_var)) + end; + (* Check that parameters are unique across all functions in the + declaration. *) + let old_all_params_size = Variable.Set.cardinal all_params in + let params = Parameter.Set.vars params in + let params_size = Variable.Set.cardinal params in + let all_params = Variable.Set.union all_params params in + let all_params_size = Variable.Set.cardinal all_params in + if all_params_size <> old_all_params_size + params_size then begin + raise (Function_decls_have_overlapping_parameters all_params) + end; + (* Check that parameters and function variables are not + bound somewhere else in the program *) + declare_variables params; + declare_variable fun_var; + (* Check that the body of the functions is correctly structured *) + let body_env = + let (var_env, _, sym_env) = env in + let var_env = + Variable.Set.fold (fun var -> Variable.Set.add var) + free_variables var_env + in + (* Mutable variables cannot be captured by closures *) + let mut_env = Mutable_variable.Set.empty in + (var_env, mut_env, sym_env) + in + loop body_env body; + all_params, Variable.Set.union free_variables all_free_vars) + funs (Variable.Set.empty, Variable.Set.empty) + in + (* CR-soon pchambart: This is not a property that we can certainly + ensure. + If the function get inlined, it is possible for the inlined version + to still use that variable. To be able to ensure that, we need to + also ensure that the inlined version will certainly be transformed + in a same way that can drop the dependency. + mshinwell: This should get some thought after the first release to + decide for sure what to do. *) + (* Check that the free variables rewriting map in the set of closures + does not contain variables in its domain that are not actually free + variables of any of the function bodies. *) + let bad_free_vars = + Variable.Set.diff (Variable.Map.keys free_vars) all_free_vars + in +(* + if not (Variable.Set.is_empty bad_free_vars) then begin + raise (Set_of_closures_free_vars_map_has_wrong_range bad_free_vars) + end; +*) + (* CR-someday pchambart: Ignore it to avoid the warning: get rid of that + when the case is settled *) + ignore (Set_of_closures_free_vars_map_has_wrong_range bad_free_vars); + (* Check that free variables are not bound somewhere + else in the program *) + declare_variables (Variable.Map.keys free_vars); + (* Check that every "specialised arg" is a parameter of one of the + functions being declared, and that the variable to which the + parameter is being specialised is bound. *) + Variable.Map.iter (fun _inner_var + (specialised_to : Flambda.specialised_to) -> + check_variable_is_bound env specialised_to.var; + match specialised_to.projection with + | None -> () + | Some projection -> + let projecting_from = Projection.projecting_from projection in + if not (Variable.Map.mem projecting_from free_vars) + then begin + raise (Projection_must_be_a_free_var projection) + end) + free_vars; + Variable.Map.iter (fun being_specialised + (specialised_to : Flambda.specialised_to) -> + if not (Variable.Set.mem being_specialised all_params) then begin + raise (Specialised_arg_that_is_not_a_parameter being_specialised) + end; + check_variable_is_bound env specialised_to.var; + match specialised_to.projection with + | None -> () + | Some projection -> + let projecting_from = Projection.projecting_from projection in + if not (Variable.Map.mem projecting_from specialised_args) + then begin + raise (Projection_must_be_a_specialised_arg projection) + end) + specialised_args + in + let loop_constant_defining_value env + (const : Flambda.constant_defining_value) = + match const with + | Flambda.Allocated_const c -> + ignore_allocated_const c + | Flambda.Block (tag,fields) -> + ignore_tag tag; + List.iter (fun (fields : Flambda.constant_defining_value_block_field) -> + match fields with + | Const c -> ignore_const c + | Symbol s -> check_symbol_is_bound env s) + fields + | Flambda.Set_of_closures set_of_closures -> + loop_set_of_closures env set_of_closures; + (* Constant set of closures must not have free variables *) + if not (Variable.Map.is_empty set_of_closures.free_vars) then + assert false; (* TODO: correct error *) + if not (Variable.Map.is_empty set_of_closures.specialised_args) then + assert false; (* TODO: correct error *) + | Flambda.Project_closure (symbol,closure_id) -> + ignore_closure_id closure_id; + check_symbol_is_bound env symbol + in + let rec loop_program_body env (program : Flambda.program_body) = + match program with + | Let_rec_symbol (defs, program) -> + let env = + List.fold_left (fun env (symbol, _) -> + add_binding_occurrence_of_symbol env symbol) + env defs + in + List.iter (fun (_, def) -> + loop_constant_defining_value env def) + defs; + loop_program_body env program + | Let_symbol (symbol, def, program) -> + loop_constant_defining_value env def; + let env = add_binding_occurrence_of_symbol env symbol in + loop_program_body env program + | Initialize_symbol (symbol, _tag, fields, program) -> + List.iter (loop env) fields; + let env = add_binding_occurrence_of_symbol env symbol in + loop_program_body env program + | Effect (expr, program) -> + loop env expr; + loop_program_body env program + | End root -> + check_symbol_is_bound env root + in + let env = + Symbol.Set.fold (fun symbol env -> + add_binding_occurrence_of_symbol env symbol) + program.imported_symbols + (Variable.Set.empty, Mutable_variable.Set.empty, Symbol.Set.empty) + in + loop_program_body env program.program_body + +let primitive_invariants flam = + Flambda_iterators.iter_named (function + | Prim (prim, _, _) -> + begin match prim with + | Psequand | Psequor -> + raise (Sequential_logical_operator_primitives_must_be_expanded prim) + | _ -> () + end + | _ -> ()) + flam + +let declared_var_within_closure (flam:Flambda.program) = + let bound = ref Var_within_closure.Set.empty in + let bound_multiple_times = ref None in + let add_and_check var = + if Var_within_closure.Set.mem var !bound then begin + bound_multiple_times := Some var + end; + bound := Var_within_closure.Set.add var !bound + in + Flambda_iterators.iter_on_set_of_closures_of_program + ~f:(fun ~constant:_ { Flambda. free_vars; _ } -> + Variable.Map.iter (fun id _ -> + let var = Var_within_closure.wrap id in + add_and_check var) + free_vars) + flam; + !bound, !bound_multiple_times + +let no_var_within_closure_is_bound_multiple_times (flam:Flambda.program) = + match declared_var_within_closure flam with + | _, Some var -> raise (Var_within_closure_bound_multiple_times var) + | _, None -> () + +let every_declared_closure_is_from_current_compilation_unit flam = + let current_compilation_unit = Compilation_unit.get_current_exn () in + Flambda_iterators.iter_on_sets_of_closures (fun + { Flambda. function_decls; _ } -> + let compilation_unit = + Set_of_closures_id.get_compilation_unit + function_decls.set_of_closures_id + in + if not (Compilation_unit.equal compilation_unit current_compilation_unit) + then raise (Declared_closure_from_another_unit compilation_unit)) + flam + +let declared_closure_ids program = + let bound = ref Closure_id.Set.empty in + let bound_multiple_times = ref None in + let add_and_check var = + if Closure_id.Set.mem var !bound + then bound_multiple_times := Some var; + bound := Closure_id.Set.add var !bound + in + Flambda_iterators.iter_on_set_of_closures_of_program program + ~f:(fun ~constant:_ { Flambda. function_decls; _; } -> + Variable.Map.iter (fun id _ -> + let var = Closure_id.wrap id in + add_and_check var) + function_decls.funs); + !bound, !bound_multiple_times + +let no_closure_id_is_bound_multiple_times program = + match declared_closure_ids program with + | _, Some closure_id -> + raise (Closure_id_is_bound_multiple_times closure_id) + | _, None -> () + +let declared_set_of_closures_ids program = + let bound = ref Set_of_closures_id.Set.empty in + let bound_multiple_times = ref None in + let add_and_check var = + if Set_of_closures_id.Set.mem var !bound + then bound_multiple_times := Some var; + bound := Set_of_closures_id.Set.add var !bound + in + Flambda_iterators.iter_on_set_of_closures_of_program program + ~f:(fun ~constant:_ { Flambda. function_decls; _; } -> + add_and_check function_decls.set_of_closures_id); + !bound, !bound_multiple_times + +let no_set_of_closures_id_is_bound_multiple_times program = + match declared_set_of_closures_ids program with + | _, Some set_of_closures_id -> + raise (Set_of_closures_id_is_bound_multiple_times set_of_closures_id) + | _, None -> () + +let used_closure_ids (program:Flambda.program) = + let used = ref Closure_id.Set.empty in + let f (flam : Flambda.named) = + match flam with + | Project_closure { closure_id; _} -> + used := Closure_id.Set.add closure_id !used; + | Move_within_set_of_closures { closure = _; start_from; move_to; } -> + used := Closure_id.Set.add start_from !used; + used := Closure_id.Set.add move_to !used + | Project_var { closure = _; closure_id; var = _ } -> + used := Closure_id.Set.add closure_id !used + | Set_of_closures _ | Symbol _ | Const _ | Allocated_const _ + | Prim _ | Expr _ | Read_mutable _ | Read_symbol_field _ -> () + in + (* CR-someday pchambart: check closure_ids of constant_defining_values' + project_closures *) + Flambda_iterators.iter_named_of_program ~f program; + !used + +let used_vars_within_closures (flam:Flambda.program) = + let used = ref Var_within_closure.Set.empty in + let f (flam : Flambda.named) = + match flam with + | Project_var { closure = _; closure_id = _; var; } -> + used := Var_within_closure.Set.add var !used + | _ -> () + in + Flambda_iterators.iter_named_of_program ~f flam; + !used + +let every_used_function_from_current_compilation_unit_is_declared + (program:Flambda.program) = + let current_compilation_unit = Compilation_unit.get_current_exn () in + let declared, _ = declared_closure_ids program in + let used = used_closure_ids program in + let used_from_current_unit = + Closure_id.Set.filter (fun cu -> + Closure_id.in_compilation_unit cu current_compilation_unit) + used + in + let counter_examples = + Closure_id.Set.diff used_from_current_unit declared + in + if Closure_id.Set.is_empty counter_examples + then () + else raise (Unbound_closure_ids counter_examples) + +let every_used_var_within_closure_from_current_compilation_unit_is_declared + (flam:Flambda.program) = + let current_compilation_unit = Compilation_unit.get_current_exn () in + let declared, _ = declared_var_within_closure flam in + let used = used_vars_within_closures flam in + let used_from_current_unit = + Var_within_closure.Set.filter (fun cu -> + Var_within_closure.in_compilation_unit cu current_compilation_unit) + used + in + let counter_examples = + Var_within_closure.Set.diff used_from_current_unit declared in + if Var_within_closure.Set.is_empty counter_examples + then () + else raise (Unbound_vars_within_closures counter_examples) + +let every_static_exception_is_caught flam = + let check env (flam : Flambda.t) = + match flam with + | Static_raise (exn, _) -> + if not (Static_exception.Set.mem exn env) + then raise (Static_exception_not_caught exn) + | _ -> () + in + let rec loop env (flam : Flambda.t) = + match flam with + | Static_catch (i, _, body, handler) -> + let env = Static_exception.Set.add i env in + loop env handler; + loop env body + | exp -> + check env exp; + Flambda_iterators.apply_on_subexpressions (loop env) + (fun (_ : Flambda.named) -> ()) exp + in + loop Static_exception.Set.empty flam + +let every_static_exception_is_caught_at_a_single_position flam = + let caught = ref Static_exception.Set.empty in + let f (flam : Flambda.t) = + match flam with + | Static_catch (i, _, _body, _handler) -> + if Static_exception.Set.mem i !caught then + raise (Static_exception_caught_in_multiple_places i); + caught := Static_exception.Set.add i !caught + | _ -> () + in + Flambda_iterators.iter f (fun (_ : Flambda.named) -> ()) flam + +let _every_move_within_set_of_closures_is_to_a_function_in_the_free_vars + program = + let moves = ref Closure_id.Map.empty in + Flambda_iterators.iter_named_of_program program + ~f:(function + | Move_within_set_of_closures { start_from; move_to; _ } -> + let moved_to = + try Closure_id.Map.find start_from !moves with + | Not_found -> Closure_id.Set.empty + in + moves := + Closure_id.Map.add start_from + (Closure_id.Set.add move_to moved_to) + !moves + | _ -> ()); + Flambda_iterators.iter_on_set_of_closures_of_program program + ~f:(fun ~constant:_ { Flambda.function_decls = { funs; _ }; _ } -> + Variable.Map.iter (fun fun_var { Flambda.free_variables; _ } -> + match Closure_id.Map.find (Closure_id.wrap fun_var) !moves with + | exception Not_found -> () + | moved_to -> + let missing_dependencies = + Variable.Set.diff (Closure_id.unwrap_set moved_to) + free_variables + in + if not (Variable.Set.is_empty missing_dependencies) then + raise (Move_to_a_closure_not_in_the_free_variables + (fun_var, missing_dependencies))) + funs) + +let check_exn ?(kind=Normal) (flam:Flambda.program) = + ignore kind; + try + variable_and_symbol_invariants flam; + no_closure_id_is_bound_multiple_times flam; + no_set_of_closures_id_is_bound_multiple_times flam; + every_used_function_from_current_compilation_unit_is_declared flam; + no_var_within_closure_is_bound_multiple_times flam; + every_used_var_within_closure_from_current_compilation_unit_is_declared + flam; + (* CR-soon pchambart: This invariant is not maintained. It should be + either relaxed or reformulated. Currently, it is safe to disable it as + the potential related errors would result in fatal errors, not in + miscompilations *) + (* every_move_within_set_of_closures_is_to_a_function_in_the_free_vars + flam; *) + Flambda_iterators.iter_exprs_at_toplevel_of_program flam ~f:(fun flam -> + primitive_invariants flam; + every_static_exception_is_caught flam; + every_static_exception_is_caught_at_a_single_position flam; + every_declared_closure_is_from_current_compilation_unit flam) + with exn -> begin + (* CR-someday split printing code into its own function *) + begin match exn with + | Binding_occurrence_not_from_current_compilation_unit var -> + Format.eprintf ">> Binding occurrence of variable marked as not being \ + from the current compilation unit: %a" + Variable.print var + | Mutable_binding_occurrence_not_from_current_compilation_unit mut_var -> + Format.eprintf ">> Binding occurrence of mutable variable marked as not \ + being from the current compilation unit: %a" + Mutable_variable.print mut_var + | Binding_occurrence_of_variable_already_bound var -> + Format.eprintf ">> Binding occurrence of variable that was already \ + bound: %a" + Variable.print var + | Binding_occurrence_of_mutable_variable_already_bound mut_var -> + Format.eprintf ">> Binding occurrence of mutable variable that was \ + already bound: %a" + Mutable_variable.print mut_var + | Binding_occurrence_of_symbol_already_bound sym -> + Format.eprintf ">> Binding occurrence of symbol that was already \ + bound: %a" + Symbol.print sym + | Unbound_variable var -> + Format.eprintf ">> Unbound variable: %a" Variable.print var + | Unbound_mutable_variable mut_var -> + Format.eprintf ">> Unbound mutable variable: %a" + Mutable_variable.print mut_var + | Unbound_symbol sym -> + Format.eprintf ">> Unbound symbol: %a %s" + Symbol.print sym + (Printexc.raw_backtrace_to_string (Printexc.get_callstack 100)) + | Vars_in_function_body_not_bound_by_closure_or_params + (vars, set_of_closures, fun_var) -> + Format.eprintf ">> Variable(s) (%a) in the body of a function \ + declaration (fun_var = %a) that is not bound by either the closure \ + or the function's parameter list. Set of closures: %a" + Variable.Set.print vars + Variable.print fun_var + Flambda.print_set_of_closures set_of_closures + | Function_decls_have_overlapping_parameters vars -> + Format.eprintf ">> Function declarations whose parameters overlap: \ + %a" + Variable.Set.print vars + | Specialised_arg_that_is_not_a_parameter var -> + Format.eprintf ">> Variable in [specialised_args] that is not a \ + parameter of any of the function(s) in the corresponding \ + declaration(s): %a" + Variable.print var + | Projection_must_be_a_free_var var -> + Format.eprintf ">> Projection %a in [free_vars] from a variable that is \ + not a (inner) free variable of the set of closures" + Projection.print var + | Projection_must_be_a_specialised_arg var -> + Format.eprintf ">> Projection %a in [specialised_args] from a variable \ + that is not a (inner) specialised argument variable of the set of \ + closures" + Projection.print var + | Free_variables_set_is_lying (var, claimed, calculated, function_decl) -> + Format.eprintf ">> Function declaration whose [free_variables] set (%a) \ + is not a superset of the result of [Flambda.free_variables] \ + applied to the body of the function (%a). Declaration: %a" + Variable.Set.print claimed + Variable.Set.print calculated + Flambda.print_function_declaration (var, function_decl) + | Set_of_closures_free_vars_map_has_wrong_range vars -> + Format.eprintf ">> [free_vars] map in set of closures has in its range \ + variables that are not free variables of the corresponding \ + functions: %a" + Variable.Set.print vars + | Sequential_logical_operator_primitives_must_be_expanded prim -> + Format.eprintf ">> Sequential logical operator primitives must be \ + expanded (see closure_conversion.ml): %a" + Printclambda_primitives.primitive prim + | Var_within_closure_bound_multiple_times var -> + Format.eprintf ">> Variable within a closure is bound multiple times: \ + %a" + Var_within_closure.print var + | Closure_id_is_bound_multiple_times closure_id -> + Format.eprintf ">> Closure ID is bound multiple times: %a" + Closure_id.print closure_id + | Set_of_closures_id_is_bound_multiple_times set_of_closures_id -> + Format.eprintf ">> Set of closures ID is bound multiple times: %a" + Set_of_closures_id.print set_of_closures_id + | Declared_closure_from_another_unit compilation_unit -> + Format.eprintf ">> Closure declared as being from another compilation \ + unit: %a" + Compilation_unit.print compilation_unit + | Unbound_closure_ids closure_ids -> + Format.eprintf ">> Unbound closure ID(s) from the current compilation \ + unit: %a" + Closure_id.Set.print closure_ids + | Unbound_vars_within_closures vars_within_closures -> + Format.eprintf ">> Unbound variable(s) within closure(s) from the \ + current compilation_unit: %a" + Var_within_closure.Set.print vars_within_closures + | Static_exception_not_caught static_exn -> + Format.eprintf ">> Uncaught static exception: %a" + Static_exception.print static_exn + | Static_exception_caught_in_multiple_places static_exn -> + Format.eprintf ">> Static exception caught in multiple places: %a" + Static_exception.print static_exn + | Move_to_a_closure_not_in_the_free_variables (start_from, move_to) -> + Format.eprintf ">> A Move_within_set_of_closures from the closure %a \ + to closures that are not parts of its free variables: %a" + Variable.print start_from + Variable.Set.print move_to + | exn -> raise exn + end; + Format.eprintf "\n@?"; + raise Flambda_invariants_failed + end diff --git a/middle_end/flambda/flambda_invariants.mli b/middle_end/flambda/flambda_invariants.mli new file mode 100644 index 0000000000..252578e88e --- /dev/null +++ b/middle_end/flambda/flambda_invariants.mli @@ -0,0 +1,28 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +type flambda_kind = + | Normal + | Lifted + +(** Checking of invariants on Flambda expressions. Raises an exception if + a check fails. *) +val check_exn + : ?kind:flambda_kind + -> Flambda.program + -> unit diff --git a/middle_end/flambda/flambda_iterators.ml b/middle_end/flambda/flambda_iterators.ml new file mode 100644 index 0000000000..a69575da63 --- /dev/null +++ b/middle_end/flambda/flambda_iterators.ml @@ -0,0 +1,808 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +let apply_on_subexpressions f f_named (flam : Flambda.t) = + match flam with + | Var _ | Apply _ | Assign _ | Send _ | Proved_unreachable + | Static_raise _ -> () + | Let { defining_expr; body; _ } -> + f_named defining_expr; + f body + | Let_mutable { body; _ } -> + f body + | Let_rec (defs, body) -> + List.iter (fun (_,l) -> f_named l) defs; + f body + | Switch (_, sw) -> + List.iter (fun (_,l) -> f l) sw.consts; + List.iter (fun (_,l) -> f l) sw.blocks; + Misc.may f sw.failaction + | String_switch (_, sw, def) -> + List.iter (fun (_,l) -> f l) sw; + Misc.may f def + | Static_catch (_,_,f1,f2) -> + f f1; f f2; + | Try_with (f1,_,f2) -> + f f1; f f2 + | If_then_else (_,f1, f2) -> + f f1;f f2 + | While (f1,f2) -> + f f1; f f2 + | For { body; _ } -> f body + +let rec list_map_sharing f l = + match l with + | [] -> l + | h :: t -> + let new_t = list_map_sharing f t in + let new_h = f h in + if h == new_h && t == new_t then + l + else + new_h :: new_t + +let may_map_sharing f v = + match v with + | None -> v + | Some s -> + let new_s = f s in + if s == new_s then + v + else + Some new_s + +let map_snd_sharing f ((a, b) as cpl) = + let new_b = f a b in + if b == new_b then + cpl + else + (a, new_b) + +let map_subexpressions f f_named (tree:Flambda.t) : Flambda.t = + match tree with + | Var _ | Apply _ | Assign _ | Send _ | Proved_unreachable + | Static_raise _ -> tree + | Let { var; defining_expr; body; _ } -> + let new_named = f_named var defining_expr in + let new_body = f body in + if new_named == defining_expr && new_body == body then + tree + else + Flambda.create_let var new_named new_body + | Let_rec (defs, body) -> + let new_defs = + list_map_sharing (map_snd_sharing f_named) defs + in + let new_body = f body in + if new_defs == defs && new_body == body then + tree + else + Let_rec (new_defs, new_body) + | Let_mutable mutable_let -> + let new_body = f mutable_let.body in + if new_body == mutable_let.body then + tree + else + Let_mutable { mutable_let with body = new_body } + | Switch (arg, sw) -> + let aux = map_snd_sharing (fun _ v -> f v) in + let new_consts = list_map_sharing aux sw.consts in + let new_blocks = list_map_sharing aux sw.blocks in + let new_failaction = may_map_sharing f sw.failaction in + if sw.failaction == new_failaction && + new_consts == sw.consts && + new_blocks == sw.blocks then + tree + else + let sw = + { sw with + failaction = new_failaction; + consts = new_consts; + blocks = new_blocks; + } + in + Switch (arg, sw) + | String_switch (arg, sw, def) -> + let new_sw = list_map_sharing (map_snd_sharing (fun _ v -> f v)) sw in + let new_def = may_map_sharing f def in + if sw == new_sw && def == new_def then + tree + else + String_switch(arg, new_sw, new_def) + | Static_catch (i, vars, body, handler) -> + let new_body = f body in + let new_handler = f handler in + if new_body == body && new_handler == handler then + tree + else + Static_catch (i, vars, new_body, new_handler) + | Try_with(body, id, handler) -> + let new_body = f body in + let new_handler = f handler in + if body == new_body && handler == new_handler then + tree + else + Try_with(new_body, id, new_handler) + | If_then_else(arg, ifso, ifnot) -> + let new_ifso = f ifso in + let new_ifnot = f ifnot in + if new_ifso == ifso && new_ifnot == ifnot then + tree + else + If_then_else(arg, new_ifso, new_ifnot) + | While(cond, body) -> + let new_cond = f cond in + let new_body = f body in + if new_cond == cond && new_body == body then + tree + else + While(new_cond, new_body) + | For { bound_var; from_value; to_value; direction; body; } -> + let new_body = f body in + if new_body == body then + tree + else + For { bound_var; from_value; to_value; direction; body = new_body; } + +let iter_general = Flambda.iter_general + +let iter f f_named t = iter_general ~toplevel:false f f_named (Is_expr t) +let iter_expr f t = iter f (fun _ -> ()) t +let iter_on_named f f_named t = + iter_general ~toplevel:false f f_named (Is_named t) +let iter_named f_named t = iter (fun (_ : Flambda.t) -> ()) f_named t +let iter_named_on_named f_named named = + iter_general ~toplevel:false (fun (_ : Flambda.t) -> ()) f_named + (Is_named named) + +let iter_toplevel f f_named t = + iter_general ~toplevel:true f f_named (Is_expr t) +let iter_named_toplevel f f_named named = + iter_general ~toplevel:true f f_named (Is_named named) + +let iter_all_immutable_let_and_let_rec_bindings t ~f = + iter_expr (function + | Let { var; defining_expr; _ } -> f var defining_expr + | Let_rec (defs, _) -> List.iter (fun (var, named) -> f var named) defs + | _ -> ()) + t + +let iter_all_toplevel_immutable_let_and_let_rec_bindings t ~f = + iter_general ~toplevel:true + (function + | Let { var; defining_expr; _ } -> f var defining_expr + | Let_rec (defs, _) -> List.iter (fun (var, named) -> f var named) defs + | _ -> ()) + (fun _ -> ()) + (Is_expr t) + +let iter_on_sets_of_closures f t = + iter_named (function + | Set_of_closures clos -> f clos + | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ + | Read_symbol_field _ + | Project_closure _ | Move_within_set_of_closures _ | Project_var _ + | Prim _ | Expr _ -> ()) + t + +let iter_exprs_at_toplevel_of_program (program : Flambda.program) ~f = + let rec loop (program : Flambda.program_body) = + match program with + | Let_symbol (_, Set_of_closures set_of_closures, program) -> + Variable.Map.iter (fun _ (function_decl : Flambda.function_declaration) -> + f function_decl.body) + set_of_closures.function_decls.funs; + loop program + | Let_rec_symbol (defs, program) -> + List.iter (function + | (_, Flambda.Set_of_closures set_of_closures) -> + Variable.Map.iter + (fun _ (function_decl : Flambda.function_declaration) -> + f function_decl.body) + set_of_closures.function_decls.funs + | _ -> ()) defs; + loop program + | Let_symbol (_, _, program) -> + loop program + | Initialize_symbol (_, _, fields, program) -> + List.iter f fields; + loop program + | Effect (expr, program) -> + f expr; + loop program + | End _ -> () + in + loop program.program_body + +let iter_named_of_program program ~f = + iter_exprs_at_toplevel_of_program program ~f:(iter_named f) + +let iter_on_set_of_closures_of_program (program : Flambda.program) ~f = + let rec loop (program : Flambda.program_body) = + match program with + | Let_symbol (_, Set_of_closures set_of_closures, program) -> + f ~constant:true set_of_closures; + Variable.Map.iter (fun _ (function_decl : Flambda.function_declaration) -> + iter_on_sets_of_closures (f ~constant:false) function_decl.body) + set_of_closures.function_decls.funs; + loop program + | Let_rec_symbol (defs, program) -> + List.iter (function + | (_, Flambda.Set_of_closures set_of_closures) -> + f ~constant:true set_of_closures; + Variable.Map.iter + (fun _ (function_decl : Flambda.function_declaration) -> + iter_on_sets_of_closures (f ~constant:false) function_decl.body) + set_of_closures.function_decls.funs + | _ -> ()) defs; + loop program + | Let_symbol (_, _, program) -> + loop program + | Initialize_symbol (_, _, fields, program) -> + List.iter (iter_on_sets_of_closures (f ~constant:false)) fields; + loop program + | Effect (expr, program) -> + iter_on_sets_of_closures (f ~constant:false) expr; + loop program + | End _ -> () + in + loop program.program_body + +let iter_constant_defining_values_on_program (program : Flambda.program) ~f = + let rec loop (program : Flambda.program_body) = + match program with + | Let_symbol (_, const, program) -> + f const; + loop program + | Let_rec_symbol (defs, program) -> + List.iter (fun (_, const) -> f const) defs; + loop program + | Initialize_symbol (_, _, _, program) -> + loop program + | Effect (_, program) -> + loop program + | End _ -> () + in + loop program.program_body + +let map_general ~toplevel f f_named tree = + let rec aux (tree : Flambda.t) = + match tree with + | Let _ -> + Flambda.map_lets tree ~for_defining_expr:aux_named ~for_last_body:aux + ~after_rebuild:f + | _ -> + let exp : Flambda.t = + match tree with + | Var _ | Apply _ | Assign _ | Send _ | Proved_unreachable + | Static_raise _ -> tree + | Let _ -> assert false + | Let_mutable mutable_let -> + let new_body = aux mutable_let.body in + if new_body == mutable_let.body then + tree + else + Let_mutable { mutable_let with body = new_body } + | Let_rec (defs, body) -> + let done_something = ref false in + let defs = + List.map (fun (id, lam) -> + id, aux_named_done_something id lam done_something) + defs + in + let body = aux_done_something body done_something in + if not !done_something then + tree + else + Let_rec (defs, body) + | Switch (arg, sw) -> + let done_something = ref false in + let sw = + { sw with + failaction = + begin match sw.failaction with + | None -> None + | Some failaction -> + Some (aux_done_something failaction done_something) + end; + consts = + List.map (fun (i, v) -> + i, aux_done_something v done_something) + sw.consts; + blocks = + List.map (fun (i, v) -> + i, aux_done_something v done_something) + sw.blocks; + } + in + if not !done_something then + tree + else + Switch (arg, sw) + | String_switch (arg, sw, def) -> + let done_something = ref false in + let sw = + List.map (fun (i, v) -> i, aux_done_something v done_something) sw + in + let def = + match def with + | None -> None + | Some def -> Some (aux_done_something def done_something) + in + if not !done_something then + tree + else + String_switch(arg, sw, def) + | Static_catch (i, vars, body, handler) -> + let new_body = aux body in + let new_handler = aux handler in + if new_body == body && new_handler == handler then + tree + else + Static_catch (i, vars, new_body, new_handler) + | Try_with(body, id, handler) -> + let new_body = aux body in + let new_handler = aux handler in + if new_body == body && new_handler == handler then + tree + else + Try_with (new_body, id, new_handler) + | If_then_else (arg, ifso, ifnot) -> + let new_ifso = aux ifso in + let new_ifnot = aux ifnot in + if new_ifso == ifso && new_ifnot == ifnot then + tree + else + If_then_else (arg, new_ifso, new_ifnot) + | While (cond, body) -> + let new_cond = aux cond in + let new_body = aux body in + if new_cond == cond && new_body == body then + tree + else + While (new_cond, new_body) + | For { bound_var; from_value; to_value; direction; body; } -> + let new_body = aux body in + if new_body == body then + tree + else + For { bound_var; from_value; to_value; direction; + body = new_body; } + in + f exp + and aux_done_something expr done_something = + let new_expr = aux expr in + if not (new_expr == expr) then begin + done_something := true + end; + new_expr + and aux_named (id : Variable.t) (named : Flambda.named) = + let named : Flambda.named = + match named with + | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ + | Project_closure _ | Move_within_set_of_closures _ | Project_var _ + | Prim _ | Read_symbol_field _ -> named + | Set_of_closures ({ function_decls; free_vars; specialised_args; + direct_call_surrogates }) -> + if toplevel then named + else begin + let done_something = ref false in + let funs = + Variable.Map.map (fun (func_decl : Flambda.function_declaration) -> + let new_body = aux func_decl.body in + if new_body == func_decl.body then begin + func_decl + end else begin + done_something := true; + Flambda.update_function_declaration func_decl + ~params:func_decl.params ~body:new_body + end) + function_decls.funs + in + if not !done_something then + named + else + let function_decls = + Flambda.update_function_declarations function_decls ~funs + in + let set_of_closures = + Flambda.create_set_of_closures ~function_decls ~free_vars + ~specialised_args ~direct_call_surrogates + in + Set_of_closures set_of_closures + end + | Expr expr -> + let new_expr = aux expr in + if new_expr == expr then named + else Expr new_expr + in + f_named id named + and aux_named_done_something id named done_something = + let new_named = aux_named id named in + if not (new_named == named) then begin + done_something := true + end; + new_named + in + aux tree + +let iter_apply_on_program program ~f = + iter_exprs_at_toplevel_of_program program ~f:(fun expr -> + iter (function + | Apply apply -> f apply + | _ -> ()) + (fun _ -> ()) + expr) + +let map f f_named tree = + map_general ~toplevel:false f (fun _ n -> f_named n) tree +let map_expr f tree = map f (fun named -> named) tree +let map_named f_named tree = map (fun expr -> expr) f_named tree +let map_named_with_id f_named tree = + map_general ~toplevel:false (fun expr -> expr) f_named tree +let map_toplevel f f_named tree = + map_general ~toplevel:true f (fun _ n -> f_named n) tree +let map_toplevel_expr f_expr tree = + map_toplevel f_expr (fun named -> named) tree +let map_toplevel_named f_named tree = + map_toplevel (fun tree -> tree) f_named tree + +let map_symbols tree ~f = + map_named (function + | (Symbol sym) as named -> + let new_sym = f sym in + if new_sym == sym then + named + else + Symbol new_sym + | ((Read_symbol_field (sym, field)) as named) -> + let new_sym = f sym in + if new_sym == sym then + named + else + Read_symbol_field (new_sym, field) + | (Const _ | Allocated_const _ | Set_of_closures _ | Read_mutable _ + | Project_closure _ | Move_within_set_of_closures _ | Project_var _ + | Prim _ | Expr _) as named -> named) + tree + +let map_symbols_on_set_of_closures + ({ Flambda.function_decls; free_vars; specialised_args; + direct_call_surrogates; } as + set_of_closures) + ~f = + let done_something = ref false in + let funs = + Variable.Map.map (fun (func_decl : Flambda.function_declaration) -> + let body = map_symbols func_decl.body ~f in + if not (body == func_decl.body) then begin + done_something := true; + end; + Flambda.update_function_declaration func_decl + ~params:func_decl.params ~body) + function_decls.funs + in + if not !done_something then + set_of_closures + else + let function_decls = + Flambda.update_function_declarations function_decls ~funs + in + Flambda.create_set_of_closures ~function_decls ~free_vars + ~specialised_args ~direct_call_surrogates + +let map_toplevel_sets_of_closures tree ~f = + map_toplevel_named (function + | (Set_of_closures set_of_closures) as named -> + let new_set_of_closures = f set_of_closures in + if new_set_of_closures == set_of_closures then + named + else + Set_of_closures new_set_of_closures + | (Symbol _ | Const _ | Allocated_const _ | Read_mutable _ + | Read_symbol_field _ + | Project_closure _ | Move_within_set_of_closures _ | Project_var _ + | Prim _ | Expr _) as named -> named) + tree + +let map_apply tree ~f = + map (function + | (Apply apply) as expr -> + let new_apply = f apply in + if new_apply == apply then + expr + else + Apply new_apply + | expr -> expr) + (fun named -> named) + tree + +let map_sets_of_closures tree ~f = + map_named (function + | (Set_of_closures set_of_closures) as named -> + let new_set_of_closures = f set_of_closures in + if new_set_of_closures == set_of_closures then + named + else + Set_of_closures new_set_of_closures + | (Symbol _ | Const _ | Allocated_const _ | Project_closure _ + | Move_within_set_of_closures _ | Project_var _ + | Prim _ | Expr _ | Read_mutable _ + | Read_symbol_field _) as named -> named) + tree + +let map_project_var_to_expr_opt tree ~f = + map_named (function + | (Project_var project_var) as named -> + begin match f project_var with + | None -> named + | Some expr -> Expr expr + end + | (Symbol _ | Const _ | Allocated_const _ + | Set_of_closures _ | Project_closure _ | Move_within_set_of_closures _ + | Prim _ | Expr _ | Read_mutable _ | Read_symbol_field _) + as named -> named) + tree + +let map_project_var_to_named_opt tree ~f = + map_named (function + | (Project_var project_var) as named -> + begin match f project_var with + | None -> named + | Some named -> named + end + | (Symbol _ | Const _ | Allocated_const _ + | Set_of_closures _ | Project_closure _ | Move_within_set_of_closures _ + | Prim _ | Expr _ | Read_mutable _ | Read_symbol_field _) + as named -> named) + tree + +let map_function_bodies (set_of_closures : Flambda.set_of_closures) ~f = + let done_something = ref false in + let funs = + Variable.Map.map (fun (function_decl : Flambda.function_declaration) -> + let new_body = f function_decl.body in + if new_body == function_decl.body then + function_decl + else begin + done_something := true; + Flambda.update_function_declaration function_decl + ~body:new_body ~params:function_decl.params + end) + set_of_closures.function_decls.funs + in + if not !done_something then + set_of_closures + else + let function_decls = + Flambda.update_function_declarations set_of_closures.function_decls ~funs + in + Flambda.create_set_of_closures + ~function_decls + ~free_vars:set_of_closures.free_vars + ~specialised_args:set_of_closures.specialised_args + ~direct_call_surrogates:set_of_closures.direct_call_surrogates + +let map_sets_of_closures_of_program (program : Flambda.program) + ~(f : Flambda.set_of_closures -> Flambda.set_of_closures) = + let rec loop (program : Flambda.program_body) : Flambda.program_body = + let map_constant_set_of_closures (set_of_closures:Flambda.set_of_closures) = + let done_something = ref false in + let function_decls = + let funs = + Variable.Map.map (fun + (function_decl : Flambda.function_declaration) -> + let body = map_sets_of_closures ~f function_decl.body in + if body == function_decl.body then + function_decl + else begin + done_something := true; + Flambda.update_function_declaration function_decl + ~body ~params:function_decl.params + end) + set_of_closures.function_decls.funs + in + if not !done_something then + set_of_closures.function_decls + else + Flambda.update_function_declarations set_of_closures.function_decls + ~funs + in + let new_set_of_closures = f set_of_closures in + if new_set_of_closures == set_of_closures then + set_of_closures + else + Flambda.create_set_of_closures ~function_decls + ~free_vars:set_of_closures.free_vars + ~specialised_args:set_of_closures.specialised_args + ~direct_call_surrogates:set_of_closures.direct_call_surrogates + in + match program with + | Let_symbol (symbol, Set_of_closures set_of_closures, program') -> + let new_set_of_closures = map_constant_set_of_closures set_of_closures in + let new_program' = loop program' in + if new_set_of_closures == set_of_closures + && new_program' == program' then + program + else + Let_symbol (symbol, Set_of_closures new_set_of_closures, new_program') + | Let_symbol (symbol, const, program') -> + let new_program' = loop program' in + if new_program' == program' then + program + else + Let_symbol (symbol, const, new_program') + | Let_rec_symbol (defs, program') -> + let done_something = ref false in + let defs = + List.map (function + | (var, Flambda.Set_of_closures set_of_closures) -> + let new_set_of_closures = + map_constant_set_of_closures set_of_closures + in + if not (new_set_of_closures == set_of_closures) then begin + done_something := true + end; + var, Flambda.Set_of_closures new_set_of_closures + | def -> def) + defs + in + let new_program' = loop program' in + if new_program' == program' && not !done_something then + program + else + Let_rec_symbol (defs, loop program') + | Initialize_symbol (symbol, tag, fields, program') -> + let done_something = ref false in + let fields = + List.map (fun field -> + let new_field = map_sets_of_closures field ~f in + if not (new_field == field) then begin + done_something := true + end; + new_field) + fields + in + let new_program' = loop program' in + if new_program' == program' && not !done_something then + program + else + Initialize_symbol (symbol, tag, fields, new_program') + | Effect (expr, program') -> + let new_expr = map_sets_of_closures expr ~f in + let new_program' = loop program' in + if new_expr == expr && new_program' == program' then + program + else + Effect (new_expr, new_program') + | End _ -> program + in + { program with + program_body = loop program.program_body; + } + +let map_exprs_at_toplevel_of_program (program : Flambda.program) + ~(f : Flambda.t -> Flambda.t) = + let rec loop (program : Flambda.program_body) : Flambda.program_body = + let map_constant_set_of_closures (set_of_closures:Flambda.set_of_closures) = + let done_something = ref false in + let funs = + Variable.Map.map (fun (function_decl : Flambda.function_declaration) -> + let body = f function_decl.body in + if body == function_decl.body then + function_decl + else begin + done_something := true; + Flambda.update_function_declaration function_decl + ~body ~params:function_decl.params + end) + set_of_closures.function_decls.funs + in + if not !done_something then + set_of_closures + else + let function_decls = + Flambda.update_function_declarations set_of_closures.function_decls + ~funs + in + Flambda.create_set_of_closures ~function_decls + ~free_vars:set_of_closures.free_vars + ~specialised_args:set_of_closures.specialised_args + ~direct_call_surrogates:set_of_closures.direct_call_surrogates + in + (* CR-soon mshinwell: code very similar to the above function *) + match program with + | Let_symbol (symbol, Set_of_closures set_of_closures, program') -> + let new_set_of_closures = map_constant_set_of_closures set_of_closures in + let new_program' = loop program' in + if new_set_of_closures == set_of_closures + && new_program' == program' then + program + else + Let_symbol (symbol, Set_of_closures new_set_of_closures, new_program') + | Let_symbol (symbol, const, program') -> + let new_program' = loop program' in + if new_program' == program' then + program + else + Let_symbol (symbol, const, new_program') + | Let_rec_symbol (defs, program') -> + let done_something = ref false in + let defs = + List.map (function + | (var, Flambda.Set_of_closures set_of_closures) -> + let new_set_of_closures = + map_constant_set_of_closures set_of_closures + in + if not (new_set_of_closures == set_of_closures) then begin + done_something := true + end; + var, Flambda.Set_of_closures new_set_of_closures + | def -> def) + defs + in + let new_program' = loop program' in + if new_program' == program' && not !done_something then + program + else + Let_rec_symbol (defs, new_program') + | Initialize_symbol (symbol, tag, fields, program') -> + let done_something = ref false in + let fields = + List.map (fun field -> + let new_field = f field in + if not (new_field == field) then begin + done_something := true + end; + new_field) + fields + in + let new_program' = loop program' in + if new_program' == program' && not !done_something then + program + else + Initialize_symbol (symbol, tag, fields, new_program') + | Effect (expr, program') -> + let new_expr = f expr in + let new_program' = loop program' in + if new_expr == expr && new_program' == program' then + program + else + Effect (new_expr, new_program') + | End _ -> program + in + { program with + program_body = loop program.program_body; + } + +let map_named_of_program (program : Flambda.program) + ~(f : Variable.t -> Flambda.named -> Flambda.named) : Flambda.program = + map_exprs_at_toplevel_of_program program + ~f:(fun expr -> map_named_with_id f expr) + +let map_all_immutable_let_and_let_rec_bindings (expr : Flambda.t) + ~(f : Variable.t -> Flambda.named -> Flambda.named) : Flambda.t = + map_named_with_id f expr + +let fold_function_decls_ignoring_stubs + (set_of_closures : Flambda.set_of_closures) ~init ~f = + Variable.Map.fold (fun fun_var function_decl acc -> + f ~fun_var ~function_decl acc) + set_of_closures.function_decls.funs + init diff --git a/middle_end/flambda/flambda_iterators.mli b/middle_end/flambda/flambda_iterators.mli new file mode 100644 index 0000000000..02fe685097 --- /dev/null +++ b/middle_end/flambda/flambda_iterators.mli @@ -0,0 +1,227 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(* CR-soon mshinwell: we need to document whether these iterators follow any + particular order. *) + +(** Apply the given functions to the immediate subexpressions of the given + Flambda expression. For avoidance of doubt, if a subexpression is + [Expr], it is passed to the function taking [Flambda.named], rather + than being followed and passed to the function taking [Flambda.t]. *) +val apply_on_subexpressions + : (Flambda.t -> unit) + -> (Flambda.named -> unit) + -> Flambda.t + -> unit + +val map_subexpressions + : (Flambda.t -> Flambda.t) + -> (Variable.t -> Flambda.named -> Flambda.named) + -> Flambda.t + -> Flambda.t + +(* CR-soon lwhite: add comment to clarify that these recurse unlike the + ones above *) +val iter + : (Flambda.t -> unit) + -> (Flambda.named -> unit) + -> Flambda.t + -> unit + +val iter_expr + : (Flambda.t -> unit) + -> Flambda.t + -> unit + +val iter_on_named + : (Flambda.t -> unit) + -> (Flambda.named -> unit) + -> Flambda.named + -> unit + +(* CR-someday mshinwell: we might need to add the corresponding variable to + the parameters of the user function for [iter_named] *) +val iter_named + : (Flambda.named -> unit) + -> Flambda.t + -> unit + +(* CR-someday lwhite: These names are pretty indecipherable, perhaps + create submodules for the normal and "on_named" variants of each + function. *) + +val iter_named_on_named + : (Flambda.named -> unit) + -> Flambda.named + -> unit + +(** [iter_toplevel f t] applies [f] on every toplevel subexpression of [t]. + In particular, it never applies [f] to the body of a function (which + will always be contained within an [Set_of_closures] expression). *) +val iter_toplevel + : (Flambda.t -> unit) + -> (Flambda.named -> unit) + -> Flambda.t + -> unit + +val iter_named_toplevel + : (Flambda.t -> unit) + -> (Flambda.named -> unit) + -> Flambda.named + -> unit + +val iter_on_sets_of_closures + : (Flambda.set_of_closures -> unit) + -> Flambda.t + -> unit + +val iter_on_set_of_closures_of_program + : Flambda.program + -> f:(constant:bool -> Flambda.set_of_closures -> unit) + -> unit + +val iter_all_immutable_let_and_let_rec_bindings + : Flambda.t + -> f:(Variable.t -> Flambda.named -> unit) + -> unit + +val iter_all_toplevel_immutable_let_and_let_rec_bindings + : Flambda.t + -> f:(Variable.t -> Flambda.named -> unit) + -> unit + +val iter_exprs_at_toplevel_of_program + : Flambda.program + -> f:(Flambda.t -> unit) + -> unit + +val iter_named_of_program + : Flambda.program + -> f:(Flambda.named -> unit) + -> unit + +val iter_constant_defining_values_on_program + : Flambda.program + -> f:(Flambda.constant_defining_value -> unit) + -> unit + +val iter_apply_on_program + : Flambda.program + -> f:(Flambda.apply -> unit) + -> unit + +val map + : (Flambda.t -> Flambda.t) + -> (Flambda.named -> Flambda.named) + -> Flambda.t + -> Flambda.t + +val map_expr + : (Flambda.t -> Flambda.t) + -> Flambda.t + -> Flambda.t + +val map_named + : (Flambda.named -> Flambda.named) + -> Flambda.t + -> Flambda.t + +val map_toplevel + : (Flambda.t -> Flambda.t) + -> (Flambda.named -> Flambda.named) + -> Flambda.t + -> Flambda.t + +val map_toplevel_expr + : (Flambda.t -> Flambda.t) + -> Flambda.t + -> Flambda.t + +val map_toplevel_named + : (Flambda.named -> Flambda.named) + -> Flambda.t + -> Flambda.t + +val map_symbols + : Flambda.t + -> f:(Symbol.t -> Symbol.t) + -> Flambda.t + +val map_symbols_on_set_of_closures + : Flambda.set_of_closures + -> f:(Symbol.t -> Symbol.t) + -> Flambda.set_of_closures + +val map_toplevel_sets_of_closures + : Flambda.t + -> f:(Flambda.set_of_closures -> Flambda.set_of_closures) + -> Flambda.t + +val map_apply + : Flambda.t + -> f:(Flambda.apply -> Flambda.apply) + -> Flambda.t + +val map_function_bodies + : Flambda.set_of_closures + -> f:(Flambda.t -> Flambda.t) + -> Flambda.set_of_closures + +val map_sets_of_closures + : Flambda.t + -> f:(Flambda.set_of_closures -> Flambda.set_of_closures) + -> Flambda.t + +val map_sets_of_closures_of_program + : Flambda.program + -> f:(Flambda.set_of_closures -> Flambda.set_of_closures) + -> Flambda.program + +val map_project_var_to_expr_opt + : Flambda.t + -> f:(Flambda.project_var -> Flambda.t option) + -> Flambda.t + +val map_project_var_to_named_opt + : Flambda.t + -> f:(Flambda.project_var -> Flambda.named option) + -> Flambda.t + +val map_exprs_at_toplevel_of_program + : Flambda.program + -> f:(Flambda.t -> Flambda.t) + -> Flambda.program + +val map_named_of_program + : Flambda.program + -> f:(Variable.t -> Flambda.named -> Flambda.named) + -> Flambda.program + +val map_all_immutable_let_and_let_rec_bindings + : Flambda.t + -> f:(Variable.t -> Flambda.named -> Flambda.named) + -> Flambda.t + +val fold_function_decls_ignoring_stubs + : Flambda.set_of_closures + -> init:'a + -> f:(fun_var:Variable.t + -> function_decl:Flambda.function_declaration + -> 'a + -> 'a) + -> 'a diff --git a/middle_end/flambda/flambda_middle_end.ml b/middle_end/flambda/flambda_middle_end.ml new file mode 100644 index 0000000000..e604a3285b --- /dev/null +++ b/middle_end/flambda/flambda_middle_end.ml @@ -0,0 +1,200 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +let _dump_function_sizes flam ~backend = + let module Backend = (val backend : Backend_intf.S) in + let than = max_int in + Flambda_iterators.iter_on_set_of_closures_of_program flam + ~f:(fun ~constant:_ (set_of_closures : Flambda.set_of_closures) -> + Variable.Map.iter (fun fun_var + (function_decl : Flambda.function_declaration) -> + let closure_id = Closure_id.wrap fun_var in + let symbol = Backend.closure_symbol closure_id in + match Inlining_cost.lambda_smaller' function_decl.body ~than with + | Some size -> Format.eprintf "%a %d\n" Symbol.print symbol size + | None -> assert false) + set_of_closures.function_decls.funs) + +let middle_end ~ppf_dump ~prefixname ~backend + ~size + ~filename + ~module_ident + ~module_initializer = + Profile.record_call "flambda" (fun () -> + let previous_warning_reporter = !Location.warning_reporter in + let module WarningSet = + Set.Make (struct + type t = Location.t * Warnings.t + let compare = Stdlib.compare + end) + in + let warning_set = ref WarningSet.empty in + let flambda_warning_reporter loc w = + let elt = loc, w in + if not (WarningSet.mem elt !warning_set) then begin + warning_set := WarningSet.add elt !warning_set; + previous_warning_reporter loc w + end else None + in + Misc.protect_refs + [Misc.R (Location.warning_reporter, flambda_warning_reporter)] + (fun () -> + let pass_number = ref 0 in + let round_number = ref 0 in + let check flam = + if !Clflags.flambda_invariant_checks then begin + try Flambda_invariants.check_exn flam + with exn -> + Misc.fatal_errorf "After Flambda pass %d, round %d:@.%s:@.%a" + !pass_number !round_number (Printexc.to_string exn) + Flambda.print_program flam + end + in + let (+-+) flam (name, pass) = + incr pass_number; + if !Clflags.dump_flambda_verbose then begin + Format.fprintf ppf_dump "@.PASS: %s@." name; + Format.fprintf ppf_dump "Before pass %d, round %d:@ %a@." + !pass_number !round_number Flambda.print_program flam; + Format.fprintf ppf_dump "\n@?" + end; + let flam = Profile.record ~accumulate:true name pass flam in + if !Clflags.flambda_invariant_checks then begin + Profile.record ~accumulate:true "check" check flam + end; + flam + in + Profile.record_call ~accumulate:true "middle_end" (fun () -> + let flam = + Profile.record_call ~accumulate:true "closure_conversion" + (fun () -> + module_initializer + |> Closure_conversion.lambda_to_flambda ~backend + ~module_ident ~size ~filename) + in + if !Clflags.dump_rawflambda + then + Format.fprintf ppf_dump "After closure conversion:@ %a@." + Flambda.print_program flam; + check flam; + let fast_mode flam = + pass_number := 0; + let round = 0 in + flam + +-+ ("lift_lets 1", Lift_code.lift_lets) + +-+ ("Lift_constants", Lift_constants.lift_constants ~backend) + +-+ ("Share_constants", Share_constants.share_constants) + +-+ ("Lift_let_to_initialize_symbol", + Lift_let_to_initialize_symbol.lift ~backend) + +-+ ("Inline_and_simplify", + Inline_and_simplify.run ~never_inline:false ~backend + ~prefixname ~round ~ppf_dump) + +-+ ("Remove_unused_closure_vars 2", + Remove_unused_closure_vars.remove_unused_closure_variables + ~remove_direct_call_surrogates:false) + +-+ ("Ref_to_variables", + Ref_to_variables.eliminate_ref) + +-+ ("Initialize_symbol_to_let_symbol", + Initialize_symbol_to_let_symbol.run) + in + let rec loop flam = + pass_number := 0; + let round = !round_number in + incr round_number; + if !round_number > (Clflags.rounds ()) then flam + else + flam + (* Beware: [Lift_constants] must be run before any pass that + might duplicate strings. *) + +-+ ("lift_lets 1", Lift_code.lift_lets) + +-+ ("Lift_constants", Lift_constants.lift_constants ~backend) + +-+ ("Share_constants", Share_constants.share_constants) + +-+ ("Remove_unused_program_constructs", + Remove_unused_program_constructs.remove_unused_program_constructs) + +-+ ("Lift_let_to_initialize_symbol", + Lift_let_to_initialize_symbol.lift ~backend) + +-+ ("lift_lets 2", Lift_code.lift_lets) + +-+ ("Remove_unused_closure_vars 1", + Remove_unused_closure_vars.remove_unused_closure_variables + ~remove_direct_call_surrogates:false) + +-+ ("Inline_and_simplify", + Inline_and_simplify.run ~never_inline:false ~backend + ~prefixname ~round ~ppf_dump) + +-+ ("Remove_unused_closure_vars 2", + Remove_unused_closure_vars.remove_unused_closure_variables + ~remove_direct_call_surrogates:false) + +-+ ("lift_lets 3", Lift_code.lift_lets) + +-+ ("Inline_and_simplify noinline", + Inline_and_simplify.run ~never_inline:true ~backend + ~prefixname ~round ~ppf_dump) + +-+ ("Remove_unused_closure_vars 3", + Remove_unused_closure_vars.remove_unused_closure_variables + ~remove_direct_call_surrogates:false) + +-+ ("Ref_to_variables", + Ref_to_variables.eliminate_ref) + +-+ ("Initialize_symbol_to_let_symbol", + Initialize_symbol_to_let_symbol.run) + |> loop + in + let back_end flam = + flam + +-+ ("Remove_unused_closure_vars", + Remove_unused_closure_vars.remove_unused_closure_variables + ~remove_direct_call_surrogates:true) + +-+ ("Lift_constants", Lift_constants.lift_constants ~backend) + +-+ ("Share_constants", Share_constants.share_constants) + +-+ ("Remove_unused_program_constructs", + Remove_unused_program_constructs.remove_unused_program_constructs) + in + let flam = + if !Clflags.classic_inlining then + fast_mode flam + else + loop flam + in + let flam = back_end flam in + (* Check that there aren't any unused "always inline" attributes. *) + Flambda_iterators.iter_apply_on_program flam ~f:(fun apply -> + match apply.inline with + | Default_inline | Never_inline -> () + | Always_inline -> + (* CR-someday mshinwell: consider a different error message if + this triggers as a result of the propagation of a user's + attribute into the second part of an over application + (inline_and_simplify.ml line 710). *) + Location.prerr_warning (Debuginfo.to_location apply.dbg) + (Warnings.Inlining_impossible + "[@inlined] attribute was not used on this function \ + application (the optimizer did not know what function \ + was being applied)") + | Unroll _ -> + Location.prerr_warning (Debuginfo.to_location apply.dbg) + (Warnings.Inlining_impossible + "[@unroll] attribute was not used on this function \ + application (the optimizer did not know what function \ + was being applied)")); + if !Clflags.dump_flambda + then + Format.fprintf ppf_dump "End of middle end:@ %a@." + Flambda.print_program flam; + check flam; + (* CR-someday mshinwell: add -d... option for this *) + (* dump_function_sizes flam ~backend; *) + flam)) + ) diff --git a/middle_end/flambda/flambda_middle_end.mli b/middle_end/flambda/flambda_middle_end.mli new file mode 100644 index 0000000000..584cb45a98 --- /dev/null +++ b/middle_end/flambda/flambda_middle_end.mli @@ -0,0 +1,29 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(* Translate Lambda code to Flambda code and then optimize it. *) + +val middle_end + : ppf_dump:Format.formatter + -> prefixname:string + -> backend:(module Backend_intf.S) + -> size:int + -> filename:string + -> module_ident:Ident.t + -> module_initializer:Lambda.lambda + -> Flambda.program diff --git a/middle_end/flambda/flambda_to_clambda.ml b/middle_end/flambda/flambda_to_clambda.ml new file mode 100644 index 0000000000..2f60f9fcfc --- /dev/null +++ b/middle_end/flambda/flambda_to_clambda.ml @@ -0,0 +1,749 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +module V = Backend_var +module VP = Backend_var.With_provenance + +type 'a for_one_or_more_units = { + fun_offset_table : int Closure_id.Map.t; + fv_offset_table : int Var_within_closure.Map.t; + constant_closures : Closure_id.Set.t; + closures: Closure_id.Set.t; +} + +type t = { + current_unit : + Set_of_closures_id.t for_one_or_more_units; + imported_units : + Simple_value_approx.function_declarations for_one_or_more_units; +} + +let get_fun_offset t closure_id = + let fun_offset_table = + if Closure_id.in_compilation_unit closure_id (Compilenv.current_unit ()) + then + t.current_unit.fun_offset_table + else + t.imported_units.fun_offset_table + in + try Closure_id.Map.find closure_id fun_offset_table + with Not_found -> + Misc.fatal_errorf "Flambda_to_clambda: missing offset for closure %a" + Closure_id.print closure_id + +let get_fv_offset t var_within_closure = + let fv_offset_table = + if Var_within_closure.in_compilation_unit var_within_closure + (Compilenv.current_unit ()) + then t.current_unit.fv_offset_table + else t.imported_units.fv_offset_table + in + try Var_within_closure.Map.find var_within_closure fv_offset_table + with Not_found -> + Misc.fatal_errorf "Flambda_to_clambda: missing offset for variable %a" + Var_within_closure.print var_within_closure + +let is_function_constant t closure_id = + if Closure_id.Set.mem closure_id t.current_unit.closures then + Closure_id.Set.mem closure_id t.current_unit.constant_closures + else if Closure_id.Set.mem closure_id t.imported_units.closures then + Closure_id.Set.mem closure_id t.imported_units.constant_closures + else + Misc.fatal_errorf "Flambda_to_clambda: missing closure %a" + Closure_id.print closure_id + +(* Instrumentation of closure and field accesses to try to catch compiler + bugs. *) + +let check_closure ulam named : Clambda.ulambda = + if not !Clflags.clambda_checks then ulam + else + let desc = + Primitive.simple ~name:"caml_check_value_is_closure" + ~arity:2 ~alloc:false + in + let str = Format.asprintf "%a" Flambda.print_named named in + let str_const = + Compilenv.new_structured_constant (Uconst_string str) ~shared:true + in + Uprim (Pccall desc, + [ulam; Clambda.Uconst (Uconst_ref (str_const, None))], + Debuginfo.none) + +let check_field ulam pos named_opt : Clambda.ulambda = + if not !Clflags.clambda_checks then ulam + else + let desc = + Primitive.simple ~name:"caml_check_field_access" + ~arity:3 ~alloc:false + in + let str = + match named_opt with + | None -> "" + | Some named -> Format.asprintf "%a" Flambda.print_named named + in + let str_const = + Compilenv.new_structured_constant (Uconst_string str) ~shared:true + in + Uprim (Pccall desc, [ulam; Clambda.Uconst (Uconst_int pos); + Clambda.Uconst (Uconst_ref (str_const, None))], + Debuginfo.none) + +module Env : sig + type t + + val empty : t + + val add_subst : t -> Variable.t -> Clambda.ulambda -> t + val find_subst_exn : t -> Variable.t -> Clambda.ulambda + + val add_fresh_ident : t -> Variable.t -> V.t * t + val ident_for_var_exn : t -> Variable.t -> V.t + + val add_fresh_mutable_ident : t -> Mutable_variable.t -> V.t * t + val ident_for_mutable_var_exn : t -> Mutable_variable.t -> V.t + + val add_allocated_const : t -> Symbol.t -> Allocated_const.t -> t + val allocated_const_for_symbol : t -> Symbol.t -> Allocated_const.t option + + val keep_only_symbols : t -> t +end = struct + type t = + { subst : Clambda.ulambda Variable.Map.t; + var : V.t Variable.Map.t; + mutable_var : V.t Mutable_variable.Map.t; + toplevel : bool; + allocated_constant_for_symbol : Allocated_const.t Symbol.Map.t; + } + + let empty = + { subst = Variable.Map.empty; + var = Variable.Map.empty; + mutable_var = Mutable_variable.Map.empty; + toplevel = false; + allocated_constant_for_symbol = Symbol.Map.empty; + } + + let add_subst t id subst = + { t with subst = Variable.Map.add id subst t.subst } + + let find_subst_exn t id = Variable.Map.find id t.subst + + let ident_for_var_exn t id = Variable.Map.find id t.var + + let add_fresh_ident t var = + let id = V.create_local (Variable.name var) in + id, { t with var = Variable.Map.add var id t.var } + + let ident_for_mutable_var_exn t mut_var = + Mutable_variable.Map.find mut_var t.mutable_var + + let add_fresh_mutable_ident t mut_var = + let id = V.create_local (Mutable_variable.name mut_var) in + let mutable_var = Mutable_variable.Map.add mut_var id t.mutable_var in + id, { t with mutable_var; } + + let add_allocated_const t sym cons = + { t with + allocated_constant_for_symbol = + Symbol.Map.add sym cons t.allocated_constant_for_symbol; + } + + let allocated_const_for_symbol t sym = + try + Some (Symbol.Map.find sym t.allocated_constant_for_symbol) + with Not_found -> None + + let keep_only_symbols t = + { empty with + allocated_constant_for_symbol = t.allocated_constant_for_symbol; + } +end + +let subst_var env var : Clambda.ulambda = + try Env.find_subst_exn env var + with Not_found -> + try Uvar (Env.ident_for_var_exn env var) + with Not_found -> + Misc.fatal_errorf "Flambda_to_clambda: unbound variable %a@." + Variable.print var + +let subst_vars env vars = List.map (subst_var env) vars + +let build_uoffset ulam offset : Clambda.ulambda = + if offset = 0 then ulam + else Uoffset (ulam, offset) + +let to_clambda_allocated_constant (const : Allocated_const.t) + : Clambda.ustructured_constant = + match const with + | Float f -> Uconst_float f + | Int32 i -> Uconst_int32 i + | Int64 i -> Uconst_int64 i + | Nativeint i -> Uconst_nativeint i + | Immutable_string s | String s -> Uconst_string s + | Immutable_float_array a | Float_array a -> Uconst_float_array a + +let to_uconst_symbol env symbol : Clambda.ustructured_constant option = + match Env.allocated_const_for_symbol env symbol with + | Some ((Float _ | Int32 _ | Int64 _ | Nativeint _) as const) -> + Some (to_clambda_allocated_constant const) + | None (* CR-soon mshinwell: Try to make this an error. *) + | Some _ -> None + +let to_clambda_symbol' env sym : Clambda.uconstant = + let lbl = Linkage_name.to_string (Symbol.label sym) in + Uconst_ref (lbl, to_uconst_symbol env sym) + +let to_clambda_symbol env sym : Clambda.ulambda = + Uconst (to_clambda_symbol' env sym) + +let to_clambda_const env (const : Flambda.constant_defining_value_block_field) + : Clambda.uconstant = + match const with + | Symbol symbol -> to_clambda_symbol' env symbol + | Const (Int i) -> Uconst_int i + | Const (Char c) -> Uconst_int (Char.code c) + | Const (Const_pointer i) -> Uconst_ptr i + +let rec to_clambda t env (flam : Flambda.t) : Clambda.ulambda = + match flam with + | Var var -> subst_var env var + | Let { var; defining_expr; body; _ } -> + (* TODO: synthesize proper value_kind *) + let id, env_body = Env.add_fresh_ident env var in + Ulet (Immutable, Pgenval, VP.create id, + to_clambda_named t env var defining_expr, + to_clambda t env_body body) + | Let_mutable { var = mut_var; initial_value = var; body; contents_kind } -> + let id, env_body = Env.add_fresh_mutable_ident env mut_var in + let def = subst_var env var in + Ulet (Mutable, contents_kind, VP.create id, def, to_clambda t env_body body) + | Let_rec (defs, body) -> + let env, defs = + List.fold_right (fun (var, def) (env, defs) -> + let id, env = Env.add_fresh_ident env var in + env, (id, var, def) :: defs) + defs (env, []) + in + let defs = + List.map (fun (id, var, def) -> + VP.create id, to_clambda_named t env var def) + defs + in + Uletrec (defs, to_clambda t env body) + | Apply { func; args; kind = Direct direct_func; dbg = dbg } -> + (* The closure _parameter_ of the function is added by cmmgen. + At the call site, for a direct call, the closure argument must be + explicitly added (by [to_clambda_direct_apply]); there is no special + handling of such in the direct call primitive. + For an indirect call, we do not need to do anything here; Cmmgen will + do the equivalent of the previous paragraph when it generates a direct + call to [caml_apply]. *) + to_clambda_direct_apply t func args direct_func dbg env + | Apply { func; args; kind = Indirect; dbg = dbg } -> + let callee = subst_var env func in + Ugeneric_apply (check_closure callee (Flambda.Expr (Var func)), + subst_vars env args, dbg) + | Switch (arg, sw) -> + let aux () : Clambda.ulambda = + let const_index, const_actions = + to_clambda_switch t env sw.consts sw.numconsts sw.failaction + in + let block_index, block_actions = + to_clambda_switch t env sw.blocks sw.numblocks sw.failaction + in + Uswitch (subst_var env arg, + { us_index_consts = const_index; + us_actions_consts = const_actions; + us_index_blocks = block_index; + us_actions_blocks = block_actions; + }, + Debuginfo.none) (* debug info will be added by GPR#855 *) + in + (* Check that the [failaction] may be duplicated. If this is not the + case, share it through a static raise / static catch. *) + (* CR-someday pchambart for pchambart: This is overly simplified. + We should verify that this does not generates too bad code. + If it the case, handle some let cases. + *) + begin match sw.failaction with + | None -> aux () + | Some (Static_raise _) -> aux () + | Some failaction -> + let exn = Static_exception.create () in + let sw = + { sw with + failaction = Some (Flambda.Static_raise (exn, [])); + } + in + let expr : Flambda.t = + Static_catch (exn, [], Switch (arg, sw), failaction) + in + to_clambda t env expr + end + | String_switch (arg, sw, def) -> + let arg = subst_var env arg in + let sw = List.map (fun (s, e) -> s, to_clambda t env e) sw in + let def = Misc.may_map (to_clambda t env) def in + Ustringswitch (arg, sw, def) + | Static_raise (static_exn, args) -> + Ustaticfail (Static_exception.to_int static_exn, + List.map (subst_var env) args) + | Static_catch (static_exn, vars, body, handler) -> + let env_handler, ids = + List.fold_right (fun var (env, ids) -> + let id, env = Env.add_fresh_ident env var in + env, (VP.create id, Lambda.Pgenval) :: ids) + vars (env, []) + in + Ucatch (Static_exception.to_int static_exn, ids, + to_clambda t env body, to_clambda t env_handler handler) + | Try_with (body, var, handler) -> + let id, env_handler = Env.add_fresh_ident env var in + Utrywith (to_clambda t env body, VP.create id, + to_clambda t env_handler handler) + | If_then_else (arg, ifso, ifnot) -> + Uifthenelse (subst_var env arg, to_clambda t env ifso, + to_clambda t env ifnot) + | While (cond, body) -> + Uwhile (to_clambda t env cond, to_clambda t env body) + | For { bound_var; from_value; to_value; direction; body } -> + let id, env_body = Env.add_fresh_ident env bound_var in + Ufor (VP.create id, subst_var env from_value, subst_var env to_value, + direction, to_clambda t env_body body) + | Assign { being_assigned; new_value } -> + let id = + try Env.ident_for_mutable_var_exn env being_assigned + with Not_found -> + Misc.fatal_errorf "Unbound mutable variable %a in [Assign]: %a" + Mutable_variable.print being_assigned + Flambda.print flam + in + Uassign (id, subst_var env new_value) + | Send { kind; meth; obj; args; dbg } -> + Usend (kind, subst_var env meth, subst_var env obj, + subst_vars env args, dbg) + | Proved_unreachable -> Uunreachable + +and to_clambda_named t env var (named : Flambda.named) : Clambda.ulambda = + match named with + | Symbol sym -> to_clambda_symbol env sym + | Const (Const_pointer n) -> Uconst (Uconst_ptr n) + | Const (Int n) -> Uconst (Uconst_int n) + | Const (Char c) -> Uconst (Uconst_int (Char.code c)) + | Allocated_const _ -> + Misc.fatal_errorf "[Allocated_const] should have been lifted to a \ + [Let_symbol] construction before [Flambda_to_clambda]: %a = %a" + Variable.print var + Flambda.print_named named + | Read_mutable mut_var -> + begin try Uvar (Env.ident_for_mutable_var_exn env mut_var) + with Not_found -> + Misc.fatal_errorf "Unbound mutable variable %a in [Read_mutable]: %a" + Mutable_variable.print mut_var + Flambda.print_named named + end + | Read_symbol_field (symbol, field) -> + Uprim (Pfield field, [to_clambda_symbol env symbol], Debuginfo.none) + | Set_of_closures set_of_closures -> + to_clambda_set_of_closures t env set_of_closures + | Project_closure { set_of_closures; closure_id } -> + (* Note that we must use [build_uoffset] to ensure that we do not generate + a [Uoffset] construction in the event that the offset is zero, otherwise + we might break pattern matches in Cmmgen (in particular for the + compilation of "let rec"). *) + check_closure ( + build_uoffset + (check_closure (subst_var env set_of_closures) + (Flambda.Expr (Var set_of_closures))) + (get_fun_offset t closure_id)) + named + | Move_within_set_of_closures { closure; start_from; move_to } -> + check_closure (build_uoffset + (check_closure (subst_var env closure) + (Flambda.Expr (Var closure))) + ((get_fun_offset t move_to) - (get_fun_offset t start_from))) + named + | Project_var { closure; var; closure_id } -> + let ulam = subst_var env closure in + let fun_offset = get_fun_offset t closure_id in + let var_offset = get_fv_offset t var in + let pos = var_offset - fun_offset in + Uprim (Pfield pos, + [check_field (check_closure ulam (Expr (Var closure))) pos (Some named)], + Debuginfo.none) + | Prim (Pfield index, [block], dbg) -> + Uprim (Pfield index, [check_field (subst_var env block) index None], dbg) + | Prim (Psetfield (index, maybe_ptr, init), [block; new_value], dbg) -> + Uprim (Psetfield (index, maybe_ptr, init), [ + check_field (subst_var env block) index None; + subst_var env new_value; + ], dbg) + | Prim (Popaque, args, dbg) -> + Uprim (Popaque, subst_vars env args, dbg) + | Prim (p, args, dbg) -> + Uprim (p, subst_vars env args, dbg) + | Expr expr -> to_clambda t env expr + +and to_clambda_switch t env cases num_keys default = + let num_keys = + if Numbers.Int.Set.cardinal num_keys = 0 then 0 + else Numbers.Int.Set.max_elt num_keys + 1 + in + let store = Flambda_utils.Switch_storer.mk_store () in + let default_action = + match default with + | Some def when List.length cases < num_keys -> + store.act_store () def + | _ -> -1 + in + let index = Array.make num_keys default_action in + let smallest_key = ref num_keys in + List.iter + (fun (key, lam) -> + index.(key) <- store.act_store () lam; + smallest_key := min key !smallest_key + ) + cases; + if !smallest_key < num_keys then begin + let action = ref index.(!smallest_key) in + Array.iteri + (fun i act -> + if act >= 0 then action := act else index.(i) <- !action) + index + end; + let actions = Array.map (to_clambda t env) (store.act_get ()) in + match actions with + | [| |] -> [| |], [| |] (* May happen when [default] is [None]. *) + | _ -> index, actions + +and to_clambda_direct_apply t func args direct_func dbg env : Clambda.ulambda = + let closed = is_function_constant t direct_func in + let label = Compilenv.function_label direct_func in + let uargs = + let uargs = subst_vars env args in + (* Remove the closure argument if the closure is closed. (Note that the + closure argument is always a variable, so we can be sure we are not + dropping any side effects.) *) + if closed then uargs else uargs @ [subst_var env func] + in + Udirect_apply (label, uargs, dbg) + +(* Describe how to build a runtime closure block that corresponds to the + given Flambda set of closures. + + For instance the closure for the following set of closures: + + let rec fun_a x = + if x <= 0 then 0 else fun_b (x-1) v1 + and fun_b x y = + if x <= 0 then 0 else v1 + v2 + y + fun_a (x-1) + + will be represented in memory as: + + [ closure header; fun_a; + 1; infix header; fun caml_curry_2; + 2; fun_b; v1; v2 ] + + fun_a and fun_b will take an additional parameter 'env' to + access their closure. It will be arranged such that in the body + of each function the env parameter points to its own code + pointer. For example, in fun_b it will be shifted by 3 words. + + Hence accessing v1 in the body of fun_a is accessing the + 6th field of 'env' and in the body of fun_b the 1st field. +*) +and to_clambda_set_of_closures t env + (({ function_decls; free_vars } : Flambda.set_of_closures) + as set_of_closures) : Clambda.ulambda = + let all_functions = Variable.Map.bindings function_decls.funs in + let env_var = V.create_local "env" in + let to_clambda_function + (closure_id, (function_decl : Flambda.function_declaration)) + : Clambda.ufunction = + let closure_id = Closure_id.wrap closure_id in + let fun_offset = + Closure_id.Map.find closure_id t.current_unit.fun_offset_table + in + let env = + (* Inside the body of the function, we cannot access variables + declared outside, so start with a suitably clean environment. + Note that we must not forget the information about which allocated + constants contain which unboxed values. *) + let env = Env.keep_only_symbols env in + (* Add the Clambda expressions for the free variables of the function + to the environment. *) + let add_env_free_variable id _ env = + let var_offset = + try + Var_within_closure.Map.find + (Var_within_closure.wrap id) t.current_unit.fv_offset_table + with Not_found -> + Misc.fatal_errorf "Clambda.to_clambda_set_of_closures: offset for \ + free variable %a is unknown. Set of closures: %a" + Variable.print id + Flambda.print_set_of_closures set_of_closures + in + let pos = var_offset - fun_offset in + Env.add_subst env id + (Uprim (Pfield pos, [Clambda.Uvar env_var], Debuginfo.none)) + in + let env = Variable.Map.fold add_env_free_variable free_vars env in + (* Add the Clambda expressions for all functions defined in the current + set of closures to the environment. The various functions may be + retrieved by moving within the runtime closure, starting from the + current function's closure. *) + let add_env_function pos env (id, _) = + let offset = + Closure_id.Map.find (Closure_id.wrap id) + t.current_unit.fun_offset_table + in + let exp : Clambda.ulambda = Uoffset (Uvar env_var, offset - pos) in + Env.add_subst env id exp + in + List.fold_left (add_env_function fun_offset) env all_functions + in + let env_body, params = + List.fold_right (fun var (env, params) -> + let id, env = Env.add_fresh_ident env (Parameter.var var) in + env, id :: params) + function_decl.params (env, []) + in + { label = Compilenv.function_label closure_id; + arity = Flambda_utils.function_arity function_decl; + params = + List.map + (fun var -> VP.create var, Lambda.Pgenval) + (params @ [env_var]); + return = Lambda.Pgenval; + body = to_clambda t env_body function_decl.body; + dbg = function_decl.dbg; + env = Some env_var; + } + in + let funs = List.map to_clambda_function all_functions in + let free_vars = + Variable.Map.bindings (Variable.Map.map ( + fun (free_var : Flambda.specialised_to) -> + subst_var env free_var.var) free_vars) + in + Uclosure (funs, List.map snd free_vars) + +and to_clambda_closed_set_of_closures t env symbol + ({ function_decls; } : Flambda.set_of_closures) + : Clambda.ustructured_constant = + let functions = Variable.Map.bindings function_decls.funs in + let to_clambda_function (id, (function_decl : Flambda.function_declaration)) + : Clambda.ufunction = + (* All that we need in the environment, for translating one closure from + a closed set of closures, is the substitutions for variables bound to + the various closures in the set. Such closures will always be + referenced via symbols. *) + let env = + List.fold_left (fun env (var, _) -> + let closure_id = Closure_id.wrap var in + let symbol = Compilenv.closure_symbol closure_id in + Env.add_subst env var (to_clambda_symbol env symbol)) + (Env.keep_only_symbols env) + functions + in + let env_body, params = + List.fold_right (fun var (env, params) -> + let id, env = Env.add_fresh_ident env (Parameter.var var) in + env, id :: params) + function_decl.params (env, []) + in + { label = Compilenv.function_label (Closure_id.wrap id); + arity = Flambda_utils.function_arity function_decl; + params = List.map (fun var -> VP.create var, Lambda.Pgenval) params; + return = Lambda.Pgenval; + body = to_clambda t env_body function_decl.body; + dbg = function_decl.dbg; + env = None; + } + in + let ufunct = List.map to_clambda_function functions in + let closure_lbl = Linkage_name.to_string (Symbol.label symbol) in + Uconst_closure (ufunct, closure_lbl, []) + +let to_clambda_initialize_symbol t env symbol fields : Clambda.ulambda = + let fields = + List.map (fun (index, expr) -> index, to_clambda t env expr) fields + in + let build_setfield (index, field) : Clambda.ulambda = + (* Note that this will never cause a write barrier hit, owing to + the [Initialization]. *) + Uprim (Psetfield (index, Pointer, Root_initialization), + [to_clambda_symbol env symbol; field], + Debuginfo.none) + in + match fields with + | [] -> Uconst (Uconst_ptr 0) + | h :: t -> + List.fold_left (fun acc (p, field) -> + Clambda.Usequence (build_setfield (p, field), acc)) + (build_setfield h) t + +let accumulate_structured_constants t env symbol + (c : Flambda.constant_defining_value) acc = + match c with + | Allocated_const c -> + Symbol.Map.add symbol (to_clambda_allocated_constant c) acc + | Block (tag, fields) -> + let fields = List.map (to_clambda_const env) fields in + Symbol.Map.add symbol (Clambda.Uconst_block (Tag.to_int tag, fields)) acc + | Set_of_closures set_of_closures -> + let to_clambda_set_of_closures = + to_clambda_closed_set_of_closures t env symbol set_of_closures + in + Symbol.Map.add symbol to_clambda_set_of_closures acc + | Project_closure _ -> acc + +let to_clambda_program t env constants (program : Flambda.program) = + let rec loop env constants (program : Flambda.program_body) + : Clambda.ulambda * + Clambda.ustructured_constant Symbol.Map.t * + Clambda.preallocated_block list = + match program with + | Let_symbol (symbol, alloc, program) -> + (* Useful only for unboxing. Since floats and boxed integers will + never be part of a Let_rec_symbol, handling only the Let_symbol + is sufficient. *) + let env = + match alloc with + | Allocated_const const -> Env.add_allocated_const env symbol const + | _ -> env + in + let constants = + accumulate_structured_constants t env symbol alloc constants + in + loop env constants program + | Let_rec_symbol (defs, program) -> + let constants = + List.fold_left (fun constants (symbol, alloc) -> + accumulate_structured_constants t env symbol alloc constants) + constants defs + in + loop env constants program + | Initialize_symbol (symbol, tag, fields, program) -> + let fields = + List.mapi (fun i field -> + i, field, + Initialize_symbol_to_let_symbol.constant_field field) + fields + in + let init_fields = + List.filter_map (function + | (i, field, None) -> Some (i, field) + | (_, _, Some _) -> None) + fields + in + let constant_fields = + List.map (fun (_, _, constant_field) -> + match constant_field with + | None -> None + | Some (Flambda.Const const) -> + let n = + match const with + | Int i -> i + | Char c -> Char.code c + | Const_pointer i -> i + in + Some (Clambda.Uconst_field_int n) + | Some (Flambda.Symbol sym) -> + let lbl = Linkage_name.to_string (Symbol.label sym) in + Some (Clambda.Uconst_field_ref lbl)) + fields + in + let e1 = to_clambda_initialize_symbol t env symbol init_fields in + let preallocated_block : Clambda.preallocated_block = + { symbol = Linkage_name.to_string (Symbol.label symbol); + exported = true; + tag = Tag.to_int tag; + fields = constant_fields; + provenance = None; + } + in + let e2, constants, preallocated_blocks = loop env constants program in + Usequence (e1, e2), constants, preallocated_block :: preallocated_blocks + | Effect (expr, program) -> + let e1 = to_clambda t env expr in + let e2, constants, preallocated_blocks = loop env constants program in + Usequence (e1, e2), constants, preallocated_blocks + | End _ -> + Uconst (Uconst_ptr 0), constants, [] + in + loop env constants program.program_body + +type result = { + expr : Clambda.ulambda; + preallocated_blocks : Clambda.preallocated_block list; + structured_constants : Clambda.ustructured_constant Symbol.Map.t; + exported : Export_info.t; +} + +let convert (program, exported_transient) : result = + let current_unit = + let closures = + Closure_id.Map.keys (Flambda_utils.make_closure_map program) + in + let constant_closures = + Flambda_utils.all_lifted_constant_closures program + in + let offsets = Closure_offsets.compute program in + { fun_offset_table = offsets.function_offsets; + fv_offset_table = offsets.free_variable_offsets; + constant_closures; + closures; + } + in + let imported_units = + let imported = Compilenv.approx_env () in + let closures = + Set_of_closures_id.Map.fold + (fun (_ : Set_of_closures_id.t) fun_decls acc -> + Variable.Map.fold + (fun var (_ : Simple_value_approx.function_declaration) acc -> + let closure_id = Closure_id.wrap var in + Closure_id.Set.add closure_id acc) + fun_decls.Simple_value_approx.funs + acc) + imported.sets_of_closures + Closure_id.Set.empty + in + { fun_offset_table = imported.offset_fun; + fv_offset_table = imported.offset_fv; + constant_closures = imported.constant_closures; + closures; + } + in + let t = { current_unit; imported_units; } in + let expr, structured_constants, preallocated_blocks = + to_clambda_program t Env.empty Symbol.Map.empty program + in + let exported = + Export_info.t_of_transient exported_transient + ~program + ~local_offset_fun:current_unit.fun_offset_table + ~local_offset_fv:current_unit.fv_offset_table + ~imported_offset_fun:imported_units.fun_offset_table + ~imported_offset_fv:imported_units.fv_offset_table + ~constant_closures:current_unit.constant_closures + in + { expr; preallocated_blocks; structured_constants; exported; } diff --git a/middle_end/flambda/flambda_to_clambda.mli b/middle_end/flambda/flambda_to_clambda.mli new file mode 100644 index 0000000000..8c493d40d6 --- /dev/null +++ b/middle_end/flambda/flambda_to_clambda.mli @@ -0,0 +1,38 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +type result = { + expr : Clambda.ulambda; + preallocated_blocks : Clambda.preallocated_block list; + structured_constants : Clambda.ustructured_constant Symbol.Map.t; + exported : Export_info.t; +} + +(** Convert an Flambda program, with associated proto-export information, + to Clambda. + This yields a Clambda expression together with augmented export + information and details about required statically-allocated values + (preallocated blocks, for [Initialize_symbol], and structured + constants). + + It is during this process that accesses to variables within + closures are transformed to field accesses within closure values. + For direct calls, the hidden closure parameter is added. Switch + tables are also built. +*) +val convert : Flambda.program * Export_info.transient -> result diff --git a/middle_end/flambda/flambda_utils.ml b/middle_end/flambda/flambda_utils.ml new file mode 100644 index 0000000000..c204f5e67c --- /dev/null +++ b/middle_end/flambda/flambda_utils.ml @@ -0,0 +1,929 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +let name_expr ~name (named : Flambda.named) : Flambda.t = + let var = + Variable.create + ~current_compilation_unit:(Compilation_unit.get_current_exn ()) + name + in + Flambda.create_let var named (Var var) + +let name_expr_from_var ~var (named : Flambda.named) : Flambda.t = + let var = + Variable.rename + ~current_compilation_unit:(Compilation_unit.get_current_exn ()) + var + in + Flambda.create_let var named (Var var) + +let find_declaration cf ({ funs } : Flambda.function_declarations) = + Variable.Map.find (Closure_id.unwrap cf) funs + +let find_declaration_variable cf ({ funs } : Flambda.function_declarations) = + let var = Closure_id.unwrap cf in + if not (Variable.Map.mem var funs) + then raise Not_found + else var + +let find_free_variable cv ({ free_vars } : Flambda.set_of_closures) = + let var : Flambda.specialised_to = + Variable.Map.find (Var_within_closure.unwrap cv) free_vars + in + var.var + +let function_arity (f : Flambda.function_declaration) = List.length f.params + +let variables_bound_by_the_closure cf + (decls : Flambda.function_declarations) = + let func = find_declaration cf decls in + let params = Parameter.Set.vars func.params in + let functions = Variable.Map.keys decls.funs in + Variable.Set.diff + (Variable.Set.diff func.free_variables params) + functions + +let description_of_toplevel_node (expr : Flambda.t) = + match expr with + | Var id -> Format.asprintf "var %a" Variable.print id + | Apply _ -> "apply" + | Assign _ -> "assign" + | Send _ -> "send" + | Proved_unreachable -> "unreachable" + | Let { var; _ } -> Format.asprintf "let %a" Variable.print var + | Let_mutable _ -> "let_mutable" + | Let_rec _ -> "letrec" + | If_then_else _ -> "if" + | Switch _ -> "switch" + | String_switch _ -> "stringswitch" + | Static_raise _ -> "staticraise" + | Static_catch _ -> "catch" + | Try_with _ -> "trywith" + | While _ -> "while" + | For _ -> "for" + +let equal_direction_flag + (x : Asttypes.direction_flag) + (y : Asttypes.direction_flag) = + match x, y with + | Upto, Upto -> true + | Downto, Downto -> true + | (Upto | Downto), _ -> false + +let rec same (l1 : Flambda.t) (l2 : Flambda.t) = + l1 == l2 || (* it is ok for the string case: if they are physically the same, + it is the same original branch *) + match (l1, l2) with + | Var v1 , Var v2 -> Variable.equal v1 v2 + | Var _, _ | _, Var _ -> false + | Apply a1 , Apply a2 -> + Flambda.equal_call_kind a1.kind a2.kind + && Variable.equal a1.func a2.func + && Misc.Stdlib.List.equal Variable.equal a1.args a2.args + | Apply _, _ | _, Apply _ -> false + | Let { var = var1; defining_expr = defining_expr1; body = body1; _ }, + Let { var = var2; defining_expr = defining_expr2; body = body2; _ } -> + Variable.equal var1 var2 && same_named defining_expr1 defining_expr2 + && same body1 body2 + | Let _, _ | _, Let _ -> false + | Let_mutable {var = mv1; initial_value = v1; contents_kind = ck1; body = b1}, + Let_mutable {var = mv2; initial_value = v2; contents_kind = ck2; body = b2} + -> + Mutable_variable.equal mv1 mv2 + && Variable.equal v1 v2 + && Lambda.equal_value_kind ck1 ck2 + && same b1 b2 + | Let_mutable _, _ | _, Let_mutable _ -> false + | Let_rec (bl1, a1), Let_rec (bl2, a2) -> + Misc.Stdlib.List.equal samebinding bl1 bl2 && same a1 a2 + | Let_rec _, _ | _, Let_rec _ -> false + | Switch (a1, s1), Switch (a2, s2) -> + Variable.equal a1 a2 && sameswitch s1 s2 + | Switch _, _ | _, Switch _ -> false + | String_switch (a1, s1, d1), String_switch (a2, s2, d2) -> + Variable.equal a1 a2 + && Misc.Stdlib.List.equal + (fun (s1, e1) (s2, e2) -> String.equal s1 s2 && same e1 e2) s1 s2 + && Option.equal same d1 d2 + | String_switch _, _ | _, String_switch _ -> false + | Static_raise (e1, a1), Static_raise (e2, a2) -> + Static_exception.equal e1 e2 && Misc.Stdlib.List.equal Variable.equal a1 a2 + | Static_raise _, _ | _, Static_raise _ -> false + | Static_catch (s1, v1, a1, b1), Static_catch (s2, v2, a2, b2) -> + Static_exception.equal s1 s2 + && Misc.Stdlib.List.equal Variable.equal v1 v2 + && same a1 a2 + && same b1 b2 + | Static_catch _, _ | _, Static_catch _ -> false + | Try_with (a1, v1, b1), Try_with (a2, v2, b2) -> + same a1 a2 && Variable.equal v1 v2 && same b1 b2 + | Try_with _, _ | _, Try_with _ -> false + | If_then_else (a1, b1, c1), If_then_else (a2, b2, c2) -> + Variable.equal a1 a2 && same b1 b2 && same c1 c2 + | If_then_else _, _ | _, If_then_else _ -> false + | While (a1, b1), While (a2, b2) -> + same a1 a2 && same b1 b2 + | While _, _ | _, While _ -> false + | For { bound_var = bound_var1; from_value = from_value1; + to_value = to_value1; direction = direction1; body = body1; }, + For { bound_var = bound_var2; from_value = from_value2; + to_value = to_value2; direction = direction2; body = body2; } -> + Variable.equal bound_var1 bound_var2 + && Variable.equal from_value1 from_value2 + && Variable.equal to_value1 to_value2 + && equal_direction_flag direction1 direction2 + && same body1 body2 + | For _, _ | _, For _ -> false + | Assign { being_assigned = being_assigned1; new_value = new_value1; }, + Assign { being_assigned = being_assigned2; new_value = new_value2; } -> + Mutable_variable.equal being_assigned1 being_assigned2 + && Variable.equal new_value1 new_value2 + | Assign _, _ | _, Assign _ -> false + | Send { kind = kind1; meth = meth1; obj = obj1; args = args1; dbg = _; }, + Send { kind = kind2; meth = meth2; obj = obj2; args = args2; dbg = _; } -> + Lambda.equal_meth_kind kind1 kind2 + && Variable.equal meth1 meth2 + && Variable.equal obj1 obj2 + && Misc.Stdlib.List.equal Variable.equal args1 args2 + | Send _, _ | _, Send _ -> false + | Proved_unreachable, Proved_unreachable -> true + +and same_named (named1 : Flambda.named) (named2 : Flambda.named) = + match named1, named2 with + | Symbol s1 , Symbol s2 -> Symbol.equal s1 s2 + | Symbol _, _ | _, Symbol _ -> false + | Const c1, Const c2 -> Flambda.compare_const c1 c2 = 0 + | Const _, _ | _, Const _ -> false + | Allocated_const c1, Allocated_const c2 -> + Allocated_const.compare c1 c2 = 0 + | Allocated_const _, _ | _, Allocated_const _ -> false + | Read_mutable mv1, Read_mutable mv2 -> Mutable_variable.equal mv1 mv2 + | Read_mutable _, _ | _, Read_mutable _ -> false + | Read_symbol_field (s1, i1), Read_symbol_field (s2, i2) -> + Symbol.equal s1 s2 && i1 = i2 + | Read_symbol_field _, _ | _, Read_symbol_field _ -> false + | Set_of_closures s1, Set_of_closures s2 -> same_set_of_closures s1 s2 + | Set_of_closures _, _ | _, Set_of_closures _ -> false + | Project_closure f1, Project_closure f2 -> same_project_closure f1 f2 + | Project_closure _, _ | _, Project_closure _ -> false + | Project_var v1, Project_var v2 -> + Variable.equal v1.closure v2.closure + && Closure_id.equal v1.closure_id v2.closure_id + && Var_within_closure.equal v1.var v2.var + | Project_var _, _ | _, Project_var _ -> false + | Move_within_set_of_closures m1, Move_within_set_of_closures m2 -> + same_move_within_set_of_closures m1 m2 + | Move_within_set_of_closures _, _ | _, Move_within_set_of_closures _ -> + false + | Prim (p1, al1, _), Prim (p2, al2, _) -> + Clambda_primitives.equal p1 p2 + && Misc.Stdlib.List.equal Variable.equal al1 al2 + | Prim _, _ | _, Prim _ -> false + | Expr e1, Expr e2 -> same e1 e2 + +and sameclosure (c1 : Flambda.function_declaration) + (c2 : Flambda.function_declaration) = + Misc.Stdlib.List.equal Parameter.equal c1.params c2.params + && same c1.body c2.body + +and same_set_of_closures (c1 : Flambda.set_of_closures) + (c2 : Flambda.set_of_closures) = + Variable.Map.equal sameclosure c1.function_decls.funs c2.function_decls.funs + && Variable.Map.equal Flambda.equal_specialised_to + c1.free_vars c2.free_vars + && Variable.Map.equal Flambda.equal_specialised_to c1.specialised_args + c2.specialised_args + +and same_project_closure (s1 : Flambda.project_closure) + (s2 : Flambda.project_closure) = + Variable.equal s1.set_of_closures s2.set_of_closures + && Closure_id.equal s1.closure_id s2.closure_id + +and same_move_within_set_of_closures (m1 : Flambda.move_within_set_of_closures) + (m2 : Flambda.move_within_set_of_closures) = + Variable.equal m1.closure m2.closure + && Closure_id.equal m1.start_from m2.start_from + && Closure_id.equal m1.move_to m2.move_to + +and samebinding (v1, n1) (v2, n2) = + Variable.equal v1 v2 && same_named n1 n2 + +and sameswitch (fs1 : Flambda.switch) (fs2 : Flambda.switch) = + let samecase (n1, a1) (n2, a2) = n1 = n2 && same a1 a2 in + Numbers.Int.Set.equal fs1.numconsts fs2.numconsts + && Numbers.Int.Set.equal fs1.numblocks fs2.numblocks + && Misc.Stdlib.List.equal samecase fs1.consts fs2.consts + && Misc.Stdlib.List.equal samecase fs1.blocks fs2.blocks + && Option.equal same fs1.failaction fs2.failaction + +let can_be_merged = same + +(* CR-soon mshinwell: this should use the explicit ignore functions *) +let toplevel_substitution sb tree = + let sb' = sb in + let sb v = try Variable.Map.find v sb with Not_found -> v in + let aux (flam : Flambda.t) : Flambda.t = + match flam with + | Var var -> + let var = sb var in + Var var + | Let_mutable mutable_let -> + let initial_value = sb mutable_let.initial_value in + Let_mutable { mutable_let with initial_value } + | Assign { being_assigned; new_value; } -> + let new_value = sb new_value in + Assign { being_assigned; new_value; } + | Apply { func; args; kind; dbg; inline; specialise; } -> + let func = sb func in + let args = List.map sb args in + Apply { func; args; kind; dbg; inline; specialise; } + | If_then_else (cond, e1, e2) -> + let cond = sb cond in + If_then_else (cond, e1, e2) + | Switch (cond, sw) -> + let cond = sb cond in + Switch (cond, sw) + | String_switch (cond, branches, def) -> + let cond = sb cond in + String_switch (cond, branches, def) + | Send { kind; meth; obj; args; dbg } -> + let meth = sb meth in + let obj = sb obj in + let args = List.map sb args in + Send { kind; meth; obj; args; dbg } + | For { bound_var; from_value; to_value; direction; body } -> + let from_value = sb from_value in + let to_value = sb to_value in + For { bound_var; from_value; to_value; direction; body } + | Static_raise (static_exn, args) -> + let args = List.map sb args in + Static_raise (static_exn, args) + | Static_catch _ | Try_with _ | While _ + | Let _ | Let_rec _ | Proved_unreachable -> flam + in + let aux_named (named : Flambda.named) : Flambda.named = + match named with + | Symbol _ | Const _ | Expr _ -> named + | Allocated_const _ | Read_mutable _ -> named + | Read_symbol_field _ -> named + | Set_of_closures set_of_closures -> + let set_of_closures = + Flambda.create_set_of_closures + ~function_decls:set_of_closures.function_decls + ~free_vars: + (Variable.Map.map (fun (spec_to : Flambda.specialised_to) -> + { spec_to with var = sb spec_to.var; }) + set_of_closures.free_vars) + ~specialised_args: + (Variable.Map.map (fun (spec_to : Flambda.specialised_to) -> + { spec_to with var = sb spec_to.var; }) + set_of_closures.specialised_args) + ~direct_call_surrogates:set_of_closures.direct_call_surrogates + in + Set_of_closures set_of_closures + | Project_closure project_closure -> + Project_closure { + project_closure with + set_of_closures = sb project_closure.set_of_closures; + } + | Move_within_set_of_closures move_within_set_of_closures -> + Move_within_set_of_closures { + move_within_set_of_closures with + closure = sb move_within_set_of_closures.closure; + } + | Project_var project_var -> + Project_var { + project_var with + closure = sb project_var.closure; + } + | Prim (prim, args, dbg) -> + Prim (prim, List.map sb args, dbg) + in + if Variable.Map.is_empty sb' then tree + else Flambda_iterators.map_toplevel aux aux_named tree + +(* CR-someday mshinwell: Fix [Flambda_iterators] so this can be implemented + properly. *) +let toplevel_substitution_named sb named = + let name = Internal_variable_names.toplevel_substitution_named in + let expr = name_expr named ~name in + match toplevel_substitution sb expr with + | Let let_expr -> let_expr.defining_expr + | _ -> assert false + +let make_closure_declaration + ~is_classic_mode ~id ~body ~params ~stub : Flambda.t = + let free_variables = Flambda.free_variables body in + let param_set = Parameter.Set.vars params in + if not (Variable.Set.subset param_set free_variables) then begin + Misc.fatal_error "Flambda_utils.make_closure_declaration" + end; + let sb = + Variable.Set.fold + (fun id sb -> Variable.Map.add id (Variable.rename id) sb) + free_variables Variable.Map.empty + in + (* CR-soon mshinwell: try to eliminate this [toplevel_substitution]. This + function is only called from [Inline_and_simplify], so we should be able + to do something similar to what happens in [Inlining_transforms] now. *) + let body = toplevel_substitution sb body in + let subst id = Variable.Map.find id sb in + let subst_param param = Parameter.map_var subst param in + let function_declaration = + Flambda.create_function_declaration ~params:(List.map subst_param params) + ~body ~stub ~dbg:Debuginfo.none ~inline:Default_inline + ~specialise:Default_specialise ~is_a_functor:false + ~closure_origin:(Closure_origin.create (Closure_id.wrap id)) + in + assert (Variable.Set.equal (Variable.Set.map subst free_variables) + function_declaration.free_variables); + let free_vars = + Variable.Map.fold (fun id id' fv' -> + let spec_to : Flambda.specialised_to = + { var = id; + projection = None; + } + in + Variable.Map.add id' spec_to fv') + (Variable.Map.filter + (fun id _ -> not (Variable.Set.mem id param_set)) + sb) + Variable.Map.empty + in + let compilation_unit = Compilation_unit.get_current_exn () in + let set_of_closures_var = + Variable.create Internal_variable_names.set_of_closures + ~current_compilation_unit:compilation_unit + in + let set_of_closures = + let function_decls = + Flambda.create_function_declarations + ~is_classic_mode + ~funs:(Variable.Map.singleton id function_declaration) + in + Flambda.create_set_of_closures ~function_decls ~free_vars + ~specialised_args:Variable.Map.empty + ~direct_call_surrogates:Variable.Map.empty + in + let project_closure : Flambda.named = + Project_closure { + set_of_closures = set_of_closures_var; + closure_id = Closure_id.wrap id; + } + in + let project_closure_var = + Variable.create Internal_variable_names.project_closure + ~current_compilation_unit:compilation_unit + in + Flambda.create_let set_of_closures_var (Set_of_closures set_of_closures) + (Flambda.create_let project_closure_var project_closure + (Var (project_closure_var))) + +let bind ~bindings ~body = + List.fold_left (fun expr (var, var_def) -> + Flambda.create_let var var_def expr) + body bindings + +let all_lifted_constants (program : Flambda.program) = + let rec loop (program : Flambda.program_body) = + match program with + | Let_symbol (symbol, decl, program) -> (symbol, decl) :: (loop program) + | Let_rec_symbol (decls, program) -> + List.fold_left (fun l (symbol, decl) -> (symbol, decl) :: l) + (loop program) + decls + | Initialize_symbol (_, _, _, program) + | Effect (_, program) -> loop program + | End _ -> [] + in + loop program.program_body + +let all_lifted_constants_as_map program = + Symbol.Map.of_list (all_lifted_constants program) + +let initialize_symbols (program : Flambda.program) = + let rec loop (program : Flambda.program_body) = + match program with + | Initialize_symbol (symbol, tag, fields, program) -> + (symbol, tag, fields) :: (loop program) + | Effect (_, program) + | Let_symbol (_, _, program) + | Let_rec_symbol (_, program) -> loop program + | End _ -> [] + in + loop program.program_body + +let imported_symbols (program : Flambda.program) = + program.imported_symbols + +let needed_import_symbols (program : Flambda.program) = + let dependencies = Flambda.free_symbols_program program in + let defined_symbol = + Symbol.Set.union + (Symbol.Set.of_list + (List.map fst (all_lifted_constants program))) + (Symbol.Set.of_list + (List.map (fun (s, _, _) -> s) (initialize_symbols program))) + in + Symbol.Set.diff dependencies defined_symbol + +let introduce_needed_import_symbols program : Flambda.program = + { program with + imported_symbols = needed_import_symbols program; + } + +let root_symbol (program : Flambda.program) = + let rec loop (program : Flambda.program_body) = + match program with + | Effect (_, program) + | Let_symbol (_, _, program) + | Let_rec_symbol (_, program) + | Initialize_symbol (_, _, _, program) -> loop program + | End root -> + root + in + loop program.program_body + +let might_raise_static_exn flam stexn = + try + Flambda_iterators.iter_on_named + (function + | Flambda.Static_raise (ex, _) when Static_exception.equal ex stexn -> + raise Exit + | _ -> ()) + (fun _ -> ()) + flam; + false + with Exit -> true + +let make_closure_map program = + let map = ref Closure_id.Map.empty in + let add_set_of_closures ~constant:_ : Flambda.set_of_closures -> unit = fun + { function_decls } -> + Variable.Map.iter (fun var _ -> + let closure_id = Closure_id.wrap var in + let set_of_closures_id = function_decls.set_of_closures_id in + map := Closure_id.Map.add closure_id set_of_closures_id !map) + function_decls.funs + in + Flambda_iterators.iter_on_set_of_closures_of_program + program + ~f:add_set_of_closures; + !map + +let all_lifted_constant_closures program = + List.fold_left (fun unchanged flambda -> + match flambda with + | (_, Flambda.Set_of_closures { function_decls = { funs } }) -> + Variable.Map.fold + (fun key (_ : Flambda.function_declaration) acc -> + Closure_id.Set.add (Closure_id.wrap key) acc) + funs + unchanged + | _ -> unchanged) + Closure_id.Set.empty + (all_lifted_constants program) + +let all_lifted_constant_sets_of_closures program = + let set = ref Set_of_closures_id.Set.empty in + List.iter (function + | (_, Flambda.Set_of_closures { + function_decls = { set_of_closures_id } }) -> + set := Set_of_closures_id.Set.add set_of_closures_id !set + | _ -> ()) + (all_lifted_constants program); + !set + +let all_sets_of_closures program = + let list = ref [] in + Flambda_iterators.iter_on_set_of_closures_of_program program + ~f:(fun ~constant:_ set_of_closures -> + list := set_of_closures :: !list); + !list + +let all_sets_of_closures_map program = + let r = ref Set_of_closures_id.Map.empty in + Flambda_iterators.iter_on_set_of_closures_of_program program + ~f:(fun ~constant:_ set_of_closures -> + r := Set_of_closures_id.Map.add + set_of_closures.function_decls.set_of_closures_id + set_of_closures !r); + !r + +let substitute_read_symbol_field_for_variables + (substitution : (Symbol.t * int list) Variable.Map.t) + (expr : Flambda.t) = + let bind var fresh_var (expr:Flambda.t) : Flambda.t = + let symbol, path = Variable.Map.find var substitution in + let rec make_named (path:int list) : Flambda.named = + match path with + | [] -> Symbol symbol + | [i] -> Read_symbol_field (symbol, i) + | h :: t -> + let block_name = Internal_variable_names.symbol_field_block in + let block = Variable.create block_name in + let field_name = Internal_variable_names.get_symbol_field in + let field = Variable.create field_name in + Expr ( + Flambda.create_let block (make_named t) + (Flambda.create_let field + (Prim (Pfield h, [block], Debuginfo.none)) + (Var field))) + in + Flambda.create_let fresh_var (make_named path) expr + in + let substitute_named bindings (named:Flambda.named) : Flambda.named = + let sb to_substitute = + try Variable.Map.find to_substitute bindings with + | Not_found -> + to_substitute + in + match named with + | Symbol _ | Const _ | Expr _ -> named + | Allocated_const _ | Read_mutable _ -> named + | Read_symbol_field _ -> named + | Set_of_closures set_of_closures -> + let set_of_closures = + Flambda.create_set_of_closures + ~function_decls:set_of_closures.function_decls + ~free_vars: + (Variable.Map.map (fun (spec_to : Flambda.specialised_to) -> + { spec_to with var = sb spec_to.var; }) + set_of_closures.free_vars) + ~specialised_args: + (Variable.Map.map (fun (spec_to : Flambda.specialised_to) -> + { spec_to with var = sb spec_to.var; }) + set_of_closures.specialised_args) + ~direct_call_surrogates:set_of_closures.direct_call_surrogates + in + Set_of_closures set_of_closures + | Project_closure project_closure -> + Project_closure { + project_closure with + set_of_closures = sb project_closure.set_of_closures; + } + | Move_within_set_of_closures move_within_set_of_closures -> + Move_within_set_of_closures { + move_within_set_of_closures with + closure = sb move_within_set_of_closures.closure; + } + | Project_var project_var -> + Project_var { + project_var with + closure = sb project_var.closure; + } + | Prim (prim, args, dbg) -> + Prim (prim, List.map sb args, dbg) + in + let make_var_subst var = + if Variable.Map.mem var substitution then + let fresh = Variable.rename var in + fresh, (fun expr -> bind var fresh expr) + else + var, (fun x -> x) + in + let f (expr:Flambda.t) : Flambda.t = + match expr with + | Var v when Variable.Map.mem v substitution -> + let fresh = Variable.rename v in + bind v fresh (Var fresh) + | Var _ -> expr + | Let ({ var = v; defining_expr = named; _ } as let_expr) -> + let to_substitute = + Variable.Set.filter + (fun v -> Variable.Map.mem v substitution) + (Flambda.free_variables_named named) + in + if Variable.Set.is_empty to_substitute then + expr + else + let bindings = + Variable.Map.of_set (fun var -> Variable.rename var) to_substitute + in + let named = + substitute_named bindings named + in + let expr = + let module W = Flambda.With_free_variables in + W.create_let_reusing_body v named (W.of_body_of_let let_expr) + in + Variable.Map.fold (fun to_substitute fresh expr -> + bind to_substitute fresh expr) + bindings expr + | Let_mutable let_mutable when + Variable.Map.mem let_mutable.initial_value substitution -> + let fresh = Variable.rename let_mutable.initial_value in + bind let_mutable.initial_value fresh + (Let_mutable { let_mutable with initial_value = fresh }) + | Let_mutable _ -> + expr + | Let_rec (defs, body) -> + let free_variables_of_defs = + List.fold_left (fun set (_, named) -> + Variable.Set.union set (Flambda.free_variables_named named)) + Variable.Set.empty defs + in + let to_substitute = + Variable.Set.filter + (fun v -> Variable.Map.mem v substitution) + free_variables_of_defs + in + if Variable.Set.is_empty to_substitute then + expr + else begin + let bindings = + Variable.Map.of_set (fun var -> Variable.rename var) to_substitute + in + let defs = + List.map (fun (var, named) -> + var, substitute_named bindings named) + defs + in + let expr = + Flambda.Let_rec (defs, body) + in + Variable.Map.fold (fun to_substitute fresh expr -> + bind to_substitute fresh expr) + bindings expr + end + | If_then_else (cond, ifso, ifnot) + when Variable.Map.mem cond substitution -> + let fresh = Variable.rename cond in + bind cond fresh (If_then_else (fresh, ifso, ifnot)) + | If_then_else _ -> + expr + | Switch (cond, sw) when Variable.Map.mem cond substitution -> + let fresh = Variable.rename cond in + bind cond fresh (Switch (fresh, sw)) + | Switch _ -> + expr + | String_switch (cond, sw, def) when Variable.Map.mem cond substitution -> + let fresh = Variable.rename cond in + bind cond fresh (String_switch (fresh, sw, def)) + | String_switch _ -> + expr + | Assign { being_assigned; new_value } + when Variable.Map.mem new_value substitution -> + let fresh = Variable.rename new_value in + bind new_value fresh (Assign { being_assigned; new_value = fresh }) + | Assign _ -> + expr + | Static_raise (exn, args) -> + let args, bind_args = + List.split (List.map make_var_subst args) + in + List.fold_right (fun f expr -> f expr) bind_args @@ + Flambda.Static_raise (exn, args) + | For { bound_var; from_value; to_value; direction; body } -> + let from_value, bind_from_value = make_var_subst from_value in + let to_value, bind_to_value = make_var_subst to_value in + bind_from_value @@ + bind_to_value @@ + Flambda.For { bound_var; from_value; to_value; direction; body } + | Apply { func; args; kind; dbg; inline; specialise } -> + let func, bind_func = make_var_subst func in + let args, bind_args = + List.split (List.map make_var_subst args) + in + bind_func @@ + List.fold_right (fun f expr -> f expr) bind_args @@ + Flambda.Apply { func; args; kind; dbg; inline; specialise } + | Send { kind; meth; obj; args; dbg } -> + let meth, bind_meth = make_var_subst meth in + let obj, bind_obj = make_var_subst obj in + let args, bind_args = + List.split (List.map make_var_subst args) + in + bind_meth @@ + bind_obj @@ + List.fold_right (fun f expr -> f expr) bind_args @@ + Flambda.Send { kind; meth; obj; args; dbg } + | Proved_unreachable + | While _ + | Try_with _ + | Static_catch _ -> + (* No variables directly used in those expressions *) + expr + in + Flambda_iterators.map_toplevel f (fun v -> v) expr + +module Switch_storer = Switch.Store (struct + type t = Flambda.t + + (* An easily-comparable subset of [Flambda.t]: currently this only + supports that required to share switch branches. *) + type key = + | Var of Variable.t + | Let of Variable.t * key_named * key + | Static_raise of Static_exception.t * Variable.t list + and key_named = + | Symbol of Symbol.t + | Const of Flambda.const + | Prim of Clambda_primitives.primitive * Variable.t list + | Expr of key + + exception Not_comparable + + let rec make_expr_key (expr : Flambda.t) : key = + match expr with + | Var v -> Var v + | Let { var; defining_expr; body; } -> + Let (var, make_named_key defining_expr, make_expr_key body) + | Static_raise (e, args) -> Static_raise (e, args) + | _ -> raise Not_comparable + and make_named_key (named:Flambda.named) : key_named = + match named with + | Symbol s -> Symbol s + | Const c -> Const c + | Expr e -> Expr (make_expr_key e) + | Prim (prim, args, _dbg) -> Prim (prim, args) + | _ -> raise Not_comparable + + let make_key expr = + match make_expr_key expr with + | exception Not_comparable -> None + | key -> Some key + + let compare_key e1 e2 = + (* The environment [env] maps variables bound in [e2] to the corresponding + bound variables in [e1]. Every variable to compare in [e2] must have an + equivalent in [e1], otherwise the comparison wouldn't have gone + past the [Let] binding. Hence [Variable.Map.find] is safe here. *) + let compare_var env v1 v2 = + match Variable.Map.find v2 env with + | exception Not_found -> + (* The variable is free in the expression [e2], hence we can + compare it with [v1] directly. *) + Variable.compare v1 v2 + | bound -> + Variable.compare v1 bound + in + let rec compare_expr env (e1 : key) (e2 : key) : int = + match e1, e2 with + | Var v1, Var v2 -> + compare_var env v1 v2 + | Var _, (Let _| Static_raise _) -> -1 + | (Let _| Static_raise _), Var _ -> 1 + | Let (v1, n1, b1), Let (v2, n2, b2) -> + let comp_named = compare_named env n1 n2 in + if comp_named <> 0 then comp_named + else + let env = Variable.Map.add v2 v1 env in + compare_expr env b1 b2 + | Let _, Static_raise _ -> -1 + | Static_raise _, Let _ -> 1 + | Static_raise (sexn1, args1), Static_raise (sexn2, args2) -> + let comp_sexn = Static_exception.compare sexn1 sexn2 in + if comp_sexn <> 0 then comp_sexn + else Misc.Stdlib.List.compare (compare_var env) args1 args2 + and compare_named env (n1:key_named) (n2:key_named) : int = + match n1, n2 with + | Symbol s1, Symbol s2 -> Symbol.compare s1 s2 + | Symbol _, (Const _ | Expr _ | Prim _) -> -1 + | (Const _ | Expr _ | Prim _), Symbol _ -> 1 + | Const c1, Const c2 -> Flambda.compare_const c1 c2 + | Const _, (Expr _ | Prim _) -> -1 + | (Expr _ | Prim _), Const _ -> 1 + | Expr e1, Expr e2 -> compare_expr env e1 e2 + | Expr _, Prim _ -> -1 + | Prim _, Expr _ -> 1 + | Prim (prim1, args1), Prim (prim2, args2) -> + let comp_prim = Stdlib.compare prim1 prim2 in + if comp_prim <> 0 then comp_prim + else Misc.Stdlib.List.compare (compare_var env) args1 args2 + in + compare_expr Variable.Map.empty e1 e2 +end) + +let fun_vars_referenced_in_decls + (function_decls : Flambda.function_declarations) ~closure_symbol = + let fun_vars = Variable.Map.keys function_decls.funs in + let symbols_to_fun_vars = + Variable.Set.fold (fun fun_var symbols_to_fun_vars -> + let closure_id = Closure_id.wrap fun_var in + let symbol = closure_symbol closure_id in + Symbol.Map.add symbol fun_var symbols_to_fun_vars) + fun_vars + Symbol.Map.empty + in + Variable.Map.map (fun (func_decl : Flambda.function_declaration) -> + let from_symbols = + Symbol.Set.fold (fun symbol fun_vars' -> + match Symbol.Map.find symbol symbols_to_fun_vars with + | exception Not_found -> fun_vars' + | fun_var -> + assert (Variable.Set.mem fun_var fun_vars); + Variable.Set.add fun_var fun_vars') + func_decl.free_symbols + Variable.Set.empty + in + let from_variables = + Variable.Set.inter func_decl.free_variables fun_vars + in + Variable.Set.union from_symbols from_variables) + function_decls.funs + +let closures_required_by_entry_point ~(entry_point : Closure_id.t) + ~closure_symbol (function_decls : Flambda.function_declarations) = + let dependencies = + fun_vars_referenced_in_decls function_decls ~closure_symbol + in + let set = ref Variable.Set.empty in + let queue = Queue.create () in + let add v = + if not (Variable.Set.mem v !set) then begin + set := Variable.Set.add v !set; + Queue.push v queue + end + in + add (Closure_id.unwrap entry_point); + while not (Queue.is_empty queue) do + let fun_var = Queue.pop queue in + match Variable.Map.find fun_var dependencies with + | exception Not_found -> () + | fun_dependencies -> + Variable.Set.iter (fun dep -> + if Variable.Map.mem dep function_decls.funs then + add dep) + fun_dependencies + done; + !set + +let all_functions_parameters (function_decls : Flambda.function_declarations) = + Variable.Map.fold (fun _ ({ params } : Flambda.function_declaration) set -> + Variable.Set.union set (Parameter.Set.vars params)) + function_decls.funs Variable.Set.empty + +let all_free_symbols (function_decls : Flambda.function_declarations) = + Variable.Map.fold (fun _ (function_decl : Flambda.function_declaration) + syms -> + Symbol.Set.union syms function_decl.free_symbols) + function_decls.funs Symbol.Set.empty + +let contains_stub (fun_decls : Flambda.function_declarations) = + let number_of_stub_functions = + Variable.Map.cardinal + (Variable.Map.filter (fun _ { Flambda.stub } -> stub) + fun_decls.funs) + in + number_of_stub_functions > 0 + +let clean_projections ~which_variables = + Variable.Map.map (fun (spec_to : Flambda.specialised_to) -> + match spec_to.projection with + | None -> spec_to + | Some projection -> + let from = Projection.projecting_from projection in + if Variable.Map.mem from which_variables then + spec_to + else + ({ spec_to with projection = None; } : Flambda.specialised_to)) + which_variables + +let projection_to_named (projection : Projection.t) : Flambda.named = + match projection with + | Project_var project_var -> Project_var project_var + | Project_closure project_closure -> Project_closure project_closure + | Move_within_set_of_closures move -> Move_within_set_of_closures move + | Field (field_index, var) -> + Prim (Pfield field_index, [var], Debuginfo.none) + +type specialised_to_same_as = + | Not_specialised + | Specialised_and_aliased_to of Variable.Set.t + +let parameters_specialised_to_the_same_variable + ~(function_decls : Flambda.function_declarations) + ~(specialised_args : Flambda.specialised_to Variable.Map.t) = + let specialised_arg_aliasing = + (* For each external variable involved in a specialisation, which + internal variable(s) it maps to via that specialisation. *) + Variable.Map.transpose_keys_and_data_set + (Variable.Map.map (fun ({ var; _ } : Flambda.specialised_to) -> var) + specialised_args) + in + Variable.Map.map (fun ({ params; _ } : Flambda.function_declaration) -> + List.map (fun param -> + match Variable.Map.find (Parameter.var param) specialised_args with + | exception Not_found -> Not_specialised + | { var; _ } -> + Specialised_and_aliased_to + (Variable.Map.find var specialised_arg_aliasing)) + params) + function_decls.funs diff --git a/middle_end/flambda/flambda_utils.mli b/middle_end/flambda/flambda_utils.mli new file mode 100644 index 0000000000..0f7b318627 --- /dev/null +++ b/middle_end/flambda/flambda_utils.mli @@ -0,0 +1,220 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(** Utility functions for the Flambda intermediate language. *) + +(** Access functions *) + +(** [find_declaration f decl] raises [Not_found] if [f] is not in [decl]. *) +val find_declaration : + Closure_id.t -> Flambda.function_declarations -> Flambda.function_declaration + +(** [find_declaration_variable f decl] raises [Not_found] if [f] is not in + [decl]. *) +val find_declaration_variable : + Closure_id.t -> Flambda.function_declarations -> Variable.t + +(** [find_free_variable v clos] raises [Not_found] if [c] is not in [clos]. *) +val find_free_variable : + Var_within_closure.t -> Flambda.set_of_closures -> Variable.t + +(** Utility functions *) + +val function_arity : Flambda.function_declaration -> int + +(** Variables "bound by a closure" are those variables free in the + corresponding function's body that are neither: + - bound as parameters of that function; nor + - bound by the [let] binding that introduces the function declaration(s). + In particular, if [f], [g] and [h] are being introduced by a + simultaneous, possibly mutually-recursive [let] binding then none of + [f], [g] or [h] are bound in any of the closures for [f], [g] and [h]. +*) +val variables_bound_by_the_closure : + Closure_id.t -> Flambda.function_declarations -> Variable.Set.t + +(** If [can_be_merged f1 f2] is [true], it is safe to merge switch + branches containing [f1] and [f2]. *) +val can_be_merged : Flambda.t -> Flambda.t -> bool + +val description_of_toplevel_node : Flambda.t -> string + +(* Given an expression, freshen all variables within it, and form a function + whose body is the resulting expression. The variables specified by + [params] will become the parameters of the function; the closure will be + identified by [id]. [params] must only reference variables that are + free variables of [body]. *) +(* CR-soon mshinwell: consider improving name and names of arguments + lwhite: the params restriction seems odd, perhaps give a reason + in the comment. *) +val make_closure_declaration + : is_classic_mode:bool + -> id:Variable.t + -> body:Flambda.t + -> params:Parameter.t list + -> stub:bool + -> Flambda.t + +val toplevel_substitution + : Variable.t Variable.Map.t + -> Flambda.expr + -> Flambda.expr + +val toplevel_substitution_named + : Variable.t Variable.Map.t + -> Flambda.named + -> Flambda.named + +(** [bind [var1, expr1; ...; varN, exprN] body] binds using + [Immutable] [Let] expressions the given [(var, expr)] pairs around the + body. *) +val bind + : bindings:(Variable.t * Flambda.named) list + -> body:Flambda.t + -> Flambda.t + +val name_expr + : name:Internal_variable_names.t + -> Flambda.named + -> Flambda.t + +val name_expr_from_var + : var:Variable.t + -> Flambda.named + -> Flambda.t + +val initialize_symbols + : Flambda.program + -> (Symbol.t * Tag.t * Flambda.t list) list + +val imported_symbols : Flambda.program -> Symbol.Set.t + +val needed_import_symbols : Flambda.program -> Symbol.Set.t + +val introduce_needed_import_symbols : Flambda.program -> Flambda.program + +val root_symbol : Flambda.program -> Symbol.t + +(** Returns [true] iff the given term might raise the given static + exception. *) +val might_raise_static_exn : Flambda.named -> Static_exception.t -> bool + +(** Creates a map from closure IDs to set_of_closure IDs by iterating over + all sets of closures in the given program. *) +val make_closure_map + : Flambda.program + -> Set_of_closures_id.t Closure_id.Map.t + +(** The definitions of all constants that have been lifted out to [Let_symbol] + or [Let_rec_symbol] constructions. *) +val all_lifted_constants + : Flambda.program + -> (Symbol.t * Flambda.constant_defining_value) list + +(** Like [all_lifted_constant_symbols], but returns a map instead of a list. *) +val all_lifted_constants_as_map + : Flambda.program + -> Flambda.constant_defining_value Symbol.Map.t + +(** The identifiers of all constant sets of closures that have been lifted out + to [Let_symbol] or [Let_rec_symbol] constructions. *) +val all_lifted_constant_sets_of_closures + : Flambda.program + -> Set_of_closures_id.Set.t + +val all_lifted_constant_closures : Flambda.program -> Closure_id.Set.t + +(** All sets of closures in the given program (whether or not bound to a + symbol.) *) +val all_sets_of_closures : Flambda.program -> Flambda.set_of_closures list + +val all_sets_of_closures_map + : Flambda.program + -> Flambda.set_of_closures Set_of_closures_id.Map.t + + +(* CR-someday pchambart: A more general version of this function might + take a [named] instead of a symbol and be called with + [Read_symbol_field (symbol, 0)]. *) +val substitute_read_symbol_field_for_variables + : (Symbol.t * int list) Variable.Map.t + -> Flambda.t + -> Flambda.t + +(** For the compilation of switch statements. *) +module Switch_storer : sig + val mk_store : unit -> (Flambda.t, unit) Switch.t_store +end + +(** Within a set of function declarations there is a set of function bodies, + each of which may (or may not) reference one of the other functions in + the same set. Initially such intra-set references are by [Var]s (known + as "fun_var"s) but if the function is lifted by [Lift_constants] then the + references will be translated to [Symbol]s. This means that optimization + passes that need to identify whether a given "fun_var" (i.e. a key in the + [funs] map in a value of type [function_declarations]) is used in one of + the function bodies need to examine the [free_symbols] as well as the + [free_variables] members of [function_declarations]. This function makes + that process easier by computing all used "fun_var"s in the bodies of + the given set of function declarations, including the cases where the + references are [Symbol]s. The returned value is a map from "fun_var"s + to the "fun_var"s (if any) used in the body of the function associated + with that "fun_var". +*) +val fun_vars_referenced_in_decls + : Flambda.function_declarations + -> closure_symbol:(Closure_id.t -> Symbol.t) + -> Variable.Set.t Variable.Map.t + +(** Computes the set of closure_id in the set of closures that are + required used (transitively) the entry_point *) +val closures_required_by_entry_point + : entry_point:Closure_id.t + -> closure_symbol:(Closure_id.t -> Symbol.t) + -> Flambda.function_declarations + -> Variable.Set.t + +val all_functions_parameters : Flambda.function_declarations -> Variable.Set.t + +val all_free_symbols : Flambda.function_declarations -> Symbol.Set.t + +val contains_stub : Flambda.function_declarations -> bool + +(* Ensure that projection information is suitably erased from + free_vars and specialised_args if we have deleted the variable being + projected from. *) +val clean_projections + : which_variables : Flambda.specialised_to Variable.Map.t + -> Flambda.specialised_to Variable.Map.t + +val projection_to_named : Projection.t -> Flambda.named + +type specialised_to_same_as = + | Not_specialised + | Specialised_and_aliased_to of Variable.Set.t + +(** For each parameter in a given set of function declarations and the usual + specialised-args mapping, determine which other parameters are specialised + to the same variable as that parameter. + The result is presented as a map from [fun_vars] to lists, corresponding + componentwise to the usual [params] list in the corresponding function + declaration. *) +val parameters_specialised_to_the_same_variable + : function_decls:Flambda.function_declarations + -> specialised_args:Flambda.specialised_to Variable.Map.t + -> specialised_to_same_as list Variable.Map.t diff --git a/middle_end/flambda/freshening.ml b/middle_end/flambda/freshening.ml new file mode 100644 index 0000000000..891861a33e --- /dev/null +++ b/middle_end/flambda/freshening.ml @@ -0,0 +1,458 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +type tbl = { + sb_var : Variable.t Variable.Map.t; + sb_mutable_var : Mutable_variable.t Mutable_variable.Map.t; + sb_exn : Static_exception.t Static_exception.Map.t; + (* Used to handle substitution sequences: we cannot call the substitution + recursively because there can be name clashes. *) + back_var : Variable.t list Variable.Map.t; + back_mutable_var : Mutable_variable.t list Mutable_variable.Map.t; +} + +type t = + | Inactive + | Active of tbl + +type subst = t + +let empty_tbl = { + sb_var = Variable.Map.empty; + sb_mutable_var = Mutable_variable.Map.empty; + sb_exn = Static_exception.Map.empty; + back_var = Variable.Map.empty; + back_mutable_var = Mutable_variable.Map.empty; +} + +let print ppf = function + | Inactive -> Format.fprintf ppf "Inactive" + | Active tbl -> + Format.fprintf ppf "Active:@ "; + Variable.Map.iter (fun var1 var2 -> + Format.fprintf ppf "%a -> %a@ " + Variable.print var1 + Variable.print var2) + tbl.sb_var; + Mutable_variable.Map.iter (fun mut_var1 mut_var2 -> + Format.fprintf ppf "(mutable) %a -> %a@ " + Mutable_variable.print mut_var1 + Mutable_variable.print mut_var2) + tbl.sb_mutable_var; + Variable.Map.iter (fun var vars -> + Format.fprintf ppf "%a -> %a@ " + Variable.print var + Variable.Set.print (Variable.Set.of_list vars)) + tbl.back_var; + Mutable_variable.Map.iter (fun mut_var mut_vars -> + Format.fprintf ppf "(mutable) %a -> %a@ " + Mutable_variable.print mut_var + Mutable_variable.Set.print (Mutable_variable.Set.of_list mut_vars)) + tbl.back_mutable_var + +let empty = Inactive + +let is_empty = function + | Inactive -> true + | Active _ -> false + +let empty_preserving_activation_state = function + | Inactive -> Inactive + | Active _ -> Active empty_tbl + +let activate = function + | Inactive -> Active empty_tbl + | Active _ as t -> t + +let rec add_sb_var sb id id' = + let sb = { sb with sb_var = Variable.Map.add id id' sb.sb_var } in + let sb = + try let pre_vars = Variable.Map.find id sb.back_var in + List.fold_left (fun sb pre_id -> add_sb_var sb pre_id id') sb pre_vars + with Not_found -> sb in + let back_var = + let l = try Variable.Map.find id' sb.back_var with Not_found -> [] in + Variable.Map.add id' (id :: l) sb.back_var in + { sb with back_var } + +let rec add_sb_mutable_var sb id id' = + let sb = + { sb with + sb_mutable_var = Mutable_variable.Map.add id id' sb.sb_mutable_var; + } + in + let sb = + try + let pre_vars = Mutable_variable.Map.find id sb.back_mutable_var in + List.fold_left (fun sb pre_id -> add_sb_mutable_var sb pre_id id') + sb pre_vars + with Not_found -> sb in + let back_mutable_var = + let l = + try Mutable_variable.Map.find id' sb.back_mutable_var + with Not_found -> [] + in + Mutable_variable.Map.add id' (id :: l) sb.back_mutable_var + in + { sb with back_mutable_var } + +let apply_static_exception t i = + match t with + | Inactive -> + i + | Active t -> + try Static_exception.Map.find i t.sb_exn + with Not_found -> i + +let add_static_exception t i = + match t with + | Inactive -> i, t + | Active t -> + let i' = Static_exception.create () in + let sb_exn = + Static_exception.Map.add i i' t.sb_exn + in + i', Active { t with sb_exn; } + +let active_add_variable t id = + let id' = Variable.rename id in + let t = add_sb_var t id id' in + id', t + +let active_add_parameter t param = + let param' = Parameter.rename param in + let t = add_sb_var t (Parameter.var param) (Parameter.var param') in + param', t + +let add_variable t id = + match t with + | Inactive -> id, t + | Active t -> + let id', t = active_add_variable t id in + id', Active t + +let active_add_parameters' t (params:Parameter.t list) = + List.fold_right (fun param (params, t) -> + let param', t = active_add_parameter t param in + param' :: params, t) + params ([], t) + +let add_variables t defs = + List.fold_right (fun (id, data) (defs, t) -> + let id', t = add_variable t id in + (id', data) :: defs, t) defs ([], t) + +let add_variables' t ids = + List.fold_right (fun id (ids, t) -> + let id', t = add_variable t id in + id' :: ids, t) ids ([], t) + +let active_add_mutable_variable t id = + let id' = Mutable_variable.rename id in + let t = add_sb_mutable_var t id id' in + id', t + +let add_mutable_variable t id = + match t with + | Inactive -> id, t + | Active t -> + let id', t = active_add_mutable_variable t id in + id', Active t + +let active_find_var_exn t id = + try Variable.Map.find id t.sb_var with + | Not_found -> + Misc.fatal_error (Format.asprintf "find_var: can't find %a@." + Variable.print id) + +let apply_variable t var = + match t with + | Inactive -> var + | Active t -> + try Variable.Map.find var t.sb_var with + | Not_found -> var + +let apply_mutable_variable t mut_var = + match t with + | Inactive -> mut_var + | Active t -> + try Mutable_variable.Map.find mut_var t.sb_mutable_var with + | Not_found -> mut_var + +let rewrite_recursive_calls_with_symbols t + (function_declarations : Flambda.function_declarations) + ~make_closure_symbol = + match t with + | Inactive -> function_declarations + | Active _ -> + let all_free_symbols = + Variable.Map.fold + (fun _ (function_decl : Flambda.function_declaration) + syms -> + Symbol.Set.union syms function_decl.free_symbols) + function_declarations.funs Symbol.Set.empty + in + let closure_symbols_used = ref false in + let closure_symbols = + Variable.Map.fold (fun var _ map -> + let closure_id = Closure_id.wrap var in + let sym = make_closure_symbol closure_id in + if Symbol.Set.mem sym all_free_symbols then begin + closure_symbols_used := true; + Symbol.Map.add sym var map + end else begin + map + end) + function_declarations.funs Symbol.Map.empty + in + if not !closure_symbols_used then begin + (* Don't waste time rewriting the function declaration(s) if there + are no occurrences of any of the closure symbols. *) + function_declarations + end else begin + let funs = + Variable.Map.map (fun (ffun : Flambda.function_declaration) -> + let body = + Flambda_iterators.map_toplevel_named + (* CR-someday pchambart: This may be worth deep substituting + below the closures, but that means that we need to take care + of functions' free variables. *) + (function + | Symbol sym when Symbol.Map.mem sym closure_symbols -> + Expr (Var (Symbol.Map.find sym closure_symbols)) + | e -> e) + ffun.body + in + Flambda.update_body_of_function_declaration ffun ~body) + function_declarations.funs + in + Flambda.update_function_declarations function_declarations ~funs + end + +module Project_var = struct + type t = + { vars_within_closure : Var_within_closure.t Var_within_closure.Map.t; + closure_id : Closure_id.t Closure_id.Map.t } + + let empty = + { vars_within_closure = Var_within_closure.Map.empty; + closure_id = Closure_id.Map.empty; + } + + let print ppf t = + Format.fprintf ppf "{ vars_within_closure %a, closure_id %a }" + (Var_within_closure.Map.print Var_within_closure.print) + t.vars_within_closure + (Closure_id.Map.print Closure_id.print) + t.closure_id + + let new_subst_fv t id subst = + match subst with + | Inactive -> id, subst, t + | Active subst -> + let id' = Variable.rename id in + let subst = add_sb_var subst id id' in + let off = Var_within_closure.wrap id in + let off' = Var_within_closure.wrap id' in + let off_sb = Var_within_closure.Map.add off off' t.vars_within_closure in + id', Active subst, { t with vars_within_closure = off_sb; } + + let new_subst_fun t id subst = + let id' = Variable.rename id in + let subst = add_sb_var subst id id' in + let off = Closure_id.wrap id in + let off' = Closure_id.wrap id' in + let off_sb = Closure_id.Map.add off off' t.closure_id in + id', subst, { t with closure_id = off_sb; } + + (** Returns : + * The map of new_identifiers -> expression + * The new environment with added substitution + * a fresh ffunction_subst with only the substitution of free variables + *) + let subst_free_vars fv subst ~only_freshen_parameters + : (Flambda.specialised_to * _) Variable.Map.t * _ * _ = + Variable.Map.fold (fun id lam (fv, subst, t) -> + let id, subst, t = + if only_freshen_parameters then + id, subst, t + else + new_subst_fv t id subst + in + Variable.Map.add id lam fv, subst, t) + fv + (Variable.Map.empty, subst, empty) + + (** Returns : + * The function_declaration with renamed function identifiers + * The new environment with added substitution + * The ffunction_subst completed with function substitution + + subst_free_vars must have been used to build off_sb + *) + let func_decls_subst t (subst : subst) + (func_decls : Flambda.function_declarations) + ~only_freshen_parameters = + match subst with + | Inactive -> func_decls, subst, t + | Active subst -> + let subst_func_decl _fun_id (func_decl : Flambda.function_declaration) + subst = + let params, subst = active_add_parameters' subst func_decl.params in + (* Since all parameters are distinct, even between functions, we can + just use a single substitution. *) + let body = + Flambda_utils.toplevel_substitution subst.sb_var func_decl.body + in + let function_decl = + Flambda.create_function_declaration ~params ~body + ~stub:func_decl.stub ~dbg:func_decl.dbg + ~inline:func_decl.inline ~specialise:func_decl.specialise + ~is_a_functor:func_decl.is_a_functor + ~closure_origin:func_decl.closure_origin + in + function_decl, subst + in + let subst, t = + if only_freshen_parameters then + subst, t + else + Variable.Map.fold (fun orig_id _func_decl (subst, t) -> + let _id, subst, t = new_subst_fun t orig_id subst in + subst, t) + func_decls.funs + (subst, t) + in + let funs, subst = + Variable.Map.fold (fun orig_id func_decl (funs, subst) -> + let func_decl, subst = subst_func_decl orig_id func_decl subst in + let id = + if only_freshen_parameters then orig_id + else active_find_var_exn subst orig_id + in + let funs = Variable.Map.add id func_decl funs in + funs, subst) + func_decls.funs + (Variable.Map.empty, subst) + in + let function_decls = + Flambda.update_function_declarations func_decls ~funs + in + function_decls, Active subst, t + + let apply_closure_id t closure_id = + try Closure_id.Map.find closure_id t.closure_id + with Not_found -> closure_id + + let apply_var_within_closure t var_in_closure = + try Var_within_closure.Map.find var_in_closure t.vars_within_closure + with Not_found -> var_in_closure + + module Compose (T : Identifiable.S) = struct + let compose ~earlier ~later = + if (T.Map.equal T.equal) earlier later + || T.Map.cardinal later = 0 + then + earlier + else + T.Map.mapi (fun src_var var -> + if T.Map.mem src_var later then begin + Misc.fatal_errorf "Freshening.Project_var.compose: domains \ + of substitutions must be disjoint. earlier=%a later=%a" + (T.Map.print T.print) earlier + (T.Map.print T.print) later + end; + match T.Map.find var later with + | exception Not_found -> var + | var -> var) + earlier + end + + module V = Compose (Var_within_closure) + module C = Compose (Closure_id) + + let compose ~earlier ~later : t = + { vars_within_closure = + V.compose ~earlier:earlier.vars_within_closure + ~later:later.vars_within_closure; + closure_id = + C.compose ~earlier:earlier.closure_id + ~later:later.closure_id; + } +end + +let apply_function_decls_and_free_vars t fv func_decls + ~only_freshen_parameters = + let module I = Project_var in + let fv, t, of_closures = I.subst_free_vars fv t ~only_freshen_parameters in + let func_decls, t, of_closures = + I.func_decls_subst of_closures t func_decls ~only_freshen_parameters + in + fv, func_decls, t, of_closures + +let does_not_freshen t vars = + match t with + | Inactive -> true + | Active subst -> + not (List.exists (fun var -> Variable.Map.mem var subst.sb_var) vars) + +let freshen_projection (projection : Projection.t) ~freshening + ~closure_freshening : Projection.t = + match projection with + | Project_var { closure; closure_id; var; } -> + Project_var { + closure = apply_variable freshening closure; + closure_id = Project_var.apply_closure_id closure_freshening closure_id; + var = Project_var.apply_var_within_closure closure_freshening var; + } + | Project_closure { set_of_closures; closure_id; } -> + Project_closure { + set_of_closures = apply_variable freshening set_of_closures; + closure_id = Project_var.apply_closure_id closure_freshening closure_id; + } + | Move_within_set_of_closures { closure; start_from; move_to; } -> + Move_within_set_of_closures { + closure = apply_variable freshening closure; + start_from = Project_var.apply_closure_id closure_freshening start_from; + move_to = Project_var.apply_closure_id closure_freshening move_to; + } + | Field (field_index, var) -> + Field (field_index, apply_variable freshening var) + +let freshen_projection_relation relation ~freshening ~closure_freshening = + Variable.Map.map (fun (spec_to : Flambda.specialised_to) -> + let projection = + match spec_to.projection with + | None -> None + | Some projection -> + Some (freshen_projection projection ~freshening ~closure_freshening) + in + { spec_to with projection; }) + relation + +let freshen_projection_relation' relation ~freshening ~closure_freshening = + Variable.Map.map (fun ((spec_to : Flambda.specialised_to), data) -> + let projection = + match spec_to.projection with + | None -> None + | Some projection -> + Some (freshen_projection projection ~freshening ~closure_freshening) + in + { spec_to with projection; }, data) + relation diff --git a/middle_end/flambda/freshening.mli b/middle_end/flambda/freshening.mli new file mode 100644 index 0000000000..1550797ac1 --- /dev/null +++ b/middle_end/flambda/freshening.mli @@ -0,0 +1,167 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(** Freshening of various identifiers. *) + +(** A table used for freshening variables and static exception identifiers. *) +type t +type subst = t + +(** The freshening that does nothing. This is the unique inactive + freshening. *) +val empty : t + +val is_empty : t -> bool + +(** Activate the freshening. Without activation, operations to request + freshenings have no effect (cf. the documentation below for + [add_variable]). As such, the inactive renaming is unique. *) +val activate : t -> t + +(** Given the inactive freshening, return the same; otherwise, return an + empty active freshening. *) +val empty_preserving_activation_state : t -> t + +(** [add_variable t var] + If [t] is active: + It returns a fresh variable [new_var] and adds [var] -> [new_var] + to the freshening. + If a renaming [other_var] -> [var] or [symbol] -> [var] was already + present in [t], it will also add [other_var] -> [new_var] and + [symbol] -> [new_var]. + If [t] is inactive, this is the identity. +*) +val add_variable : t -> Variable.t -> Variable.t * t + +(** Like [add_variable], but for multiple variables, each freshened + separately. *) +val add_variables' + : t + -> Variable.t list + -> Variable.t list * t + +(** Like [add_variables'], but passes through the second component of the + input list unchanged. *) +val add_variables + : t + -> (Variable.t * 'a) list + -> (Variable.t * 'a) list * t + +(** Like [add_variable], but for mutable variables. *) +val add_mutable_variable : t -> Mutable_variable.t -> Mutable_variable.t * t + +(** As for [add_variable], but for static exception identifiers. *) +val add_static_exception : t -> Static_exception.t -> Static_exception.t * t + +(** [apply_variable t var] applies the freshening [t] to [var]. + If no renaming is specified in [t] for [var] it is returned unchanged. *) +val apply_variable : t -> Variable.t -> Variable.t + +(** As for [apply_variable], but for mutable variables. *) +val apply_mutable_variable : t -> Mutable_variable.t -> Mutable_variable.t + +(** As for [apply_variable], but for static exception identifiers. *) +val apply_static_exception : t -> Static_exception.t -> Static_exception.t + +(** Replace recursive accesses to the closures in the set through + [Symbol] by the corresponding [Var]. This is used to recover + the recursive call when importing code from another compilation unit. + + If the renaming is inactive, this is the identity. +*) +val rewrite_recursive_calls_with_symbols + : t + -> Flambda.function_declarations + -> make_closure_symbol:(Closure_id.t -> Symbol.t) + -> Flambda.function_declarations + +(* CR-soon mshinwell for mshinwell: maybe inaccurate module name, it freshens + closure IDs as well. Check use points though *) +module Project_var : sig + (** A table used for freshening of identifiers in [Project_closure] and + [Move_within_set_of_closures] ("ids of closures"); and [Project_var] + ("bound vars of closures") expressions. + + This information is propagated bottom up and populated when inlining a + function containing a closure declaration. + + For instance, + [let f x = + let g y = ... x ... in + ... g.x ... (Project_var x) + ... g 1 ... (Apply (Project_closure g ...)) + ] + + If f is inlined, g is renamed. The approximation of g will carry this + table such that later the access to the field x of g and selection of + g in the closure can be substituted. + *) + type t + + (* The freshening that does nothing. *) + val empty : t + + (** Composition of two freshenings. *) + val compose : earlier:t -> later:t -> t + + (** Freshen a closure ID based on the given renaming. The same ID is + returned if the renaming does not affect it. + If dealing with approximations, you probably want to use + [Simple_value_approx.freshen_and_check_closure_id] instead of this + function. + *) + val apply_closure_id : t -> Closure_id.t -> Closure_id.t + + (** Like [apply_closure_id], but for variables within closures. *) + val apply_var_within_closure + : t + -> Var_within_closure.t + -> Var_within_closure.t + + val print : Format.formatter -> t -> unit +end + +(* CR-soon mshinwell for mshinwell: add comment *) +val apply_function_decls_and_free_vars + : t + -> (Flambda.specialised_to * 'a) Variable.Map.t + -> Flambda.function_declarations + -> only_freshen_parameters:bool + -> (Flambda.specialised_to * 'a) Variable.Map.t + * Flambda.function_declarations + * t + * Project_var.t + +val does_not_freshen : t -> Variable.t list -> bool + +val print : Format.formatter -> t -> unit + +(** N.B. This does not freshen the domain of the supplied map, only the + range. *) +(* CR-someday mshinwell: consider fixing that *) +val freshen_projection_relation + : Flambda.specialised_to Variable.Map.t + -> freshening:t + -> closure_freshening:Project_var.t + -> Flambda.specialised_to Variable.Map.t + +val freshen_projection_relation' + : (Flambda.specialised_to * 'a) Variable.Map.t + -> freshening:t + -> closure_freshening:Project_var.t + -> (Flambda.specialised_to * 'a) Variable.Map.t diff --git a/middle_end/flambda/import_approx.ml b/middle_end/flambda/import_approx.ml new file mode 100644 index 0000000000..64fbbb8bff --- /dev/null +++ b/middle_end/flambda/import_approx.ml @@ -0,0 +1,222 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +module A = Simple_value_approx + +let import_set_of_closures = + let import_function_declarations (clos : A.function_declarations) + : A.function_declarations = + (* CR-soon mshinwell for pchambart: Do we still need to do this + rewriting? I'm wondering if maybe we don't have to any more. *) + let sym_to_fun_var_map (clos : A.function_declarations) = + Variable.Map.fold (fun fun_var _ acc -> + let closure_id = Closure_id.wrap fun_var in + let sym = Compilenv.closure_symbol closure_id in + Symbol.Map.add sym fun_var acc) + clos.funs Symbol.Map.empty + in + let sym_map = sym_to_fun_var_map clos in + let f_named (named : Flambda.named) = + match named with + | Symbol sym -> + begin try Flambda.Expr (Var (Symbol.Map.find sym sym_map)) with + | Not_found -> named + end + | named -> named + in + let funs = + Variable.Map.map (fun (function_decl : A.function_declaration) -> + A.update_function_declaration_body function_decl + (Flambda_iterators.map_toplevel_named f_named)) + clos.funs + in + A.update_function_declarations clos ~funs + in + let aux set_of_closures_id = + match + Compilenv.approx_for_global + (Set_of_closures_id.get_compilation_unit set_of_closures_id) + with + | None -> None + | Some ex_info -> + try + let function_declarations = + Set_of_closures_id.Map.find set_of_closures_id + ex_info.sets_of_closures + in + Some (import_function_declarations function_declarations) + with Not_found -> + Misc.fatal_error "Cannot find set of closures" + in + Set_of_closures_id.Tbl.memoize Compilenv.imported_sets_of_closures_table aux + +let rec import_ex ex = + let import_value_set_of_closures ~set_of_closures_id ~bound_vars ~free_vars + ~(ex_info : Export_info.t) ~what : A.value_set_of_closures option = + let bound_vars = Var_within_closure.Map.map import_approx bound_vars in + match import_set_of_closures set_of_closures_id with + | None -> None + | Some function_decls -> + (* CR-someday xclerc: add a test to the test suite to ensure that + classic mode behaves as expected. *) + let is_classic_mode = function_decls.is_classic_mode in + let invariant_params = + match + Set_of_closures_id.Map.find set_of_closures_id + ex_info.invariant_params + with + | exception Not_found -> + if is_classic_mode then + Variable.Map.empty + else + Misc.fatal_errorf "Set of closures ID %a not found in \ + invariant_params (when importing [%a: %s])" + Set_of_closures_id.print set_of_closures_id + Export_id.print ex + what + | found -> found + in + let recursive = + match + Set_of_closures_id.Map.find set_of_closures_id ex_info.recursive + with + | exception Not_found -> + if is_classic_mode then + Variable.Set.empty + else + Misc.fatal_errorf "Set of closures ID %a not found in \ + recursive (when importing [%a: %s])" + Set_of_closures_id.print set_of_closures_id + Export_id.print ex + what + | found -> found + in + Some (A.create_value_set_of_closures + ~function_decls + ~bound_vars + ~free_vars + ~invariant_params:(lazy invariant_params) + ~recursive:(lazy recursive) + ~specialised_args:Variable.Map.empty + ~freshening:Freshening.Project_var.empty + ~direct_call_surrogates:Closure_id.Map.empty) + in + let compilation_unit = Export_id.get_compilation_unit ex in + match Compilenv.approx_for_global compilation_unit with + | None -> A.value_unknown Other + | Some ex_info -> + match Export_info.find_description ex_info ex with + | exception Not_found -> + Misc.fatal_errorf "Cannot find export id %a" Export_id.print ex + | Value_unknown_descr -> A.value_unknown Other + | Value_int i -> A.value_int i + | Value_char c -> A.value_char c + | Value_constptr i -> A.value_constptr i + | Value_float f -> A.value_float f + | Value_float_array float_array -> + begin match float_array.contents with + | Unknown_or_mutable -> + A.value_mutable_float_array ~size:float_array.size + | Contents contents -> + A.value_immutable_float_array + (Array.map (function + | None -> A.value_any_float + | Some f -> A.value_float f) + contents) + end + | Export_info.Value_boxed_int (t, i) -> A.value_boxed_int t i + | Value_string { size; contents } -> + let contents = + match contents with + | Unknown_or_mutable -> None + | Contents contents -> Some contents + in + A.value_string size contents + | Value_mutable_block _ -> A.value_unknown Other + | Value_block (tag, fields) -> + A.value_block tag (Array.map import_approx fields) + | Value_closure { closure_id; + set_of_closures = + { set_of_closures_id; bound_vars; free_vars; aliased_symbol } } -> + let value_set_of_closures = + import_value_set_of_closures + ~set_of_closures_id ~bound_vars ~free_vars ~ex_info + ~what:(Format.asprintf "Value_closure %a" Closure_id.print closure_id) + in + begin match value_set_of_closures with + | None -> A.value_unresolved (Set_of_closures_id set_of_closures_id) + | Some value_set_of_closures -> + A.value_closure ?set_of_closures_symbol:aliased_symbol + value_set_of_closures closure_id + end + | Value_set_of_closures + { set_of_closures_id; bound_vars; free_vars; aliased_symbol } -> + let value_set_of_closures = + import_value_set_of_closures ~set_of_closures_id + ~bound_vars ~free_vars ~ex_info ~what:"Value_set_of_closures" + in + match value_set_of_closures with + | None -> + A.value_unresolved (Set_of_closures_id set_of_closures_id) + | Some value_set_of_closures -> + let approx = A.value_set_of_closures value_set_of_closures in + match aliased_symbol with + | None -> approx + | Some symbol -> A.augment_with_symbol approx symbol + +and import_approx (ap : Export_info.approx) = + match ap with + | Value_unknown -> A.value_unknown Other + | Value_id ex -> A.value_extern ex + | Value_symbol sym -> A.value_symbol sym + +let import_symbol sym = + if Compilenv.is_predefined_exception sym then + A.value_unknown Other + else begin + let compilation_unit = Symbol.compilation_unit sym in + match Compilenv.approx_for_global compilation_unit with + | None -> A.value_unresolved (Symbol sym) + | Some export_info -> + match Symbol.Map.find sym export_info.symbol_id with + | approx -> A.augment_with_symbol (import_ex approx) sym + | exception Not_found -> + Misc.fatal_errorf + "Compilation unit = %a Cannot find symbol %a" + Compilation_unit.print compilation_unit + Symbol.print sym + end + +(* Note for code reviewers: Observe that [really_import] iterates until + the approximation description is fully resolved (or a necessary .cmx + file is missing). *) + +let rec really_import (approx : A.descr) = + match approx with + | Value_extern ex -> really_import_ex ex + | Value_symbol sym -> really_import_symbol sym + | r -> r + +and really_import_ex ex = + really_import (import_ex ex).descr + +and really_import_symbol sym = + really_import (import_symbol sym).descr + +let really_import_approx (approx : Simple_value_approx.t) = + A.replace_description approx (really_import approx.descr) diff --git a/middle_end/flambda/import_approx.mli b/middle_end/flambda/import_approx.mli new file mode 100644 index 0000000000..23d9d29482 --- /dev/null +++ b/middle_end/flambda/import_approx.mli @@ -0,0 +1,34 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(** Create simple value approximations from the export information in + .cmx files. *) + +(** Given an approximation description, load .cmx files (possibly more + than one) until the description is fully resolved. If a necessary .cmx + file cannot be found, "unresolved" will be returned. *) +val really_import : Simple_value_approx.descr -> Simple_value_approx.descr + +(** Maps the description of the given approximation through [really_import]. *) +val really_import_approx : Simple_value_approx.t -> Simple_value_approx.t + +(** Read and convert the approximation of a given symbol from the + relevant .cmx file. Unlike the "really_" functions, this does not + continue to load .cmx files until the approximation is fully + resolved. *) +val import_symbol : Symbol.t -> Simple_value_approx.t diff --git a/middle_end/flambda/inconstant_idents.ml b/middle_end/flambda/inconstant_idents.ml new file mode 100644 index 0000000000..59f8aa8a8c --- /dev/null +++ b/middle_end/flambda/inconstant_idents.ml @@ -0,0 +1,502 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +(* This cannot be done in a single simple pass due to expressions like: + + let rec ... = + ... + let rec f1 x = + let f2 y = + f1 rec_list + in + f2 v + and rec_list = f1 :: rec_list in + ... + + and v = ... + + f1, f2 and rec_list are constants iff v is a constant. + + To handle this we populate both a 'not constant' set NC and a set of + implications between variables. + + For example, the above code would generate the implications: + + f1 in NC => rec_list in NC + f2 in NC => f1 in NC + rec_list in NC => f2 in NC + v in NC => f1 in NC + + then if v is found to be in NC this will be propagated to place + f1, f2 and rec_list in NC as well. + +*) + +(* CR-someday lwhite: I think this pass could be combined with + alias_analysis and other parts of lift_constants into a single + type-based analysis which infers a "type" for each variable that is + either an allocated_constant expression or "not constant". Recursion + would be handled with unification variables. *) + +module Int = Numbers.Int +module Symbol_field = struct + type t = Symbol.t * Int.t + include Identifiable.Make (Identifiable.Pair (Symbol) (Int)) +end + +type dep = + | Closure of Set_of_closures_id.t + | Var of Variable.t + | Symbol of Symbol.t + | Symbol_field of Symbol_field.t + +type state = + | Not_constant + | Implication of dep list + +type result = { + id : state Variable.Tbl.t; + closure : state Set_of_closures_id.Tbl.t; +} + +module type Param = sig + val program : Flambda.program + val compilation_unit : Compilation_unit.t +end + +(* CR-soon mshinwell: consider removing functor *) +module Inconstants (P:Param) (Backend:Backend_intf.S) = struct + let program = P.program + let compilation_unit = P.compilation_unit + let imported_symbols = Flambda_utils.imported_symbols program + + (* Sets representing NC *) + let variables : state Variable.Tbl.t = Variable.Tbl.create 42 + let closures : state Set_of_closures_id.Tbl.t = + Set_of_closures_id.Tbl.create 42 + let symbols : state Symbol.Tbl.t = Symbol.Tbl.create 42 + let symbol_fields : state Symbol_field.Tbl.t = Symbol_field.Tbl.create 42 + + let mark_queue = Queue.create () + + (* CR-soon pchambart: We could probably improve that quite a lot by adding + (the future annotation) [@unrolled] at the right call sites. Or more + directly mark mark_dep as [@inline] and call it instead of mark_curr in + some situations. + *) + + (* adds 'dep in NC' *) + let rec mark_dep = function + | Var id -> begin + match Variable.Tbl.find variables id with + | Not_constant -> () + | Implication deps -> + Variable.Tbl.replace variables id Not_constant; + Queue.push deps mark_queue + | exception Not_found -> + Variable.Tbl.add variables id Not_constant + end + | Closure cl -> begin + match Set_of_closures_id.Tbl.find closures cl with + | Not_constant -> () + | Implication deps -> + Set_of_closures_id.Tbl.replace closures cl Not_constant; + Queue.push deps mark_queue + | exception Not_found -> + Set_of_closures_id.Tbl.add closures cl Not_constant + end + | Symbol s -> begin + match Symbol.Tbl.find symbols s with + | Not_constant -> () + | Implication deps -> + Symbol.Tbl.replace symbols s Not_constant; + Queue.push deps mark_queue + | exception Not_found -> + Symbol.Tbl.add symbols s Not_constant + end + | Symbol_field s -> begin + match Symbol_field.Tbl.find symbol_fields s with + | Not_constant -> () + | Implication deps -> + Symbol_field.Tbl.replace symbol_fields s Not_constant; + Queue.push deps mark_queue + | exception Not_found -> + Symbol_field.Tbl.add symbol_fields s Not_constant + end + + and mark_deps deps = + List.iter mark_dep deps + + and complete_marking () = + while not (Queue.is_empty mark_queue) do + let deps = + try + Queue.take mark_queue + with Not_found -> [] + in + mark_deps deps; + done + + (* adds 'curr in NC' *) + let mark_curr curr = + mark_deps curr; + complete_marking () + + (* adds in the tables 'dep in NC => curr in NC' *) + let register_implication ~in_nc:dep ~implies_in_nc:curr = + match dep with + | Var id -> begin + match Variable.Tbl.find variables id with + | Not_constant -> + mark_deps curr; + complete_marking (); + | Implication deps -> + let deps = List.rev_append curr deps in + Variable.Tbl.replace variables id (Implication deps) + | exception Not_found -> + Variable.Tbl.add variables id (Implication curr); + end + | Closure cl -> begin + match Set_of_closures_id.Tbl.find closures cl with + | Not_constant -> + mark_deps curr; + complete_marking (); + | Implication deps -> + let deps = List.rev_append curr deps in + Set_of_closures_id.Tbl.replace closures cl (Implication deps) + | exception Not_found -> + Set_of_closures_id.Tbl.add closures cl (Implication curr); + end + | Symbol symbol -> begin + match Symbol.Tbl.find symbols symbol with + | Not_constant -> + mark_deps curr; + complete_marking (); + | Implication deps -> + let deps = List.rev_append curr deps in + Symbol.Tbl.replace symbols symbol (Implication deps) + | exception Not_found -> + Symbol.Tbl.add symbols symbol (Implication curr); + end + | Symbol_field ((symbol, _) as field) -> begin + match Symbol_field.Tbl.find symbol_fields field with + | Not_constant -> + mark_deps curr; + complete_marking (); + | Implication deps -> + let deps = List.rev_append curr deps in + Symbol_field.Tbl.replace symbol_fields field (Implication deps) + | exception Not_found -> + (* There is no information available about the contents of imported + symbols, so we must consider all their fields as inconstant. *) + (* CR-someday pchambart: recover that from the cmx information *) + if Symbol.Set.mem symbol imported_symbols then begin + Symbol_field.Tbl.add symbol_fields field Not_constant; + mark_deps curr; + complete_marking (); + end else begin + Symbol_field.Tbl.add symbol_fields field (Implication curr) + end + end + + (* First loop: iterates on the tree to mark dependencies. + + curr is the variables or closures to which we add constraints like + '... in NC => curr in NC' or 'curr in NC' + + It can be empty when no constraint can be added like in the toplevel + expression or in the body of a function. + *) + let rec mark_loop ~toplevel (curr : dep list) (flam : Flambda.t) = + match flam with + | Let { var; defining_expr = lam; body; _ } -> + mark_named ~toplevel [Var var] lam; + (* adds 'var in NC => curr in NC' + This is not really necessary, but compiling this correctly is + trickier than eliminating that earlier. *) + mark_var var curr; + mark_loop ~toplevel curr body + | Let_mutable { initial_value = var; body } -> + mark_var var curr; + mark_loop ~toplevel curr body + | Let_rec(defs, body) -> + List.iter (fun (var, def) -> + mark_named ~toplevel [Var var] def; + (* adds 'var in NC => curr in NC' same remark as let case *) + mark_var var curr) + defs; + mark_loop ~toplevel curr body + | Var var -> mark_var var curr + (* Not constant cases: we mark directly 'curr in NC' and mark + bound variables as in NC also *) + | Assign _ -> + mark_curr curr + | Try_with (f1,id,f2) -> + mark_curr [Var id]; + mark_curr curr; + mark_loop ~toplevel [] f1; + mark_loop ~toplevel [] f2 + | Static_catch (_,ids,f1,f2) -> + List.iter (fun id -> mark_curr [Var id]) ids; + mark_curr curr; + mark_loop ~toplevel [] f1; + mark_loop ~toplevel [] f2 + (* CR-someday pchambart: If recursive staticcatch is introduced: + this becomes ~toplevel:false *) + | For { bound_var; from_value; to_value; direction = _; body; } -> + mark_curr [Var bound_var]; + mark_var from_value curr; + mark_var to_value curr; + mark_curr curr; + mark_loop ~toplevel:false [] body + | While (f1,body) -> + mark_curr curr; + mark_loop ~toplevel [] f1; + mark_loop ~toplevel:false [] body + | If_then_else (f1,f2,f3) -> + mark_curr curr; + mark_curr [Var f1]; + mark_loop ~toplevel [] f2; + mark_loop ~toplevel [] f3 + | Static_raise (_,l) -> + mark_curr curr; + List.iter (fun v -> mark_var v curr) l + | Apply ({func; args; _ }) -> + mark_curr curr; + mark_var func curr; + mark_vars args curr; + | Switch (arg,sw) -> + mark_curr curr; + mark_var arg curr; + List.iter (fun (_,l) -> mark_loop ~toplevel [] l) sw.consts; + List.iter (fun (_,l) -> mark_loop ~toplevel [] l) sw.blocks; + Misc.may (fun l -> mark_loop ~toplevel [] l) sw.failaction + | String_switch (arg,sw,def) -> + mark_curr curr; + mark_var arg curr; + List.iter (fun (_,l) -> mark_loop ~toplevel [] l) sw; + Misc.may (fun l -> mark_loop ~toplevel [] l) def + | Send { kind = _; meth; obj; args; dbg = _; } -> + mark_curr curr; + mark_var meth curr; + mark_var obj curr; + List.iter (fun arg -> mark_var arg curr) args + | Proved_unreachable -> + mark_curr curr + + and mark_named ~toplevel curr (named : Flambda.named) = + match named with + | Set_of_closures (set_of_closures) -> + mark_loop_set_of_closures ~toplevel curr set_of_closures + | Const _ | Allocated_const _ -> () + | Read_mutable _ -> mark_curr curr + | Symbol symbol -> begin + let current_unit = Compilation_unit.get_current_exn () in + if Compilation_unit.equal current_unit (Symbol.compilation_unit symbol) + then + () + else + match (Backend.import_symbol symbol).descr with + | Value_unresolved _ -> + (* Constant when 'for_clambda' means: can be a symbol (which is + obviously the case here) with a known approximation. If this + condition is not satisfied we mark as inconstant to reflect + the fact that the symbol's contents are unknown and thus + prevent attempts to examine it. (This is a bit of a hack.) *) + mark_curr curr + | _ -> + () + end + | Read_symbol_field (symbol, index) -> + register_implication ~in_nc:(Symbol_field (symbol, index)) + ~implies_in_nc:curr + (* Constant constructors: those expressions are constant if all their + parameters are: + - makeblock is compiled to a constant block + - offset is compiled to a pointer inside a constant closure. + See Cmmgen for the details + + makeblock(Mutable) can be a 'constant' if it is allocated at + toplevel: if this expression is evaluated only once. + *) + | Prim (Pmakeblock (_tag, Asttypes.Immutable, _value_kind), args, + _dbg) -> + mark_vars args curr +(* (* CR-someday pchambart: If global mutables are allowed: *) + | Prim(Lambda.Pmakeblock(_tag, Asttypes.Mutable), args, _dbg, _) + when toplevel -> + List.iter (mark_loop ~toplevel curr) args +*) + | Prim (Pmakearray (Pfloatarray, Immutable), args, _) -> + mark_vars args curr + | Prim (Pmakearray (Pfloatarray, Mutable), args, _) -> + (* CR-someday pchambart: Toplevel float arrays could always be + statically allocated using an equivalent of the + Initialize_symbol construction. + Toplevel non-float arrays could also be turned into an + Initialize_symbol, but only when declared as immutable since + preallocated symbols does not allow mutation after + initialisation + *) + if toplevel then mark_vars args curr + else mark_curr curr + | Prim (Pduparray (Pfloatarray, Immutable), [arg], _) -> + mark_var arg curr + | Prim (Pduparray (Pfloatarray, Mutable), [arg], _) -> + if toplevel then mark_var arg curr + else mark_curr curr + | Prim (Pduparray _, _, _) -> + (* See Lift_constants *) + mark_curr curr + | Project_closure ({ set_of_closures; closure_id; }) -> + if Closure_id.in_compilation_unit closure_id compilation_unit then + mark_var set_of_closures curr + else + mark_curr curr + | Move_within_set_of_closures ({ closure; start_from; move_to; }) -> + (* CR-someday mshinwell: We should be able to deem these projections + (same for the cases below) as constant when from another + compilation unit, but there isn't code to handle this yet. (Note + that for Project_var we cannot yet generate a projection from a + closure in another compilation unit, since we only lift closed + closures.) *) + if Closure_id.in_compilation_unit start_from compilation_unit then begin + assert (Closure_id.in_compilation_unit move_to compilation_unit); + mark_var closure curr + end else begin + mark_curr curr + end + | Project_var ({ closure; closure_id; var = _ }) -> + if Closure_id.in_compilation_unit closure_id compilation_unit then + mark_var closure curr + else + mark_curr curr + | Prim (Pfield _, [f1], _) -> + mark_curr curr; + mark_var f1 curr + | Prim (_, args, _) -> + mark_curr curr; + mark_vars args curr + | Expr flam -> + mark_loop ~toplevel curr flam + + and mark_var var curr = + (* adds 'id in NC => curr in NC' *) + register_implication ~in_nc:(Var var) ~implies_in_nc:curr + + and mark_vars vars curr = + (* adds 'id in NC => curr in NC' *) + List.iter (fun var -> mark_var var curr) vars + + (* [toplevel] is intended for allowing static allocations of mutable + blocks. This feature should be available in a future release once the + necessary GC changes have been merged. (See GPR#178.) *) + and mark_loop_set_of_closures ~toplevel:_ curr + { Flambda. function_decls; free_vars; specialised_args } = + (* If a function in the set of closures is specialised, do not consider + it constant, unless all specialised args are also constant. *) + Variable.Map.iter (fun _ (spec_arg : Flambda.specialised_to) -> + register_implication + ~in_nc:(Var spec_arg.var) + ~implies_in_nc:[Closure function_decls.set_of_closures_id]) + specialised_args; + (* adds 'function_decls in NC => curr in NC' *) + register_implication ~in_nc:(Closure function_decls.set_of_closures_id) + ~implies_in_nc:curr; + (* a closure is constant if its free variables are constants. *) + Variable.Map.iter (fun inner_id (var : Flambda.specialised_to) -> + register_implication ~in_nc:(Var var.var) + ~implies_in_nc:[ + Var inner_id; + Closure function_decls.set_of_closures_id + ]) + free_vars; + Variable.Map.iter (fun fun_id (ffunc : Flambda.function_declaration) -> + (* for each function f in a closure c 'c in NC => f' *) + register_implication ~in_nc:(Closure function_decls.set_of_closures_id) + ~implies_in_nc:[Var fun_id]; + (* function parameters are in NC unless specialised *) + List.iter (fun param -> + match Variable.Map.find param specialised_args with + | exception Not_found -> mark_curr [Var param] + | outer_var -> + register_implication ~in_nc:(Var outer_var.var) + ~implies_in_nc:[Var param]) + (Parameter.List.vars ffunc.params); + mark_loop ~toplevel:false [] ffunc.body) + function_decls.funs + + let mark_constant_defining_value (const:Flambda.constant_defining_value) = + match const with + | Allocated_const _ + | Block _ + | Project_closure _ -> () + | Set_of_closures set_of_closure -> + mark_loop_set_of_closures ~toplevel:true [] set_of_closure + + let mark_program (program : Flambda.program) = + let rec loop (program : Flambda.program_body) = + match program with + | End _ -> () + | Initialize_symbol (symbol,_tag,fields,program) -> + List.iteri (fun i field -> + mark_loop ~toplevel:true + [Symbol symbol; Symbol_field (symbol,i)] field) + fields; + loop program + | Effect (expr, program) -> + mark_loop ~toplevel:true [] expr; + loop program + | Let_symbol (_, def, program) -> + mark_constant_defining_value def; + loop program + | Let_rec_symbol (defs, program) -> + List.iter (fun (_, def) -> mark_constant_defining_value def) defs; + loop program + in + loop program.program_body + + let res = + mark_program program; + { id = variables; + closure = closures; + } +end + +let inconstants_on_program ~compilation_unit ~backend + (program : Flambda.program) = + let module P = struct + let program = program + let compilation_unit = compilation_unit + end in + let module Backend = (val backend : Backend_intf.S) in + let module I = Inconstants (P) (Backend) in + I.res + +let variable var { id; _ } = + match Variable.Tbl.find id var with + | Not_constant -> true + | Implication _ -> false + | exception Not_found -> false + +let closure cl { closure; _ } = + match Set_of_closures_id.Tbl.find closure cl with + | Not_constant -> true + | Implication _ -> false + | exception Not_found -> false diff --git a/middle_end/flambda/inconstant_idents.mli b/middle_end/flambda/inconstant_idents.mli new file mode 100644 index 0000000000..2c5309e022 --- /dev/null +++ b/middle_end/flambda/inconstant_idents.mli @@ -0,0 +1,36 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +type result + +(** [inconstants_on_program] finds those variables and set-of-closures + identifiers that cannot be compiled to constants by [Flambda_to_clambda]. +*) +val inconstants_on_program + : compilation_unit:Compilation_unit.t + -> backend:(module Backend_intf.S) + -> Flambda.program + -> result + +(** [variable var res] returns [true] if [var] is marked as inconstant + in [res]. *) +val variable : Variable.t -> result -> bool + +(** [closure cl res] returns [true] if [cl] is marked as inconstant + in [res]. *) +val closure : Set_of_closures_id.t -> result -> bool diff --git a/middle_end/flambda/initialize_symbol_to_let_symbol.ml b/middle_end/flambda/initialize_symbol_to_let_symbol.ml new file mode 100644 index 0000000000..31246b0d46 --- /dev/null +++ b/middle_end/flambda/initialize_symbol_to_let_symbol.ml @@ -0,0 +1,57 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +let constant_field (expr:Flambda.t) + : Flambda.constant_defining_value_block_field option = + match expr with + | Let { var; defining_expr = Const c; body = Var var' ; _ } -> + assert(Variable.equal var var'); + (* This must be true since var is the only variable in scope *) + Some (Flambda.Const c) + | Let { var; defining_expr = Symbol s; body = Var var' ; _ } -> + assert(Variable.equal var var'); + Some (Flambda.Symbol s) + | _ -> + None + +let rec loop (program : Flambda.program_body) : Flambda.program_body = + match program with + | Initialize_symbol (symbol, tag, fields, program) -> + let constant_fields = List.map constant_field fields in + begin + match Misc.Stdlib.List.some_if_all_elements_are_some constant_fields + with + | None -> + Initialize_symbol (symbol, tag, fields, loop program) + | Some fields -> + Let_symbol (symbol, Block (tag, fields), loop program) + end + | Let_symbol (symbol, const, program) -> + Let_symbol (symbol, const, loop program) + | Let_rec_symbol (defs, program) -> + Let_rec_symbol (defs, loop program) + | Effect (expr, program) -> + Effect (expr, loop program) + | End symbol -> + End symbol + +let run (program : Flambda.program) = + { program with + program_body = loop program.program_body; + } diff --git a/middle_end/flambda/initialize_symbol_to_let_symbol.mli b/middle_end/flambda/initialize_symbol_to_let_symbol.mli new file mode 100644 index 0000000000..fc54f76075 --- /dev/null +++ b/middle_end/flambda/initialize_symbol_to_let_symbol.mli @@ -0,0 +1,25 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +val constant_field + : Flambda.t + -> Flambda.constant_defining_value_block_field option + +(** Transform Initialize_symbol with only constant fields to + let_symbol construction. *) +val run : Flambda.program -> Flambda.program diff --git a/middle_end/flambda/inline_and_simplify.ml b/middle_end/flambda/inline_and_simplify.ml new file mode 100644 index 0000000000..7d304cd88f --- /dev/null +++ b/middle_end/flambda/inline_and_simplify.ml @@ -0,0 +1,1703 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +module A = Simple_value_approx +module B = Inlining_cost.Benefit +module E = Inline_and_simplify_aux.Env +module R = Inline_and_simplify_aux.Result + +(** Values of two types hold the information propagated during simplification: + - [E.t] "environments", top-down, almost always called "env"; + - [R.t] "results", bottom-up approximately following the evaluation order, + almost always called "r". These results come along with rewritten + Flambda terms. + The environments map variables to approximations, which enable various + simplifications to be performed; for example, some variable may be known + to always hold a particular constant. +*) + +let ret = R.set_approx + +type simplify_variable_result = + | No_binding of Variable.t + | Binding of Variable.t * (Flambda.named Flambda.With_free_variables.t) + +let simplify_free_variable_internal env original_var = + let var = Freshening.apply_variable (E.freshening env) original_var in + let original_var = var in + (* In the case where an approximation is useful, we introduce a [let] + to bind (e.g.) the constant or symbol replacing [var], unless this + would introduce a useless [let] as a consequence of [var] already being + in the current scope. + + Even when the approximation is not useful, this simplification helps. + In particular, it squashes aliases of the form: + let var1 = var2 in ... var2 ... + by replacing [var2] in the body with [var1]. Simplification can then + eliminate the [let]. + *) + let var = + let approx = E.find_exn env var in + match approx.var with + | Some var when E.mem env var -> var + | Some _ | None -> var + in + (* CR-soon mshinwell: Should we update [r] when we *add* code? + Aside from that, it looks like maybe we don't need [r] in this function, + because the approximation within it wouldn't be used by any of the + call sites. *) + match E.find_with_scope_exn env var with + | Current, approx -> No_binding var, approx (* avoid useless [let] *) + | Outer, approx -> + match A.simplify_var approx with + | None -> No_binding var, approx + | Some (named, approx) -> + let module W = Flambda.With_free_variables in + Binding (original_var, W.of_named named), approx + +let simplify_free_variable env var ~f : Flambda.t * R.t = + match simplify_free_variable_internal env var with + | No_binding var, approx -> f env var approx + | Binding (var, named), approx -> + let module W = Flambda.With_free_variables in + let var = Variable.rename var in + let env = E.add env var approx in + let body, r = f env var approx in + (W.create_let_reusing_defining_expr var named body), r + +let simplify_free_variables env vars ~f : Flambda.t * R.t = + let rec collect_bindings vars env bound_vars approxs : Flambda.t * R.t = + match vars with + | [] -> f env (List.rev bound_vars) (List.rev approxs) + | var::vars -> + match simplify_free_variable_internal env var with + | No_binding var, approx -> + collect_bindings vars env (var::bound_vars) (approx::approxs) + | Binding (var, named), approx -> + let module W = Flambda.With_free_variables in + let var = Variable.rename var in + let env = E.add env var approx in + let body, r = + collect_bindings vars env (var::bound_vars) (approx::approxs) + in + (W.create_let_reusing_defining_expr var named body), r + in + collect_bindings vars env [] [] + +let simplify_free_variables_named env vars ~f : Flambda.named * R.t = + let rec collect_bindings vars env bound_vars approxs + : Flambda.maybe_named * R.t = + match vars with + | [] -> + let named, r = f env (List.rev bound_vars) (List.rev approxs) in + Is_named named, r + | var::vars -> + match simplify_free_variable_internal env var with + | No_binding var, approx -> + collect_bindings vars env (var::bound_vars) (approx::approxs) + | Binding (var, named), approx -> + let module W = Flambda.With_free_variables in + let var = Variable.rename var in + let env = E.add env var approx in + let body, r = + collect_bindings vars env (var::bound_vars) (approx::approxs) + in + let body = + match body with + | Is_named body -> + let name = Internal_variable_names.simplify_fv in + Flambda_utils.name_expr body ~name + | Is_expr body -> body + in + Is_expr (W.create_let_reusing_defining_expr var named body), r + in + let named_or_expr, r = collect_bindings vars env [] [] in + match named_or_expr with + | Is_named named -> named, r + | Is_expr expr -> Expr expr, r + +(* CR-soon mshinwell: tidy this up *) +let simplify_free_variable_named env var ~f : Flambda.named * R.t = + simplify_free_variables_named env [var] ~f:(fun env vars vars_approxs -> + match vars, vars_approxs with + | [var], [approx] -> f env var approx + | _ -> assert false) + +let simplify_named_using_approx r lam approx = + let lam, _summary, approx = A.simplify_named approx lam in + lam, R.set_approx r approx + +let simplify_using_approx_and_env env r original_lam approx = + let lam, summary, approx = + A.simplify_using_env approx ~is_present_in_env:(E.mem env) original_lam + in + let r = + let r = ret r approx in + match summary with + (* CR-soon mshinwell: Why is [r] not updated with the cost of adding the + new code? + mshinwell: similar to CR above *) + | Replaced_term -> R.map_benefit r (B.remove_code original_lam) + | Nothing_done -> r + in + lam, r + +let simplify_named_using_approx_and_env env r original_named approx = + let named, summary, approx = + A.simplify_named_using_env approx ~is_present_in_env:(E.mem env) + original_named + in + let r = + let r = ret r approx in + match summary with + | Replaced_term -> R.map_benefit r (B.remove_code_named original_named) + | Nothing_done -> r + in + named, r + +let simplify_const (const : Flambda.const) = + match const with + | Int i -> A.value_int i + | Char c -> A.value_char c + | Const_pointer i -> A.value_constptr i + +let approx_for_allocated_const (const : Allocated_const.t) = + match const with + | String s -> A.value_string (String.length s) None + | Immutable_string s -> A.value_string (String.length s) (Some s) + | Int32 i -> A.value_boxed_int Int32 i + | Int64 i -> A.value_boxed_int Int64 i + | Nativeint i -> A.value_boxed_int Nativeint i + | Float f -> A.value_float f + | Float_array a -> A.value_mutable_float_array ~size:(List.length a) + | Immutable_float_array a -> + A.value_immutable_float_array + (Array.map A.value_float (Array.of_list a)) + +type filtered_switch_branches = + | Must_be_taken of Flambda.t + | Can_be_taken of (int * Flambda.t) list + +(* Determine whether a given closure ID corresponds directly to a variable + (bound to a closure) in the given environment. This happens when the body + of a [let rec]-bound function refers to another in the same set of closures. + If we succeed in this process, we can change [Project_closure] + expressions into [Var] expressions, thus sharing closure projections. *) +let reference_recursive_function_directly env closure_id = + let closure_id = Closure_id.unwrap closure_id in + match E.find_opt env closure_id with + | None -> None + | Some approx -> Some (Flambda.Expr (Var closure_id), approx) + +(* Simplify an expression that takes a set of closures and projects an + individual closure from it. *) +let simplify_project_closure env r ~(project_closure : Flambda.project_closure) + : Flambda.named * R.t = + simplify_free_variable_named env project_closure.set_of_closures + ~f:(fun _env set_of_closures set_of_closures_approx -> + match A.check_approx_for_set_of_closures set_of_closures_approx with + | Wrong -> + Misc.fatal_errorf "Wrong approximation when projecting closure: %a" + Flambda.print_project_closure project_closure + | Unresolved value -> + (* A set of closures coming from another compilation unit, whose .cmx is + missing; as such, we cannot have rewritten the function and don't + need to do any freshening. *) + Project_closure { + set_of_closures; + closure_id = project_closure.closure_id; + }, ret r (A.value_unresolved value) + | Unknown -> + (* CR-soon mshinwell: see CR comment in e.g. simple_value_approx.ml + [check_approx_for_closure_allowing_unresolved] *) + Project_closure { + set_of_closures; + closure_id = project_closure.closure_id; + }, ret r (A.value_unknown Other) + | Unknown_because_of_unresolved_value value -> + Project_closure { + set_of_closures; + closure_id = project_closure.closure_id; + }, ret r (A.value_unknown (Unresolved_value value)) + | Ok (set_of_closures_var, value_set_of_closures) -> + let closure_id = + A.freshen_and_check_closure_id value_set_of_closures + project_closure.closure_id + in + let projecting_from = + match set_of_closures_var with + | None -> None + | Some set_of_closures_var -> + let projection : Projection.t = + Project_closure { + set_of_closures = set_of_closures_var; + closure_id; + } + in + match E.find_projection env ~projection with + | None -> None + | Some var -> Some (var, projection) + in + match projecting_from with + | Some (var, projection) -> + simplify_free_variable_named env var ~f:(fun _env var var_approx -> + let r = R.map_benefit r (B.remove_projection projection) in + Expr (Var var), ret r var_approx) + | None -> + match reference_recursive_function_directly env closure_id with + | Some (flam, approx) -> flam, ret r approx + | None -> + let set_of_closures_var = + match set_of_closures_var with + | Some set_of_closures_var' when E.mem env set_of_closures_var' -> + set_of_closures_var + | Some _ | None -> None + in + let approx = + A.value_closure ?set_of_closures_var value_set_of_closures + closure_id + in + Project_closure { set_of_closures; closure_id; }, ret r approx) + +(* Simplify an expression that, given one closure within some set of + closures, returns another closure (possibly the same one) within the + same set. *) +let simplify_move_within_set_of_closures env r + ~(move_within_set_of_closures : Flambda.move_within_set_of_closures) + : Flambda.named * R.t = + simplify_free_variable_named env move_within_set_of_closures.closure + ~f:(fun _env closure closure_approx -> + match A.check_approx_for_closure_allowing_unresolved closure_approx with + | Wrong -> + Misc.fatal_errorf "Wrong approximation when moving within set of \ + closures. Approximation: %a Term: %a" + A.print closure_approx + Flambda.print_move_within_set_of_closures move_within_set_of_closures + | Unresolved sym -> + Move_within_set_of_closures { + closure; + start_from = move_within_set_of_closures.start_from; + move_to = move_within_set_of_closures.move_to; + }, + ret r (A.value_unresolved sym) + | Unknown -> + Move_within_set_of_closures { + closure; + start_from = move_within_set_of_closures.start_from; + move_to = move_within_set_of_closures.move_to; + }, + ret r (A.value_unknown Other) + | Unknown_because_of_unresolved_value value -> + (* For example: a move upon a (move upon a closure whose .cmx file + is missing). *) + Move_within_set_of_closures { + closure; + start_from = move_within_set_of_closures.start_from; + move_to = move_within_set_of_closures.move_to; + }, + ret r (A.value_unknown (Unresolved_value value)) + | Ok (_value_closure, set_of_closures_var, set_of_closures_symbol, + value_set_of_closures) -> + let freshen = + (* CR-soon mshinwell: potentially misleading name---not freshening with + new names, but with previously fresh names *) + A.freshen_and_check_closure_id value_set_of_closures + in + let move_to = freshen move_within_set_of_closures.move_to in + let start_from = freshen move_within_set_of_closures.start_from in + let projection : Projection.t = + Move_within_set_of_closures { + closure; + start_from; + move_to; + } + in + match E.find_projection env ~projection with + | Some var -> + simplify_free_variable_named env var ~f:(fun _env var var_approx -> + let r = R.map_benefit r (B.remove_projection projection) in + Expr (Var var), ret r var_approx) + | None -> + match reference_recursive_function_directly env move_to with + | Some (flam, approx) -> flam, ret r approx + | None -> + if Closure_id.equal start_from move_to then + (* Moving from one closure to itself is a no-op. We can return an + [Var] since we already have a variable bound to the closure. *) + Expr (Var closure), ret r closure_approx + else + match set_of_closures_var with + | Some set_of_closures_var when E.mem env set_of_closures_var -> + (* A variable bound to the set of closures is in scope, + meaning we can rewrite the [Move_within_set_of_closures] to a + [Project_closure]. *) + let project_closure : Flambda.project_closure = + { set_of_closures = set_of_closures_var; + closure_id = move_to; + } + in + let approx = + A.value_closure ~set_of_closures_var value_set_of_closures + move_to + in + Project_closure project_closure, ret r approx + | Some _ | None -> + match set_of_closures_symbol with + | Some set_of_closures_symbol -> + let set_of_closures_var = + Variable.create Internal_variable_names.symbol + in + let project_closure : Flambda.project_closure = + { set_of_closures = set_of_closures_var; + closure_id = move_to; + } + in + let project_closure_var = + Variable.create Internal_variable_names.project_closure + in + let let1 = + Flambda.create_let project_closure_var + (Project_closure project_closure) + (Var project_closure_var) + in + let expr = + Flambda.create_let set_of_closures_var + (Symbol set_of_closures_symbol) + let1 + in + let approx = + A.value_closure ~set_of_closures_var ~set_of_closures_symbol + value_set_of_closures move_to + in + Expr expr, ret r approx + | None -> + (* The set of closures is not available in scope, and we + have no other information by which to simplify the move. *) + let move_within : Flambda.move_within_set_of_closures = + { closure; start_from; move_to; } + in + let approx = A.value_closure value_set_of_closures move_to in + Move_within_set_of_closures move_within, ret r approx) + +(* Transform an expression denoting an access to a variable bound in + a closure. Variables in the closure ([project_var.closure]) may + have been freshened since [expr] was constructed; as such, we + must ensure the same happens to [expr]. The renaming information is + contained within the approximation deduced from [closure] (as + such, that approximation *must* identify which closure it is). + + For instance in some imaginary syntax for flambda: + + [let f x = + let g y ~closure:{a} = a + y in + let closure = { a = x } in + g 12 ~closure] + + when [f] is traversed, [g] can be inlined, resulting in the + expression + + [let f z = + let g y ~closure:{a} = a + y in + let closure = { a = x } in + closure.a + 12] + + [closure.a] being a notation for: + + [Project_var{closure = closure; closure_id = g; var = a}] + + If [f] is inlined later, the resulting code will be + + [let x = ... in + let g' y' ~closure':{a'} = a' + y' in + let closure' = { a' = x } in + closure'.a' + 12] + + in particular the field [a] of the closure has been alpha renamed to [a']. + This information must be carried from the declaration to the use. + + If the function is declared outside of the alpha renamed part, there is + no need for renaming in the [Ffunction] and [Project_var]. + This is not usually the case, except when the closure declaration is a + symbol. + + What ensures that this information is available at [Project_var] + point is that those constructions can only be introduced by inlining, + which requires that same information. For this to still be valid, + other transformation must avoid transforming the information flow in + a way that the inline function can't propagate it. +*) +let rec simplify_project_var env r ~(project_var : Flambda.project_var) + : Flambda.named * R.t = + simplify_free_variable_named env project_var.closure + ~f:(fun _env closure approx -> + match A.check_approx_for_closure_allowing_unresolved approx with + | Ok (value_closure, _set_of_closures_var, _set_of_closures_symbol, + value_set_of_closures) -> + let module F = Freshening.Project_var in + let freshening = value_set_of_closures.freshening in + let var = F.apply_var_within_closure freshening project_var.var in + let closure_id = F.apply_closure_id freshening project_var.closure_id in + let closure_id_in_approx = value_closure.closure_id in + if not (Closure_id.equal closure_id closure_id_in_approx) then begin + Misc.fatal_errorf "When simplifying [Project_var], the closure ID %a \ + in the approximation of the set of closures did not match the \ + closure ID %a in the [Project_var] term. Approximation: %a@. \ + Var-within-closure being projected: %a@." + Closure_id.print closure_id_in_approx + Closure_id.print closure_id + Simple_value_approx.print approx + Var_within_closure.print var + end; + let projection : Projection.t = + Project_var { + closure; + closure_id; + var; + } + in + begin match E.find_projection env ~projection with + | Some var -> + simplify_free_variable_named env var ~f:(fun _env var var_approx -> + let r = R.map_benefit r (B.remove_projection projection) in + Expr (Var var), ret r var_approx) + | None -> + let approx = A.approx_for_bound_var value_set_of_closures var in + let expr : Flambda.named = Project_var { closure; closure_id; var; } in + let unwrapped = Var_within_closure.unwrap var in + let expr = + if E.mem env unwrapped then + Flambda.Expr (Var unwrapped) + else + expr + in + simplify_named_using_approx_and_env env r expr approx + end + | Unresolved symbol -> + (* This value comes from a symbol for which we couldn't find any + approximation, telling us that names within the closure couldn't + have been renamed. So we don't need to change the variable or + closure ID in the [Project_var] expression. *) + Project_var { project_var with closure }, + ret r (A.value_unresolved symbol) + | Unknown -> + Project_var { project_var with closure }, + ret r (A.value_unknown Other) + | Unknown_because_of_unresolved_value value -> + Project_var { project_var with closure }, + ret r (A.value_unknown (Unresolved_value value)) + | Wrong -> + (* We must have the correct approximation of the value to ensure + we take account of all freshenings. *) + Misc.fatal_errorf "[Project_var] from a value with wrong \ + approximation: %a@.closure=%a@.approx of closure=%a@." + Flambda.print_project_var project_var + Variable.print closure + Simple_value_approx.print approx) + +(* Transforms closure definitions by applying [loop] on the code of every + one of the set and on the expressions of the free variables. + If the substitution is activated, alpha renaming also occur on everything + defined by the set of closures: + * Variables bound by a closure of the set + * closure identifiers + * parameters + + The rewriting occurs in a clean environment without any of the variables + defined outside reachable. This helps increase robustness against + accidental, potentially unsound simplification of variable accesses by + [simplify_using_approx_and_env]. + + The rewriting occurs in an environment filled with: + * The approximation of the free variables + * An explicitly unknown approximation for function parameters, + except for those where it is known to be safe: those present in the + [specialised_args] set. + * An approximation for the closures in the set. It contains the code of + the functions before rewriting. + + The approximation of the currently defined closures is available to + allow marking recursives calls as direct and in some cases, allow + inlining of one closure from the set inside another one. For this to + be correct an alpha renaming is first applied on the expressions by + [apply_function_decls_and_free_vars]. + + For instance when rewriting the declaration + + [let rec f_1 x_1 = + let y_1 = x_1 + 1 in + g_1 y_1 + and g_1 z_1 = f_1 (f_1 z_1)] + + When rewriting this function, the first substitution will contain + some mapping: + { f_1 -> f_2; + g_1 -> g_2; + x_1 -> x_2; + z_1 -> z_2 } + + And the approximation for the closure will contain + + { f_2: + fun x_2 -> + let y_1 = x_2 + 1 in + g_2 y_1 + g_2: + fun z_2 -> f_2 (f_2 z_2) } + + Note that no substitution is applied to the let-bound variable [y_1]. + If [f_2] where to be inlined inside [g_2], we known that a new substitution + will be introduced in the current scope for [y_1] each time. + + + If the function where a recursive one coming from another compilation + unit, the code already went through [Flambdasym] that could have + replaced the function variable by the symbol identifying the function + (this occur if the function contains only constants in its closure). + To handle that case, we first replace those symbols by the original + variable. +*) +and simplify_set_of_closures original_env r + (set_of_closures : Flambda.set_of_closures) + : Flambda.set_of_closures * R.t * Freshening.Project_var.t = + let function_decls = + let module Backend = (val (E.backend original_env) : Backend_intf.S) in + (* CR-soon mshinwell: Does this affect + [reference_recursive_function_directly]? + mshinwell: This should be thought about as part of the wider issue of + references to functions via symbols or variables. *) + Freshening.rewrite_recursive_calls_with_symbols (E.freshening original_env) + set_of_closures.function_decls + ~make_closure_symbol:Backend.closure_symbol + in + let env = E.increase_closure_depth original_env in + let free_vars, specialised_args, function_decls, parameter_approximations, + internal_value_set_of_closures, set_of_closures_env = + Inline_and_simplify_aux.prepare_to_simplify_set_of_closures ~env + ~set_of_closures ~function_decls ~only_for_function_decl:None + ~freshen:true + in + let simplify_function fun_var (function_decl : Flambda.function_declaration) + (funs, used_params, r) + : Flambda.function_declaration Variable.Map.t * Variable.Set.t * R.t = + let closure_env = + Inline_and_simplify_aux.prepare_to_simplify_closure ~function_decl + ~free_vars ~specialised_args ~parameter_approximations + ~set_of_closures_env + in + let body, r = + E.enter_closure closure_env ~closure_id:(Closure_id.wrap fun_var) + ~inline_inside: + (Inlining_decision.should_inline_inside_declaration function_decl) + ~dbg:function_decl.dbg + ~f:(fun body_env -> + assert (E.inside_set_of_closures_declaration + function_decls.set_of_closures_origin body_env); + simplify body_env r function_decl.body) + in + let function_decl = + Flambda.create_function_declaration ~params:function_decl.params + ~body ~stub:function_decl.stub ~dbg:function_decl.dbg + ~inline:function_decl.inline ~specialise:function_decl.specialise + ~is_a_functor:function_decl.is_a_functor + ~closure_origin:function_decl.closure_origin + in + let used_params' = Flambda.used_params function_decl in + Variable.Map.add fun_var function_decl funs, + Variable.Set.union used_params used_params', r + in + let funs, _used_params, r = + Variable.Map.fold simplify_function function_decls.funs + (Variable.Map.empty, Variable.Set.empty, r) + in + let function_decls = + Flambda.update_function_declarations function_decls ~funs + in + let invariant_params = + lazy (Invariant_params.invariant_params_in_recursion function_decls + ~backend:(E.backend env)) + in + let recursive = + lazy (Find_recursive_functions.in_function_declarations function_decls + ~backend:(E.backend env)) + in + let keep_body = + Inline_and_simplify_aux.keep_body_check + ~is_classic_mode:function_decls.is_classic_mode ~recursive + in + let function_decls_approx = + A.function_declarations_approx ~keep_body function_decls + in + let value_set_of_closures = + A.create_value_set_of_closures + ~function_decls:function_decls_approx + ~bound_vars:internal_value_set_of_closures.bound_vars + ~invariant_params + ~recursive + ~specialised_args:internal_value_set_of_closures.specialised_args + ~free_vars:internal_value_set_of_closures.free_vars + ~freshening:internal_value_set_of_closures.freshening + ~direct_call_surrogates: + internal_value_set_of_closures.direct_call_surrogates + in + let direct_call_surrogates = + Closure_id.Map.fold (fun existing surrogate surrogates -> + Variable.Map.add (Closure_id.unwrap existing) + (Closure_id.unwrap surrogate) surrogates) + internal_value_set_of_closures.direct_call_surrogates + Variable.Map.empty + in + let set_of_closures = + Flambda.create_set_of_closures ~function_decls + ~free_vars:(Variable.Map.map fst free_vars) + ~specialised_args + ~direct_call_surrogates + in + let r = ret r (A.value_set_of_closures value_set_of_closures) in + set_of_closures, r, value_set_of_closures.freshening + +and simplify_apply env r ~(apply : Flambda.apply) : Flambda.t * R.t = + let { + Flambda. func = lhs_of_application; args; kind = _; dbg; + inline = inline_requested; specialise = specialise_requested; + } = apply in + let dbg = E.add_inlined_debuginfo env ~dbg in + simplify_free_variable env lhs_of_application + ~f:(fun env lhs_of_application lhs_of_application_approx -> + simplify_free_variables env args ~f:(fun env args args_approxs -> + (* By using the approximation of the left-hand side of the + application, attempt to determine which function is being applied + (even if the application is currently [Indirect]). If + successful---in which case we then have a direct + application---consider inlining. *) + match A.check_approx_for_closure lhs_of_application_approx with + | Ok (value_closure, set_of_closures_var, + set_of_closures_symbol, value_set_of_closures) -> + let lhs_of_application, closure_id_being_applied, + value_set_of_closures, env, wrap = + let closure_id_being_applied = value_closure.closure_id in + (* If the call site is a direct call to a function that has a + "direct call surrogate" (see inline_and_simplify_aux.mli), + repoint the call to the surrogate. *) + let surrogates = value_set_of_closures.direct_call_surrogates in + match Closure_id.Map.find closure_id_being_applied surrogates with + | exception Not_found -> + lhs_of_application, closure_id_being_applied, + value_set_of_closures, env, (fun expr -> expr) + | surrogate -> + let rec find_transitively surrogate = + match Closure_id.Map.find surrogate surrogates with + | exception Not_found -> surrogate + | surrogate -> find_transitively surrogate + in + let surrogate = find_transitively surrogate in + let surrogate_var = Variable.rename lhs_of_application in + let move_to_surrogate : Projection.move_within_set_of_closures = + { closure = lhs_of_application; + start_from = closure_id_being_applied; + move_to = surrogate; + } + in + let approx_for_surrogate = + A.value_closure ~closure_var:surrogate_var + ?set_of_closures_var ?set_of_closures_symbol + value_set_of_closures surrogate + in + let env = E.add env surrogate_var approx_for_surrogate in + let wrap expr = + Flambda.create_let surrogate_var + (Move_within_set_of_closures move_to_surrogate) + expr + in + surrogate_var, surrogate, value_set_of_closures, env, wrap + in + let function_decls = value_set_of_closures.function_decls in + let function_decl = + try + Variable.Map.find + (Closure_id.unwrap closure_id_being_applied) + function_decls.funs + with + | Not_found -> + Misc.fatal_errorf "When handling application expression, \ + approximation references non-existent closure %a@." + Closure_id.print closure_id_being_applied + in + let r = + match apply.kind with + | Indirect -> + R.map_benefit r Inlining_cost.Benefit.direct_call_of_indirect + | Direct _ -> r + in + let nargs = List.length args in + let arity = A.function_arity function_decl in + let result, r = + if nargs = arity then + simplify_full_application env r ~function_decls + ~lhs_of_application ~closure_id_being_applied ~function_decl + ~value_set_of_closures ~args ~args_approxs ~dbg + ~inline_requested ~specialise_requested + else if nargs > arity then + simplify_over_application env r ~args ~args_approxs + ~function_decls ~lhs_of_application ~closure_id_being_applied + ~function_decl ~value_set_of_closures ~dbg ~inline_requested + ~specialise_requested + else if nargs > 0 && nargs < arity then + simplify_partial_application env r ~lhs_of_application + ~closure_id_being_applied ~function_decl ~args ~dbg + ~inline_requested ~specialise_requested + else + Misc.fatal_errorf "Function with arity %d when simplifying \ + application expression: %a" + arity Flambda.print (Flambda.Apply apply) + in + wrap result, r + | Wrong -> (* Insufficient approximation information to simplify. *) + Apply ({ func = lhs_of_application; args; kind = Indirect; dbg; + inline = inline_requested; specialise = specialise_requested; }), + ret r (A.value_unknown Other))) + +and simplify_full_application env r ~function_decls ~lhs_of_application + ~closure_id_being_applied ~function_decl ~value_set_of_closures ~args + ~args_approxs ~dbg ~inline_requested ~specialise_requested = + Inlining_decision.for_call_site ~env ~r ~function_decls + ~lhs_of_application ~closure_id_being_applied ~function_decl + ~value_set_of_closures ~args ~args_approxs ~dbg ~simplify + ~inline_requested ~specialise_requested + +and simplify_partial_application env r ~lhs_of_application + ~closure_id_being_applied ~function_decl ~args ~dbg + ~inline_requested ~specialise_requested = + let arity = A.function_arity function_decl in + assert (arity > List.length args); + (* For simplicity, we disallow [@inline] attributes on partial + applications. The user may always write an explicit wrapper instead + with such an attribute. *) + (* CR-someday mshinwell: Pierre noted that we might like a function to be + inlined when applied to its first set of arguments, e.g. for some kind + of type class like thing. *) + begin match (inline_requested : Lambda.inline_attribute) with + | Always_inline | Never_inline -> + Location.prerr_warning (Debuginfo.to_location dbg) + (Warnings.Inlining_impossible "[@inlined] attributes may not be used \ + on partial applications") + | Unroll _ -> + Location.prerr_warning (Debuginfo.to_location dbg) + (Warnings.Inlining_impossible "[@unroll] attributes may not be used \ + on partial applications") + | Default_inline -> () + end; + begin match (specialise_requested : Lambda.specialise_attribute) with + | Always_specialise | Never_specialise -> + Location.prerr_warning (Debuginfo.to_location dbg) + (Warnings.Inlining_impossible "[@specialised] attributes may not be used \ + on partial applications") + | Default_specialise -> () + end; + let freshened_params = + List.map (fun p -> Parameter.rename p) function_decl.A.params + in + let applied_args, remaining_args = + Misc.Stdlib.List.map2_prefix (fun arg id' -> id', arg) + args freshened_params + in + let wrapper_accepting_remaining_args = + let body : Flambda.t = + Apply { + func = lhs_of_application; + args = Parameter.List.vars freshened_params; + kind = Direct closure_id_being_applied; + dbg; + inline = Default_inline; + specialise = Default_specialise; + } + in + let closure_variable = + Variable.rename + (Closure_id.unwrap closure_id_being_applied) + in + Flambda_utils.make_closure_declaration ~id:closure_variable + ~is_classic_mode:false + ~body + ~params:remaining_args + ~stub:true + in + let with_known_args = + Flambda_utils.bind + ~bindings:(List.map (fun (param, arg) -> + Parameter.var param, Flambda.Expr (Var arg)) applied_args) + ~body:wrapper_accepting_remaining_args + in + simplify env r with_known_args + +and simplify_over_application env r ~args ~args_approxs ~function_decls + ~lhs_of_application ~closure_id_being_applied ~function_decl + ~value_set_of_closures ~dbg ~inline_requested ~specialise_requested = + let arity = A.function_arity function_decl in + assert (arity < List.length args); + assert (List.length args = List.length args_approxs); + let full_app_args, remaining_args = + Misc.Stdlib.List.split_at arity args + in + let full_app_approxs, _ = + Misc.Stdlib.List.split_at arity args_approxs + in + let expr, r = + simplify_full_application env r ~function_decls ~lhs_of_application + ~closure_id_being_applied ~function_decl ~value_set_of_closures + ~args:full_app_args ~args_approxs:full_app_approxs ~dbg + ~inline_requested ~specialise_requested + in + let func_var = Variable.create Internal_variable_names.full_apply in + let expr : Flambda.t = + Flambda.create_let func_var (Expr expr) + (Apply { func = func_var; args = remaining_args; kind = Indirect; dbg; + inline = inline_requested; specialise = specialise_requested; }) + in + let expr = Lift_code.lift_lets_expr expr ~toplevel:true in + simplify (E.set_never_inline env) r expr + +and simplify_named env r (tree : Flambda.named) : Flambda.named * R.t = + match tree with + | Symbol sym -> + (* New Symbol construction could have been introduced during + transformation (by simplify_named_using_approx_and_env). + When this comes from another compilation unit, we must load it. *) + let approx = E.find_or_load_symbol env sym in + simplify_named_using_approx r tree approx + | Const cst -> tree, ret r (simplify_const cst) + | Allocated_const cst -> tree, ret r (approx_for_allocated_const cst) + | Read_mutable mut_var -> + (* See comment on the [Assign] case. *) + let mut_var = + Freshening.apply_mutable_variable (E.freshening env) mut_var + in + Read_mutable mut_var, ret r (A.value_unknown Other) + | Read_symbol_field (symbol, field_index) -> + let approx = E.find_or_load_symbol env symbol in + begin match A.get_field approx ~field_index with + (* CR-someday mshinwell: Think about [Unreachable] vs. [Value_bottom]. *) + | Unreachable -> (Flambda.Expr Proved_unreachable), r + | Ok approx -> + let approx = A.augment_with_symbol_field approx symbol field_index in + simplify_named_using_approx_and_env env r tree approx + end + | Set_of_closures set_of_closures -> begin + let backend = E.backend env in + let set_of_closures, r, first_freshening = + simplify_set_of_closures env r set_of_closures + in + let simplify env r expr ~pass_name : Flambda.named * R.t = + (* If simplifying a set of closures more than once during any given round + of simplification, the [Freshening.Project_var] substitutions arising + from each call to [simplify_set_of_closures] must be composed. + Note that this function only composes with [first_freshening] owing + to the structure of the code below (this new [simplify] is always + in tail position). *) + (* CR-someday mshinwell: It was mooted that maybe we could try + structurally-typed closures (i.e. where we would never rename the + closure elements), or something else, to try to remove + the "closure freshening" thing in the approximation which is hard + to deal with. *) + let expr, r = simplify (E.set_never_inline env) r expr in + let approx = R.approx r in + let value_set_of_closures = + match A.strict_check_approx_for_set_of_closures approx with + | Wrong -> + Misc.fatal_errorf "Unexpected approximation returned from \ + simplification of [%s] result: %a" + pass_name A.print approx + | Ok (_var, value_set_of_closures) -> + let freshening = + Freshening.Project_var.compose ~earlier:first_freshening + ~later:value_set_of_closures.freshening + in + A.update_freshening_of_value_set_of_closures value_set_of_closures + ~freshening + in + Expr expr, (ret r (A.value_set_of_closures value_set_of_closures)) + in + (* This does the actual substitutions of specialised args introduced + by [Unbox_closures] for free variables. (Apart from simplifying + the [Unbox_closures] output, this also prevents applying + [Unbox_closures] over and over.) *) + let set_of_closures = + let ppf_dump = Inline_and_simplify_aux.Env.ppf_dump env in + match Remove_free_vars_equal_to_args.run ~ppf_dump set_of_closures with + | None -> set_of_closures + | Some set_of_closures -> set_of_closures + in + (* Do [Unbox_closures] next to try to decide which things are + free variables and which things are specialised arguments before + unboxing them. *) + match + Unbox_closures.rewrite_set_of_closures ~env + ~duplicate_function ~set_of_closures + with + | Some (expr, benefit) -> + let r = R.add_benefit r benefit in + simplify env r expr ~pass_name:"Unbox_closures" + | None -> + match Unbox_free_vars_of_closures.run ~env ~set_of_closures with + | Some (expr, benefit) -> + let r = R.add_benefit r benefit in + simplify env r expr ~pass_name:"Unbox_free_vars_of_closures" + | None -> + (* CR-soon mshinwell: should maybe add one allocation for the stub *) + match + Unbox_specialised_args.rewrite_set_of_closures ~env + ~duplicate_function ~set_of_closures + with + | Some (expr, benefit) -> + let r = R.add_benefit r benefit in + simplify env r expr ~pass_name:"Unbox_specialised_args" + | None -> + match + Remove_unused_arguments. + separate_unused_arguments_in_set_of_closures + set_of_closures ~backend + with + | Some set_of_closures -> + let expr = + Flambda_utils.name_expr (Set_of_closures set_of_closures) + ~name:Internal_variable_names.remove_unused_arguments + in + simplify env r expr ~pass_name:"Remove_unused_arguments" + | None -> + Set_of_closures set_of_closures, r + end + | Project_closure project_closure -> + simplify_project_closure env r ~project_closure + | Project_var project_var -> simplify_project_var env r ~project_var + | Move_within_set_of_closures move_within_set_of_closures -> + simplify_move_within_set_of_closures env r ~move_within_set_of_closures + | Prim (prim, args, dbg) -> + let dbg = E.add_inlined_debuginfo env ~dbg in + simplify_free_variables_named env args ~f:(fun env args args_approxs -> + let tree = Flambda.Prim (prim, args, dbg) in + begin match prim, args, args_approxs with + (* CR-someday mshinwell: Optimise [Pfield_computed]. *) + | Pfield field_index, [arg], [arg_approx] -> + let projection : Projection.t = Field (field_index, arg) in + begin match E.find_projection env ~projection with + | Some var -> + simplify_free_variable_named env var ~f:(fun _env var var_approx -> + let r = R.map_benefit r (B.remove_projection projection) in + Expr (Var var), ret r var_approx) + | None -> + begin match A.get_field arg_approx ~field_index with + | Unreachable -> (Flambda.Expr Proved_unreachable, r) + | Ok approx -> + let tree, approx = + match arg_approx.symbol with + (* If the [Pfield] is projecting directly from a symbol, rewrite + the expression to [Read_symbol_field]. *) + | Some (symbol, None) -> + let approx = + A.augment_with_symbol_field approx symbol field_index + in + Flambda.Read_symbol_field (symbol, field_index), approx + | None | Some (_, Some _ ) -> + (* This [Pfield] is either not projecting from a symbol at all, + or it is the projection of a projection from a symbol. *) + let approx' = E.really_import_approx env approx in + tree, approx' + in + simplify_named_using_approx_and_env env r tree approx + end + end + | Pfield _, _, _ -> Misc.fatal_error "Pfield arity error" + | (Parraysetu kind | Parraysets kind), + [_block; _field; _value], + [block_approx; _field_approx; value_approx] -> + if A.warn_on_mutation block_approx then begin + Location.prerr_warning (Debuginfo.to_location dbg) + Warnings.Assignment_to_non_mutable_value + end; + let kind = + let check () = + match kind with + | Pfloatarray | Pgenarray -> () + | Paddrarray | Pintarray -> + (* CR pchambart: Do a proper warning here *) + Misc.fatal_errorf "Assignment of a float to a specialised \ + non-float array: %a" + Flambda.print_named tree + in + match A.descr block_approx, A.descr value_approx with + | (Value_float_array _, _) -> check (); Lambda.Pfloatarray + | (_, Value_float _) when Config.flat_float_array -> + check (); Lambda.Pfloatarray + (* CR pchambart: This should be accounted by the benefit *) + | _ -> + kind + in + let prim : Clambda_primitives.primitive = match prim with + | Parraysetu _ -> Parraysetu kind + | Parraysets _ -> Parraysets kind + | _ -> assert false + in + Prim (prim, args, dbg), ret r (A.value_unknown Other) + | Psetfield _, _block::_, block_approx::_ -> + if A.warn_on_mutation block_approx then begin + Location.prerr_warning (Debuginfo.to_location dbg) + Warnings.Assignment_to_non_mutable_value + end; + tree, ret r (A.value_unknown Other) + | (Psetfield _ | Parraysetu _ | Parraysets _), _, _ -> + Misc.fatal_error "Psetfield / Parraysetu / Parraysets arity error" + | (Psequand | Psequor), _, _ -> + Misc.fatal_error "Psequand and Psequor must be expanded (see handling \ + in closure_conversion.ml)" + | p, args, args_approxs -> + let expr, approx, benefit = + let module Backend = (val (E.backend env) : Backend_intf.S) in + Simplify_primitives.primitive p (args, args_approxs) tree dbg + ~size_int:Backend.size_int + in + let r = R.map_benefit r (B.(+) benefit) in + let approx = + match p with + | Popaque -> A.value_unknown Other + | _ -> approx + in + expr, ret r approx + end) + | Expr expr -> + let expr, r = simplify env r expr in + Expr expr, r + +and simplify env r (tree : Flambda.t) : Flambda.t * R.t = + match tree with + | Var var -> + let var = Freshening.apply_variable (E.freshening env) var in + (* If from the approximations we can simplify [var], then we will be + forced to insert [let]-expressions (done using [name_expr], in + [Simple_value_approx]) to bind a [named]. This has an important + consequence: it brings bindings of constants closer to their use + points. *) + simplify_using_approx_and_env env r (Var var) (E.find_exn env var) + | Apply apply -> + simplify_apply env r ~apply + | Let _ -> + let for_defining_expr (env, r) var defining_expr = + let defining_expr, r = simplify_named env r defining_expr in + let var, sb = Freshening.add_variable (E.freshening env) var in + let env = E.set_freshening env sb in + let env = E.add env var (R.approx r) in + (env, r), var, defining_expr + in + let for_last_body (env, r) body = + simplify env r body + in + let filter_defining_expr r var defining_expr free_vars_of_body = + if Variable.Set.mem var free_vars_of_body then + r, var, Some defining_expr + else if Effect_analysis.no_effects_named defining_expr then + let r = R.map_benefit r (B.remove_code_named defining_expr) in + r, var, None + else + r, var, Some defining_expr + in + Flambda.fold_lets_option tree + ~init:(env, r) + ~for_defining_expr + ~for_last_body + ~filter_defining_expr + | Let_mutable { var = mut_var; initial_value = var; body; contents_kind } -> + (* CR-someday mshinwell: add the dead let elimination, as above. *) + simplify_free_variable env var ~f:(fun env var _var_approx -> + let mut_var, sb = + Freshening.add_mutable_variable (E.freshening env) mut_var + in + let env = E.set_freshening env sb in + let body, r = + simplify (E.add_mutable env mut_var (A.value_unknown Other)) r body + in + Flambda.Let_mutable + { var = mut_var; + initial_value = var; + body; + contents_kind }, + r) + | Let_rec (defs, body) -> + let defs, sb = Freshening.add_variables (E.freshening env) defs in + let env = E.set_freshening env sb in + let def_env = + List.fold_left (fun env_acc (id, _lam) -> + E.add env_acc id (A.value_unknown Other)) + env defs + in + let defs, body_env, r = + List.fold_right (fun (id, lam) (defs, env_acc, r) -> + let lam, r = simplify_named def_env r lam in + let defs = (id, lam) :: defs in + let env_acc = E.add env_acc id (R.approx r) in + defs, env_acc, r) + defs ([], env, r) + in + let body, r = simplify body_env r body in + Let_rec (defs, body), r + | Static_raise (i, args) -> + let i = Freshening.apply_static_exception (E.freshening env) i in + simplify_free_variables env args ~f:(fun _env args _args_approxs -> + let r = R.use_static_exception r i in + Static_raise (i, args), ret r A.value_bottom) + | Static_catch (i, vars, body, handler) -> + begin + match body with + | Let { var; defining_expr = def; body; _ } + when not (Flambda_utils.might_raise_static_exn def i) -> + simplify env r + (Flambda.create_let var def (Static_catch (i, vars, body, handler))) + | _ -> + let i, sb = Freshening.add_static_exception (E.freshening env) i in + let env = E.set_freshening env sb in + let body, r = simplify env r body in + (* CR-soon mshinwell: for robustness, R.used_static_exceptions should + maybe be removed. *) + if not (Static_exception.Set.mem i (R.used_static_exceptions r)) then + (* If the static exception is not used, we can drop the declaration *) + body, r + else begin + match (body : Flambda.t) with + | Static_raise (j, args) -> + assert (Static_exception.equal i j); + let handler = + List.fold_left2 (fun body var arg -> + Flambda.create_let var (Expr (Var arg)) body) + handler vars args + in + let r = R.exit_scope_catch r i in + simplify env r handler + | _ -> + let vars, sb = Freshening.add_variables' (E.freshening env) vars in + let approx = R.approx r in + let env = + List.fold_left (fun env id -> + E.add env id (A.value_unknown Other)) + (E.set_freshening env sb) vars + in + let env = E.inside_branch env in + let handler, r = simplify env r handler in + let r = R.exit_scope_catch r i in + Static_catch (i, vars, body, handler), + R.meet_approx r env approx + end + end + | Try_with (body, id, handler) -> + let body, r = simplify env r body in + let id, sb = Freshening.add_variable (E.freshening env) id in + let env = E.add (E.set_freshening env sb) id (A.value_unknown Other) in + let env = E.inside_branch env in + let handler, r = simplify env r handler in + Try_with (body, id, handler), ret r (A.value_unknown Other) + | If_then_else (arg, ifso, ifnot) -> + (* When arg is the constant false or true (or something considered + as true), we can drop the if and replace it by a sequence. + if arg is not effectful we can also drop it. *) + simplify_free_variable env arg ~f:(fun env arg arg_approx -> + begin match arg_approx.descr with + | Value_constptr 0 | Value_int 0 -> (* Constant [false]: keep [ifnot] *) + let ifnot, r = simplify env r ifnot in + ifnot, R.map_benefit r B.remove_branch + | Value_constptr _ | Value_int _ + | Value_block _ -> (* Constant [true]: keep [ifso] *) + let ifso, r = simplify env r ifso in + ifso, R.map_benefit r B.remove_branch + | _ -> + let env = E.inside_branch env in + let ifso, r = simplify env r ifso in + let ifso_approx = R.approx r in + let ifnot, r = simplify env r ifnot in + If_then_else (arg, ifso, ifnot), + R.meet_approx r env ifso_approx + end) + | While (cond, body) -> + let cond, r = simplify env r cond in + let body, r = simplify env r body in + While (cond, body), ret r (A.value_unknown Other) + | Send { kind; meth; obj; args; dbg; } -> + let dbg = E.add_inlined_debuginfo env ~dbg in + simplify_free_variable env meth ~f:(fun env meth _meth_approx -> + simplify_free_variable env obj ~f:(fun env obj _obj_approx -> + simplify_free_variables env args ~f:(fun _env args _args_approx -> + Send { kind; meth; obj; args; dbg; }, + ret r (A.value_unknown Other)))) + | For { bound_var; from_value; to_value; direction; body; } -> + simplify_free_variable env from_value ~f:(fun env from_value _approx -> + simplify_free_variable env to_value ~f:(fun env to_value _approx -> + let bound_var, sb = + Freshening.add_variable (E.freshening env) bound_var + in + let env = + E.add (E.set_freshening env sb) bound_var + (A.value_unknown Other) + in + let body, r = simplify env r body in + For { bound_var; from_value; to_value; direction; body; }, + ret r (A.value_unknown Other))) + | Assign { being_assigned; new_value; } -> + (* No need to use something like [simplify_free_variable]: the + approximation of [being_assigned] is always unknown. *) + let being_assigned = + Freshening.apply_mutable_variable (E.freshening env) being_assigned + in + simplify_free_variable env new_value ~f:(fun _env new_value _approx -> + Assign { being_assigned; new_value; }, ret r (A.value_unknown Other)) + | Switch (arg, sw) -> + (* When [arg] is known to be a variable whose approximation is that of a + block with a fixed tag or a fixed integer, we can eliminate the + [Switch]. (This should also make the [Let] that binds [arg] redundant, + meaning that it too can be eliminated.) *) + simplify_free_variable env arg ~f:(fun env arg arg_approx -> + let rec filter_branches filter branches compatible_branches = + match branches with + | [] -> Can_be_taken compatible_branches + | (c, lam) as branch :: branches -> + match filter arg_approx c with + | A.Cannot_be_taken -> + filter_branches filter branches compatible_branches + | A.Can_be_taken -> + filter_branches filter branches (branch :: compatible_branches) + | A.Must_be_taken -> + Must_be_taken lam + in + let filtered_consts = + filter_branches A.potentially_taken_const_switch_branch sw.consts [] + in + let filtered_blocks = + filter_branches A.potentially_taken_block_switch_branch sw.blocks [] + in + begin match filtered_consts, filtered_blocks with + | Must_be_taken _, Must_be_taken _ -> + assert false + | Must_be_taken branch, _ + | _, Must_be_taken branch -> + let lam, r = simplify env r branch in + lam, R.map_benefit r B.remove_branch + | Can_be_taken consts, Can_be_taken blocks -> + match consts, blocks, sw.failaction with + | [], [], None -> + (* If the switch is applied to a statically-known value that does not + match any case: + * if there is a default action take that case; + * otherwise this is something that is guaranteed not to + be reachable by the type checker. For example: + [type 'a t = Int : int -> int t | Float : float -> float t + match Int 1 with + | Int _ -> ... + | Float f as v -> + match v with <-- This match is unreachable + | Float f -> ...] + *) + Proved_unreachable, ret r A.value_bottom + | [_, branch], [], None + | [], [_, branch], None + | [], [], Some branch -> + let lam, r = simplify env r branch in + lam, R.map_benefit r B.remove_branch + | _ -> + let env = E.inside_branch env in + let f (i, v) (acc, r) = + let approx = R.approx r in + let lam, r = simplify env r v in + (i, lam)::acc, + R.meet_approx r env approx + in + let r = R.set_approx r A.value_bottom in + let consts, r = List.fold_right f consts ([], r) in + let blocks, r = List.fold_right f blocks ([], r) in + let failaction, r = + match sw.failaction with + | None -> None, r + | Some l -> + let approx = R.approx r in + let l, r = simplify env r l in + Some l, + R.meet_approx r env approx + in + let sw = { sw with failaction; consts; blocks; } in + Switch (arg, sw), r + end) + | String_switch (arg, sw, def) -> + simplify_free_variable env arg ~f:(fun env arg arg_approx -> + match A.check_approx_for_string arg_approx with + | None -> + let env = E.inside_branch env in + let sw, r = + List.fold_right (fun (str, lam) (sw, r) -> + let approx = R.approx r in + let lam, r = simplify env r lam in + (str, lam)::sw, + R.meet_approx r env approx) + sw + ([], r) + in + let def, r = + match def with + | None -> def, r + | Some def -> + let approx = R.approx r in + let def, r = simplify env r def in + Some def, + R.meet_approx r env approx + in + String_switch (arg, sw, def), ret r (A.value_unknown Other) + | Some arg_string -> + let branch = + match List.find (fun (str, _) -> String.equal str arg_string) sw with + | (_, branch) -> branch + | exception Not_found -> + match def with + | None -> + Flambda.Proved_unreachable + | Some def -> + def + in + let branch, r = simplify env r branch in + branch, R.map_benefit r B.remove_branch) + | Proved_unreachable -> tree, ret r A.value_bottom + +and simplify_list env r l = + match l with + | [] -> [], [], r + | h::t -> + let t', approxs, r = simplify_list env r t in + let h', r = simplify env r h in + let approxs = (R.approx r) :: approxs in + if t' == t && h' == h + then l, approxs, r + else h' :: t', approxs, r + +and duplicate_function ~env ~(set_of_closures : Flambda.set_of_closures) + ~fun_var ~new_fun_var = + let function_decl = + match Variable.Map.find fun_var set_of_closures.function_decls.funs with + | exception Not_found -> + Misc.fatal_errorf "duplicate_function: cannot find function %a" + Variable.print fun_var + | function_decl -> function_decl + in + let env = E.activate_freshening (E.set_never_inline env) in + let free_vars, specialised_args, function_decls, parameter_approximations, + _internal_value_set_of_closures, set_of_closures_env = + Inline_and_simplify_aux.prepare_to_simplify_set_of_closures ~env + ~set_of_closures ~function_decls:set_of_closures.function_decls + ~freshen:false ~only_for_function_decl:(Some function_decl) + in + let function_decl = + match Variable.Map.find fun_var function_decls.funs with + | exception Not_found -> + Misc.fatal_errorf "duplicate_function: cannot find function %a (2)" + Variable.print fun_var + | function_decl -> function_decl + in + let closure_env = + Inline_and_simplify_aux.prepare_to_simplify_closure ~function_decl + ~free_vars ~specialised_args ~parameter_approximations + ~set_of_closures_env + in + let body, _r = + E.enter_closure closure_env + ~closure_id:(Closure_id.wrap fun_var) + ~inline_inside:false + ~dbg:function_decl.dbg + ~f:(fun body_env -> + assert (E.inside_set_of_closures_declaration + function_decls.set_of_closures_origin body_env); + simplify body_env (R.create ()) function_decl.body) + in + let function_decl = + Flambda.create_function_declaration ~params:function_decl.params + ~body ~stub:function_decl.stub ~dbg:function_decl.dbg + ~inline:function_decl.inline ~specialise:function_decl.specialise + ~is_a_functor:function_decl.is_a_functor + ~closure_origin:(Closure_origin.create (Closure_id.wrap new_fun_var)) + in + function_decl, specialised_args + +let constant_defining_value_approx + env + (constant_defining_value:Flambda.constant_defining_value) = + match constant_defining_value with + | Allocated_const const -> + approx_for_allocated_const const + | Block (tag, fields) -> + let fields = + List.map + (function + | Flambda.Symbol sym -> begin + match E.find_symbol_opt env sym with + | Some approx -> approx + | None -> A.value_unresolved (Symbol sym) + end + | Flambda.Const cst -> simplify_const cst) + fields + in + A.value_block tag (Array.of_list fields) + | Set_of_closures { function_decls; free_vars; specialised_args } -> + (* At toplevel, there is no freshening currently happening (this + cannot be the body of a currently inlined function), so we can + keep the original set_of_closures in the approximation. *) + assert(Freshening.is_empty (E.freshening env)); + assert(Variable.Map.is_empty free_vars); + assert(Variable.Map.is_empty specialised_args); + let invariant_params = + lazy (Invariant_params.invariant_params_in_recursion function_decls + ~backend:(E.backend env)) + in + let recursive = + lazy (Find_recursive_functions.in_function_declarations function_decls + ~backend:(E.backend env)) + in + let value_set_of_closures = + let keep_body = + Inline_and_simplify_aux.keep_body_check + ~is_classic_mode:function_decls.is_classic_mode ~recursive + in + let function_decls = + A.function_declarations_approx ~keep_body function_decls + in + A.create_value_set_of_closures ~function_decls + ~bound_vars:Var_within_closure.Map.empty + ~invariant_params + ~recursive + ~specialised_args:Variable.Map.empty + ~free_vars:Variable.Map.empty + ~freshening:Freshening.Project_var.empty + ~direct_call_surrogates:Closure_id.Map.empty + in + A.value_set_of_closures value_set_of_closures + | Project_closure (set_of_closures_symbol, closure_id) -> begin + match E.find_symbol_opt env set_of_closures_symbol with + | None -> + A.value_unresolved (Symbol set_of_closures_symbol) + | Some set_of_closures_approx -> + let checked_approx = + A.check_approx_for_set_of_closures set_of_closures_approx + in + match checked_approx with + | Ok (_, value_set_of_closures) -> + let closure_id = + A.freshen_and_check_closure_id value_set_of_closures closure_id + in + A.value_closure value_set_of_closures closure_id + | Unresolved sym -> A.value_unresolved sym + | Unknown -> A.value_unknown Other + | Unknown_because_of_unresolved_value value -> + A.value_unknown (Unresolved_value value) + | Wrong -> + Misc.fatal_errorf "Wrong approximation for [Project_closure] \ + when being used as a [constant_defining_value]: %a" + Flambda.print_constant_defining_value constant_defining_value + end + +(* See documentation on [Let_rec_symbol] in flambda.mli. *) +let define_let_rec_symbol_approx orig_env defs = + (* First declare an empty version of the symbols *) + let init_env = + List.fold_left (fun building_env (symbol, _) -> + E.add_symbol building_env symbol (A.value_unresolved (Symbol symbol))) + orig_env defs + in + let rec loop times lookup_env = + if times <= 0 then + lookup_env + else + let env = + List.fold_left (fun building_env (symbol, constant_defining_value) -> + let approx = + constant_defining_value_approx lookup_env constant_defining_value + in + let approx = A.augment_with_symbol approx symbol in + E.add_symbol building_env symbol approx) + orig_env defs + in + loop (times-1) env + in + loop 2 init_env + +let simplify_constant_defining_value + env r symbol + (constant_defining_value:Flambda.constant_defining_value) = + let r, constant_defining_value, approx = + match constant_defining_value with + (* No simplifications are possible for [Allocated_const] or [Block]. *) + | Allocated_const const -> + r, constant_defining_value, approx_for_allocated_const const + | Block (tag, fields) -> + let fields = List.map + (function + | Flambda.Symbol sym -> E.find_symbol_exn env sym + | Flambda.Const cst -> simplify_const cst) + fields + in + r, constant_defining_value, A.value_block tag (Array.of_list fields) + | Set_of_closures set_of_closures -> + if Variable.Map.cardinal set_of_closures.free_vars <> 0 then begin + Misc.fatal_errorf "Set of closures bound by [Let_symbol] is not \ + closed: %a" + Flambda.print_set_of_closures set_of_closures + end; + let set_of_closures, r, _freshening = + simplify_set_of_closures env r set_of_closures + in + r, ((Set_of_closures set_of_closures) : Flambda.constant_defining_value), + R.approx r + | Project_closure (set_of_closures_symbol, closure_id) -> + (* No simplifications are necessary here. *) + let set_of_closures_approx = + E.find_symbol_exn env set_of_closures_symbol + in + let closure_approx = + match A.check_approx_for_set_of_closures set_of_closures_approx with + | Ok (_, value_set_of_closures) -> + let closure_id = + A.freshen_and_check_closure_id value_set_of_closures closure_id + in + A.value_closure value_set_of_closures closure_id + | Unresolved sym -> A.value_unresolved sym + | Unknown -> A.value_unknown Other + | Unknown_because_of_unresolved_value value -> + A.value_unknown (Unresolved_value value) + | Wrong -> + Misc.fatal_errorf "Wrong approximation for [Project_closure] \ + when being used as a [constant_defining_value]: %a" + Flambda.print_constant_defining_value constant_defining_value + in + r, constant_defining_value, closure_approx + in + let approx = A.augment_with_symbol approx symbol in + let r = ret r approx in + r, constant_defining_value, approx + +let rec simplify_program_body env r (program : Flambda.program_body) + : Flambda.program_body * R.t = + match program with + | Let_rec_symbol (defs, program) -> + let set_of_closures_defs, other_defs = + List.partition + (function + | (_, Flambda.Set_of_closures _) -> true + | _ -> false) + defs in + let process_defs ~lookup_env ~env r defs = + List.fold_left (fun (building_env, r, defs) (symbol, def) -> + let r, def, approx = + simplify_constant_defining_value lookup_env r symbol def + in + let approx = A.augment_with_symbol approx symbol in + let building_env = E.add_symbol building_env symbol approx in + (building_env, r, (symbol, def) :: defs)) + (env, r, []) defs + in + let env, r, set_of_closures_defs = + let lookup_env = define_let_rec_symbol_approx env defs in + process_defs ~lookup_env ~env r set_of_closures_defs + in + let env, r, other_defs = + let lookup_env = define_let_rec_symbol_approx env other_defs in + process_defs ~lookup_env ~env r other_defs + in + let program, r = simplify_program_body env r program in + Let_rec_symbol (set_of_closures_defs @ other_defs, program), r + | Let_symbol (symbol, constant_defining_value, program) -> + let r, constant_defining_value, approx = + simplify_constant_defining_value env r symbol constant_defining_value + in + let approx = A.augment_with_symbol approx symbol in + let env = E.add_symbol env symbol approx in + let program, r = simplify_program_body env r program in + Let_symbol (symbol, constant_defining_value, program), r + | Initialize_symbol (symbol, tag, fields, program) -> + let fields, approxs, r = simplify_list env r fields in + let approx = + A.augment_with_symbol (A.value_block tag (Array.of_list approxs)) symbol + in + let module Backend = (val (E.backend env) : Backend_intf.S) in + let env = E.add_symbol env symbol approx in + let program, r = simplify_program_body env r program in + Initialize_symbol (symbol, tag, fields, program), r + | Effect (expr, program) -> + let expr, r = simplify env r expr in + let program, r = simplify_program_body env r program in + Effect (expr, program), r + | End root -> End root, r + +let simplify_program env r (program : Flambda.program) = + let env, r = + Symbol.Set.fold (fun symbol (env, r) -> + let env, approx = + match E.find_symbol_exn env symbol with + | exception Not_found -> + let module Backend = (val (E.backend env) : Backend_intf.S) in + (* CR-someday mshinwell for mshinwell: Is there a reason we cannot + use [simplify_named_using_approx_and_env] here? *) + let approx = Backend.import_symbol symbol in + E.add_symbol env symbol approx, approx + | approx -> env, approx + in + env, ret r approx) + program.imported_symbols + (env, r) + in + let program_body, r = simplify_program_body env r program.program_body in + let program = { program with program_body; } in + program, r + +let add_predef_exns_to_environment ~env ~backend = + let module Backend = (val backend : Backend_intf.S) in + List.fold_left (fun env predef_exn -> + assert (Ident.is_predef predef_exn); + let symbol = Backend.symbol_for_global' predef_exn in + let name = Ident.name predef_exn in + let approx = + A.value_block Tag.object_tag + [| A.value_string (String.length name) (Some name); + A.value_unknown Other; + |] + in + E.add_symbol env symbol (A.augment_with_symbol approx symbol)) + env + Predef.all_predef_exns + +let run ~never_inline ~backend ~prefixname ~round ~ppf_dump program = + let r = R.create () in + let report = !Clflags.inlining_report in + if never_inline then Clflags.inlining_report := false; + let initial_env = + add_predef_exns_to_environment + ~env:(E.create ~never_inline ~backend ~round ~ppf_dump) + ~backend + in + let result, r = simplify_program initial_env r program in + let result = Flambda_utils.introduce_needed_import_symbols result in + if not (Static_exception.Set.is_empty (R.used_static_exceptions r)) + then begin + Misc.fatal_error (Format.asprintf "Remaining static exceptions: %a@.%a@." + Static_exception.Set.print (R.used_static_exceptions r) + Flambda.print_program result) + end; + assert (Static_exception.Set.is_empty (R.used_static_exceptions r)); + if !Clflags.inlining_report then begin + let output_prefix = Printf.sprintf "%s.%d" prefixname round in + Inlining_stats.save_then_forget_decisions ~output_prefix + end; + Clflags.inlining_report := report; + result diff --git a/middle_end/flambda/inline_and_simplify.mli b/middle_end/flambda/inline_and_simplify.mli new file mode 100644 index 0000000000..9a8e6e8b46 --- /dev/null +++ b/middle_end/flambda/inline_and_simplify.mli @@ -0,0 +1,40 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(** Simplification of Flambda programs combined with function inlining: + for the most part a beta-reduction pass. + + Readers interested in the inlining strategy should read the + [Inlining_decision] module first. +*) +val run + : never_inline:bool + -> backend:(module Backend_intf.S) + -> prefixname:string + -> round:int + -> ppf_dump:Format.formatter + -> Flambda.program + -> Flambda.program + +val duplicate_function + : env:Inline_and_simplify_aux.Env.t + -> set_of_closures:Flambda.set_of_closures + -> fun_var:Variable.t + -> new_fun_var:Variable.t + -> Flambda.function_declaration + * Flambda.specialised_to Variable.Map.t (* new specialised arguments *) diff --git a/middle_end/flambda/inline_and_simplify_aux.ml b/middle_end/flambda/inline_and_simplify_aux.ml new file mode 100644 index 0000000000..bb725e8c64 --- /dev/null +++ b/middle_end/flambda/inline_and_simplify_aux.ml @@ -0,0 +1,738 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +module Env = struct + type scope = Current | Outer + + type t = { + backend : (module Backend_intf.S); + round : int; + ppf_dump : Format.formatter; + approx : (scope * Simple_value_approx.t) Variable.Map.t; + approx_mutable : Simple_value_approx.t Mutable_variable.Map.t; + approx_sym : Simple_value_approx.t Symbol.Map.t; + projections : Variable.t Projection.Map.t; + current_functions : Set_of_closures_origin.Set.t; + (* The functions currently being declared: used to avoid inlining + recursively *) + inlining_level : int; + (* Number of times "inline" has been called recursively *) + inside_branch : int; + freshening : Freshening.t; + never_inline : bool ; + never_inline_inside_closures : bool; + never_inline_outside_closures : bool; + unroll_counts : int Set_of_closures_origin.Map.t; + inlining_counts : int Closure_origin.Map.t; + actively_unrolling : int Set_of_closures_origin.Map.t; + closure_depth : int; + inlining_stats_closure_stack : Inlining_stats.Closure_stack.t; + inlined_debuginfo : Debuginfo.t; + } + + let create ~never_inline ~backend ~round ~ppf_dump = + { backend; + round; + ppf_dump; + approx = Variable.Map.empty; + approx_mutable = Mutable_variable.Map.empty; + approx_sym = Symbol.Map.empty; + projections = Projection.Map.empty; + current_functions = Set_of_closures_origin.Set.empty; + inlining_level = 0; + inside_branch = 0; + freshening = Freshening.empty; + never_inline; + never_inline_inside_closures = false; + never_inline_outside_closures = false; + unroll_counts = Set_of_closures_origin.Map.empty; + inlining_counts = Closure_origin.Map.empty; + actively_unrolling = Set_of_closures_origin.Map.empty; + closure_depth = 0; + inlining_stats_closure_stack = + Inlining_stats.Closure_stack.create (); + inlined_debuginfo = Debuginfo.none; + } + + let backend t = t.backend + let round t = t.round + let ppf_dump t = t.ppf_dump + + let local env = + { env with + approx = Variable.Map.empty; + projections = Projection.Map.empty; + freshening = Freshening.empty_preserving_activation_state env.freshening; + inlined_debuginfo = Debuginfo.none; + } + + let inlining_level_up env = + let max_level = + Clflags.Int_arg_helper.get ~key:(env.round) !Clflags.inline_max_depth + in + if (env.inlining_level + 1) > max_level then + Misc.fatal_error "Inlining level increased above maximum"; + { env with inlining_level = env.inlining_level + 1 } + + let print ppf t = + Format.fprintf ppf + "Environment maps: %a@.Projections: %a@.Freshening: %a@." + Variable.Set.print (Variable.Map.keys t.approx) + (Projection.Map.print Variable.print) t.projections + Freshening.print t.freshening + + let mem t var = Variable.Map.mem var t.approx + + let add_internal t var (approx : Simple_value_approx.t) ~scope = + let approx = + (* The semantics of this [match] are what preserve the property + described at the top of simple_value_approx.mli, namely that when a + [var] is mem on an approximation (amongst many possible [var]s), + it is the one with the outermost scope. *) + match approx.var with + | Some var when mem t var -> approx + | _ -> Simple_value_approx.augment_with_variable approx var + in + { t with approx = Variable.Map.add var (scope, approx) t.approx } + + let add t var approx = add_internal t var approx ~scope:Current + let add_outer_scope t var approx = add_internal t var approx ~scope:Outer + + let add_mutable t mut_var approx = + { t with approx_mutable = + Mutable_variable.Map.add mut_var approx t.approx_mutable; + } + + let really_import_approx t = + let module Backend = (val (t.backend) : Backend_intf.S) in + Backend.really_import_approx + + let really_import_approx_with_scope t (scope, approx) = + scope, really_import_approx t approx + + let find_symbol_exn t symbol = + really_import_approx t + (Symbol.Map.find symbol t.approx_sym) + + let find_symbol_opt t symbol = + try Some (really_import_approx t + (Symbol.Map.find symbol t.approx_sym)) + with Not_found -> None + + let find_symbol_fatal t symbol = + match find_symbol_exn t symbol with + | exception Not_found -> + Misc.fatal_errorf "Symbol %a is unbound. Maybe there is a missing \ + [Let_symbol], [Import_symbol] or similar?" + Symbol.print symbol + | approx -> approx + + let find_or_load_symbol t symbol = + match find_symbol_exn t symbol with + | exception Not_found -> + if Compilation_unit.equal + (Compilation_unit.get_current_exn ()) + (Symbol.compilation_unit symbol) + then + Misc.fatal_errorf "Symbol %a from the current compilation unit is \ + unbound. Maybe there is a missing [Let_symbol] or similar?" + Symbol.print symbol; + let module Backend = (val (t.backend) : Backend_intf.S) in + Backend.import_symbol symbol + | approx -> approx + + let add_projection t ~projection ~bound_to = + { t with + projections = + Projection.Map.add projection bound_to t.projections; + } + + let find_projection t ~projection = + match Projection.Map.find projection t.projections with + | exception Not_found -> None + | var -> Some var + + let does_not_bind t vars = + not (List.exists (mem t) vars) + + let does_not_freshen t vars = + Freshening.does_not_freshen t.freshening vars + + let add_symbol t symbol approx = + match find_symbol_exn t symbol with + | exception Not_found -> + { t with + approx_sym = Symbol.Map.add symbol approx t.approx_sym; + } + | _ -> + Misc.fatal_errorf "Attempt to redefine symbol %a (to %a) in environment \ + for [Inline_and_simplify]" + Symbol.print symbol + Simple_value_approx.print approx + + let redefine_symbol t symbol approx = + match find_symbol_exn t symbol with + | exception Not_found -> + assert false + | _ -> + { t with + approx_sym = Symbol.Map.add symbol approx t.approx_sym; + } + + let find_with_scope_exn t id = + try + really_import_approx_with_scope t + (Variable.Map.find id t.approx) + with Not_found -> + Misc.fatal_errorf "Env.find_with_scope_exn: Unbound variable \ + %a@.%s@. Environment: %a@." + Variable.print id + (Printexc.raw_backtrace_to_string (Printexc.get_callstack max_int)) + print t + + let find_exn t id = + snd (find_with_scope_exn t id) + + let find_mutable_exn t mut_var = + try Mutable_variable.Map.find mut_var t.approx_mutable + with Not_found -> + Misc.fatal_errorf "Env.find_mutable_exn: Unbound variable \ + %a@.%s@. Environment: %a@." + Mutable_variable.print mut_var + (Printexc.raw_backtrace_to_string (Printexc.get_callstack max_int)) + print t + + let find_list_exn t vars = + List.map (fun var -> find_exn t var) vars + + let find_opt t id = + try Some (really_import_approx t + (snd (Variable.Map.find id t.approx))) + with Not_found -> None + + let activate_freshening t = + { t with freshening = Freshening.activate t.freshening } + + let enter_set_of_closures_declaration t origin = + { t with + current_functions = + Set_of_closures_origin.Set.add origin t.current_functions; } + + let inside_set_of_closures_declaration origin t = + Set_of_closures_origin.Set.mem origin t.current_functions + + let at_toplevel t = + t.closure_depth = 0 + + let is_inside_branch env = env.inside_branch > 0 + + let branch_depth env = env.inside_branch + + let inside_branch t = + { t with inside_branch = t.inside_branch + 1 } + + let set_freshening t freshening = + { t with freshening; } + + let increase_closure_depth t = + let approx = + Variable.Map.map (fun (_scope, approx) -> Outer, approx) t.approx + in + { t with + approx; + closure_depth = t.closure_depth + 1; + } + + let set_never_inline t = + if t.never_inline then t + else { t with never_inline = true } + + let set_never_inline_inside_closures t = + if t.never_inline_inside_closures then t + else { t with never_inline_inside_closures = true } + + let unset_never_inline_inside_closures t = + if t.never_inline_inside_closures then + { t with never_inline_inside_closures = false } + else t + + let set_never_inline_outside_closures t = + if t.never_inline_outside_closures then t + else { t with never_inline_outside_closures = true } + + let unset_never_inline_outside_closures t = + if t.never_inline_outside_closures then + { t with never_inline_outside_closures = false } + else t + + let actively_unrolling t origin = + match Set_of_closures_origin.Map.find origin t.actively_unrolling with + | count -> Some count + | exception Not_found -> None + + let start_actively_unrolling t origin i = + let actively_unrolling = + Set_of_closures_origin.Map.add origin i t.actively_unrolling + in + { t with actively_unrolling } + + let continue_actively_unrolling t origin = + let unrolling = + try + Set_of_closures_origin.Map.find origin t.actively_unrolling + with Not_found -> + Misc.fatal_error "Unexpected actively unrolled function" + in + let actively_unrolling = + Set_of_closures_origin.Map.add origin (unrolling - 1) t.actively_unrolling + in + { t with actively_unrolling } + + let unrolling_allowed t origin = + let unroll_count = + try + Set_of_closures_origin.Map.find origin t.unroll_counts + with Not_found -> + Clflags.Int_arg_helper.get + ~key:t.round !Clflags.inline_max_unroll + in + unroll_count > 0 + + let inside_unrolled_function t origin = + let unroll_count = + try + Set_of_closures_origin.Map.find origin t.unroll_counts + with Not_found -> + Clflags.Int_arg_helper.get + ~key:t.round !Clflags.inline_max_unroll + in + let unroll_counts = + Set_of_closures_origin.Map.add + origin (unroll_count - 1) t.unroll_counts + in + { t with unroll_counts } + + let inlining_allowed t id = + let inlining_count = + try + Closure_origin.Map.find id t.inlining_counts + with Not_found -> + max 1 (Clflags.Int_arg_helper.get + ~key:t.round !Clflags.inline_max_unroll) + in + inlining_count > 0 + + let inside_inlined_function t id = + let inlining_count = + try + Closure_origin.Map.find id t.inlining_counts + with Not_found -> + max 1 (Clflags.Int_arg_helper.get + ~key:t.round !Clflags.inline_max_unroll) + in + let inlining_counts = + Closure_origin.Map.add id (inlining_count - 1) t.inlining_counts + in + { t with inlining_counts } + + let inlining_level t = t.inlining_level + let freshening t = t.freshening + let never_inline t = t.never_inline || t.never_inline_outside_closures + + let note_entering_closure t ~closure_id ~dbg = + if t.never_inline then t + else + { t with + inlining_stats_closure_stack = + Inlining_stats.Closure_stack.note_entering_closure + t.inlining_stats_closure_stack ~closure_id ~dbg; + } + + let note_entering_call t ~closure_id ~dbg = + if t.never_inline then t + else + { t with + inlining_stats_closure_stack = + Inlining_stats.Closure_stack.note_entering_call + t.inlining_stats_closure_stack ~closure_id ~dbg; + } + + let note_entering_inlined t = + if t.never_inline then t + else + { t with + inlining_stats_closure_stack = + Inlining_stats.Closure_stack.note_entering_inlined + t.inlining_stats_closure_stack; + } + + let note_entering_specialised t ~closure_ids = + if t.never_inline then t + else + { t with + inlining_stats_closure_stack = + Inlining_stats.Closure_stack.note_entering_specialised + t.inlining_stats_closure_stack ~closure_ids; + } + + let enter_closure t ~closure_id ~inline_inside ~dbg ~f = + let t = + if inline_inside && not t.never_inline_inside_closures then t + else set_never_inline t + in + let t = unset_never_inline_outside_closures t in + f (note_entering_closure t ~closure_id ~dbg) + + let record_decision t decision = + Inlining_stats.record_decision decision + ~closure_stack:t.inlining_stats_closure_stack + + let set_inline_debuginfo t ~dbg = + { t with inlined_debuginfo = dbg } + + let add_inlined_debuginfo t ~dbg = + Debuginfo.concat t.inlined_debuginfo dbg +end + +let initial_inlining_threshold ~round : Inlining_cost.Threshold.t = + let unscaled = + Clflags.Float_arg_helper.get ~key:round !Clflags.inline_threshold + in + (* CR-soon pchambart: Add a warning if this is too big + mshinwell: later *) + Can_inline_if_no_larger_than + (int_of_float + (unscaled *. float_of_int Inlining_cost.scale_inline_threshold_by)) + +let initial_inlining_toplevel_threshold ~round : Inlining_cost.Threshold.t = + let ordinary_threshold = + Clflags.Float_arg_helper.get ~key:round !Clflags.inline_threshold + in + let toplevel_threshold = + Clflags.Int_arg_helper.get ~key:round !Clflags.inline_toplevel_threshold + in + let unscaled = + (int_of_float ordinary_threshold) + toplevel_threshold + in + (* CR-soon pchambart: Add a warning if this is too big + mshinwell: later *) + Can_inline_if_no_larger_than + (unscaled * Inlining_cost.scale_inline_threshold_by) + +module Result = struct + type t = + { approx : Simple_value_approx.t; + used_static_exceptions : Static_exception.Set.t; + inlining_threshold : Inlining_cost.Threshold.t option; + benefit : Inlining_cost.Benefit.t; + num_direct_applications : int; + } + + let create () = + { approx = Simple_value_approx.value_unknown Other; + used_static_exceptions = Static_exception.Set.empty; + inlining_threshold = None; + benefit = Inlining_cost.Benefit.zero; + num_direct_applications = 0; + } + + let approx t = t.approx + let set_approx t approx = { t with approx } + + let meet_approx t env approx = + let really_import_approx = Env.really_import_approx env in + let meet = + Simple_value_approx.meet ~really_import_approx t.approx approx + in + set_approx t meet + + let use_static_exception t i = + { t with + used_static_exceptions = + Static_exception.Set.add i t.used_static_exceptions; + } + + let used_static_exceptions t = t.used_static_exceptions + + let exit_scope_catch t i = + { t with + used_static_exceptions = + Static_exception.Set.remove i t.used_static_exceptions; + } + + let map_benefit t f = + { t with benefit = f t.benefit } + + let add_benefit t b = + { t with benefit = Inlining_cost.Benefit.(+) t.benefit b } + + let benefit t = t.benefit + + let reset_benefit t = + { t with benefit = Inlining_cost.Benefit.zero; } + + let set_inlining_threshold t inlining_threshold = + { t with inlining_threshold } + + let add_inlining_threshold t j = + match t.inlining_threshold with + | None -> t + | Some i -> + let inlining_threshold = Some (Inlining_cost.Threshold.add i j) in + { t with inlining_threshold } + + let sub_inlining_threshold t j = + match t.inlining_threshold with + | None -> t + | Some i -> + let inlining_threshold = Some (Inlining_cost.Threshold.sub i j) in + { t with inlining_threshold } + + let inlining_threshold t = t.inlining_threshold + + let seen_direct_application t = + { t with num_direct_applications = t.num_direct_applications + 1; } + + let num_direct_applications t = + t.num_direct_applications +end + +module A = Simple_value_approx +module E = Env + +let keep_body_check ~is_classic_mode ~recursive = + if not is_classic_mode then begin + fun _ _ -> true + end else begin + let can_inline_non_rec_function (fun_decl : Flambda.function_declaration) = + (* In classic-inlining mode, the inlining decision is taken at + definition site (here). If the function is small enough + (below the -inline threshold) it will always be inlined. + + Closure gives a bonus of [8] to optional arguments. In classic + mode, however, we would inline functions with the "*opt*" argument + in all cases, as it is a stub. (This is ensured by + [middle_end/closure_conversion.ml]). + *) + let inlining_threshold = initial_inlining_threshold ~round:0 in + let bonus = Flambda_utils.function_arity fun_decl in + Inlining_cost.can_inline fun_decl.body inlining_threshold ~bonus + in + fun (var : Variable.t) (fun_decl : Flambda.function_declaration) -> + if fun_decl.stub then begin + true + end else if Variable.Set.mem var (Lazy.force recursive) then begin + false + end else begin + match fun_decl.inline with + | Default_inline -> can_inline_non_rec_function fun_decl + | Unroll factor -> factor > 0 + | Always_inline -> true + | Never_inline -> false + end + end + +let prepare_to_simplify_set_of_closures ~env + ~(set_of_closures : Flambda.set_of_closures) + ~function_decls ~freshen + ~(only_for_function_decl : Flambda.function_declaration option) = + let free_vars = + Variable.Map.map (fun (external_var : Flambda.specialised_to) -> + let var = + let var = + Freshening.apply_variable (E.freshening env) external_var.var + in + match + A.simplify_var_to_var_using_env (E.find_exn env var) + ~is_present_in_env:(fun var -> E.mem env var) + with + | None -> var + | Some var -> var + in + let approx = E.find_exn env var in + (* The projections are freshened below in one step, once we know + the closure freshening substitution. *) + let projection = external_var.projection in + ({ var; projection; } : Flambda.specialised_to), approx) + set_of_closures.free_vars + in + let specialised_args = + Variable.Map.filter_map set_of_closures.specialised_args + ~f:(fun param (spec_to : Flambda.specialised_to) -> + let keep = + match only_for_function_decl with + | None -> true + | Some function_decl -> + Variable.Set.mem param (Parameter.Set.vars function_decl.params) + in + if not keep then None + else + let external_var = spec_to.var in + let var = + Freshening.apply_variable (E.freshening env) external_var + in + let var = + match + A.simplify_var_to_var_using_env (E.find_exn env var) + ~is_present_in_env:(fun var -> E.mem env var) + with + | None -> var + | Some var -> var + in + let projection = spec_to.projection in + Some ({ var; projection; } : Flambda.specialised_to)) + in + let environment_before_cleaning = env in + (* [E.local] helps us to catch bugs whereby variables escape their scope. *) + let env = E.local env in + let free_vars, function_decls, sb, freshening = + Freshening.apply_function_decls_and_free_vars (E.freshening env) free_vars + function_decls ~only_freshen_parameters:(not freshen) + in + let env = E.set_freshening env sb in + let free_vars = + Freshening.freshen_projection_relation' free_vars + ~freshening:(E.freshening env) + ~closure_freshening:freshening + in + let specialised_args = + let specialised_args = + Variable.Map.map_keys (Freshening.apply_variable (E.freshening env)) + specialised_args + in + Freshening.freshen_projection_relation specialised_args + ~freshening:(E.freshening env) + ~closure_freshening:freshening + in + let parameter_approximations = + (* Approximations of parameters that are known to always hold the same + argument throughout the body of the function. *) + Variable.Map.map_keys (Freshening.apply_variable (E.freshening env)) + (Variable.Map.mapi (fun _id' (spec_to : Flambda.specialised_to) -> + E.find_exn environment_before_cleaning spec_to.var) + specialised_args) + in + let direct_call_surrogates = + Variable.Map.fold (fun existing surrogate surrogates -> + let existing = + Freshening.Project_var.apply_closure_id freshening + (Closure_id.wrap existing) + in + let surrogate = + Freshening.Project_var.apply_closure_id freshening + (Closure_id.wrap surrogate) + in + assert (not (Closure_id.Map.mem existing surrogates)); + Closure_id.Map.add existing surrogate surrogates) + set_of_closures.direct_call_surrogates + Closure_id.Map.empty + in + let env = + E.enter_set_of_closures_declaration env + function_decls.set_of_closures_origin + in + (* we use the previous closure for evaluating the functions *) + let internal_value_set_of_closures = + let bound_vars = + Variable.Map.fold (fun id (_, desc) map -> + Var_within_closure.Map.add (Var_within_closure.wrap id) desc map) + free_vars Var_within_closure.Map.empty + in + let free_vars = Variable.Map.map fst free_vars in + let invariant_params = lazy Variable.Map.empty in + let recursive = lazy (Variable.Map.keys function_decls.funs) in + let is_classic_mode = function_decls.is_classic_mode in + let keep_body = keep_body_check ~is_classic_mode ~recursive in + let function_decls = + A.function_declarations_approx ~keep_body function_decls + in + A.create_value_set_of_closures ~function_decls ~bound_vars + ~free_vars ~invariant_params ~recursive ~specialised_args + ~freshening ~direct_call_surrogates + in + (* Populate the environment with the approximation of each closure. + This part of the environment is shared between all of the closures in + the set of closures. *) + let set_of_closures_env = + Variable.Map.fold (fun closure _ env -> + let approx = + A.value_closure ~closure_var:closure internal_value_set_of_closures + (Closure_id.wrap closure) + in + E.add env closure approx + ) + function_decls.funs env + in + free_vars, specialised_args, function_decls, parameter_approximations, + internal_value_set_of_closures, set_of_closures_env + +(* This adds only the minimal set of approximations to the closures. + It is not strictly necessary to have this restriction, but it helps + to catch potential substitution bugs. *) +let populate_closure_approximations + ~(function_decl : Flambda.function_declaration) + ~(free_vars : (_ * A.t) Variable.Map.t) + ~(parameter_approximations : A.t Variable.Map.t) + ~set_of_closures_env = + (* Add approximations of free variables *) + let env = + Variable.Map.fold (fun id (_, desc) env -> + E.add_outer_scope env id desc) + free_vars set_of_closures_env + in + (* Add known approximations of function parameters *) + let env = + List.fold_left (fun env id -> + let approx = + try Variable.Map.find id parameter_approximations + with Not_found -> (A.value_unknown Other) + in + E.add env id approx) + env (Parameter.List.vars function_decl.params) + in + env + +let prepare_to_simplify_closure ~(function_decl : Flambda.function_declaration) + ~free_vars ~specialised_args ~parameter_approximations + ~set_of_closures_env = + let closure_env = + populate_closure_approximations ~function_decl ~free_vars + ~parameter_approximations ~set_of_closures_env + in + (* Add definitions of known projections to the environment. *) + let add_projections ~closure_env ~which_variables ~map = + Variable.Map.fold (fun inner_var spec_arg env -> + let (spec_arg : Flambda.specialised_to) = map spec_arg in + match spec_arg.projection with + | None -> env + | Some projection -> + let from = Projection.projecting_from projection in + if Variable.Set.mem from function_decl.free_variables then + E.add_projection env ~projection ~bound_to:inner_var + else + env) + which_variables + closure_env + in + let closure_env = + add_projections ~closure_env ~which_variables:specialised_args + ~map:(fun spec_to -> spec_to) + in + add_projections ~closure_env ~which_variables:free_vars + ~map:(fun (spec_to, _approx) -> spec_to) diff --git a/middle_end/flambda/inline_and_simplify_aux.mli b/middle_end/flambda/inline_and_simplify_aux.mli new file mode 100644 index 0000000000..79d84a31b8 --- /dev/null +++ b/middle_end/flambda/inline_and_simplify_aux.mli @@ -0,0 +1,368 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(** Environments and result structures used during inlining and + simplification. (See inline_and_simplify.ml.) *) + +module Env : sig + (** Environments follow the lexical scopes of the program. *) + type t + + (** Create a new environment. If [never_inline] is true then the returned + environment will prevent [Inline_and_simplify] from inlining. The + [backend] parameter is used for passing information about the compiler + backend being used. + Newly-created environments have inactive [Freshening]s (see below) and do + not initially hold any approximation information. *) + val create + : never_inline:bool + -> backend:(module Backend_intf.S) + -> round:int + -> ppf_dump:Format.formatter + -> t + + (** Obtain the first-class module that gives information about the + compiler backend being used for compilation. *) + val backend : t -> (module Backend_intf.S) + + (** Obtain the really_import_approx function from the backend module. *) + val really_import_approx + : t + -> (Simple_value_approx.t -> Simple_value_approx.t) + + (** Which simplification round we are currently in. *) + val round : t -> int + + (** Where to print intermediate asts and similar debug information *) + val ppf_dump : t -> Format.formatter + + (** Add the approximation of a variable---that is to say, some knowledge + about the value(s) the variable may take on at runtime---to the + environment. *) + val add : t -> Variable.t -> Simple_value_approx.t -> t + + val add_outer_scope : t -> Variable.t -> Simple_value_approx.t -> t + + (** Like [add], but for mutable variables. *) + val add_mutable : t -> Mutable_variable.t -> Simple_value_approx.t -> t + + (** Find the approximation of a given variable, raising a fatal error if + the environment does not know about the variable. Use [find_opt] + instead if you need to catch the failure case. *) + val find_exn : t -> Variable.t -> Simple_value_approx.t + + (** Like [find_exn], but for mutable variables. *) + val find_mutable_exn : t -> Mutable_variable.t -> Simple_value_approx.t + + type scope = Current | Outer + + val find_with_scope_exn : t -> Variable.t -> scope * Simple_value_approx.t + + (** Like [find_exn], but intended for use where the "not present in + environment" case is to be handled by the caller. *) + val find_opt : t -> Variable.t -> Simple_value_approx.t option + + (** Like [find_exn], but for a list of variables. *) + val find_list_exn : t -> Variable.t list -> Simple_value_approx.t list + + val does_not_bind : t -> Variable.t list -> bool + + val does_not_freshen : t -> Variable.t list -> bool + + val add_symbol : t -> Symbol.t -> Simple_value_approx.t -> t + val redefine_symbol : t -> Symbol.t -> Simple_value_approx.t -> t + val find_symbol_exn : t -> Symbol.t -> Simple_value_approx.t + val find_symbol_opt : t -> Symbol.t -> Simple_value_approx.t option + val find_symbol_fatal : t -> Symbol.t -> Simple_value_approx.t + + (* Like [find_symbol_exn], but load the symbol approximation using + the backend if not available in the environment. *) + val find_or_load_symbol : t -> Symbol.t -> Simple_value_approx.t + + (** Note that the given [bound_to] holds the given [projection]. *) + val add_projection + : t + -> projection:Projection.t + -> bound_to:Variable.t + -> t + + (** Determine if the environment knows about a variable that is bound + to the given [projection]. *) + val find_projection + : t + -> projection:Projection.t + -> Variable.t option + + (** Whether the environment has an approximation for the given variable. *) + val mem : t -> Variable.t -> bool + + (** Return the freshening that should be applied to variables when + rewriting code (in [Inline_and_simplify], etc.) using the given + environment. *) + val freshening : t -> Freshening.t + + (** Set the freshening that should be used as per [freshening], above. *) + val set_freshening : t -> Freshening.t -> t + + (** Causes every bound variable in code rewritten during inlining and + simplification, using the given environment, to be freshened. This is + used when descending into subexpressions substituted into existing + expressions. *) + val activate_freshening : t -> t + + (** Erase all variable approximation information and freshening information + from the given environment. However, the freshening activation state + is preserved. This function is used when rewriting inside a function + declaration, to avoid (due to a compiler bug) accidental use of + variables from outer scopes that are not accessible. *) + val local : t -> t + + (** Determine whether the inliner is currently inside a function body from + the given set of closures. This is used to detect whether a given + function call refers to a function which exists somewhere on the current + inlining stack. *) + val inside_set_of_closures_declaration : Set_of_closures_origin.t -> t -> bool + + (** Not inside a closure declaration. + Toplevel code is the one evaluated when the compilation unit is + loaded *) + val at_toplevel : t -> bool + + val is_inside_branch : t -> bool + val branch_depth : t -> int + val inside_branch : t -> t + + val increase_closure_depth : t -> t + + (** Mark that call sites contained within code rewritten using the given + environment should never be replaced by inlined (or unrolled) versions + of the callee(s). *) + val set_never_inline : t -> t + + (** Equivalent to [set_never_inline] but only applies to code inside + a set of closures. *) + val set_never_inline_inside_closures : t -> t + + (** Unset the restriction from [set_never_inline_inside_closures] *) + val unset_never_inline_inside_closures : t -> t + + (** Equivalent to [set_never_inline] but does not apply to code inside + a set of closures. *) + val set_never_inline_outside_closures : t -> t + + (** Unset the restriction from [set_never_inline_outside_closures] *) + val unset_never_inline_outside_closures : t -> t + + (** Return whether [set_never_inline] is currently in effect on the given + environment. *) + val never_inline : t -> bool + + val inlining_level : t -> int + + (** Mark that this environment is used to rewrite code for inlining. This is + used by the inlining heuristics to decide whether to continue. + Unconditionally inlined does not take this into account. *) + val inlining_level_up : t -> t + + (** Whether we are actively unrolling a given function. *) + val actively_unrolling : t -> Set_of_closures_origin.t -> int option + + (** Start actively unrolling a given function [n] times. *) + val start_actively_unrolling : t -> Set_of_closures_origin.t -> int -> t + + (** Unroll a function currently actively being unrolled. *) + val continue_actively_unrolling : t -> Set_of_closures_origin.t -> t + + (** Whether it is permissible to unroll a call to a recursive function + in the given environment. *) + val unrolling_allowed : t -> Set_of_closures_origin.t -> bool + + (** Whether the given environment is currently being used to rewrite the + body of an unrolled recursive function. *) + val inside_unrolled_function : t -> Set_of_closures_origin.t -> t + + (** Whether it is permissible to inline a call to a function in the given + environment. *) + val inlining_allowed : t -> Closure_origin.t -> bool + + (** Whether the given environment is currently being used to rewrite the + body of an inlined function. *) + val inside_inlined_function : t -> Closure_origin.t -> t + + (** If collecting inlining statistics, record that the inliner is about to + descend into [closure_id]. This information enables us to produce a + stack of closures that form a kind of context around an inlining + decision point. *) + val note_entering_closure + : t + -> closure_id:Closure_id.t + -> dbg:Debuginfo.t + -> t + + (** If collecting inlining statistics, record that the inliner is about to + descend into a call to [closure_id]. This information enables us to + produce a stack of closures that form a kind of context around an + inlining decision point. *) + val note_entering_call + : t + -> closure_id:Closure_id.t + -> dbg:Debuginfo.t + -> t + + (** If collecting inlining statistics, record that the inliner is about to + descend into an inlined function call. This requires that the inliner + has already entered the call with [note_entering_call]. *) + val note_entering_inlined : t -> t + + (** If collecting inlining statistics, record that the inliner is about to + descend into a specialised function definition. This requires that the + inliner has already entered the call with [note_entering_call]. *) + val note_entering_specialised : t -> closure_ids:Closure_id.Set.t -> t + + (** Update a given environment to record that the inliner is about to + descend into [closure_id] and pass the resulting environment to [f]. + If [inline_inside] is [false] then the environment passed to [f] will be + marked as [never_inline] (see above). *) + val enter_closure + : t + -> closure_id:Closure_id.t + -> inline_inside:bool + -> dbg:Debuginfo.t + -> f:(t -> 'a) + -> 'a + + (** If collecting inlining statistics, record an inlining decision for the + call at the top of the closure stack stored inside the given + environment. *) + val record_decision + : t + -> Inlining_stats_types.Decision.t + -> unit + + (** Print a human-readable version of the given environment. *) + val print : Format.formatter -> t -> unit + + (** The environment stores the call-site being inlined to produce + precise location information. This function sets the current + call-site being inlined. *) + val set_inline_debuginfo : t -> dbg:Debuginfo.t -> t + + (** Appends the locations of inlined call-sites to the [~dbg] argument *) + val add_inlined_debuginfo : t -> dbg:Debuginfo.t -> Debuginfo.t +end + +module Result : sig + (** Result structures approximately follow the evaluation order of the + program. They are returned by the simplification algorithm acting on + an Flambda subexpression. *) + type t + + val create : unit -> t + + (** The approximation of the subexpression that has just been + simplified. *) + val approx : t -> Simple_value_approx.t + + (** Set the approximation of the subexpression that has just been + simplified. Typically used just before returning from a case of the + simplification algorithm. *) + val set_approx : t -> Simple_value_approx.t -> t + + (** Set the approximation of the subexpression to the meet of the + current return approximation and the provided one. Typically + used just before returning from a branch case of the + simplification algorithm. *) + val meet_approx : t -> Env.t -> Simple_value_approx.t -> t + + (** All static exceptions for which [use_staticfail] has been called on + the given result structure. *) + val used_static_exceptions : t -> Static_exception.Set.t + + (** Mark that the given static exception has been used. *) + val use_static_exception : t -> Static_exception.t -> t + + (** Mark that we are moving up out of the scope of a static-catch block + that catches the given static exception identifier. This has the effect + of removing the identifier from the [used_staticfail] set. *) + val exit_scope_catch : t -> Static_exception.t -> t + + (** The benefit to be gained by inlining the subexpression whose + simplification yielded the given result structure. *) + val benefit : t -> Inlining_cost.Benefit.t + + (** Apply a transformation to the inlining benefit stored within the + given result structure. *) + val map_benefit + : t + -> (Inlining_cost.Benefit.t -> Inlining_cost.Benefit.t) + -> t + + (** Add some benefit to the inlining benefit stored within the + given result structure. *) + val add_benefit : t -> Inlining_cost.Benefit.t -> t + + (** Set the benefit of inlining the subexpression corresponding to the + given result structure to zero. *) + val reset_benefit : t -> t + + val set_inlining_threshold : + t -> Inlining_cost.Threshold.t option -> t + val add_inlining_threshold : + t -> Inlining_cost.Threshold.t -> t + val sub_inlining_threshold : + t -> Inlining_cost.Threshold.t -> t + val inlining_threshold : t -> Inlining_cost.Threshold.t option + + val seen_direct_application : t -> t + val num_direct_applications : t -> int +end + +(** Command line argument -inline *) +val initial_inlining_threshold : round:int -> Inlining_cost.Threshold.t + +(** Command line argument -inline-toplevel *) +val initial_inlining_toplevel_threshold + : round:int -> Inlining_cost.Threshold.t + +val prepare_to_simplify_set_of_closures + : env:Env.t + -> set_of_closures:Flambda.set_of_closures + -> function_decls:Flambda.function_declarations + -> freshen:bool + -> only_for_function_decl:Flambda.function_declaration option + -> (Flambda.specialised_to * Simple_value_approx.t) Variable.Map.t (* fvs *) + * Flambda.specialised_to Variable.Map.t (* specialised arguments *) + * Flambda.function_declarations + * Simple_value_approx.t Variable.Map.t (* parameter approximations *) + * Simple_value_approx.value_set_of_closures + * Env.t + +val prepare_to_simplify_closure + : function_decl:Flambda.function_declaration + -> free_vars:(Flambda.specialised_to * Simple_value_approx.t) Variable.Map.t + -> specialised_args:Flambda.specialised_to Variable.Map.t + -> parameter_approximations:Simple_value_approx.t Variable.Map.t + -> set_of_closures_env:Env.t + -> Env.t + +val keep_body_check + : is_classic_mode:bool + -> recursive:Variable.Set.t Lazy.t + -> Variable.t + -> Flambda.function_declaration + -> bool diff --git a/middle_end/flambda/inlining_cost.ml b/middle_end/flambda/inlining_cost.ml new file mode 100644 index 0000000000..33e870f90a --- /dev/null +++ b/middle_end/flambda/inlining_cost.ml @@ -0,0 +1,700 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +(* Simple approximation of the space cost of a primitive. *) + +let prim_size (prim : Clambda_primitives.primitive) args = + match prim with + | Pmakeblock _ -> 5 + List.length args + | Pfield _ -> 1 + | Psetfield (_, isptr, init) -> + begin match init with + | Root_initialization -> 1 (* never causes a write barrier hit *) + | Assignment | Heap_initialization -> + match isptr with + | Pointer -> 4 + | Immediate -> 1 + end + | Pfloatfield _ -> 1 + | Psetfloatfield _ -> 1 + | Pduprecord _ -> 10 + List.length args + | Pccall p -> (if p.Primitive.prim_alloc then 10 else 4) + List.length args + | Praise _ -> 4 + | Pstringlength -> 5 + | Pbyteslength -> 5 + | Pstringrefs -> 6 + | Pbytesrefs | Pbytessets -> 6 + | Pmakearray _ -> 5 + List.length args + | Parraylength Pgenarray -> 6 + | Parraylength _ -> 2 + | Parrayrefu Pgenarray -> 12 + | Parrayrefu _ -> 2 + | Parraysetu Pgenarray -> 16 + | Parraysetu _ -> 4 + | Parrayrefs Pgenarray -> 18 + | Parrayrefs _ -> 8 + | Parraysets Pgenarray -> 22 + | Parraysets _ -> 10 + | Pbigarrayref (_, ndims, _, _) -> 4 + ndims * 6 + | Pbigarrayset (_, ndims, _, _) -> 4 + ndims * 6 + | Psequand | Psequor -> + Misc.fatal_error "Psequand and Psequor are not allowed in Prim \ + expressions; translate out instead (cf. closure_conversion.ml)" + (* CR-soon mshinwell: This match must be made exhaustive. + mshinwell: Let's do this when we have the new size computation. *) + | _ -> 2 (* arithmetic and comparisons *) + +(* Simple approximation of the space cost of an Flambda expression. *) + +(* CR-soon mshinwell: Investigate revised size numbers. *) + +let direct_call_size = 4 +let project_size = 1 + +let lambda_smaller' lam ~than:threshold = + let size = ref 0 in + let rec lambda_size (lam : Flambda.t) = + if !size > threshold then raise Exit; + match lam with + | Var _ -> () + | Apply ({ func = _; args = _; kind = direct }) -> + let call_cost = + match direct with Indirect -> 6 | Direct _ -> direct_call_size + in + size := !size + call_cost + | Assign _ -> incr size + | Send _ -> size := !size + 8 + | Proved_unreachable -> () + | Let { defining_expr; body; _ } -> + lambda_named_size defining_expr; + lambda_size body + | Let_mutable { body } -> lambda_size body + | Let_rec (bindings, body) -> + List.iter (fun (_, lam) -> lambda_named_size lam) bindings; + lambda_size body + | Switch (_, sw) -> + let aux = function _::_::_ -> size := !size + 5 | _ -> () in + aux sw.consts; aux sw.blocks; + List.iter (fun (_, lam) -> lambda_size lam) sw.consts; + List.iter (fun (_, lam) -> lambda_size lam) sw.blocks; + Option.iter lambda_size sw.failaction + | String_switch (_, sw, def) -> + List.iter (fun (_, lam) -> + size := !size + 2; + lambda_size lam) + sw; + Misc.may lambda_size def + | Static_raise _ -> () + | Static_catch (_, _, body, handler) -> + incr size; lambda_size body; lambda_size handler + | Try_with (body, _, handler) -> + size := !size + 8; lambda_size body; lambda_size handler + | If_then_else (_, ifso, ifnot) -> + size := !size + 2; + lambda_size ifso; lambda_size ifnot + | While (cond, body) -> + size := !size + 2; lambda_size cond; lambda_size body + | For { body; _ } -> + size := !size + 4; lambda_size body + and lambda_named_size (named : Flambda.named) = + if !size > threshold then raise Exit; + match named with + | Symbol _ | Read_mutable _ -> () + | Const _ | Allocated_const _ -> incr size + | Read_symbol_field _ -> incr size + | Set_of_closures ({ function_decls = ffuns }) -> + Variable.Map.iter (fun _ (ffun : Flambda.function_declaration) -> + lambda_size ffun.body) + ffuns.funs + | Project_closure _ | Project_var _ -> + size := !size + project_size + | Move_within_set_of_closures _ -> + incr size + | Prim (prim, args, _) -> + size := !size + prim_size prim args + | Expr expr -> lambda_size expr + in + try + lambda_size lam; + if !size <= threshold then Some !size + else None + with Exit -> + None + +let lambda_size lam = + match lambda_smaller' lam ~than:max_int with + | Some size -> + size + | None -> + (* There is no way that an expression of size max_int could fit in + memory. *) + assert false + +module Threshold = struct + + type t = + | Never_inline + | Can_inline_if_no_larger_than of int + + let add t1 t2 = + match t1, t2 with + | Never_inline, t -> t + | t, Never_inline -> t + | Can_inline_if_no_larger_than i1, Can_inline_if_no_larger_than i2 -> + Can_inline_if_no_larger_than (i1 + i2) + + let sub t1 t2 = + match t1, t2 with + | Never_inline, _ -> Never_inline + | t, Never_inline -> t + | Can_inline_if_no_larger_than i1, Can_inline_if_no_larger_than i2 -> + if i1 > i2 then Can_inline_if_no_larger_than (i1 - i2) + else Never_inline + + let min t1 t2 = + match t1, t2 with + | Never_inline, _ -> Never_inline + | _, Never_inline -> Never_inline + | Can_inline_if_no_larger_than i1, Can_inline_if_no_larger_than i2 -> + Can_inline_if_no_larger_than (min i1 i2) + + let equal t1 t2 = + match t1, t2 with + | Never_inline, Never_inline -> true + | Can_inline_if_no_larger_than i1, Can_inline_if_no_larger_than i2 -> + i1 = i2 + | (Never_inline | Can_inline_if_no_larger_than _), _ -> + false + +end + +let can_try_inlining lam inlining_threshold ~number_of_arguments + ~size_from_approximation = + match inlining_threshold with + | Threshold.Never_inline -> Threshold.Never_inline + | Threshold.Can_inline_if_no_larger_than inlining_threshold -> + let bonus = + (* removing a call will reduce the size by at least the number + of arguments *) + number_of_arguments + in + let size = + let than = inlining_threshold + bonus in + match size_from_approximation with + | Some size -> if size <= than then Some size else None + | None -> lambda_smaller' lam ~than + in + match size with + | None -> Threshold.Never_inline + | Some size -> + Threshold.Can_inline_if_no_larger_than + (inlining_threshold - size + bonus) + +let lambda_smaller lam ~than = + match lambda_smaller' lam ~than with + | Some _ -> true + | None -> false + +let can_inline lam inlining_threshold ~bonus = + match inlining_threshold with + | Threshold.Never_inline -> false + | Threshold.Can_inline_if_no_larger_than inlining_threshold -> + lambda_smaller + lam + ~than:(inlining_threshold + bonus) + +let cost (flag : Clflags.Int_arg_helper.parsed) ~round = + Clflags.Int_arg_helper.get ~key:round flag + +let benefit_factor = 1 + +module Benefit = struct + type t = { + remove_call : int; + remove_alloc : int; + remove_prim : int; + remove_branch : int; + (* CR-someday pchambart: branch_benefit : t list; *) + direct_call_of_indirect : int; + requested_inline : int; + (* Benefit to compensate the size of functions marked for inlining *) + } + + let zero = { + remove_call = 0; + remove_alloc = 0; + remove_prim = 0; + remove_branch = 0; + direct_call_of_indirect = 0; + requested_inline = 0; + } + + let remove_call t = { t with remove_call = t.remove_call + 1; } + let remove_alloc t = { t with remove_alloc = t.remove_alloc + 1; } + let remove_prim t = { t with remove_prim = t.remove_prim + 1; } + let remove_prims t n = { t with remove_prim = t.remove_prim + n; } + let remove_branch t = { t with remove_branch = t.remove_branch + 1; } + let direct_call_of_indirect t = + { t with direct_call_of_indirect = t.direct_call_of_indirect + 1; } + let requested_inline t ~size_of = + let size = lambda_size size_of in + { t with requested_inline = t.requested_inline + size; } + + let remove_code_helper b (flam : Flambda.t) = + match flam with + | Assign _ -> b := remove_prim !b + | Switch _ | String_switch _ | Static_raise _ | Try_with _ + | If_then_else _ | While _ | For _ -> b := remove_branch !b + | Apply _ | Send _ -> b := remove_call !b + | Let _ | Let_mutable _ | Let_rec _ | Proved_unreachable | Var _ + | Static_catch _ -> () + + let remove_code_helper_named b (named : Flambda.named) = + match named with + | Set_of_closures _ + | Prim ((Pmakearray _ | Pmakeblock _ | Pduprecord _), _, _) -> + b := remove_alloc !b + (* CR-soon pchambart: should we consider that boxed integer and float + operations are allocations ? *) + | Prim _ | Project_closure _ | Project_var _ + | Move_within_set_of_closures _ + | Read_symbol_field _ -> b := remove_prim !b + | Symbol _ | Read_mutable _ | Allocated_const _ | Const _ | Expr _ -> () + + let remove_code lam b = + let b = ref b in + Flambda_iterators.iter_toplevel (remove_code_helper b) + (remove_code_helper_named b) lam; + !b + + let remove_code_named lam b = + let b = ref b in + Flambda_iterators.iter_named_toplevel (remove_code_helper b) + (remove_code_helper_named b) lam; + !b + + let remove_projection (_proj : Projection.t) b = + (* They are all primitives for the moment. The [Projection.t] argument + is here for future expansion. *) + remove_prim b + + let print ppf b = + Format.fprintf ppf "@[remove_call: %i@ remove_alloc: %i@ \ + remove_prim: %i@ remove_branch: %i@ \ + direct: %i@ requested: %i@]" + b.remove_call + b.remove_alloc + b.remove_prim + b.remove_branch + b.direct_call_of_indirect + b.requested_inline + + let evaluate t ~round : int = + benefit_factor * + (t.remove_call * (cost !Clflags.inline_call_cost ~round) + + t.remove_alloc * (cost !Clflags.inline_alloc_cost ~round) + + t.remove_prim * (cost !Clflags.inline_prim_cost ~round) + + t.remove_branch * (cost !Clflags.inline_branch_cost ~round) + + (t.direct_call_of_indirect + * (cost !Clflags.inline_indirect_cost ~round))) + + t.requested_inline + + let (+) t1 t2 = { + remove_call = t1.remove_call + t2.remove_call; + remove_alloc = t1.remove_alloc + t2.remove_alloc; + remove_prim = t1.remove_prim + t2.remove_prim; + remove_branch = t1.remove_branch + t2.remove_branch; + direct_call_of_indirect = + t1.direct_call_of_indirect + t2.direct_call_of_indirect; + requested_inline = t1.requested_inline + t2.requested_inline; + } + + let (-) t1 t2 = { + remove_call = t1.remove_call - t2.remove_call; + remove_alloc = t1.remove_alloc - t2.remove_alloc; + remove_prim = t1.remove_prim - t2.remove_prim; + remove_branch = t1.remove_branch - t2.remove_branch; + direct_call_of_indirect = + t1.direct_call_of_indirect - t2.direct_call_of_indirect; + requested_inline = t1.requested_inline - t2.requested_inline; + } + + let max ~round t1 t2 = + let c1 = evaluate ~round t1 in + let c2 = evaluate ~round t2 in + if c1 > c2 then t1 else t2 + + let add_code lam b = + b - (remove_code lam zero) + + let add_code_named lam b = + b - (remove_code_named lam zero) + + let add_projection proj b = + b - (remove_projection proj zero) + + (* Print out a benefit as a table *) + + let benefit_table = + [ "Calls", (fun b -> b.remove_call); + "Allocs", (fun b -> b.remove_alloc); + "Prims", (fun b -> b.remove_prim); + "Branches", (fun b -> b.remove_branch); + "Indirect calls", (fun b -> b.direct_call_of_indirect); + ] + + let benefits_table = + lazy begin + List.map + (fun (header, accessor) -> (header, accessor, String.length header)) + benefit_table + end + + let table_line = + lazy begin + let benefits_table = Lazy.force benefits_table in + let dashes = + List.map (fun (_, _, n) -> String.make n '-') benefits_table + in + "|-" ^ String.concat "-+-" dashes ^ "-|" + end + + let table_headers = + lazy begin + let benefits_table = Lazy.force benefits_table in + let headers = List.map (fun (head, _, _) -> head) benefits_table in + "| " ^ String.concat " | " headers ^ " |" + end + + let print_table_values ppf b = + let rec loop ppf = function + | [] -> Format.fprintf ppf "|" + | (_, accessor, width) :: rest -> + Format.fprintf ppf "| %*d %a" width (accessor b) loop rest + in + loop ppf (Lazy.force benefits_table) + + let print_table ppf b = + let table_line = Lazy.force table_line in + let table_headers = Lazy.force table_headers in + Format.fprintf ppf + "@[@[%s@]@;@[%s@]@;@[%s@]@;@[%a@]@;@[%s@]@]" + table_line table_headers table_line + print_table_values b + table_line +end + +module Whether_sufficient_benefit = struct + type t = { + round : int; + benefit : Benefit.t; + toplevel : bool; + branch_depth : int; + lifting : bool; + original_size : int; + new_size : int; + evaluated_benefit : int; + estimate : bool; + } + + let create ~original ~toplevel ~branch_depth lam ~benefit ~lifting ~round = + let evaluated_benefit = Benefit.evaluate benefit ~round in + { round; benefit; toplevel; branch_depth; lifting; + original_size = lambda_size original; + new_size = lambda_size lam; + evaluated_benefit; + estimate = false; + } + + let create_estimate ~original_size ~toplevel ~branch_depth ~new_size + ~benefit ~lifting ~round = + let evaluated_benefit = Benefit.evaluate benefit ~round in + { round; benefit; toplevel; branch_depth; lifting; original_size; + new_size; evaluated_benefit; estimate = true; + } + + let is_nan f = + match Float.classify_float f with + | FP_nan -> true + | FP_normal | FP_subnormal | FP_zero | FP_infinite -> false + + let correct_branch_factor f = + (not (is_nan f)) + && (Float.compare f 0. >= 0) + + let estimated_benefit t = + if t.toplevel && t.lifting && t.branch_depth = 0 then begin + let lifting_benefit = + Clflags.Int_arg_helper.get ~key:t.round !Clflags.inline_lifting_benefit + in + float (t.evaluated_benefit + lifting_benefit) + end else begin + (* The estimated benefit is the evaluated benefit times an + estimation of the probability that the branch does actually matter + for performance (i.e. is hot). The probability is very roughly + estimated by considering that under every branch the + sub-expressions have the same [1 / (1 + factor)] probability + [p] of being hot. Hence the probability for the current + call to be hot is [p ^ number of nested branches]. + The probability is expressed as [1 / (1 + factor)] rather + than letting the user directly provide [p], since for every + positive value of [factor] [p] is in [0, 1]. *) + let branch_taken_estimated_probability = + let inline_branch_factor = + let factor = + Clflags.Float_arg_helper.get ~key:t.round + !Clflags.inline_branch_factor + in + if is_nan factor then + Clflags.default_inline_branch_factor + else if Float.compare factor 0. < 0 then + 0. + else + factor + in + assert (correct_branch_factor inline_branch_factor); + 1. /. (1. +. inline_branch_factor) + in + let call_estimated_probability = + branch_taken_estimated_probability ** float t.branch_depth + in + float t.evaluated_benefit *. call_estimated_probability + end + + let evaluate t = + Float.compare + (float t.new_size -. estimated_benefit t) + (float t.original_size) <= 0 + + let to_string t = + let lifting = t.toplevel && t.lifting && t.branch_depth = 0 in + let evaluated_benefit = + if lifting then + let lifting_benefit = + Clflags.Int_arg_helper.get ~key:t.round + !Clflags.inline_lifting_benefit + in + t.evaluated_benefit + lifting_benefit + else t.evaluated_benefit + in + let estimate = if t.estimate then "<" else "=" in + Printf.sprintf "{benefit%s{call=%d,alloc=%d,prim=%i,branch=%i,\ + indirect=%i,req=%i,\ + lifting=%B}, orig_size=%d,new_size=%d,eval_size=%d,\ + eval_benefit%s%d,\ + branch_depth=%d}=%s" + estimate + t.benefit.remove_call + t.benefit.remove_alloc + t.benefit.remove_prim + t.benefit.remove_branch + t.benefit.direct_call_of_indirect + t.benefit.requested_inline + lifting + t.original_size + t.new_size + (t.original_size - t.new_size) + estimate + evaluated_benefit + t.branch_depth + (if evaluate t then "yes" else "no") + + let print_description ~subfunctions ppf t = + let pr_intro ppf = + let estimate = if t.estimate then " at most" else "" in + Format.pp_print_text ppf + "Specialisation of the function body"; + if subfunctions then + Format.pp_print_text ppf + ", including speculative inlining of other functions,"; + Format.pp_print_text ppf " removed"; + Format.pp_print_text ppf estimate; + Format.pp_print_text ppf " the following operations:" + in + let lifting = t.toplevel && t.lifting && t.branch_depth = 0 in + let requested = t.benefit.requested_inline in + let pr_requested ppf = + if requested > 0 then begin + Format.pp_open_box ppf 0; + Format.pp_print_text ppf + "and inlined user-annotated functions worth "; + Format.fprintf ppf "%d." requested; + Format.pp_close_box ppf (); + Format.pp_print_cut ppf (); + Format.pp_print_cut ppf () + end + in + let pr_lifting ppf = + if lifting then begin + Format.pp_open_box ppf 0; + Format.pp_print_text ppf + "Inlining the function would also \ + lift some definitions to toplevel."; + Format.pp_close_box ppf (); + Format.pp_print_cut ppf (); + Format.pp_print_cut ppf () + end + in + let total_benefit = + if lifting then + let lifting_benefit = + Clflags.Int_arg_helper.get ~key:t.round + !Clflags.inline_lifting_benefit + in + t.evaluated_benefit + lifting_benefit + else t.evaluated_benefit + in + let expected_benefit = estimated_benefit t in + let size_change = t.new_size - t.original_size in + let result = if evaluate t then "less" else "greater" in + let pr_conclusion ppf = + Format.pp_print_text ppf "This gives a total benefit of "; + Format.pp_print_int ppf total_benefit; + Format.pp_print_text ppf ". At a branch depth of "; + Format.pp_print_int ppf t.branch_depth; + Format.pp_print_text ppf " this produces an expected benefit of "; + Format.fprintf ppf "%.1f" expected_benefit; + Format.pp_print_text ppf ". The new code has size "; + Format.pp_print_int ppf t.new_size; + Format.pp_print_text ppf ", giving a change in code size of "; + Format.pp_print_int ppf size_change; + Format.pp_print_text ppf ". The change in code size is "; + Format.pp_print_text ppf result; + Format.pp_print_text ppf " than the expected benefit." + in + Format.fprintf ppf "%t@,@[@[@;%a@]@;@;%t%t@]%t" + pr_intro Benefit.print_table t.benefit pr_requested pr_lifting + pr_conclusion +end + +let scale_inline_threshold_by = 8 + +let default_toplevel_multiplier = 8 + + (* CR-soon mshinwell for mshinwell: hastily-written comment, to review *) + (* We may in [Inlining_decision] need to measure the size of functions + that are below the inlining threshold. We also need to measure with + regard to benefit (see [Inlining_decision.inline_non_recursive). The + intuition for having a cached size in the second case is as follows. + If a function's body exceeds some maximum size and its argument + approximations are unknown (meaning that we cannot materially simplify + it further), we can infer without examining the function's body that + it cannot be inlined. The aim is to speed up [Inlining_decision]. + + The "original size" is [Inlining_cost.direct_call_size]. The "new size" is + the size of the function's body plus [Inlining_cost.project_size] for each + free variable and mutually recursive function accessed through the closure. + + To be inlined we need: + + body_size + + (closure_accesses * project_size) <= direct_call_size + - (evaluated_benefit * call_prob) + + i.e.: + + body_size <= direct_call_size + + (evaluated_benefit * call_prob) + - (closure_accesses * project_size) + + In this case we would be removing a single call and a projection for each + free variable that can be accessed directly (i.e. not via the closure + or the internal variable). + + evaluated_benefit = + benefit_factor + * (inline_call_cost + + ((free_variables - indirect_accesses) * inline_prim_cost)) + + (For [inline_call_cost] and [inline_prim_cost], we use the maximum these + might be across any round.) + + Substituting: + + body_size <= direct_call_size + + (benefit_factor + * (inline_call_cost + + ((free_variables - indirect_accesses) + * inline_prim_cost))) + * call_prob + - (closure_accesses * project_size) + + Rearranging: + + body_size <= direct_call_size + + (inline_call_cost * benefit_factor * call_prob) + + (free_variables * inline_prim_cost + * benefit_factor * call_prob) + - (indirect_accesses * inline_prim_cost + * benefit_factor * call_prob) + - (closure_accesses * project_size) + + The upper bound for the right-hand side is when call_prob = 1.0, + indirect_accesses = 0 and closure_accesses = 0, giving: + + direct_call_size + + (inline_call_cost * benefit_factor) + + (free_variables * inline_prim_cost * benefit_factor) + + So we should measure all functions at or below this size, but also record + the size discovered, so we can later re-check (without examining the body) + when we know [call_prob], [indirect_accesses] and [closure_accesses]. + + This number is split into parts dependent and independent of the + number of free variables: + + base = direct_call_size + (inline_call_cost * benefit_factor) + + multiplier = inline_prim_cost * benefit_factor + + body_size <= base + free_variables * multiplier + + *) +let maximum_interesting_size_of_function_body_base = + lazy begin + let max_cost = ref 0 in + for round = 0 to (Clflags.rounds ()) - 1 do + let max_size = + let inline_call_cost = cost !Clflags.inline_call_cost ~round in + direct_call_size + (inline_call_cost * benefit_factor) + in + max_cost := max !max_cost max_size + done; + !max_cost + end + +let maximum_interesting_size_of_function_body_multiplier = + lazy begin + let max_cost = ref 0 in + for round = 0 to (Clflags.rounds ()) - 1 do + let max_size = + let inline_prim_cost = cost !Clflags.inline_prim_cost ~round in + inline_prim_cost * benefit_factor + in + max_cost := max !max_cost max_size + done; + !max_cost + end + +let maximum_interesting_size_of_function_body num_free_variables = + let base = Lazy.force maximum_interesting_size_of_function_body_base in + let multiplier = + Lazy.force maximum_interesting_size_of_function_body_multiplier + in + base + (num_free_variables * multiplier) diff --git a/middle_end/flambda/inlining_cost.mli b/middle_end/flambda/inlining_cost.mli new file mode 100644 index 0000000000..345f67abad --- /dev/null +++ b/middle_end/flambda/inlining_cost.mli @@ -0,0 +1,142 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(** Measurement of the cost (including cost in space) of Flambda terms + in the context of inlining. *) + +module Threshold : sig + + (** The maximum size, in some abstract measure of space cost, that an + Flambda expression may be in order to be inlined. *) + type t = + | Never_inline + | Can_inline_if_no_larger_than of int + + val add : t -> t -> t + val sub : t -> t -> t + val min : t -> t -> t + val equal : t -> t -> bool + +end + +(* Determine whether the given Flambda expression has a sufficiently low space + cost so as to fit under the given [inlining_threshold]. The [bonus] is + added to the threshold before evaluation. *) +val can_inline + : Flambda.t + -> Threshold.t + -> bonus:int + -> bool + +(* CR-soon mshinwell for pchambart: I think the name of this function might be + misleading. It should probably reflect the functionality it provides, + not the use to which it is put in another module. *) +(* As for [can_inline], but returns the decision as an inlining threshold. + If [Never_inline] is returned, the expression was too large for the + input [inlining_threshold]. Otherwise, [Can_inline_if_no_larger_than] is + returned, with the constructor argument being the measured estimated size + of the expression. *) +val can_try_inlining + : Flambda.t + -> Threshold.t + -> number_of_arguments:int + -> size_from_approximation:int option + -> Threshold.t + +module Benefit : sig + (* A model of the benefit we gain by removing a particular combination + of operations. Such removals are typically performed by inlining (for + example, [remove_call]) and simplification (for example, [remove_alloc]) + passes. *) + + type t + + val zero : t + val (+) : t -> t -> t + val max : round:int -> t -> t -> t + + val remove_call : t -> t + (* CR-soon mshinwell: [remove_alloc] should take the size of the block + (to account for removal of initializing writes). *) + val remove_alloc : t -> t + val remove_prim : t -> t + val remove_prims : t -> int -> t + val remove_branch : t -> t + val direct_call_of_indirect : t -> t + val requested_inline : t -> size_of:Flambda.t -> t + + val remove_code : Flambda.t -> t -> t + val remove_code_named : Flambda.named -> t -> t + val remove_projection : Projection.t -> t -> t + + val add_code : Flambda.t -> t -> t + val add_code_named : Flambda.named -> t -> t + val add_projection : Projection.t -> t -> t + + val print : Format.formatter -> t -> unit +end + +module Whether_sufficient_benefit : sig + (* Evaluation of the benefit of removing certain operations against an + inlining threshold. *) + + type t + + val create + : original:Flambda.t + -> toplevel:bool + -> branch_depth:int + -> Flambda.t + -> benefit:Benefit.t + -> lifting:bool + -> round:int + -> t + + val create_estimate + : original_size:int + -> toplevel:bool + -> branch_depth: int + -> new_size:int + -> benefit:Benefit.t + -> lifting:bool + -> round:int + -> t + + val evaluate : t -> bool + + val to_string : t -> string + + val print_description : subfunctions:bool -> Format.formatter -> t -> unit +end + +val scale_inline_threshold_by : int + +val default_toplevel_multiplier : int + +val direct_call_size : int + +(** If a function body exceeds this size, we can make a fast decision not + to inline it (see [Inlining_decision]). *) +val maximum_interesting_size_of_function_body : int -> int + +(** Measure the given expression to determine whether its size is at or + below the given threshold. [None] is returned if it is too big; otherwise + [Some] is returned with the measured size. *) +val lambda_smaller' : Flambda.expr -> than:int -> int option + +val lambda_size : Flambda.expr -> int diff --git a/middle_end/flambda/inlining_decision.ml b/middle_end/flambda/inlining_decision.ml new file mode 100644 index 0000000000..ca462a5613 --- /dev/null +++ b/middle_end/flambda/inlining_decision.ml @@ -0,0 +1,741 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +module A = Simple_value_approx +module E = Inline_and_simplify_aux.Env +module R = Inline_and_simplify_aux.Result +module W = Inlining_cost.Whether_sufficient_benefit +module T = Inlining_cost.Threshold +module S = Inlining_stats_types +module D = S.Decision + +let get_function_body (function_decl : A.function_declaration) = + match function_decl.function_body with + | None -> assert false + | Some function_body -> function_body + +type ('a, 'b) inlining_result = + | Changed of (Flambda.t * R.t) * 'a + | Original of 'b + +type 'b good_idea = + | Try_it + | Don't_try_it of 'b + +let inline env r ~lhs_of_application + ~closure_id_being_applied + ~(function_decl : A.function_declaration) + ~(function_body : A.function_body) + ~value_set_of_closures ~only_use_of_function ~original ~recursive + ~(args : Variable.t list) ~size_from_approximation ~dbg ~simplify + ~(inline_requested : Lambda.inline_attribute) + ~(specialise_requested : Lambda.specialise_attribute) + ~fun_vars ~set_of_closures_origin + ~self_call ~fun_cost ~inlining_threshold = + let toplevel = E.at_toplevel env in + let branch_depth = E.branch_depth env in + let unrolling, always_inline, never_inline, env = + let unrolling = E.actively_unrolling env set_of_closures_origin in + match unrolling with + | Some count -> + if count > 0 then + let env = E.continue_actively_unrolling env set_of_closures_origin in + true, true, false, env + else false, false, true, env + | None -> begin + let inline_annotation = + (* Merge call site annotation and function annotation. + The call site annotation takes precedence *) + match (inline_requested : Lambda.inline_attribute) with + | Always_inline | Never_inline | Unroll _ -> inline_requested + | Default_inline -> function_body.inline + in + match inline_annotation with + | Always_inline -> false, true, false, env + | Never_inline -> false, false, true, env + | Default_inline -> false, false, false, env + | Unroll count -> + if count > 0 then + let env = + E.start_actively_unrolling + env set_of_closures_origin (count - 1) + in + true, true, false, env + else false, false, true, env + end + in + let remaining_inlining_threshold : Inlining_cost.Threshold.t = + if always_inline then inlining_threshold + else Lazy.force fun_cost + in + let try_inlining = + if unrolling then + Try_it + else if self_call then + Don't_try_it S.Not_inlined.Self_call + else if not (E.inlining_allowed env function_decl.closure_origin) then + Don't_try_it S.Not_inlined.Unrolling_depth_exceeded + else if only_use_of_function || always_inline then + Try_it + else if never_inline then + Don't_try_it S.Not_inlined.Annotation + else if not (E.unrolling_allowed env set_of_closures_origin) + && (Lazy.force recursive) then + Don't_try_it S.Not_inlined.Unrolling_depth_exceeded + else if T.equal remaining_inlining_threshold T.Never_inline then + let threshold = + match inlining_threshold with + | T.Never_inline -> assert false + | T.Can_inline_if_no_larger_than threshold -> threshold + in + Don't_try_it (S.Not_inlined.Above_threshold threshold) + else if not (toplevel && branch_depth = 0) + && A.all_not_useful (E.find_list_exn env args) then + (* When all of the arguments to the function being inlined are unknown, + then we cannot materially simplify the function. As such, we know + what the benefit of inlining it would be: just removing the call. + In this case we may be able to prove the function cannot be inlined + without traversing its body. + Note that if the function is sufficiently small, we still have to call + [simplify], because the body needs freshening before substitution. + *) + (* CR-someday mshinwell: (from GPR#8): pchambart writes: + + We may need to think a bit about that. I can't see a lot of + meaningful examples right now, but there are some cases where some + optimization can happen even if we don't know anything about the + shape of the arguments. + + For instance + + let f x y = x + + let g x = + let y = (x,x) in + f x y + let f x y = + if x = y then ... else ... + + let g x = f x x + *) + match size_from_approximation with + | Some body_size -> + let wsb = + let benefit = Inlining_cost.Benefit.zero in + let benefit = Inlining_cost.Benefit.remove_call benefit in + let benefit = + Variable.Set.fold (fun v acc -> + try + let t = + Var_within_closure.Map.find (Var_within_closure.wrap v) + value_set_of_closures.A.bound_vars + in + match t.A.var with + | Some v -> + if (E.mem env v) then Inlining_cost.Benefit.remove_prim acc + else acc + | None -> acc + with Not_found -> acc) + function_body.free_variables benefit + in + W.create_estimate + ~original_size:Inlining_cost.direct_call_size + ~new_size:body_size + ~toplevel:(E.at_toplevel env) + ~branch_depth:(E.branch_depth env) + ~lifting:function_body.A.is_a_functor + ~round:(E.round env) + ~benefit + in + if (not (W.evaluate wsb)) then begin + Don't_try_it + (S.Not_inlined.Without_subfunctions wsb) + end else Try_it + | None -> + (* The function is definitely too large to inline given that we don't + have any approximations for its arguments. Further, the body + should already have been simplified (inside its declaration), so + we also expect no gain from the code below that permits inlining + inside the body. *) + Don't_try_it S.Not_inlined.No_useful_approximations + else begin + (* There are useful approximations, so we should simplify. *) + Try_it + end + in + match try_inlining with + | Don't_try_it decision -> Original decision + | Try_it -> + let r = + R.set_inlining_threshold r (Some remaining_inlining_threshold) + in + let body, r_inlined = + (* First we construct the code that would result from copying the body of + the function, without doing any further inlining upon it, to the call + site. *) + Inlining_transforms.inline_by_copying_function_body ~env + ~r:(R.reset_benefit r) ~lhs_of_application + ~closure_id_being_applied ~specialise_requested ~inline_requested + ~function_decl ~function_body ~fun_vars ~args ~dbg ~simplify + in + let num_direct_applications_seen = + (R.num_direct_applications r_inlined) - (R.num_direct_applications r) + in + assert (num_direct_applications_seen >= 0); + let keep_inlined_version decision = + (* Inlining the body of the function was sufficiently beneficial that we + will keep it, replacing the call site. We continue by allowing + further inlining within the inlined copy of the body. *) + let r_inlined = + (* The meaning of requesting inlining is that the user ensure + that the function has a benefit of at least its size. It is not + added to the benefit exposed by the inlining because the user should + have taken that into account before annotating the function. *) + if always_inline then + R.map_benefit r_inlined + (Inlining_cost.Benefit.max ~round:(E.round env) + Inlining_cost.Benefit.(requested_inline ~size_of:body zero)) + else r_inlined + in + let r = + R.map_benefit r_inlined (Inlining_cost.Benefit.(+) (R.benefit r)) + in + let env = E.note_entering_inlined env in + let env = + (* We decrement the unrolling count even if the function is not + recursive to avoid having to check whether or not it is recursive *) + E.inside_unrolled_function env set_of_closures_origin + in + let env = E.inside_inlined_function env function_decl.closure_origin in + let env = + if E.inlining_level env = 0 + (* If the function was considered for inlining without considering + its sub-functions, and it is not below another inlining choice, + then we are certain that this code will be kept. *) + then env + else E.inlining_level_up env + in + Changed ((simplify env r body), decision) + in + if always_inline then + keep_inlined_version S.Inlined.Annotation + else if only_use_of_function then + keep_inlined_version S.Inlined.Decl_local_to_application + else begin + let wsb = + W.create ~original body + ~toplevel:(E.at_toplevel env) + ~branch_depth:(E.branch_depth env) + ~lifting:function_body.is_a_functor + ~round:(E.round env) + ~benefit:(R.benefit r_inlined) + in + if W.evaluate wsb then + keep_inlined_version (S.Inlined.Without_subfunctions wsb) + else if num_direct_applications_seen < 1 then begin + (* Inlining the body of the function did not appear sufficiently + beneficial; however, it may become so if we inline within the body + first. We try that next, unless it is known that there were + no direct applications in the simplified body computed above, meaning + no opportunities for inlining. *) + Original (S.Not_inlined.Without_subfunctions wsb) + end else begin + let env = E.inlining_level_up env in + let env = E.note_entering_inlined env in + let env = + (* We decrement the unrolling count even if the function is recursive + to avoid having to check whether or not it is recursive *) + E.inside_unrolled_function env set_of_closures_origin + in + let body, r_inlined = simplify env r_inlined body in + let wsb_with_subfunctions = + W.create ~original body + ~toplevel:(E.at_toplevel env) + ~branch_depth:(E.branch_depth env) + ~lifting:function_body.is_a_functor + ~round:(E.round env) + ~benefit:(R.benefit r_inlined) + in + if W.evaluate wsb_with_subfunctions then begin + let res = + (body, R.map_benefit r_inlined + (Inlining_cost.Benefit.(+) (R.benefit r))) + in + let decision = + S.Inlined.With_subfunctions (wsb, wsb_with_subfunctions) + in + Changed (res, decision) + end + else begin + (* r_inlined contains an approximation that may be invalid for the + untransformed expression: it may reference functions that only + exists if the body of the function is in fact inlined. + If the function approximation contained an approximation that + does not depend on the actual values of its arguments, it + could be returned instead of [A.value_unknown]. *) + let decision = + S.Not_inlined.With_subfunctions (wsb, wsb_with_subfunctions) + in + Original decision + end + end + end + +let specialise env r ~lhs_of_application + ~(function_decls : A.function_declarations) + ~(function_decl : A.function_declaration) + ~closure_id_being_applied + ~(value_set_of_closures : A.value_set_of_closures) + ~args ~args_approxs ~dbg ~simplify ~original ~recursive ~self_call + ~inlining_threshold ~fun_cost + ~inline_requested ~specialise_requested = + let invariant_params = value_set_of_closures.invariant_params in + let free_vars = value_set_of_closures.free_vars in + let has_no_useful_approxes = + lazy + (List.for_all2 + (fun id approx -> + not ((A.useful approx) + && Variable.Map.mem id (Lazy.force invariant_params))) + (Parameter.List.vars function_decl.params) args_approxs) + in + let always_specialise, never_specialise = + (* Merge call site annotation and function annotation. + The call site annotation takes precedence *) + match (specialise_requested : Lambda.specialise_attribute) with + | Always_specialise -> true, false + | Never_specialise -> false, true + | Default_specialise -> begin + match function_decl.function_body with + | None -> false, true + | Some { specialise } -> + match (specialise : Lambda.specialise_attribute) with + | Always_specialise -> true, false + | Never_specialise -> false, true + | Default_specialise -> false, false + end + in + let remaining_inlining_threshold : Inlining_cost.Threshold.t = + if always_specialise then inlining_threshold + else Lazy.force fun_cost + in + let try_specialising = + (* Try specialising if the function: + - is recursive; and + - is closed (it and all other members of the set of closures on which + it depends); and + - has useful approximations for some invariant parameters. *) + if function_decls.is_classic_mode then + Don't_try_it S.Not_specialised.Classic_mode + else if self_call then + Don't_try_it S.Not_specialised.Self_call + else if always_specialise && not (Lazy.force has_no_useful_approxes) then + Try_it + else if never_specialise then + Don't_try_it S.Not_specialised.Annotation + else if T.equal remaining_inlining_threshold T.Never_inline then + let threshold = + match inlining_threshold with + | T.Never_inline -> assert false + | T.Can_inline_if_no_larger_than threshold -> threshold + in + Don't_try_it (S.Not_specialised.Above_threshold threshold) + else if not (Variable.Map.is_empty free_vars) then + Don't_try_it S.Not_specialised.Not_closed + else if not (Lazy.force recursive) then + Don't_try_it S.Not_specialised.Not_recursive + else if Variable.Map.is_empty (Lazy.force invariant_params) then + Don't_try_it S.Not_specialised.No_invariant_parameters + else if Lazy.force has_no_useful_approxes then + Don't_try_it S.Not_specialised.No_useful_approximations + else Try_it + in + match try_specialising with + | Don't_try_it decision -> Original decision + | Try_it -> begin + let r = + R.set_inlining_threshold r (Some remaining_inlining_threshold) + in + let copied_function_declaration = + Inlining_transforms.inline_by_copying_function_declaration ~env + ~r:(R.reset_benefit r) ~lhs_of_application + ~function_decls ~closure_id_being_applied ~function_decl + ~args ~args_approxs + ~invariant_params:invariant_params + ~specialised_args:value_set_of_closures.specialised_args + ~free_vars:value_set_of_closures.free_vars + ~direct_call_surrogates:value_set_of_closures.direct_call_surrogates + ~dbg ~simplify ~inline_requested + in + match copied_function_declaration with + | Some (expr, r_inlined) -> + let wsb = + W.create ~original expr + ~toplevel:false + ~branch_depth:(E.branch_depth env) + ~lifting:false + ~round:(E.round env) + ~benefit:(R.benefit r_inlined) + in + let env = + (* CR-someday lwhite: could avoid calculating this if stats is turned + off *) + let closure_ids = + Closure_id.Set.of_list ( + List.map Closure_id.wrap + (Variable.Set.elements (Variable.Map.keys function_decls.funs))) + in + E.note_entering_specialised env ~closure_ids + in + if always_specialise || W.evaluate wsb then begin + let r_inlined = + if always_specialise then + R.map_benefit r_inlined + (Inlining_cost.Benefit.max ~round:(E.round env) + Inlining_cost.Benefit.(requested_inline ~size_of:expr zero)) + else r_inlined + in + let r = + R.map_benefit r_inlined (Inlining_cost.Benefit.(+) (R.benefit r)) + in + let closure_env = + let env = + if E.inlining_level env = 0 + (* If the function was considered for specialising without + considering its sub-functions, and it is not below another + inlining choice, then we are certain that this code will + be kept. *) + then env + else E.inlining_level_up env + in + E.set_never_inline_outside_closures env + in + let application_env = E.set_never_inline_inside_closures env in + let expr, r = simplify closure_env r expr in + let res = simplify application_env r expr in + let decision = + if always_specialise then S.Specialised.Annotation + else S.Specialised.Without_subfunctions wsb + in + Changed (res, decision) + end else begin + let closure_env = + let env = E.inlining_level_up env in + E.set_never_inline_outside_closures env + in + let expr, r_inlined = simplify closure_env r_inlined expr in + let wsb_with_subfunctions = + W.create ~original expr + ~toplevel:false + ~branch_depth:(E.branch_depth env) + ~lifting:false + ~round:(E.round env) + ~benefit:(R.benefit r_inlined) + in + if W.evaluate wsb_with_subfunctions then begin + let r = + R.map_benefit r_inlined + (Inlining_cost.Benefit.(+) (R.benefit r)) + in + let application_env = E.set_never_inline_inside_closures env in + let res = simplify application_env r expr in + let decision = + S.Specialised.With_subfunctions (wsb, wsb_with_subfunctions) + in + Changed (res, decision) + end else begin + let decision = + S.Not_specialised.Not_beneficial (wsb, wsb_with_subfunctions) + in + Original decision + end + end + | None -> + let decision = S.Not_specialised.No_useful_approximations in + Original decision + end + +let for_call_site ~env ~r ~(function_decls : A.function_declarations) + ~lhs_of_application ~closure_id_being_applied + ~(function_decl : A.function_declaration) + ~(value_set_of_closures : A.value_set_of_closures) + ~args ~args_approxs ~dbg ~simplify ~inline_requested + ~specialise_requested = + if List.length args <> List.length args_approxs then begin + Misc.fatal_error "Inlining_decision.for_call_site: inconsistent lengths \ + of [args] and [args_approxs]" + end; + (* Remove unroll attributes from functions we are already actively + unrolling, otherwise they'll be unrolled again next round. *) + let inline_requested : Lambda.inline_attribute = + match (inline_requested : Lambda.inline_attribute) with + | Unroll _ -> begin + let unrolling = + E.actively_unrolling env function_decls.set_of_closures_origin + in + match unrolling with + | Some _ -> Default_inline + | None -> inline_requested + end + | Always_inline | Default_inline | Never_inline -> + inline_requested + in + let original = + Flambda.Apply { + func = lhs_of_application; + args; + kind = Direct closure_id_being_applied; + dbg; + inline = inline_requested; + specialise = specialise_requested; + } + in + let original_r = + R.set_approx (R.seen_direct_application r) (A.value_unknown Other) + in + match function_decl.function_body with + | None -> original, original_r + | Some { stub; _ } -> + if stub then begin + let fun_vars = Variable.Map.keys function_decls.funs in + let function_body = get_function_body function_decl in + let body, r = + Inlining_transforms.inline_by_copying_function_body ~env + ~r ~fun_vars ~lhs_of_application + ~closure_id_being_applied ~specialise_requested ~inline_requested + ~function_decl ~function_body ~args ~dbg ~simplify + in + simplify env r body + end else if E.never_inline env then + (* This case only occurs when examining the body of a stub function + but not in the context of inlining said function. As such, there + is nothing to do here (and no decision to report). *) + original, original_r + else if function_decls.is_classic_mode then begin + let env = + E.note_entering_call env + ~closure_id:closure_id_being_applied ~dbg:dbg + in + let simpl = + match function_decl.function_body with + | None -> Original S.Not_inlined.Classic_mode + | Some function_body -> + let self_call = + E.inside_set_of_closures_declaration + function_decls.set_of_closures_origin env + in + let try_inlining = + if self_call then + Don't_try_it S.Not_inlined.Self_call + else + if not (E.inlining_allowed env function_decl.closure_origin) then + Don't_try_it S.Not_inlined.Unrolling_depth_exceeded + else + Try_it + in + match try_inlining with + | Don't_try_it decision -> Original decision + | Try_it -> + let fun_vars = Variable.Map.keys function_decls.funs in + let body, r = + Inlining_transforms.inline_by_copying_function_body ~env + ~r ~function_body ~lhs_of_application + ~closure_id_being_applied ~specialise_requested + ~inline_requested ~function_decl ~fun_vars ~args ~dbg ~simplify + in + let env = E.note_entering_inlined env in + let env = + (* We decrement the unrolling count even if the function is not + recursive to avoid having to check whether or not it is + recursive *) + E.inside_unrolled_function env + function_decls.set_of_closures_origin + in + let env = + E.inside_inlined_function env function_decl.closure_origin + in + Changed ((simplify env r body), S.Inlined.Classic_mode) + in + let res, decision = + match simpl with + | Original decision -> + let decision = + S.Decision.Unchanged (S.Not_specialised.Classic_mode, decision) + in + (original, original_r), decision + | Changed ((expr, r), decision) -> + let max_inlining_threshold = + if E.at_toplevel env then + Inline_and_simplify_aux.initial_inlining_toplevel_threshold + ~round:(E.round env) + else + Inline_and_simplify_aux.initial_inlining_threshold + ~round:(E.round env) + in + let raw_inlining_threshold = R.inlining_threshold r in + let unthrottled_inlining_threshold = + match raw_inlining_threshold with + | None -> max_inlining_threshold + | Some inlining_threshold -> inlining_threshold + in + let inlining_threshold = + T.min unthrottled_inlining_threshold max_inlining_threshold + in + let inlining_threshold_diff = + T.sub unthrottled_inlining_threshold inlining_threshold + in + let res = + if E.inlining_level env = 0 + then expr, R.set_inlining_threshold r raw_inlining_threshold + else expr, R.add_inlining_threshold r inlining_threshold_diff + in + res, S.Decision.Inlined (S.Not_specialised.Classic_mode, decision) + in + E.record_decision env decision; + res + end else begin + let function_body = get_function_body function_decl in + let env = E.unset_never_inline_inside_closures env in + let env = + E.note_entering_call env + ~closure_id:closure_id_being_applied ~dbg:dbg + in + let max_level = + Clflags.Int_arg_helper.get ~key:(E.round env) !Clflags.inline_max_depth + in + let raw_inlining_threshold = R.inlining_threshold r in + let max_inlining_threshold = + if E.at_toplevel env then + Inline_and_simplify_aux.initial_inlining_toplevel_threshold + ~round:(E.round env) + else + Inline_and_simplify_aux.initial_inlining_threshold + ~round:(E.round env) + in + let unthrottled_inlining_threshold = + match raw_inlining_threshold with + | None -> max_inlining_threshold + | Some inlining_threshold -> inlining_threshold + in + let inlining_threshold = + T.min unthrottled_inlining_threshold max_inlining_threshold + in + let inlining_threshold_diff = + T.sub unthrottled_inlining_threshold inlining_threshold + in + let inlining_prevented = + match inlining_threshold with + | Never_inline -> true + | Can_inline_if_no_larger_than _ -> false + in + let simpl = + if inlining_prevented then + Original (D.Prevented Function_prevented_from_inlining) + else if E.inlining_level env >= max_level then + Original (D.Prevented Level_exceeded) + else begin + let self_call = + E.inside_set_of_closures_declaration + function_decls.set_of_closures_origin env + in + let fun_cost = + lazy + (Inlining_cost.can_try_inlining function_body.body + inlining_threshold + ~number_of_arguments:(List.length function_decl.params) + (* CR-someday mshinwell: for the moment, this is None, since + the Inlining_cost code isn't checking sizes up to the max + inlining threshold---this seems to take too long. *) + ~size_from_approximation:None) + in + let recursive = + lazy + (let fun_var = Closure_id.unwrap closure_id_being_applied in + Variable.Set.mem fun_var + (Lazy.force value_set_of_closures.recursive)) + in + let specialise_result = + specialise env r + ~function_decls ~function_decl + ~lhs_of_application ~recursive ~closure_id_being_applied + ~value_set_of_closures ~args ~args_approxs ~dbg ~simplify + ~original ~inline_requested ~specialise_requested ~fun_cost + ~self_call ~inlining_threshold + in + match specialise_result with + | Changed (res, spec_reason) -> + Changed (res, D.Specialised spec_reason) + | Original spec_reason -> + let only_use_of_function = false in + (* If we didn't specialise then try inlining *) + let size_from_approximation = + let fun_var = Closure_id.unwrap closure_id_being_applied in + match + Variable.Map.find fun_var + (Lazy.force value_set_of_closures.size) + with + | size -> size + | exception Not_found -> + Misc.fatal_errorf "Approximation does not give a size for the \ + function having fun_var %a. \ + value_set_of_closures: %a" + Variable.print fun_var + A.print_value_set_of_closures value_set_of_closures + in + let fun_vars = Variable.Map.keys function_decls.funs in + let set_of_closures_origin = + function_decls.set_of_closures_origin + in + let inline_result = + inline env r ~lhs_of_application + ~closure_id_being_applied ~function_decl ~value_set_of_closures + ~only_use_of_function ~original ~recursive + ~inline_requested ~specialise_requested + ~fun_vars ~set_of_closures_origin ~args + ~size_from_approximation ~dbg ~simplify ~fun_cost ~self_call + ~inlining_threshold ~function_body + in + match inline_result with + | Changed (res, inl_reason) -> + Changed (res, D.Inlined (spec_reason, inl_reason)) + | Original inl_reason -> + Original (D.Unchanged (spec_reason, inl_reason)) + end + in + let res, decision = + match simpl with + | Original decision -> (original, original_r), decision + | Changed ((expr, r), decision) -> + let res = + if E.inlining_level env = 0 + then expr, R.set_inlining_threshold r raw_inlining_threshold + else expr, R.add_inlining_threshold r inlining_threshold_diff + in + res, decision + in + E.record_decision env decision; + res + end + +(* We do not inline inside stubs, which are always inlined at their call site. + Inlining inside the declaration of a stub could result in more code than + expected being inlined (e.g. the body of a function that was transformed + by adding the stub). *) +let should_inline_inside_declaration (decl : Flambda.function_declaration) = + not decl.stub diff --git a/middle_end/flambda/inlining_decision.mli b/middle_end/flambda/inlining_decision.mli new file mode 100644 index 0000000000..3694e30366 --- /dev/null +++ b/middle_end/flambda/inlining_decision.mli @@ -0,0 +1,43 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(** See the Flambda manual chapter for an explanation in prose of the + inlining decision procedure. *) + +(** Try to inline a full application of a known function, guided by various + heuristics. *) +val for_call_site + : env:Inline_and_simplify_aux.Env.t + -> r:Inline_and_simplify_aux.Result.t + -> function_decls:Simple_value_approx.function_declarations + -> lhs_of_application:Variable.t + -> closure_id_being_applied:Closure_id.t + -> function_decl:Simple_value_approx.function_declaration + -> value_set_of_closures:Simple_value_approx.value_set_of_closures + -> args:Variable.t list + -> args_approxs:Simple_value_approx.t list + -> dbg:Debuginfo.t + -> simplify:Inlining_decision_intf.simplify + -> inline_requested:Lambda.inline_attribute + -> specialise_requested:Lambda.specialise_attribute + -> Flambda.t * Inline_and_simplify_aux.Result.t + +(** When a function declaration is encountered by [for_call_site], the body + may be subject to inlining immediately, thus changing the declaration. + This function must return [true] for that to be able to happen. *) +val should_inline_inside_declaration : Flambda.function_declaration -> bool diff --git a/middle_end/flambda/inlining_decision_intf.mli b/middle_end/flambda/inlining_decision_intf.mli new file mode 100644 index 0000000000..15a080316c --- /dev/null +++ b/middle_end/flambda/inlining_decision_intf.mli @@ -0,0 +1,49 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(* CR-someday mshinwell: name of this source file could now be improved *) + +type 'a by_copying_function_body = + env:Inline_and_simplify_aux.Env.t + -> r:Inline_and_simplify_aux.Result.t + -> clos:Flambda.function_declarations + -> lfunc:Flambda.t + -> fun_id:Closure_id.t + -> func:Flambda.function_declaration + -> args:Flambda.t list + -> Flambda.t * Inline_and_simplify_aux.Result.t + +type 'a by_copying_function_declaration = + env:Inline_and_simplify_aux.Env.t + -> r:Inline_and_simplify_aux.Result.t + -> funct:Flambda.t + -> clos:Flambda.function_declarations + -> fun_id:Closure_id.t + -> func:Flambda.function_declaration + -> args_with_approxs: + (Flambda.t list) * (Simple_value_approx.t list) + -> invariant_params:Variable.Set.t + -> specialised_args:Variable.Set.t + -> dbg:Debuginfo.t + -> (Flambda.t * Inline_and_simplify_aux.Result.t) option + +type simplify = + Inline_and_simplify_aux.Env.t + -> Inline_and_simplify_aux.Result.t + -> Flambda.t + -> Flambda.t * Inline_and_simplify_aux.Result.t diff --git a/middle_end/flambda/inlining_stats.ml b/middle_end/flambda/inlining_stats.ml new file mode 100644 index 0000000000..6809d4cbb4 --- /dev/null +++ b/middle_end/flambda/inlining_stats.ml @@ -0,0 +1,252 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +module Closure_stack = struct + type t = node list + + and node = + | Closure of Closure_id.t * Debuginfo.t + | Call of Closure_id.t * Debuginfo.t + | Inlined + | Specialised of Closure_id.Set.t + + let create () = [] + + let note_entering_closure t ~closure_id ~dbg = + if not !Clflags.inlining_report then t + else + match t with + | [] | (Closure _ | Inlined | Specialised _) :: _-> + (Closure (closure_id, dbg)) :: t + | (Call _) :: _ -> + Misc.fatal_errorf "note_entering_closure: unexpected Call node" + + (* CR-someday lwhite: since calls do not have a unique id it is possible + some calls will end up sharing nodes. *) + let note_entering_call t ~closure_id ~dbg = + if not !Clflags.inlining_report then t + else + match t with + | [] | (Closure _ | Inlined | Specialised _) :: _ -> + (Call (closure_id, dbg)) :: t + | (Call _) :: _ -> + Misc.fatal_errorf "note_entering_call: unexpected Call node" + + let note_entering_inlined t = + if not !Clflags.inlining_report then t + else + match t with + | [] | (Closure _ | Inlined | Specialised _) :: _-> + Misc.fatal_errorf "note_entering_inlined: missing Call node" + | (Call _) :: _ -> Inlined :: t + + let note_entering_specialised t ~closure_ids = + if not !Clflags.inlining_report then t + else + match t with + | [] | (Closure _ | Inlined | Specialised _) :: _ -> + Misc.fatal_errorf "note_entering_specialised: missing Call node" + | (Call _) :: _ -> Specialised closure_ids :: t + +end + +let log + : (Closure_stack.t * Inlining_stats_types.Decision.t) list ref + = ref [] + +let record_decision decision ~closure_stack = + if !Clflags.inlining_report then begin + match closure_stack with + | [] + | Closure_stack.Closure _ :: _ + | Closure_stack.Inlined :: _ + | Closure_stack.Specialised _ :: _ -> + Misc.fatal_errorf "record_decision: missing Call node" + | Closure_stack.Call _ :: _ -> + log := (closure_stack, decision) :: !log + end + +module Inlining_report = struct + + module Place = struct + type kind = + | Closure + | Call + + type t = Debuginfo.t * Closure_id.t * kind + + let compare ((d1, cl1, k1) : t) ((d2, cl2, k2) : t) = + let c = Debuginfo.compare d1 d2 in + if c <> 0 then c else + let c = Closure_id.compare cl1 cl2 in + if c <> 0 then c else + match k1, k2 with + | Closure, Closure -> 0 + | Call, Call -> 0 + | Closure, Call -> 1 + | Call, Closure -> -1 + end + + module Place_map = Map.Make(Place) + + type t = node Place_map.t + + and node = + | Closure of t + | Call of call + + and call = + { decision: Inlining_stats_types.Decision.t option; + inlined: t option; + specialised: t option; } + + let empty_call = + { decision = None; + inlined = None; + specialised = None; } + + (* Prevented or unchanged decisions may be overridden by a later look at the + same call. Other decisions may also be "overridden" because calls are not + uniquely identified. *) + let add_call_decision call (decision : Inlining_stats_types.Decision.t) = + match call.decision, decision with + | None, _ -> { call with decision = Some decision } + | Some _, Prevented _ -> call + | Some (Prevented _), _ -> { call with decision = Some decision } + | Some (Specialised _), _ -> call + | Some _, Specialised _ -> { call with decision = Some decision } + | Some (Inlined _), _ -> call + | Some _, Inlined _ -> { call with decision = Some decision } + | Some Unchanged _, Unchanged _ -> call + + let add_decision t (stack, decision) = + let rec loop t : Closure_stack.t -> _ = function + | Closure(cl, dbg) :: rest -> + let key : Place.t = (dbg, cl, Closure) in + let v = + try + match Place_map.find key t with + | Closure v -> v + | Call _ -> assert false + with Not_found -> Place_map.empty + in + let v = loop v rest in + Place_map.add key (Closure v) t + | Call(cl, dbg) :: rest -> + let key : Place.t = (dbg, cl, Call) in + let v = + try + match Place_map.find key t with + | Call v -> v + | Closure _ -> assert false + with Not_found -> empty_call + in + let v = + match rest with + | [] -> add_call_decision v decision + | Inlined :: rest -> + let inlined = + match v.inlined with + | None -> Place_map.empty + | Some inlined -> inlined + in + let inlined = loop inlined rest in + { v with inlined = Some inlined } + | Specialised _ :: rest -> + let specialised = + match v.specialised with + | None -> Place_map.empty + | Some specialised -> specialised + in + let specialised = loop specialised rest in + { v with specialised = Some specialised } + | Call _ :: _ -> assert false + | Closure _ :: _ -> assert false + in + Place_map.add key (Call v) t + | [] -> assert false + | Inlined :: _ -> assert false + | Specialised _ :: _ -> assert false + in + loop t (List.rev stack) + + let build log = + List.fold_left add_decision Place_map.empty log + + let print_stars ppf n = + let s = String.make n '*' in + Format.fprintf ppf "%s" s + + let rec print ~depth ppf t = + Place_map.iter (fun (dbg, cl, _) v -> + match v with + | Closure t -> + Format.fprintf ppf "@[%a Definition of %a%s@]@." + print_stars (depth + 1) + Closure_id.print cl + (Debuginfo.to_string dbg); + print ppf ~depth:(depth + 1) t; + if depth = 0 then Format.pp_print_newline ppf () + | Call c -> + match c.decision with + | None -> + Misc.fatal_error "Inlining_report.print: missing call decision" + | Some decision -> + Format.pp_open_vbox ppf (depth + 2); + Format.fprintf ppf "@[%a Application of %a%s@]@;@;@[%a@]" + print_stars (depth + 1) + Closure_id.print cl + (Debuginfo.to_string dbg) + Inlining_stats_types.Decision.summary decision; + Format.pp_close_box ppf (); + Format.pp_print_newline ppf (); + Format.pp_print_newline ppf (); + Inlining_stats_types.Decision.calculation ~depth:(depth + 1) + ppf decision; + begin + match c.specialised with + | None -> () + | Some specialised -> + print ppf ~depth:(depth + 1) specialised + end; + begin + match c.inlined with + | None -> () + | Some inlined -> + print ppf ~depth:(depth + 1) inlined + end; + if depth = 0 then Format.pp_print_newline ppf ()) + t + + let print ppf t = print ~depth:0 ppf t + +end + +let really_save_then_forget_decisions ~output_prefix = + let report = Inlining_report.build !log in + let out_channel = open_out (output_prefix ^ ".inlining.org") in + let ppf = Format.formatter_of_out_channel out_channel in + Inlining_report.print ppf report; + close_out out_channel; + log := [] + +let save_then_forget_decisions ~output_prefix = + if !Clflags.inlining_report then begin + really_save_then_forget_decisions ~output_prefix + end diff --git a/middle_end/flambda/inlining_stats.mli b/middle_end/flambda/inlining_stats.mli new file mode 100644 index 0000000000..f1e84fdcea --- /dev/null +++ b/middle_end/flambda/inlining_stats.mli @@ -0,0 +1,46 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +module Closure_stack : sig + type t + + val create : unit -> t + + val note_entering_closure + : t + -> closure_id:Closure_id.t + -> dbg:Debuginfo.t + -> t + + val note_entering_call + : t + -> closure_id:Closure_id.t + -> dbg:Debuginfo.t + -> t + + val note_entering_inlined : t -> t + val note_entering_specialised : t -> closure_ids:Closure_id.Set.t -> t + +end + +val record_decision + : Inlining_stats_types.Decision.t + -> closure_stack:Closure_stack.t + -> unit + +val save_then_forget_decisions : output_prefix:string -> unit diff --git a/middle_end/flambda/inlining_stats_types.ml b/middle_end/flambda/inlining_stats_types.ml new file mode 100644 index 0000000000..7aef0796d9 --- /dev/null +++ b/middle_end/flambda/inlining_stats_types.ml @@ -0,0 +1,290 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +module Wsb = Inlining_cost.Whether_sufficient_benefit + +let print_stars ppf n = + let s = String.make n '*' in + Format.fprintf ppf "%s" s + +let print_calculation ~depth ~title ~subfunctions ppf wsb = + Format.pp_open_vbox ppf (depth + 2); + Format.fprintf ppf "@[%a %s@]@;@;@[%a@]" + print_stars (depth + 1) + title + (Wsb.print_description ~subfunctions) wsb; + Format.pp_close_box ppf (); + Format.pp_print_newline ppf (); + Format.pp_print_newline ppf () + +module Inlined = struct + + type t = + | Classic_mode + | Annotation + | Decl_local_to_application + | Without_subfunctions of Wsb.t + | With_subfunctions of Wsb.t * Wsb.t + + let summary ppf = function + | Classic_mode -> + Format.pp_print_text ppf + "This function was inlined because it was small enough \ + to be inlined in `-Oclassic'" + | Annotation -> + Format.pp_print_text ppf + "This function was inlined because of an annotation." + | Decl_local_to_application -> + Format.pp_print_text ppf + "This function was inlined because it was local to this application." + | Without_subfunctions _ -> + Format.pp_print_text ppf + "This function was inlined because \ + the expected benefit outweighed the change in code size." + | With_subfunctions _ -> + Format.pp_print_text ppf + "This function was inlined because \ + the expected benefit outweighed the change in code size." + + let calculation ~depth ppf = function + | Classic_mode -> () + | Annotation -> () + | Decl_local_to_application -> () + | Without_subfunctions wsb -> + print_calculation + ~depth ~title:"Inlining benefit calculation" + ~subfunctions:false ppf wsb + | With_subfunctions(_, wsb) -> + print_calculation + ~depth ~title:"Inlining benefit calculation" + ~subfunctions:true ppf wsb + +end + +module Not_inlined = struct + type t = + | Classic_mode + | Above_threshold of int + | Annotation + | No_useful_approximations + | Unrolling_depth_exceeded + | Self_call + | Without_subfunctions of Wsb.t + | With_subfunctions of Wsb.t * Wsb.t + + + let summary ppf = function + | Classic_mode -> + Format.pp_print_text ppf + "This function was not inlined because it was too \ + large to be inlined in `-Oclassic'." + | Above_threshold size -> + Format.pp_print_text ppf + "This function was not inlined because \ + it was larger than the current size threshold"; + Format.fprintf ppf "(%i)" size + | Annotation -> + Format.pp_print_text ppf + "This function was not inlined because \ + of an annotation." + | No_useful_approximations -> + Format.pp_print_text ppf + "This function was not inlined because \ + there was no useful information about any of its parameters, \ + and it was not particularly small." + | Unrolling_depth_exceeded -> + Format.pp_print_text ppf + "This function was not inlined because \ + its unrolling depth was exceeded." + | Self_call -> + Format.pp_print_text ppf + "This function was not inlined because \ + it was a self call." + | Without_subfunctions _ -> + Format.pp_print_text ppf + "This function was not inlined because \ + the expected benefit did not outweigh the change in code size." + | With_subfunctions _ -> + Format.pp_print_text ppf + "This function was not inlined because \ + the expected benefit did not outweigh the change in code size." + + let calculation ~depth ppf = function + | Classic_mode + | Above_threshold _ + | Annotation + | No_useful_approximations + | Unrolling_depth_exceeded + | Self_call -> () + | Without_subfunctions wsb -> + print_calculation + ~depth ~title:"Inlining benefit calculation" + ~subfunctions:false ppf wsb + | With_subfunctions(_, wsb) -> + print_calculation + ~depth ~title:"Inlining benefit calculation" + ~subfunctions:true ppf wsb + +end + +module Specialised = struct + type t = + | Annotation + | Without_subfunctions of Wsb.t + | With_subfunctions of Wsb.t * Wsb.t + + let summary ppf = function + | Annotation -> + Format.pp_print_text ppf + "This function was specialised because of an annotation." + | Without_subfunctions _ -> + Format.pp_print_text ppf + "This function was specialised because the expected benefit \ + outweighed the change in code size." + | With_subfunctions _ -> + Format.pp_print_text ppf + "This function was specialised because the expected benefit \ + outweighed the change in code size." + + + let calculation ~depth ppf = function + | Annotation -> () + | Without_subfunctions wsb -> + print_calculation + ~depth ~title:"Specialising benefit calculation" + ~subfunctions:false ppf wsb + | With_subfunctions(_, wsb) -> + print_calculation + ~depth ~title:"Specialising benefit calculation" + ~subfunctions:true ppf wsb +end + +module Not_specialised = struct + type t = + | Classic_mode + | Above_threshold of int + | Annotation + | Not_recursive + | Not_closed + | No_invariant_parameters + | No_useful_approximations + | Self_call + | Not_beneficial of Wsb.t * Wsb.t + + let summary ppf = function + | Classic_mode -> + Format.pp_print_text ppf + "This function was not specialised because it was \ + compiled with `-Oclassic'." + | Above_threshold size -> + Format.pp_print_text ppf + "This function was not specialised because \ + it was larger than the current size threshold"; + Format.fprintf ppf "(%i)" size + | Annotation -> + Format.pp_print_text ppf + "This function was not specialised because \ + of an annotation." + | Not_recursive -> + Format.pp_print_text ppf + "This function was not specialised because \ + it is not recursive." + | Not_closed -> + Format.pp_print_text ppf + "This function was not specialised because \ + it is not closed." + | No_invariant_parameters -> + Format.pp_print_text ppf + "This function was not specialised because \ + it has no invariant parameters." + | No_useful_approximations -> + Format.pp_print_text ppf + "This function was not specialised because \ + there was no useful information about any of its invariant \ + parameters." + | Self_call -> + Format.pp_print_text ppf + "This function was not specialised because \ + it was a self call." + | Not_beneficial _ -> + Format.pp_print_text ppf + "This function was not specialised because \ + the expected benefit did not outweigh the change in code size." + + let calculation ~depth ppf = function + | Classic_mode + | Above_threshold _ + | Annotation + | Not_recursive + | Not_closed + | No_invariant_parameters + | No_useful_approximations + | Self_call -> () + | Not_beneficial(_, wsb) -> + print_calculation + ~depth ~title:"Specialising benefit calculation" + ~subfunctions:true ppf wsb + +end + +module Prevented = struct + type t = + | Function_prevented_from_inlining + | Level_exceeded + + let summary ppf = function + | Function_prevented_from_inlining -> + Format.pp_print_text ppf + "This function was prevented from inlining or specialising." + | Level_exceeded -> + Format.pp_print_text ppf + "This function was prevented from inlining or specialising \ + because the inlining depth was exceeded." +end + +module Decision = struct + type t = + | Prevented of Prevented.t + | Specialised of Specialised.t + | Inlined of Not_specialised.t * Inlined.t + | Unchanged of Not_specialised.t * Not_inlined.t + + let summary ppf = function + | Prevented p -> + Prevented.summary ppf p + | Specialised s -> + Specialised.summary ppf s + | Inlined (s, i) -> + Format.fprintf ppf "@[@[%a@]@;@;@[%a@]@]" + Not_specialised.summary s Inlined.summary i + | Unchanged (s, i) -> + Format.fprintf ppf "@[@[%a@]@;@;@[%a@]@]" + Not_specialised.summary s Not_inlined.summary i + + let calculation ~depth ppf = function + | Prevented _ -> () + | Specialised s -> + Specialised.calculation ~depth ppf s + | Inlined (s, i) -> + Not_specialised.calculation ~depth ppf s; + Inlined.calculation ~depth ppf i + | Unchanged (s, i) -> + Not_specialised.calculation ~depth ppf s; + Not_inlined.calculation ~depth ppf i +end diff --git a/middle_end/flambda/inlining_stats_types.mli b/middle_end/flambda/inlining_stats_types.mli new file mode 100644 index 0000000000..9d476c8981 --- /dev/null +++ b/middle_end/flambda/inlining_stats_types.mli @@ -0,0 +1,89 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(* Types used for producing statistics about inlining. *) + +module Inlined : sig + type t = + | Classic_mode + | Annotation + | Decl_local_to_application + | Without_subfunctions of + Inlining_cost.Whether_sufficient_benefit.t + | With_subfunctions of + Inlining_cost.Whether_sufficient_benefit.t + * Inlining_cost.Whether_sufficient_benefit.t +end + +module Not_inlined : sig + type t = + | Classic_mode + | Above_threshold of int + | Annotation + | No_useful_approximations + | Unrolling_depth_exceeded + | Self_call + | Without_subfunctions of + Inlining_cost.Whether_sufficient_benefit.t + | With_subfunctions of + Inlining_cost.Whether_sufficient_benefit.t + * Inlining_cost.Whether_sufficient_benefit.t +end + +module Specialised : sig + type t = + | Annotation + | Without_subfunctions of + Inlining_cost.Whether_sufficient_benefit.t + | With_subfunctions of + Inlining_cost.Whether_sufficient_benefit.t + * Inlining_cost.Whether_sufficient_benefit.t +end + +module Not_specialised : sig + type t = + | Classic_mode + | Above_threshold of int + | Annotation + | Not_recursive + | Not_closed + | No_invariant_parameters + | No_useful_approximations + | Self_call + | Not_beneficial of + Inlining_cost.Whether_sufficient_benefit.t + * Inlining_cost.Whether_sufficient_benefit.t +end + +module Prevented : sig + type t = + | Function_prevented_from_inlining + | Level_exceeded +end + +module Decision : sig + + type t = + | Prevented of Prevented.t + | Specialised of Specialised.t + | Inlined of Not_specialised.t * Inlined.t + | Unchanged of Not_specialised.t * Not_inlined.t + + val summary : Format.formatter -> t -> unit + val calculation : depth:int -> Format.formatter -> t -> unit +end diff --git a/middle_end/flambda/inlining_transforms.ml b/middle_end/flambda/inlining_transforms.ml new file mode 100644 index 0000000000..b08e62bb0a --- /dev/null +++ b/middle_end/flambda/inlining_transforms.ml @@ -0,0 +1,668 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +module B = Inlining_cost.Benefit +module E = Inline_and_simplify_aux.Env +module R = Inline_and_simplify_aux.Result +module A = Simple_value_approx + +let new_var name = + Variable.create name + ~current_compilation_unit:(Compilation_unit.get_current_exn ()) + +(** Fold over all variables bound by the given closure, which is bound to the + variable [lhs_of_application], and corresponds to the given + [function_decls]. Each variable bound by the closure is passed to the + user-specified function as an [Flambda.named] value that projects the + variable from its closure. *) +let fold_over_projections_of_vars_bound_by_closure ~closure_id_being_applied + ~lhs_of_application ~bound_variables ~init ~f = + Variable.Set.fold (fun var acc -> + let expr : Flambda.named = + Project_var { + closure = lhs_of_application; + closure_id = closure_id_being_applied; + var = Var_within_closure.wrap var; + } + in + f ~acc ~var ~expr) + bound_variables + init + +let set_inline_attribute_on_all_apply body inline specialise = + Flambda_iterators.map_toplevel_expr (function + | Apply apply -> Apply { apply with inline; specialise } + | expr -> expr) + body + +(** Assign fresh names for a function's parameters and rewrite the body to + use these new names. *) +let copy_of_function's_body_with_freshened_params env + ~(function_decl : A.function_declaration) + ~(function_body : A.function_body) = + let params = function_decl.params in + let param_vars = Parameter.List.vars params in + (* We cannot avoid the substitution in the case where we are inlining + inside the function itself. This can happen in two ways: either + (a) we are inlining the function itself directly inside its declaration; + or (b) we are inlining the function into an already-inlined copy. + For (a) we cannot short-cut the substitution by freshening since the + original [params] may still be referenced; for (b) we cannot do it + either since the freshening may already be renaming the parameters for + the first inlining of the function. *) + if E.does_not_bind env param_vars + && E.does_not_freshen env param_vars + then + params, function_body.body + else + let freshened_params = List.map (fun p -> Parameter.rename p) params in + let subst = + Variable.Map.of_list + (List.combine param_vars (Parameter.List.vars freshened_params)) + in + let body = Flambda_utils.toplevel_substitution subst function_body.body in + freshened_params, body + +(* CR-soon mshinwell: Add a note somewhere to explain why "bound by the closure" + does not include the function identifiers for other functions in the same + set of closures. + mshinwell: The terminology may be used inconsistently. *) + +(** Inline a function by copying its body into a context where it becomes + closed. That is to say, we bind the free variables of the body + (= "variables bound by the closure"), and any function identifiers + introduced by the corresponding set of closures. *) +let inline_by_copying_function_body ~env ~r + ~lhs_of_application + ~(inline_requested : Lambda.inline_attribute) + ~(specialise_requested : Lambda.specialise_attribute) + ~closure_id_being_applied + ~(function_decl : A.function_declaration) + ~(function_body : A.function_body) + ~fun_vars + ~args ~dbg ~simplify = + assert (E.mem env lhs_of_application); + assert (List.for_all (E.mem env) args); + let r = + if function_body.stub then r + else R.map_benefit r B.remove_call + in + let freshened_params, body = + copy_of_function's_body_with_freshened_params env + ~function_decl ~function_body + in + let body = + let default_inline = + Lambda.equal_inline_attribute inline_requested Default_inline + in + let default_specialise = + Lambda.equal_specialise_attribute specialise_requested Default_specialise + in + if function_body.stub + && ((not default_inline) || (not default_specialise)) then + (* When the function inlined function is a stub, the annotation + is reported to the function applications inside the stub. + This allows to report the annotation to the application the + original programmer really intended: the stub is not visible + in the source. *) + set_inline_attribute_on_all_apply body + inline_requested specialise_requested + else + body + in + let bindings_for_params_to_args = + (* Bind the function's parameters to the arguments from the call site. *) + let args = List.map (fun arg -> Flambda.Expr (Var arg)) args in + Flambda_utils.bind ~body + ~bindings:(List.combine (Parameter.List.vars freshened_params) args) + in + (* Add bindings for the variables bound by the closure. *) + let bindings_for_vars_bound_by_closure_and_params_to_args = + let bound_variables = + let params = Parameter.Set.vars function_decl.params in + Variable.Set.diff + (Variable.Set.diff function_body.free_variables params) + fun_vars + in + fold_over_projections_of_vars_bound_by_closure ~closure_id_being_applied + ~lhs_of_application ~bound_variables ~init:bindings_for_params_to_args + ~f:(fun ~acc:body ~var ~expr -> Flambda.create_let var expr body) + in + (* Add bindings for variables corresponding to the functions introduced by + the whole set of closures. Each such variable will be bound to a closure; + each such closure is in turn produced by moving from the closure being + applied to another closure in the same set. + *) + let expr = + Variable.Set.fold (fun another_closure_in_the_same_set expr -> + let used = + Variable.Set.mem another_closure_in_the_same_set + function_body.free_variables + in + if used then + Flambda.create_let another_closure_in_the_same_set + (Move_within_set_of_closures { + closure = lhs_of_application; + start_from = closure_id_being_applied; + move_to = Closure_id.wrap another_closure_in_the_same_set; + }) + expr + else expr) + fun_vars + bindings_for_vars_bound_by_closure_and_params_to_args + in + let env = E.set_never_inline env in + let env = E.activate_freshening env in + let env = E.set_inline_debuginfo ~dbg env in + simplify env r expr + +type state = { + old_inside_to_new_inside : Variable.t Variable.Map.t; + (* Map from old inner vars to new inner vars *) + old_outside_to_new_outside : Variable.t Variable.Map.t; + (* Map from old outer vars to new outer vars *) + old_params_to_new_outside : Variable.t Variable.Map.t; + (* Map from old parameters to new outer vars. These are params + that should be specialised if they are copied to the new set of + closures. *) + old_fun_var_to_new_fun_var : Variable.t Variable.Map.t; + (* Map from old fun vars to new fun vars. These are the functions + that will be copied into the new set of closures *) + let_bindings : (Variable.t * Flambda.named) list; + (* Let bindings that will surround the definition of the new set + of closures *) + to_copy : Variable.t list; + (* List of functions that still need to be copied to the new set + of closures *) + new_funs : Flambda.function_declaration Variable.Map.t; + (* The function declarations for the new set of closures *) + new_free_vars_with_old_projections : Flambda.specialised_to Variable.Map.t; + (* The free variables for the new set of closures, but the projection + fields still point to old free variables. *) + new_specialised_args_with_old_projections : + Flambda.specialised_to Variable.Map.t; + (* The specialised parameters for the new set of closures, but the + projection fields still point to old specialised parameters. *) +} + +let empty_state = + { to_copy = []; + old_inside_to_new_inside = Variable.Map.empty; + old_outside_to_new_outside = Variable.Map.empty; + old_params_to_new_outside = Variable.Map.empty; + old_fun_var_to_new_fun_var = Variable.Map.empty; + let_bindings = []; + new_funs = Variable.Map.empty; + new_free_vars_with_old_projections = Variable.Map.empty; + new_specialised_args_with_old_projections = Variable.Map.empty; } + +(* Add let bindings for the free vars in the set_of_closures and + add them to [old_outside_to_new_outside] *) +let bind_free_vars ~lhs_of_application ~closure_id_being_applied + ~state ~free_vars = + Variable.Map.fold + (fun free_var (spec : Flambda.specialised_to) state -> + let var_clos = new_var Internal_variable_names.from_closure in + let expr : Flambda.named = + Project_var { + closure = lhs_of_application; + closure_id = closure_id_being_applied; + var = Var_within_closure.wrap free_var; + } + in + let let_bindings = (var_clos, expr) :: state.let_bindings in + let old_outside_to_new_outside = + Variable.Map.add spec.var var_clos state.old_outside_to_new_outside + in + { state with let_bindings; old_outside_to_new_outside }) + free_vars state + +(* For arguments of specialised parameters: + - Add them to [old_outside_to_new_outside] + - Add them and their invariant aliases to [old_params_to_new_outside] + For other arguments that are also worth specialising: + - Add them and their invariant aliases to [old_params_to_new_outside] *) +let register_arguments ~specialised_args ~invariant_params + ~state ~params ~args ~args_approxs = + let rec loop ~state ~params ~args ~args_approxs = + match params, args, args_approxs with + | [], [], [] -> state + | param :: params, arg :: args, arg_approx :: args_approxs -> begin + let param = Parameter.var param in + let worth_specialising, old_outside_to_new_outside = + match Variable.Map.find_opt param specialised_args with + | Some (spec : Flambda.specialised_to) -> + let old_outside_to_new_outside = + Variable.Map.add spec.var arg state.old_outside_to_new_outside + in + true, old_outside_to_new_outside + | None -> + let worth_specialising = + A.useful arg_approx + && Variable.Map.mem param (Lazy.force invariant_params) + in + worth_specialising, state.old_outside_to_new_outside + in + let old_params_to_new_outside = + if worth_specialising then begin + let old_params_to_new_outside = + Variable.Map.add param arg state.old_params_to_new_outside + in + match Variable.Map.find_opt param (Lazy.force invariant_params) with + | Some set -> + Variable.Set.fold + (fun elem acc -> Variable.Map.add elem arg acc) + set old_params_to_new_outside + | None -> + old_params_to_new_outside + end else begin + state.old_params_to_new_outside + end + in + let state = + { state with old_outside_to_new_outside; old_params_to_new_outside } + in + loop ~state ~params ~args ~args_approxs + end + | _, _, _ -> assert false + in + loop ~state ~params ~args ~args_approxs + +(* Add an old parameter to [old_inside_to_new_inside]. If it appears in + [old_params_to_new_outside] then also add it to the new specialised args. *) +let add_param ~specialised_args ~state ~param = + let param = Parameter.var param in + let new_param = Variable.rename param in + let old_inside_to_new_inside = + Variable.Map.add param new_param state.old_inside_to_new_inside + in + let new_specialised_args_with_old_projections = + match Variable.Map.find_opt param specialised_args with + | Some (spec : Flambda.specialised_to) -> + let new_outside_var = + Variable.Map.find spec.var state.old_outside_to_new_outside + in + let new_spec : Flambda.specialised_to = + { spec with var = new_outside_var } + in + Variable.Map.add new_param new_spec + state.new_specialised_args_with_old_projections + | None -> begin + match Variable.Map.find_opt param state.old_params_to_new_outside with + | None -> state.new_specialised_args_with_old_projections + | Some new_outside_var -> + let new_spec : Flambda.specialised_to = + { var = new_outside_var; projection = None } + in + Variable.Map.add new_param new_spec + state.new_specialised_args_with_old_projections + end + in + let state = + { state with old_inside_to_new_inside; + new_specialised_args_with_old_projections } + in + state, Parameter.wrap new_param + +(* Add a let binding for an old fun_var, add it to the new free variables, and + add it to [old_inside_to_new_inside] *) +let add_fun_var ~lhs_of_application ~closure_id_being_applied ~state ~fun_var = + if Variable.Map.mem fun_var state.old_inside_to_new_inside then state + else begin + let inside_var = Variable.rename fun_var in + let outside_var = Variable.create Internal_variable_names.closure in + let expr = + Flambda.Move_within_set_of_closures + { closure = lhs_of_application; + start_from = closure_id_being_applied; + move_to = Closure_id.wrap fun_var; } + in + let let_bindings = (outside_var, expr) :: state.let_bindings in + let spec : Flambda.specialised_to = + { var = outside_var; projection = None; } + in + let new_free_vars_with_old_projections = + Variable.Map.add inside_var spec state.new_free_vars_with_old_projections + in + let old_inside_to_new_inside = + Variable.Map.add fun_var inside_var state.old_inside_to_new_inside + in + { state with + old_inside_to_new_inside; let_bindings; + new_free_vars_with_old_projections } + end + +(* Add an old free_var to the new free variables and add it to + [old_inside_to_new_inside]. *) +let add_free_var ~free_vars ~state ~free_var = + if Variable.Map.mem free_var state.old_inside_to_new_inside then state + else begin + let spec : Flambda.specialised_to = Variable.Map.find free_var free_vars in + let outside_var = spec.var in + let new_outside_var = + Variable.Map.find outside_var state.old_outside_to_new_outside + in + let new_spec : Flambda.specialised_to = + { spec with var = new_outside_var } + in + let new_inside_var = Variable.rename free_var in + let new_free_vars_with_old_projections = + Variable.Map.add new_inside_var new_spec + state.new_free_vars_with_old_projections + in + let old_inside_to_new_inside = + Variable.Map.add free_var new_inside_var state.old_inside_to_new_inside + in + { state with old_inside_to_new_inside; new_free_vars_with_old_projections } + end + +(* Add a function to the new set of closures iff: + 1) All it's specialised parameters are available in + [old_outside_to_new_outside] + 2) At least one more parameter will become specialised *) +let add_function ~specialised_args ~state ~fun_var ~function_decl = + match function_decl.A.function_body with + | None -> None + | Some _ -> begin + let rec loop worth_specialising = function + | [] -> worth_specialising + | param :: params -> begin + let param = Parameter.var param in + match Variable.Map.find_opt param specialised_args with + | Some (spec : Flambda.specialised_to) -> + Variable.Map.mem spec.var state.old_outside_to_new_outside + && loop worth_specialising params + | None -> + let worth_specialising = + worth_specialising + || Variable.Map.mem param state.old_params_to_new_outside + in + loop worth_specialising params + end + in + let worth_specialising = loop false function_decl.A.params in + if not worth_specialising then None + else begin + let new_fun_var = Variable.rename fun_var in + let old_fun_var_to_new_fun_var = + Variable.Map.add fun_var new_fun_var state.old_fun_var_to_new_fun_var + in + let to_copy = fun_var :: state.to_copy in + let state = { state with old_fun_var_to_new_fun_var; to_copy } in + Some (state, new_fun_var) + end + end + +(* Lookup a function in the new set of closures, trying to add it if + necessary. *) +let lookup_function ~specialised_args ~state ~fun_var ~function_decl = + match Variable.Map.find_opt fun_var state.old_fun_var_to_new_fun_var with + | Some new_fun_var -> Some (state, new_fun_var) + | None -> add_function ~specialised_args ~state ~fun_var ~function_decl + +(* A direct call to a function in the new set of closures can be specialised + if all the function's newly specialised parameters are passed arguments + that are specialised to the same outside variable *) +let specialisable_call ~specialised_args ~state ~args ~params = + List.for_all2 + (fun arg param -> + let param = Parameter.var param in + if Variable.Map.mem param specialised_args then true + else begin + let old_params_to_new_outside = state.old_params_to_new_outside in + match Variable.Map.find_opt param old_params_to_new_outside with + | None -> true + | Some outside_var -> begin + match Variable.Map.find_opt arg old_params_to_new_outside with + | Some outside_var' -> + Variable.equal outside_var outside_var' + | None -> false + end + end) + args params + +(* Rewrite a call iff: + 1) It is to a function in the old set of closures that can be specialised + 2) All the newly specialised parameters of that function are passed values + known to be equal to their new specialisation. *) +let rec rewrite_direct_call ~specialised_args ~funs ~direct_call_surrogates + ~state ~closure_id ~(apply : Flambda.apply) = + match Closure_id.Map.find_opt closure_id direct_call_surrogates with + | Some closure_id -> + rewrite_direct_call ~specialised_args ~funs ~direct_call_surrogates + ~state ~closure_id ~apply + | None -> begin + let fun_var = Closure_id.unwrap closure_id in + match Variable.Map.find_opt fun_var funs with + | None -> None + | Some function_decl -> begin + match + lookup_function ~specialised_args ~state ~fun_var ~function_decl + with + | None -> None + | Some (state, new_fun_var) -> begin + let args = apply.args in + let params = function_decl.A.params in + let specialisable = + specialisable_call ~specialised_args ~state ~args ~params + in + if not specialisable then None + else begin + let kind = Flambda.Direct (Closure_id.wrap new_fun_var) in + let apply = { apply with func = new_fun_var; kind } in + Some (state, Flambda.Apply apply) + end + end + end + end + +(* Rewrite the body a function declaration for use in the new set of + closures. *) +let rewrite_function ~lhs_of_application ~closure_id_being_applied + ~direct_call_surrogates ~specialised_args ~free_vars ~funs + ~state fun_var = + let function_decl : A.function_declaration = + Variable.Map.find fun_var funs + in + let function_body = + match function_decl.function_body with + | None -> assert false + | Some function_body -> function_body + in + let new_fun_var = + Variable.Map.find fun_var state.old_fun_var_to_new_fun_var + in + let state, params = + List.fold_right + (fun param (state, params) -> + let state, param = add_param ~specialised_args ~state ~param in + (state, param :: params)) + function_decl.params (state, []) + in + let state = + Variable.Set.fold + (fun var state -> + if Variable.Map.mem var funs then + add_fun_var ~lhs_of_application ~closure_id_being_applied + ~state ~fun_var:var + else if Variable.Map.mem var free_vars then + add_free_var ~free_vars ~state ~free_var:var + else + state) + function_body.free_variables state + in + let state_ref = ref state in + let body = + Flambda_iterators.map_toplevel_expr + (fun (expr : Flambda.t) -> + match expr with + | Apply ({ kind = Direct closure_id } as apply) -> begin + match + rewrite_direct_call ~specialised_args ~funs + ~direct_call_surrogates ~state:!state_ref ~closure_id ~apply + with + | None -> expr + | Some (state, expr) -> + state_ref := state; + expr + end + | _ -> expr) + function_body.body + in + let body = + Flambda_utils.toplevel_substitution state.old_inside_to_new_inside body + in + let new_function_decl = + Flambda.create_function_declaration + ~params ~body + ~stub:function_body.stub + ~dbg:function_body.dbg + ~inline:function_body.inline + ~specialise:function_body.specialise + ~is_a_functor:function_body.is_a_functor + ~closure_origin:(Closure_origin.create (Closure_id.wrap new_fun_var)) + in + let new_funs = + Variable.Map.add new_fun_var new_function_decl state.new_funs + in + let state = { !state_ref with new_funs } in + state + +let update_projections ~state projections = + let old_to_new = state.old_inside_to_new_inside in + Variable.Map.map + (fun (spec_to : Flambda.specialised_to) -> + let projection : Projection.t option = + match spec_to.projection with + | None -> None + | Some (Project_var proj) -> begin + match Variable.Map.find_opt proj.closure old_to_new with + | None -> None + | Some closure -> + let proj = { proj with closure } in + Some (Projection.Project_var proj) + end + | Some (Project_closure proj) -> begin + match Variable.Map.find_opt proj.set_of_closures old_to_new with + | None -> None + | Some set_of_closures -> + let proj = { proj with set_of_closures } in + Some (Projection.Project_closure proj) + end + | Some (Move_within_set_of_closures proj) -> begin + match Variable.Map.find_opt proj.closure old_to_new with + | None -> None + | Some closure -> + let proj = { proj with closure } in + Some (Projection.Move_within_set_of_closures proj) + end + | Some (Field (index, var)) -> begin + match Variable.Map.find_opt var old_to_new with + | None -> None + | Some var -> Some (Projection.Field(index, var)) + end + in + { spec_to with projection }) + projections + +let inline_by_copying_function_declaration + ~(env : Inline_and_simplify_aux.Env.t) + ~(r : Inline_and_simplify_aux.Result.t) + ~(function_decls : A.function_declarations) + ~(lhs_of_application : Variable.t) + ~(inline_requested : Lambda.inline_attribute) + ~(closure_id_being_applied : Closure_id.t) + ~(function_decl : A.function_declaration) + ~(args : Variable.t list) + ~(args_approxs : A.t list) + ~(invariant_params : Variable.Set.t Variable.Map.t lazy_t) + ~(specialised_args : Flambda.specialised_to Variable.Map.t) + ~(free_vars : Flambda.specialised_to Variable.Map.t) + ~(direct_call_surrogates : Closure_id.t Closure_id.Map.t) + ~(dbg : Debuginfo.t) + ~(simplify : Inlining_decision_intf.simplify) = + let state = empty_state in + let state = + bind_free_vars ~lhs_of_application ~closure_id_being_applied + ~state ~free_vars + in + let params = function_decl.params in + let state = + register_arguments ~specialised_args ~invariant_params + ~state ~params ~args ~args_approxs + in + let fun_var = Closure_id.unwrap closure_id_being_applied in + match add_function ~specialised_args ~state ~fun_var ~function_decl with + | None -> None + | Some (state, new_fun_var) -> begin + let funs = function_decls.funs in + let rec loop state = + match state.to_copy with + | [] -> state + | next :: rest -> + let state = { state with to_copy = rest } in + let state = + rewrite_function ~lhs_of_application ~closure_id_being_applied + ~direct_call_surrogates ~specialised_args ~free_vars ~funs + ~state next + in + loop state + in + let state = loop state in + let closure_id = Closure_id.wrap new_fun_var in + let function_decls = + Flambda.create_function_declarations_with_origin + ~funs:state.new_funs + ~set_of_closures_origin:function_decls.set_of_closures_origin + ~is_classic_mode:function_decls.is_classic_mode + in + let free_vars = + update_projections ~state + state.new_free_vars_with_old_projections + in + let specialised_args = + update_projections ~state + state.new_specialised_args_with_old_projections + in + let direct_call_surrogates = Variable.Map.empty in + let set_of_closures = + Flambda.create_set_of_closures ~function_decls + ~free_vars ~specialised_args ~direct_call_surrogates + in + let closure_var = new_var Internal_variable_names.dup_func in + let set_of_closures_var = + new_var Internal_variable_names.dup_set_of_closures + in + let project : Flambda.project_closure = + {set_of_closures = set_of_closures_var; closure_id} + in + let apply : Flambda.apply = + { func = closure_var; args; kind = Direct closure_id; dbg; + inline = inline_requested; specialise = Default_specialise; } + in + let body = + Flambda.create_let + set_of_closures_var (Set_of_closures set_of_closures) + (Flambda.create_let closure_var (Project_closure project) + (Apply apply)) + in + let expr = Flambda_utils.bind ~body ~bindings:state.let_bindings in + let env = E.activate_freshening (E.set_never_inline env) in + Some (simplify env r expr) + end diff --git a/middle_end/flambda/inlining_transforms.mli b/middle_end/flambda/inlining_transforms.mli new file mode 100644 index 0000000000..e31d1b0849 --- /dev/null +++ b/middle_end/flambda/inlining_transforms.mli @@ -0,0 +1,105 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(** Source code transformations used during inlining. *) + +(** Inline a function by substituting its body (which may be subject to + further transformation) at a call site. The function's declaration is + not copied. + + This transformation is used when: + - inlining a call to a non-recursive function; + - inlining a call, within a recursive or mutually-recursive function, to + the same or another function being defined simultaneously ("unrolling"). + The maximum depth of unrolling is bounded (see [E.unrolling_allowed]). + + In both cases, the body of the function is copied, within a sequence of + [let]s that bind the function parameters, the variables "bound by the + closure" (see flambda.mli), and any function identifiers introduced by the + set of closures. These stages are delimited below by comments. + + As an example, suppose we are inlining the following function: + + let f x = x + y + ... + let p = f, f in + (fst p) 42 + + The call site [ (fst p) 42] will be transformed to: + + let clos_id = fst p in (* must eventually yield a closure *) + let y = in + let x' = 42 in + let x = x' in + x + y + + When unrolling a recursive function we rename the arguments to the + recursive call in order to avoid clashes with existing bindings. For + example, suppose we are inlining the following call to [f], which lies + within its own declaration: + + let rec f x y = + f (fst x) (y + snd x) + + This will be transformed to: + + let rec f x y = + let clos_id = f in (* not used this time, since [f] has no free vars *) + let x' = fst x in + let y' = y + snd x in + f (fst x') (y' + snd x') (* body of [f] with parameters freshened *) +*) +val inline_by_copying_function_body + : env:Inline_and_simplify_aux.Env.t + -> r:Inline_and_simplify_aux.Result.t + -> lhs_of_application:Variable.t + -> inline_requested:Lambda.inline_attribute + -> specialise_requested:Lambda.specialise_attribute + -> closure_id_being_applied:Closure_id.t + -> function_decl:Simple_value_approx.function_declaration + -> function_body:Simple_value_approx.function_body + -> fun_vars:Variable.Set.t + -> args:Variable.t list + -> dbg:Debuginfo.t + -> simplify:Inlining_decision_intf.simplify + -> Flambda.t * Inline_and_simplify_aux.Result.t + +(** Inlining of recursive function(s) yields a copy of the functions' + definitions (not just their bodies, unlike the non-recursive case) and + a direct application of the new body. + Note: the function really does need to be recursive (but possibly only via + some mutual recursion) to end up in here; a simultaneous binding [that is + non-recursive] is not sufficient. +*) +val inline_by_copying_function_declaration + : env:Inline_and_simplify_aux.Env.t + -> r:Inline_and_simplify_aux.Result.t + -> function_decls:Simple_value_approx.function_declarations + -> lhs_of_application:Variable.t + -> inline_requested:Lambda.inline_attribute + -> closure_id_being_applied:Closure_id.t + -> function_decl:Simple_value_approx.function_declaration + -> args:Variable.t list + -> args_approxs:Simple_value_approx.t list + -> invariant_params:Variable.Set.t Variable.Map.t lazy_t + -> specialised_args:Flambda.specialised_to Variable.Map.t + -> free_vars:Flambda.specialised_to Variable.Map.t + -> direct_call_surrogates:Closure_id.t Closure_id.Map.t + -> dbg:Debuginfo.t + -> simplify:Inlining_decision_intf.simplify + -> (Flambda.t * Inline_and_simplify_aux.Result.t) option diff --git a/middle_end/flambda/invariant_params.ml b/middle_end/flambda/invariant_params.ml new file mode 100644 index 0000000000..a43cfdace1 --- /dev/null +++ b/middle_end/flambda/invariant_params.ml @@ -0,0 +1,420 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +(* CR-someday pchambart to pchambart: in fact partial application doesn't + work because there are no 'known' partial application left: they are + converted to applications new partial function declaration. + That can be improved (and many other cases) by keeping track of aliases in + closure of functions. *) + +(* These analyses are computed in two steps: + * accumulate the atomic <- relations + * compute the least-fixed point + + The <- relation is represented by the type + + t Variable.Pair.Map.t + + if [Variable.Pair.Map.find (f, x) relation = Top] then (f, x) <- Top + is in the relation. + + if [Variable.Pair.Map.find (f, x) relation = Implication s] and + [Variable.Pair.Set.mem (g, y) s] then (f, x) <- (g, y) is in the + relation. +*) + +type t = + | Top + | Implication of Variable.Pair.Set.t + +let _print ppf = function + | Top -> Format.fprintf ppf "Top" + | Implication args -> + Format.fprintf ppf "Implication: @[%a@]" + Variable.Pair.Set.print args + +let top relation p = + Variable.Pair.Map.add p Top relation + +let implies relation from to_ = + match Variable.Pair.Map.find to_ relation with + | Top -> relation + | Implication set -> + Variable.Pair.Map.add to_ + (Implication (Variable.Pair.Set.add from set)) + relation + | exception Not_found -> + Variable.Pair.Map.add to_ + (Implication (Variable.Pair.Set.singleton from)) + relation + +let transitive_closure state = + let union s1 s2 = + match s1, s2 with + | Top, _ | _, Top -> Top + | Implication s1, Implication s2 -> + Implication (Variable.Pair.Set.union s1 s2) + in + let equal s1 s2 = + match s1, s2 with + | Top, Implication _ | Implication _, Top -> false + | Top, Top -> true + | Implication s1, Implication s2 -> Variable.Pair.Set.equal s1 s2 + in + let update arg state = + let original_set = + try Variable.Pair.Map.find arg state with + | Not_found -> Implication Variable.Pair.Set.empty + in + match original_set with + | Top -> state + | Implication arguments -> + let set = + Variable.Pair.Set.fold + (fun orig acc-> + let set = + try Variable.Pair.Map.find orig state with + | Not_found -> Implication Variable.Pair.Set.empty in + union set acc) + arguments original_set + in + Variable.Pair.Map.add arg set state + in + let once state = + Variable.Pair.Map.fold (fun arg _ state -> update arg state) state state + in + let rec fp state = + let state' = once state in + if Variable.Pair.Map.equal equal state state' + then state + else fp state' + in + fp state + +(* CR-soon pchambart: to move to Flambda_utils and document + mshinwell: I think this calculation is basically the same as + [Flambda_utils.fun_vars_referenced_in_decls], so we should try + to share code. However let's defer until after 4.03. (And note CR + below.) +*) +(* Finds variables that represent the functions. + In a construction like: + let f x = + let g = Symbol f_closure in + .. + the variable g is bound to the symbol f_closure which + is the current closure. + The result of [function_variable_alias] will contain + the association [g -> f] +*) +let function_variable_alias + (function_decls : Flambda.function_declarations) + ~backend = + let fun_vars = Variable.Map.keys function_decls.funs in + let symbols_to_fun_vars = + let module Backend = (val backend : Backend_intf.S) in + Variable.Set.fold (fun fun_var symbols_to_fun_vars -> + let closure_id = Closure_id.wrap fun_var in + let symbol = Backend.closure_symbol closure_id in + Symbol.Map.add symbol fun_var symbols_to_fun_vars) + fun_vars + Symbol.Map.empty + in + let fun_var_bindings = ref Variable.Map.empty in + Variable.Map.iter (fun _ ( function_decl : Flambda.function_declaration ) -> + Flambda_iterators.iter_all_toplevel_immutable_let_and_let_rec_bindings + ~f:(fun var named -> + (* CR-soon mshinwell: consider having the body passed to this + function and using fv calculation instead of used_variables. + Need to be careful of "let rec" *) + match named with + | Symbol sym -> + begin match Symbol.Map.find sym symbols_to_fun_vars with + | exception Not_found -> () + | fun_var -> + fun_var_bindings := + Variable.Map.add var fun_var !fun_var_bindings + end + | _ -> ()) + function_decl.body) + function_decls.funs; + !fun_var_bindings + +let analyse_functions ~backend ~param_to_param + ~anything_to_param ~param_to_anywhere + (decls : Flambda.function_declarations) = + let function_variable_alias = function_variable_alias ~backend decls in + let param_indexes_by_fun_vars = + Variable.Map.map (fun (decl : Flambda.function_declaration) -> + Array.of_list (Parameter.List.vars decl.params)) + decls.funs + in + let find_callee_arg ~callee ~callee_pos = + match Variable.Map.find callee param_indexes_by_fun_vars with + | exception Not_found -> None (* not a recursive call *) + | arr -> + (* Ignore overapplied parameters: they are applied to a different + function. *) + if callee_pos < Array.length arr then Some arr.(callee_pos) + else None + in + let escaping_functions = Variable.Tbl.create 13 in + let escaping_function fun_var = + let fun_var = + match Variable.Map.find fun_var function_variable_alias with + | exception Not_found -> fun_var + | fun_var -> fun_var + in + if Variable.Map.mem fun_var decls.funs + then Variable.Tbl.add escaping_functions fun_var (); + in + let used_variables = Variable.Tbl.create 42 in + let used_variable var = Variable.Tbl.add used_variables var () in + let relation = ref Variable.Pair.Map.empty in + (* If the called closure is in the current set of closures, record the + relation (callee, callee_arg) <- (caller, caller_arg) *) + let check_argument ~caller ~callee ~callee_pos ~caller_arg = + escaping_function caller_arg; + match find_callee_arg ~callee ~callee_pos with + | None -> used_variable caller_arg (* not a recursive call *) + | Some callee_arg -> + match Variable.Map.find caller decls.funs with + | exception Not_found -> + assert false + | { params } -> + let new_relation = + (* We only track dataflow for parameters of functions, not + arbitrary variables. *) + if List.exists + (fun param -> Variable.equal (Parameter.var param) caller_arg) + params + then + param_to_param ~caller ~caller_arg ~callee ~callee_arg !relation + else begin + used_variable caller_arg; + anything_to_param ~callee ~callee_arg !relation + end + in + relation := new_relation + in + let arity ~callee = + match Variable.Map.find callee decls.funs with + | exception Not_found -> 0 + | func -> Flambda_utils.function_arity func + in + let check_expr ~caller (expr : Flambda.t) = + match expr with + | Apply { func; args } -> + used_variable func; + let callee = + match Variable.Map.find func function_variable_alias with + | exception Not_found -> func + | callee -> callee + in + let num_args = List.length args in + for callee_pos = num_args to (arity ~callee) - 1 do + (* If a function is partially applied, consider all missing + arguments as "anything". *) + match find_callee_arg ~callee ~callee_pos with + | None -> () + | Some callee_arg -> + relation := anything_to_param ~callee ~callee_arg !relation + done; + List.iteri (fun callee_pos caller_arg -> + check_argument ~caller ~callee ~callee_pos ~caller_arg) + args + | _ -> () + in + Variable.Map.iter (fun caller (decl : Flambda.function_declaration) -> + Flambda_iterators.iter (check_expr ~caller) + (fun (_ : Flambda.named) -> ()) + decl.body; + Variable.Set.iter + (fun var -> escaping_function var; used_variable var) + (* CR-soon mshinwell: we should avoid recomputing this, cache in + [function_declaration]. See also comment on + [only_via_symbols] in [Flambda_utils]. *) + (Flambda.free_variables ~ignore_uses_as_callee:() + ~ignore_uses_as_argument:() decl.body)) + decls.funs; + Variable.Map.iter + (fun func_var ({ params } : Flambda.function_declaration) -> + List.iter + (fun (param : Parameter.t) -> + if Variable.Tbl.mem used_variables (Parameter.var param) then + relation := + param_to_anywhere ~caller:func_var + ~caller_arg:(Parameter.var param) !relation; + if Variable.Tbl.mem escaping_functions func_var then + relation := + anything_to_param ~callee:func_var + ~callee_arg:(Parameter.var param) !relation) + params) + decls.funs; + transitive_closure !relation + + +(* A parameter [x] of the function [f] is considered as unchanging if + during an 'external' (call from outside the set of closures) call of + [f], every recursive call of [f] all the instances of [x] are aliased + to the original one. This function computes an underapproximation of + that set by computing the flow of parameters between the different + functions of the set of closures. + + We record [(f, x) <- (g, y)] when the function g calls f and + the y parameter of g is used as argument for the x parameter of f. For + instance in + + let rec f x = ... + and g y = f x + + We record [(f, x) <- Top] when some unknown values can flow to the + [y] parameter. + + let rec f x = f 1 + + We record also [(f, x) <- Top] if [f] could escape. This is over + approximated by considering that a function escape when its variable is used + for something else than an application: + + let rec f x = (f, f) + + [x] is not unchanging if either + (f, x) <- Top + or (f, x) <- (f, y) with x != y + + Notice that having (f, x) <- (g, a) and (f, x) <- (g, b) does not make + x not unchanging. This is because (g, a) and (g, b) represent necessarily + different values only if g is the externaly called function. If some + value where created during the execution of the function that could + flow to (g, a), then (g, a) <- Top, so (f, x) <- Top. + + *) + +let invariant_params_in_recursion (decls : Flambda.function_declarations) + ~backend = + let param_to_param ~caller ~caller_arg ~callee ~callee_arg relation = + implies relation (caller, caller_arg) (callee, callee_arg) + in + let anything_to_param ~callee ~callee_arg relation = + top relation (callee, callee_arg) + in + let param_to_anywhere ~caller:_ ~caller_arg:_ relation = relation in + let relation = + analyse_functions ~backend ~param_to_param + ~anything_to_param ~param_to_anywhere + decls + in + let not_unchanging = + Variable.Pair.Map.fold (fun (func, var) set not_unchanging -> + match set with + | Top -> Variable.Set.add var not_unchanging + | Implication set -> + if Variable.Pair.Set.exists (fun (func', var') -> + Variable.equal func func' && not (Variable.equal var var')) + set + then Variable.Set.add var not_unchanging + else not_unchanging) + relation Variable.Set.empty + in + let params = Variable.Map.fold (fun _ + ({ params } : Flambda.function_declaration) set -> + Variable.Set.union (Parameter.Set.vars params) set) + decls.funs Variable.Set.empty + in + let unchanging = Variable.Set.diff params not_unchanging in + let aliased_to = + Variable.Pair.Map.fold (fun (_, var) set aliases -> + match set with + | Implication set + when Variable.Set.mem var unchanging -> + Variable.Pair.Set.fold (fun (_, caller_args) aliases -> + if Variable.Set.mem caller_args unchanging then + let alias_set = + match Variable.Map.find caller_args aliases with + | exception Not_found -> + Variable.Set.singleton var + | alias_set -> + Variable.Set.add var alias_set + in + Variable.Map.add caller_args alias_set aliases + else + aliases) + set aliases + | Top | Implication _ -> aliases) + relation Variable.Map.empty + in + (* We complete the set of aliases such that there does not miss any + unchanging param *) + Variable.Map.of_set (fun var -> + match Variable.Map.find var aliased_to with + | exception Not_found -> Variable.Set.empty + | set -> set) + unchanging + +let invariant_param_sources decls ~backend = + let param_to_param ~caller ~caller_arg ~callee ~callee_arg relation = + implies relation (caller, caller_arg) (callee, callee_arg) + in + let anything_to_param ~callee:_ ~callee_arg:_ relation = relation in + let param_to_anywhere ~caller:_ ~caller_arg:_ relation = relation in + let relation = + analyse_functions ~backend ~param_to_param + ~anything_to_param ~param_to_anywhere + decls + in + Variable.Pair.Map.fold (fun (_, var) set relation -> + match set with + | Top -> relation + | Implication set -> Variable.Map.add var set relation) + relation Variable.Map.empty + +let pass_name = "unused-arguments" +let () = Clflags.all_passes := pass_name :: !Clflags.all_passes + +let unused_arguments (decls : Flambda.function_declarations) ~backend = + let dump = Clflags.dumped_pass pass_name in + let param_to_param ~caller ~caller_arg ~callee ~callee_arg relation = + implies relation (callee, callee_arg) (caller, caller_arg) + in + let anything_to_param ~callee:_ ~callee_arg:_ relation = relation in + let param_to_anywhere ~caller ~caller_arg relation = + top relation (caller, caller_arg) + in + let relation = + analyse_functions ~backend ~param_to_param + ~anything_to_param ~param_to_anywhere + decls + in + let arguments = + Variable.Map.fold + (fun fun_var decl acc -> + List.fold_left + (fun acc param -> + match Variable.Pair.Map.find (fun_var, param) relation with + | exception Not_found -> Variable.Set.add param acc + | Implication _ -> Variable.Set.add param acc + | Top -> acc) + acc (Parameter.List.vars decl.Flambda.params)) + decls.funs Variable.Set.empty + in + if dump then begin + Format.printf "Unused arguments: %a@." Variable.Set.print arguments + end; + arguments diff --git a/middle_end/flambda/invariant_params.mli b/middle_end/flambda/invariant_params.mli new file mode 100644 index 0000000000..c68514203c --- /dev/null +++ b/middle_end/flambda/invariant_params.mli @@ -0,0 +1,57 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(* [invariant_params_in_recursion] calculates the set of parameters whose + values are known not to change during the execution of a recursive + function. As such, occurrences of the parameters may always be replaced + by the corresponding values. + + For example, [x] would be in [invariant_params] for both of the following + functions: + + let rec f x y = (f x y) + (f x (y+1)) + + let rec f x l = List.iter (f x) l + + For invariant parameters it also computes the set of parameters of functions + in the set of closures that are always aliased to it. For example in the set + of closures: + + let rec f x y = (f x y) + (f x (y+1)) + g x + and g z = z + 1 + + The map of aliases is + + x -> { x; z } +*) +val invariant_params_in_recursion + : Flambda.function_declarations + -> backend:(module Backend_intf.S) + -> Variable.Set.t Variable.Map.t + +val invariant_param_sources + : Flambda.function_declarations + -> backend:(module Backend_intf.S) + -> Variable.Pair.Set.t Variable.Map.t + +(* CR-soon mshinwell: think about whether this function should + be in this file. Should it be called "unused_parameters"? *) +val unused_arguments + : Flambda.function_declarations + -> backend:(module Backend_intf.S) + -> Variable.Set.t diff --git a/middle_end/flambda/lift_code.ml b/middle_end/flambda/lift_code.ml new file mode 100644 index 0000000000..02292c46e1 --- /dev/null +++ b/middle_end/flambda/lift_code.ml @@ -0,0 +1,163 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +type lifter = Flambda.program -> Flambda.program + +let rebuild_let + (defs : (Variable.t * Flambda.named Flambda.With_free_variables.t) list) + (body : Flambda.t) = + let module W = Flambda.With_free_variables in + List.fold_left (fun body (var, def) -> + W.create_let_reusing_defining_expr var def body) + body defs + +let rec extract_lets + (acc:(Variable.t * Flambda.named Flambda.With_free_variables.t) list) + (let_expr:Flambda.let_expr) : + (Variable.t * Flambda.named Flambda.With_free_variables.t) list * + Flambda.t Flambda.With_free_variables.t = + let module W = Flambda.With_free_variables in + match let_expr with + | { var = v1; defining_expr = Expr (Let let2); _ } -> + let acc, body2 = extract_lets acc let2 in + let acc = (v1, W.expr body2) :: acc in + let body = W.of_body_of_let let_expr in + extract acc body + | { var = v; _ } -> + let acc = (v, W.of_defining_expr_of_let let_expr) :: acc in + let body = W.of_body_of_let let_expr in + extract acc body + +and extract acc (expr : Flambda.t Flambda.With_free_variables.t) = + let module W = Flambda.With_free_variables in + match W.contents expr with + | Let let_expr -> + extract_lets acc let_expr + | _ -> + acc, expr + +let rec lift_lets_expr (expr:Flambda.t) ~toplevel : Flambda.t = + let module W = Flambda.With_free_variables in + match expr with + | Let let_expr -> + let defs, body = extract_lets [] let_expr in + let rev_defs = + List.rev_map (lift_lets_named_with_free_variables ~toplevel) defs + in + let body = lift_lets_expr (W.contents body) ~toplevel in + rebuild_let (List.rev rev_defs) body + | e -> + Flambda_iterators.map_subexpressions + (lift_lets_expr ~toplevel) + (lift_lets_named ~toplevel) + e + +and lift_lets_named_with_free_variables + ((var, named):Variable.t * Flambda.named Flambda.With_free_variables.t) + ~toplevel : Variable.t * Flambda.named Flambda.With_free_variables.t = + let module W = Flambda.With_free_variables in + match W.contents named with + | Expr e -> + var, W.expr (W.of_expr (lift_lets_expr e ~toplevel)) + | Set_of_closures set when not toplevel -> + var, + W.of_named + (Set_of_closures + (Flambda_iterators.map_function_bodies + ~f:(lift_lets_expr ~toplevel) set)) + | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ + | Read_symbol_field (_, _) | Project_closure _ | Move_within_set_of_closures _ + | Project_var _ | Prim _ | Set_of_closures _ -> + var, named + +and lift_lets_named _var (named:Flambda.named) ~toplevel : Flambda.named = + let module W = Flambda.With_free_variables in + match named with + | Expr e -> + Expr (lift_lets_expr e ~toplevel) + | Set_of_closures set when not toplevel -> + Set_of_closures + (Flambda_iterators.map_function_bodies ~f:(lift_lets_expr ~toplevel) set) + | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ + | Read_symbol_field (_, _) | Project_closure _ | Move_within_set_of_closures _ + | Project_var _ | Prim _ | Set_of_closures _ -> + named + +module Sort_lets = Strongly_connected_components.Make (Variable) + +let rebuild_let_rec (defs:(Variable.t * Flambda.named) list) body = + let map = Variable.Map.of_list defs in + let graph = + Variable.Map.map + (fun named -> + Variable.Set.filter (fun v -> Variable.Map.mem v map) + (Flambda.free_variables_named named)) + map + in + let components = + Sort_lets.connected_components_sorted_from_roots_to_leaf graph + in + Array.fold_left (fun body (component:Sort_lets.component) -> + match component with + | No_loop v -> + let def = Variable.Map.find v map in + Flambda.create_let v def body + | Has_loop l -> + Flambda.Let_rec + (List.map (fun v -> v, Variable.Map.find v map) l, + body)) + body components + +let lift_let_rec program = + Flambda_iterators.map_exprs_at_toplevel_of_program program + ~f:(Flambda_iterators.map_expr + (fun expr -> match expr with + | Let_rec (defs, body) -> + rebuild_let_rec defs body + | expr -> expr)) + +let lift_lets program = + let program = lift_let_rec program in + Flambda_iterators.map_exprs_at_toplevel_of_program program + ~f:(lift_lets_expr ~toplevel:false) + +let lifting_helper exprs ~evaluation_order ~create_body ~name = + let vars, lets = + (* [vars] corresponds elementwise to [exprs]; the order is unchanged. *) + List.fold_right (fun (flam : Flambda.t) (vars, lets) -> + match flam with + | Var v -> + (* Note that [v] is (statically) always an immutable variable. *) + v::vars, lets + | expr -> + let v = + Variable.create name ~current_compilation_unit: + (Compilation_unit.get_current_exn ()) + in + v::vars, (v, expr)::lets) + exprs ([], []) + in + let lets = + match evaluation_order with + | `Right_to_left -> lets + | `Left_to_right -> List.rev lets + in + List.fold_left (fun body (v, expr) -> + Flambda.create_let v (Expr expr) body) + (create_body vars) lets diff --git a/middle_end/flambda/lift_code.mli b/middle_end/flambda/lift_code.mli new file mode 100644 index 0000000000..92ecda0154 --- /dev/null +++ b/middle_end/flambda/lift_code.mli @@ -0,0 +1,43 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +type lifter = Flambda.program -> Flambda.program + +(** Lift [let] bindings to attempt to increase the length of scopes, as an + aid to further optimizations. For example: + let c = let b = in b, b in fst c + would be transformed to: + let b = in let c = b, b in fst c + which is then clearly just: + +*) +val lift_lets : lifter + +val lift_lets_expr : Flambda.t -> toplevel:bool -> Flambda.t + +(* CR-someday mshinwell: Rename to [bind]? Also see Flambda_utils.bind. *) +(* [create_body] always receives the variables corresponding to [evaluate] + in the same order. However [evaluation_order] specifies in which order + the (possibly complex) expressions bound to those variables are + evaluated. *) +val lifting_helper + : Flambda.t list + -> evaluation_order:[ `Left_to_right | `Right_to_left ] + -> create_body:(Variable.t list -> Flambda.t) + -> name:Internal_variable_names.t + -> Flambda.t diff --git a/middle_end/flambda/lift_constants.ml b/middle_end/flambda/lift_constants.ml new file mode 100644 index 0000000000..dd60de9ce2 --- /dev/null +++ b/middle_end/flambda/lift_constants.ml @@ -0,0 +1,1019 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +(* CR-someday mshinwell: move to Flambda_utils *) +let rec tail_variable : Flambda.t -> Variable.t option = function + | Var v -> Some v + | Let_rec (_, e) + | Let_mutable { body = e } + | Let { body = e; _ } -> tail_variable e + | _ -> None + +let closure_symbol ~(backend : (module Backend_intf.S)) closure_id = + let module Backend = (val backend) in + Backend.closure_symbol closure_id + +(** Traverse the given expression assigning symbols to [let]- and [let rec]- + bound constant variables. At the same time collect the definitions of + such variables. *) +let assign_symbols_and_collect_constant_definitions + ~(backend : (module Backend_intf.S)) + ~(program : Flambda.program) + ~(inconstants : Inconstant_idents.result) = + let var_to_symbol_tbl = Variable.Tbl.create 42 in + let var_to_definition_tbl = Variable.Tbl.create 42 in + let module AA = Alias_analysis in + let assign_symbol var (named : Flambda.named) = + if not (Inconstant_idents.variable var inconstants) then begin + let assign_symbol () = + let symbol = Symbol.of_variable (Variable.rename var) in + Variable.Tbl.add var_to_symbol_tbl var symbol + in + let assign_existing_symbol = Variable.Tbl.add var_to_symbol_tbl var in + let record_definition = Variable.Tbl.add var_to_definition_tbl var in + match named with + | Symbol symbol -> + assign_existing_symbol symbol; + record_definition (AA.Symbol symbol) + | Const const -> record_definition (AA.Const const) + | Allocated_const const -> + assign_symbol (); + record_definition (AA.Allocated_const (Normal const)) + | Read_mutable _ -> + (* [Inconstant_idents] always marks these expressions as + inconstant, so we should never get here. *) + assert false + | Prim (Pmakeblock (tag, _, _value_kind), fields, _) -> + assign_symbol (); + record_definition (AA.Block (Tag.create_exn tag, fields)) + | Read_symbol_field (symbol, field) -> + record_definition (AA.Symbol_field (symbol, field)) + | Set_of_closures ( + { function_decls = { funs; set_of_closures_id; _ }; + _ } as set) -> + assert (not (Inconstant_idents.closure set_of_closures_id + inconstants)); + assign_symbol (); + record_definition (AA.Set_of_closures set); + Variable.Map.iter (fun fun_var _ -> + let closure_id = Closure_id.wrap fun_var in + let closure_symbol = closure_symbol ~backend closure_id in + Variable.Tbl.add var_to_symbol_tbl fun_var closure_symbol; + let project_closure = + Alias_analysis.Project_closure + { set_of_closures = var; closure_id } + in + Variable.Tbl.add var_to_definition_tbl fun_var + project_closure) + funs + | Move_within_set_of_closures ({ closure = _; start_from = _; move_to; } + as move) -> + assign_existing_symbol (closure_symbol ~backend move_to); + record_definition (AA.Move_within_set_of_closures move) + | Project_closure ({ closure_id } as project_closure) -> + assign_existing_symbol (closure_symbol ~backend closure_id); + record_definition (AA.Project_closure project_closure) + | Prim (Pfield index, [block], _) -> + record_definition (AA.Field (block, index)) + | Prim (Pfield _, _, _) -> + Misc.fatal_errorf "[Pfield] with the wrong number of arguments" + Flambda.print_named named + | Prim (Pmakearray (Pfloatarray as kind, mutability), args, _) -> + assign_symbol (); + record_definition (AA.Allocated_const (Array (kind, mutability, args))) + | Prim (Pduparray (kind, mutability), [arg], _) -> + assign_symbol (); + record_definition (AA.Allocated_const ( + Duplicate_array (kind, mutability, arg))) + | Prim _ -> + Misc.fatal_errorf "Primitive not expected to be constant: @.%a@." + Flambda.print_named named + | Project_var project_var -> + record_definition (AA.Project_var project_var) + | Expr e -> + match tail_variable e with + | None -> assert false (* See [Inconstant_idents]. *) + | Some v -> record_definition (AA.Variable v) + end + in + let assign_symbol_program expr = + Flambda_iterators.iter_all_immutable_let_and_let_rec_bindings expr + ~f:assign_symbol + in + Flambda_iterators.iter_exprs_at_toplevel_of_program program + ~f:assign_symbol_program; + let let_symbol_to_definition_tbl = Symbol.Tbl.create 42 in + let initialize_symbol_to_definition_tbl = Symbol.Tbl.create 42 in + let rec collect_let_and_initialize_symbols (program : Flambda.program_body) = + match program with + | Let_symbol (symbol, decl, program) -> + Symbol.Tbl.add let_symbol_to_definition_tbl symbol decl; + collect_let_and_initialize_symbols program + | Let_rec_symbol (decls, program) -> + List.iter (fun (symbol, decl) -> + Symbol.Tbl.add let_symbol_to_definition_tbl symbol decl) + decls; + collect_let_and_initialize_symbols program + | Effect (_, program) -> collect_let_and_initialize_symbols program + | Initialize_symbol (symbol,_tag,fields,program) -> + collect_let_and_initialize_symbols program; + let fields = List.map tail_variable fields in + Symbol.Tbl.add initialize_symbol_to_definition_tbl symbol fields + | End _ -> () + in + collect_let_and_initialize_symbols program.program_body; + let record_set_of_closure_equalities + (set_of_closures : Flambda.set_of_closures) = + Variable.Map.iter (fun arg (var : Flambda.specialised_to) -> + if not (Inconstant_idents.variable arg inconstants) then + Variable.Tbl.add var_to_definition_tbl arg (AA.Variable var.var)) + set_of_closures.free_vars; + Variable.Map.iter (fun arg (spec_to : Flambda.specialised_to) -> + if not (Inconstant_idents.variable arg inconstants) then + Variable.Tbl.add var_to_definition_tbl arg + (AA.Variable spec_to.var)) + set_of_closures.specialised_args + in + Flambda_iterators.iter_on_set_of_closures_of_program program + ~f:(fun ~constant set_of_closures -> + record_set_of_closure_equalities set_of_closures; + if constant then begin + Variable.Map.iter (fun fun_var _ -> + let closure_id = Closure_id.wrap fun_var in + let closure_symbol = closure_symbol ~backend closure_id in + Variable.Tbl.add var_to_definition_tbl fun_var + (AA.Symbol closure_symbol); + Variable.Tbl.add var_to_symbol_tbl fun_var closure_symbol) + set_of_closures.Flambda.function_decls.funs + end); + var_to_symbol_tbl, var_to_definition_tbl, + let_symbol_to_definition_tbl, initialize_symbol_to_definition_tbl + +let variable_field_definition + (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) + (var_to_definition_tbl : + Alias_analysis.constant_defining_value Variable.Tbl.t) + (var : Variable.t) : Flambda.constant_defining_value_block_field = + try + Symbol (Variable.Tbl.find var_to_symbol_tbl var) + with Not_found -> + match Variable.Tbl.find var_to_definition_tbl var with + | Const c -> Const c + | const_defining_value -> + Misc.fatal_errorf "Unexpected pattern for a constant: %a: %a" + Variable.print var + Alias_analysis.print_constant_defining_value const_defining_value + | exception Not_found -> + Misc.fatal_errorf "No associated symbol for the constant %a" + Variable.print var + +let resolve_variable + (aliases : Alias_analysis.allocation_point Variable.Map.t) + (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) + (var_to_definition_tbl : + Alias_analysis.constant_defining_value Variable.Tbl.t) + (var : Variable.t) : Flambda.constant_defining_value_block_field = + match Variable.Map.find var aliases with + | exception Not_found -> + variable_field_definition var_to_symbol_tbl var_to_definition_tbl var + | Symbol s -> Symbol s + | Variable aliased_variable -> + variable_field_definition var_to_symbol_tbl var_to_definition_tbl + aliased_variable + +let translate_set_of_closures + (inconstants : Inconstant_idents.result) + (aliases : Alias_analysis.allocation_point Variable.Map.t) + (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) + (var_to_definition_tbl: + Alias_analysis.constant_defining_value Variable.Tbl.t) + (set_of_closures : Flambda.set_of_closures) = + let f var (named : Flambda.named) : Flambda.named = + if Inconstant_idents.variable var inconstants then + named + else + let resolved = + resolve_variable + aliases + var_to_symbol_tbl + var_to_definition_tbl + var + in + match resolved with + | Symbol s -> Symbol s + | Const c -> Const c + in + Flambda_iterators.map_function_bodies set_of_closures + ~f:(Flambda_iterators.map_all_immutable_let_and_let_rec_bindings ~f) + +let translate_constant_set_of_closures + (inconstants : Inconstant_idents.result) + (aliases : Alias_analysis.allocation_point Variable.Map.t) + (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) + (var_to_definition_tbl: + Alias_analysis.constant_defining_value Variable.Tbl.t) + (constant_defining_values : Flambda.constant_defining_value Symbol.Map.t) = + Symbol.Map.map (fun (const : Flambda.constant_defining_value) -> + match const with + | Flambda.Allocated_const _ + | Flambda.Block _ + | Flambda.Project_closure _ -> + const + | Flambda.Set_of_closures set_of_closures -> + let set_of_closures = + translate_set_of_closures + (inconstants : Inconstant_idents.result) + (aliases : Alias_analysis.allocation_point Variable.Map.t) + (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) + (var_to_definition_tbl: + Alias_analysis.constant_defining_value Variable.Tbl.t) + (set_of_closures : Flambda.set_of_closures) + in + Flambda.Set_of_closures set_of_closures) + constant_defining_values + +let find_original_set_of_closure + (aliases : Alias_analysis.allocation_point Variable.Map.t) + (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) + (var_to_definition_tbl: + Alias_analysis.constant_defining_value Variable.Tbl.t) + project_closure_map + var = + let rec loop var = + match Variable.Map.find var aliases with + | Variable var -> + begin match Variable.Tbl.find var_to_definition_tbl var with + | Project_closure { set_of_closures = var } + | Move_within_set_of_closures { closure = var } -> + loop var + | Set_of_closures _ -> begin + match Variable.Tbl.find var_to_symbol_tbl var with + | s -> + s + | exception Not_found -> + Format.eprintf "var: %a@." Variable.print var; + assert false + end + | _ -> assert false + end + | Symbol s -> + match Symbol.Map.find s project_closure_map with + | exception Not_found -> + Misc.fatal_errorf "find_original_set_of_closure: cannot find \ + symbol %a in the project-closure map" + Symbol.print s + | s -> s + in + loop var + +let translate_definition_and_resolve_alias inconstants + (aliases : Alias_analysis.allocation_point Variable.Map.t) + (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) + (var_to_definition_tbl : + Alias_analysis.constant_defining_value Variable.Tbl.t) + (symbol_definition_map : Flambda.constant_defining_value Symbol.Map.t) + (project_closure_map : Symbol.t Symbol.Map.t) + (definition : Alias_analysis.constant_defining_value) + ~(backend : (module Backend_intf.S)) + : Flambda.constant_defining_value option = + let resolve_float_array_involving_variables + ~(mutability : Asttypes.mutable_flag) ~vars = + (* Resolve an [Allocated_const] of the form: + [Array (Pfloatarray, _, _)] + (which references its contents via variables; it does not contain + manifest floats). *) + let find_float_var_definition var = + match Variable.Tbl.find var_to_definition_tbl var with + | Allocated_const (Normal (Float f)) -> f + | const_defining_value -> + Misc.fatal_errorf "Bad definition for float array member %a: %a" + Variable.print var + Alias_analysis.print_constant_defining_value + const_defining_value + in + let find_float_symbol_definition sym = + match Symbol.Map.find sym symbol_definition_map with + | Allocated_const (Float f) -> f + | const_defining_value -> + Misc.fatal_errorf "Bad definition for float array member %a: %a" + Symbol.print sym + Flambda.print_constant_defining_value + const_defining_value + in + let floats = + List.map (fun var -> + match Variable.Map.find var aliases with + | exception Not_found -> find_float_var_definition var + | Variable var -> find_float_var_definition var + | Symbol sym -> find_float_symbol_definition sym) + vars + in + let const : Allocated_const.t = + match mutability with + | Immutable -> Immutable_float_array floats + | Mutable -> Float_array floats + in + Some (Flambda.Allocated_const const) + in + match definition with + | Block (tag, fields) -> + Some (Flambda.Block (tag, + List.map (resolve_variable aliases var_to_symbol_tbl + var_to_definition_tbl) + fields)) + | Allocated_const (Normal const) -> Some (Flambda.Allocated_const const) + | Allocated_const (Duplicate_array (Pfloatarray, mutability, var)) -> + (* CR-someday mshinwell: This next section could do with cleanup. + What happens is: + - Duplicate contains a variable, which is resolved to + a float array thing full of variables; + - We send that value back through this function again so the + individual members of that array are resolved from variables to + floats. + - Then we can build the Flambda.name term containing the + Allocated_const (full of floats). + We should maybe factor out the code from the + Allocated_const (Array (...)) case below so this function doesn't have + to be recursive. *) + let (constant_defining_value : Alias_analysis.constant_defining_value) = + match Variable.Map.find var aliases with + | exception Not_found -> + Variable.Tbl.find var_to_definition_tbl var + | Variable var -> + Variable.Tbl.find var_to_definition_tbl var + | Symbol sym -> + match Symbol.Map.find sym symbol_definition_map with + | Allocated_const ((Immutable_float_array _) as const) -> + Alias_analysis.Allocated_const (Normal const) + | (Allocated_const _ | Block _ | Set_of_closures _ + | Project_closure _) as wrong -> + Misc.fatal_errorf + "Lift_constants.translate_definition_and_resolve_alias: \ + Duplicate Pfloatarray %a with symbol %a mapping to \ + wrong constant defining value %a" + Variable.print var + Alias_analysis.print_constant_defining_value definition + Flambda.print_constant_defining_value wrong + | exception Not_found -> + let module Backend = (val backend) in + match (Backend.import_symbol sym).descr with + | Value_unresolved _ -> + Misc.fatal_errorf + "Lift_constants.translate_definition_and_resolve_alias: \ + Duplicate Pfloatarray %a with unknown symbol: %a" + Variable.print var + Alias_analysis.print_constant_defining_value definition + | Value_float_array value_float_array -> + let contents = + Simple_value_approx.float_array_as_constant value_float_array + in + begin match contents with + | None -> + Misc.fatal_errorf + "Lift_constants.translate_definition_and_resolve_alias: \ + Duplicate Pfloatarray %a with not completely known float \ + array from symbol: %a" + Variable.print var + Alias_analysis.print_constant_defining_value definition + | Some l -> + Alias_analysis.Allocated_const (Normal (Immutable_float_array l)) + end + | wrong -> + (* CR-someday mshinwell: we might hit this if we ever duplicate + a mutable array across compilation units (e.g. "snapshotting" + an array). We do not currently generate such code. *) + Misc.fatal_errorf + "Lift_constants.translate_definition_and_resolve_alias: \ + Duplicate Pfloatarray %a with symbol %a that does not \ + have an export description of an immutable array" + Variable.print var + Alias_analysis.print_constant_defining_value definition + Simple_value_approx.print_descr wrong + in + begin match constant_defining_value with + | Allocated_const (Normal (Float_array _)) -> + (* This example from pchambart illustrates why we do not allow + the duplication of mutable arrays: + + {| + let_symbol a = Allocated_const (Immutable_float_array [|0.|]) + initialize_symbol b = Duparray(Mutable, a) + effect b.(0) <- 1. + initialize_symbol c = Duparray(Mutable, b) + |} + + This will be converted to: + {| + let_symbol a = Allocated_const (Immutable_float_array [|0.|]) + let_symbol b = Allocated_const (Float_array [|0.|]) + effect b.(0) <- 1. + let_symbol c = Allocated_const (Float_array [|0.|]) + |} + + We can't encounter that currently, but it's scary. + *) + Misc.fatal_error "Pduparray is not allowed on mutable arrays" + | Allocated_const (Normal (Immutable_float_array floats)) -> + let const : Allocated_const.t = + match mutability with + | Immutable -> Immutable_float_array floats + | Mutable -> Float_array floats + in + Some (Flambda.Allocated_const const) + | Allocated_const (Array (Pfloatarray, _, vars)) -> + (* Important: [mutability] is from the [Duplicate_array] + construction above. *) + resolve_float_array_involving_variables ~mutability ~vars + | const -> + Misc.fatal_errorf + "Lift_constants.translate_definition_and_resolve_alias: \ + Duplicate Pfloatarray %a with wrong argument: %a" + Variable.print var + Alias_analysis.print_constant_defining_value const + end + | Allocated_const (Duplicate_array (_, _, _)) -> + Misc.fatal_errorf "Lift_constants.translate_definition_and_resolve_alias: \ + Duplicate_array with non-Pfloatarray kind: %a" + Alias_analysis.print_constant_defining_value definition + | Allocated_const (Array (Pfloatarray, mutability, vars)) -> + resolve_float_array_involving_variables ~mutability ~vars + | Allocated_const (Array (_, _, _)) -> + Misc.fatal_errorf "Lift_constants.translate_definition_and_resolve_alias: \ + Array with non-Pfloatarray kind: %a" + Alias_analysis.print_constant_defining_value definition + | Project_closure { set_of_closures; closure_id } -> + begin match Variable.Map.find set_of_closures aliases with + | Symbol s -> + Some (Flambda.Project_closure (s, closure_id)) + (* If a closure projection is a constant, the set of closures must + be assigned to a symbol. *) + | exception Not_found -> + assert false + | Variable v -> + match Variable.Tbl.find var_to_symbol_tbl v with + | s -> + Some (Flambda.Project_closure (s, closure_id)) + | exception Not_found -> + Format.eprintf "var: %a@." Variable.print v; + assert false + end + | Move_within_set_of_closures { closure; move_to } -> + let set_of_closure_symbol = + find_original_set_of_closure + aliases + var_to_symbol_tbl + var_to_definition_tbl + project_closure_map + closure + in + Some (Flambda.Project_closure (set_of_closure_symbol, move_to)) + | Set_of_closures set_of_closures -> + let set_of_closures = + translate_set_of_closures + inconstants + aliases + var_to_symbol_tbl + var_to_definition_tbl + set_of_closures + in + Some (Flambda.Set_of_closures set_of_closures) + | Project_var _ -> None + | Field (_,_) | Symbol_field _ -> None + | Const _ -> None + | Symbol _ -> None + | Variable _ -> None + +let translate_definitions_and_resolve_alias + inconstants + (aliases : Alias_analysis.allocation_point Variable.Map.t) + (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) + (var_to_definition_tbl: + Alias_analysis.constant_defining_value Variable.Tbl.t) + symbol_definition_map + project_closure_map + ~backend = + Variable.Tbl.fold (fun var def map -> + match + translate_definition_and_resolve_alias inconstants aliases ~backend + var_to_symbol_tbl var_to_definition_tbl symbol_definition_map + project_closure_map def + with + | None -> map + | Some def -> + let symbol = Variable.Tbl.find var_to_symbol_tbl var in + Symbol.Map.add symbol def map) + var_to_definition_tbl Symbol.Map.empty + +(* Resorting of graph including Initialize_symbol *) +let constant_dependencies ~backend:_ + (const : Flambda.constant_defining_value) = + match const with + | Allocated_const _ -> Symbol.Set.empty + | Block (_, fields) -> + let symbol_fields = + List.filter_map + (function + | (Symbol s : Flambda.constant_defining_value_block_field) -> Some s + | Flambda.Const _ -> None) + fields + in + Symbol.Set.of_list symbol_fields + | Set_of_closures set_of_closures -> + Flambda.free_symbols_named (Set_of_closures set_of_closures) + | Project_closure (s, _) -> + Symbol.Set.singleton s + +module Symbol_SCC = Strongly_connected_components.Make (Symbol) + +let program_graph ~backend imported_symbols symbol_to_constant + (initialize_symbol_tbl : + (Tag.t * Flambda.t list * Symbol.t option) Symbol.Tbl.t) + (effect_tbl : (Flambda.t * Symbol.t option) Symbol.Tbl.t) = + let expression_symbol_dependencies expr = Flambda.free_symbols expr in + let graph_with_only_constant_parts = + Symbol.Map.map (fun const -> + Symbol.Set.diff (constant_dependencies ~backend const) + imported_symbols) + symbol_to_constant + in + let graph_with_initialisation = + Symbol.Tbl.fold (fun sym (_tag, fields, previous) -> + let order_dep = + match previous with + | None -> Symbol.Set.empty + | Some previous -> Symbol.Set.singleton previous + in + let deps = List.fold_left (fun set field -> + Symbol.Set.union (expression_symbol_dependencies field) set) + order_dep fields + in + let deps = Symbol.Set.diff deps imported_symbols in + Symbol.Map.add sym deps) + initialize_symbol_tbl graph_with_only_constant_parts + in + let graph = + Symbol.Tbl.fold (fun sym (expr, previous) -> + let order_dep = + match previous with + | None -> Symbol.Set.empty + | Some previous -> Symbol.Set.singleton previous + in + let deps = + Symbol.Set.union (expression_symbol_dependencies expr) order_dep + in + let deps = Symbol.Set.diff deps imported_symbols in + Symbol.Map.add sym deps + ) + effect_tbl graph_with_initialisation + in + let components = + Symbol_SCC.connected_components_sorted_from_roots_to_leaf + graph + in + components + +(* rebuilding the program *) +let add_definition_of_symbol constant_definitions + (initialize_symbol_tbl : + (Tag.t * Flambda.t list * Symbol.t option) Symbol.Tbl.t) + (effect_tbl : (Flambda.t * Symbol.t option) Symbol.Tbl.t) + (program : Flambda.program_body) component : Flambda.program_body = + let symbol_declaration sym = + (* A symbol declared through an Initialize_symbol construct + cannot be recursive, this is not allowed in the construction. + This also couldn't have been introduced by this pass, so we can + safely assert that this is not possible here *) + assert(not (Symbol.Tbl.mem initialize_symbol_tbl sym)); + (sym, Symbol.Map.find sym constant_definitions) + in + match component with + | Symbol_SCC.Has_loop l -> + let l = List.map symbol_declaration l in + Let_rec_symbol (l, program) + | Symbol_SCC.No_loop sym -> + match Symbol.Tbl.find initialize_symbol_tbl sym with + | (tag, fields, _previous) -> + Initialize_symbol (sym, tag, fields, program) + | exception Not_found -> + match Symbol.Tbl.find effect_tbl sym with + | (expr, _previous) -> + Effect (expr, program) + | exception Not_found -> + let decl = Symbol.Map.find sym constant_definitions in + Let_symbol (sym, decl, program) + +let add_definitions_of_symbols constant_definitions initialize_symbol_tbl + effect_tbl program components = + Array.fold_left + (add_definition_of_symbol constant_definitions initialize_symbol_tbl + effect_tbl) + program components + +let introduce_free_variables_in_set_of_closures + (var_to_block_field_tbl : + Flambda.constant_defining_value_block_field Variable.Tbl.t) + ({ Flambda.function_decls; free_vars; specialised_args; + direct_call_surrogates; } + as set_of_closures) = + let add_definition_and_make_substitution var (expr, subst) = + let searched_var = + match Variable.Map.find var specialised_args with + | exception Not_found -> var + | external_var -> + (* specialised arguments bound to constant can be rewritten *) + external_var.var + in + match Variable.Tbl.find var_to_block_field_tbl searched_var with + | def -> + let fresh = Variable.rename var in + let named : Flambda.named = match def with + | Symbol sym -> Symbol sym + | Const c -> Const c + in + (Flambda.create_let fresh named expr), Variable.Map.add var fresh subst + | exception Not_found -> + (* The variable is bound by the closure or the arguments or not + constant. In either case it does not need to be bound *) + expr, subst + in + let done_something = ref false in + let function_decls : Flambda.function_declarations = + Flambda.update_function_declarations function_decls + ~funs:(Variable.Map.map + (fun (func_decl : Flambda.function_declaration) -> + let variables_to_bind = + (* Closures from the same set must not be bound. *) + Variable.Set.diff func_decl.free_variables + (Variable.Map.keys function_decls.funs) + in + let body, subst = + Variable.Set.fold add_definition_and_make_substitution + variables_to_bind + (func_decl.body, Variable.Map.empty) + in + if Variable.Map.is_empty subst then begin + func_decl + end else begin + done_something := true; + let body = Flambda_utils.toplevel_substitution subst body in + Flambda.update_body_of_function_declaration func_decl ~body + end) + function_decls.funs) + in + let free_vars = + (* Keep only those that are not rewritten to constants. *) + Variable.Map.filter (fun v _ -> + let keep = not (Variable.Tbl.mem var_to_block_field_tbl v) in + if not keep then done_something := true; + keep) + free_vars + in + let free_vars = + Flambda_utils.clean_projections ~which_variables:free_vars + in + let specialised_args = + (* Keep only those that are not rewritten to constants. *) + Variable.Map.filter (fun _ (spec_to : Flambda.specialised_to) -> + let keep = + not (Variable.Tbl.mem var_to_block_field_tbl spec_to.var) + in + if not keep then begin + done_something := true + end; + keep) + specialised_args + in + let specialised_args = + Flambda_utils.clean_projections ~which_variables:specialised_args + in + if not !done_something then + set_of_closures + else + Flambda.create_set_of_closures ~function_decls ~free_vars + ~specialised_args ~direct_call_surrogates + +let rewrite_project_var + (var_to_block_field_tbl + : Flambda.constant_defining_value_block_field Variable.Tbl.t) + (project_var : Flambda.project_var) ~original : Flambda.named = + let var = Var_within_closure.unwrap project_var.var in + match Variable.Tbl.find var_to_block_field_tbl var with + | exception Not_found -> original + | Symbol sym -> Symbol sym + | Const const -> Const const + +let introduce_free_variables_in_sets_of_closures + (var_to_block_field_tbl: + Flambda.constant_defining_value_block_field Variable.Tbl.t) + (translate_definition : Flambda.constant_defining_value Symbol.Map.t) = + Symbol.Map.map (fun (def : Flambda.constant_defining_value) -> + match def with + | Allocated_const _ + | Block _ + | Project_closure _ -> def + | Set_of_closures set_of_closures -> + Flambda.Set_of_closures + (introduce_free_variables_in_set_of_closures + var_to_block_field_tbl + set_of_closures)) + translate_definition + +let var_to_block_field + (aliases : Alias_analysis.allocation_point Variable.Map.t) + (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) + (var_to_definition_tbl : + Alias_analysis.constant_defining_value Variable.Tbl.t) = + let var_to_block_field_tbl = Variable.Tbl.create 42 in + Variable.Tbl.iter (fun var _ -> + let def = + resolve_variable aliases var_to_symbol_tbl var_to_definition_tbl var + in + Variable.Tbl.add var_to_block_field_tbl var def) + var_to_definition_tbl; + var_to_block_field_tbl + +let program_symbols ~backend (program : Flambda.program) = + let new_fake_symbol () = + let var = Variable.create Internal_variable_names.fake_effect_symbol in + Symbol.of_variable var + in + let initialize_symbol_tbl = Symbol.Tbl.create 42 in + let effect_tbl = Symbol.Tbl.create 42 in + let symbol_definition_tbl = Symbol.Tbl.create 42 in + let add_project_closure_definitions def_symbol + (const : Flambda.constant_defining_value) = + match const with + | Set_of_closures { function_decls = { funs } } -> + Variable.Map.iter (fun fun_var _ -> + let closure_id = Closure_id.wrap fun_var in + let closure_symbol = closure_symbol ~backend closure_id in + let project_closure = + Flambda.Project_closure (def_symbol, closure_id) + in + Symbol.Tbl.add symbol_definition_tbl closure_symbol + project_closure) + funs + | Project_closure _ + | Allocated_const _ + | Block _ -> () + in + let rec loop (program : Flambda.program_body) previous_effect = + match program with + | Flambda.Let_symbol (symbol, def, program) -> + add_project_closure_definitions symbol def; + Symbol.Tbl.add symbol_definition_tbl symbol def; + loop program previous_effect + | Flambda.Let_rec_symbol (defs, program) -> + List.iter (fun (symbol, def) -> + add_project_closure_definitions symbol def; + Symbol.Tbl.add symbol_definition_tbl symbol def) + defs; + loop program previous_effect + | Flambda.Initialize_symbol (symbol, tag, fields, program) -> + (* previous_effect is used to keep the order of initialize and effect + values. Their effects order must be kept ordered. + it is used as an extra dependency when sorting the symbols. *) + (* CR-someday pchambart: if the fields expressions are pure, we could + drop this dependency + mshinwell: deferred CR *) + Symbol.Tbl.add initialize_symbol_tbl symbol + (tag, fields, previous_effect); + loop program (Some symbol) + | Flambda.Effect (expr, program) -> + (* Used to ensure that effects are correctly ordered *) + let fake_effect_symbol = new_fake_symbol () in + Symbol.Tbl.add effect_tbl fake_effect_symbol (expr, previous_effect); + loop program (Some fake_effect_symbol) + | Flambda.End _ -> () + in + loop program.program_body None; + initialize_symbol_tbl, symbol_definition_tbl, effect_tbl + +let replace_definitions_in_initialize_symbol_and_effects + (inconstants : Inconstant_idents.result) + (aliases : Alias_analysis.allocation_point Variable.Map.t) + (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) + (var_to_definition_tbl : + Alias_analysis.constant_defining_value Variable.Tbl.t) + (initialize_symbol_tbl : + (Tag.t * Flambda.t list * Symbol.t option) Symbol.Tbl.t) + (effect_tbl : (Flambda.t * Symbol.t option) Symbol.Tbl.t) = + let rewrite_expr expr = + Flambda_iterators.map_all_immutable_let_and_let_rec_bindings expr + ~f:(fun var (named : Flambda.named) : Flambda.named -> + if Inconstant_idents.variable var inconstants then + named + else + let resolved = + resolve_variable + aliases + var_to_symbol_tbl + var_to_definition_tbl + var + in + match named, resolved with + | Symbol s1, Symbol s2 -> + assert (s1 == s2); (* physical equality for speed *) + named; + | Const c1, Const c2 -> + assert (c1 == c2); + named + | _, Symbol s -> Symbol s + | _, Const c -> Const c) + in + (* This is safe because we only [replace] the current key during + iteration (cf. https://github.com/ocaml/ocaml/pull/337) *) + Symbol.Tbl.iter + (fun symbol (tag, fields, previous) -> + let fields = List.map rewrite_expr fields in + Symbol.Tbl.replace initialize_symbol_tbl symbol (tag, fields, previous)) + initialize_symbol_tbl; + Symbol.Tbl.iter + (fun symbol (expr, previous) -> + Symbol.Tbl.replace effect_tbl symbol (rewrite_expr expr, previous)) + effect_tbl + +(* CR-soon mshinwell: Update the name of [project_closure_map]. *) +let project_closure_map symbol_definition_map = + Symbol.Map.fold (fun sym (const : Flambda.constant_defining_value) acc -> + match const with + | Project_closure (set_of_closures, _) -> + Symbol.Map.add sym set_of_closures acc + | Set_of_closures _ -> + Symbol.Map.add sym sym acc + | Allocated_const _ + | Block _ -> acc) + symbol_definition_map + Symbol.Map.empty + +let lift_constants (program : Flambda.program) ~backend = + let the_dead_constant = + let var = Variable.create Internal_variable_names.the_dead_constant in + Symbol.of_variable var + in + let program_body : Flambda.program_body = + Let_symbol (the_dead_constant, Allocated_const (Nativeint 0n), + program.program_body) + in + let program : Flambda.program = + { program with program_body; } + in + let inconstants = + Inconstant_idents.inconstants_on_program program ~backend + ~compilation_unit:(Compilation_unit.get_current_exn ()) + in + let initialize_symbol_tbl, symbol_definition_tbl, effect_tbl = + program_symbols ~backend program + in + let var_to_symbol_tbl, var_to_definition_tbl, let_symbol_to_definition_tbl, + initialize_symbol_to_definition_tbl = + assign_symbols_and_collect_constant_definitions ~backend ~program + ~inconstants + in + let aliases = + Alias_analysis.run var_to_definition_tbl + initialize_symbol_to_definition_tbl + let_symbol_to_definition_tbl + ~the_dead_constant + in + replace_definitions_in_initialize_symbol_and_effects + (inconstants : Inconstant_idents.result) + (aliases : Alias_analysis.allocation_point Variable.Map.t) + (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) + (var_to_definition_tbl + : Alias_analysis.constant_defining_value Variable.Tbl.t) + initialize_symbol_tbl + effect_tbl; + let symbol_definition_map = + translate_constant_set_of_closures + (inconstants : Inconstant_idents.result) + (aliases : Alias_analysis.allocation_point Variable.Map.t) + (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) + (var_to_definition_tbl + : Alias_analysis.constant_defining_value Variable.Tbl.t) + (Symbol.Tbl.to_map symbol_definition_tbl) + in + let project_closure_map = project_closure_map symbol_definition_map in + let translated_definitions = + translate_definitions_and_resolve_alias + inconstants + (aliases : Alias_analysis.allocation_point Variable.Map.t) + (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) + (var_to_definition_tbl + : Alias_analysis.constant_defining_value Variable.Tbl.t) + symbol_definition_map + project_closure_map + ~backend + in + let var_to_block_field_tbl = + var_to_block_field + (aliases : Alias_analysis.allocation_point Variable.Map.t) + (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) + (var_to_definition_tbl + : Alias_analysis.constant_defining_value Variable.Tbl.t) + in + let translated_definitions = + introduce_free_variables_in_sets_of_closures var_to_block_field_tbl + translated_definitions + in + let constant_definitions = + (* Add previous Let_symbol to the newly discovered ones *) + Symbol.Map.union + (fun _sym + (c1:Flambda.constant_defining_value) + (c2:Flambda.constant_defining_value) -> + match c1, c2 with + | Project_closure (s1, closure_id1), + Project_closure (s2, closure_id2) when + Symbol.equal s1 s2 && + Closure_id.equal closure_id1 closure_id2 -> + Some c1 + | Project_closure (s1, closure_id1), + Project_closure (s2, closure_id2) -> + Format.eprintf "not equal project closure@. s %a %a@. cid %a %a@." + Symbol.print s1 Symbol.print s2 + Closure_id.print closure_id1 Closure_id.print closure_id2; + assert false + | _ -> + assert false + ) + symbol_definition_map + translated_definitions + in + (* Upon the [Initialize_symbol]s, the [Effect]s and the constant definitions, + do the following: + 1. Introduce [Let]s to bind variables that are going to be replaced + by constants. + 2. If a variable bound by a closure gets replaced by a symbol and + thus eliminated from the [free_vars] set of the closure, we need to + rewrite any subsequent [Project_var] expressions that project that + variable. *) + let rewrite_expr expr = + Flambda_iterators.map_named (function + | (Set_of_closures set_of_closures) as named -> + let new_set_of_closures = + introduce_free_variables_in_set_of_closures + var_to_block_field_tbl set_of_closures + in + if new_set_of_closures == set_of_closures then + named + else + Set_of_closures new_set_of_closures + | (Project_var project_var) as original -> + rewrite_project_var var_to_block_field_tbl project_var ~original + | (Symbol _ | Const _ | Allocated_const _ | Project_closure _ + | Move_within_set_of_closures _ | Prim _ | Expr _ + | Read_mutable _ | Read_symbol_field _) as named -> named) + expr + in + let constant_definitions = + Symbol.Map.map (fun (const : Flambda.constant_defining_value) -> + match const with + | Allocated_const _ | Block _ | Project_closure _ -> const + | Set_of_closures set_of_closures -> + let set_of_closures = + Flambda_iterators.map_function_bodies set_of_closures + ~f:rewrite_expr + in + Flambda.Set_of_closures + (introduce_free_variables_in_set_of_closures + var_to_block_field_tbl set_of_closures)) + constant_definitions + in + let effect_tbl = + Symbol.Tbl.map effect_tbl (fun (effect, dep) -> rewrite_expr effect, dep) + in + let initialize_symbol_tbl = + Symbol.Tbl.map initialize_symbol_tbl (fun (tag, fields, dep) -> + let fields = List.map rewrite_expr fields in + tag, fields, dep) + in + let imported_symbols = Flambda_utils.imported_symbols program in + let components = + program_graph ~backend imported_symbols constant_definitions + initialize_symbol_tbl effect_tbl + in + let program_body = + add_definitions_of_symbols constant_definitions + initialize_symbol_tbl + effect_tbl + (End (Flambda_utils.root_symbol program)) + components + in + Flambda_utils.introduce_needed_import_symbols { program with program_body; } diff --git a/middle_end/flambda/lift_constants.mli b/middle_end/flambda/lift_constants.mli new file mode 100644 index 0000000000..969c365e33 --- /dev/null +++ b/middle_end/flambda/lift_constants.mli @@ -0,0 +1,65 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(** The aim of this pass is to assign symbols to values known to be + constant (in other words, whose values we know at compile time), with + appropriate sharing of constants, and replace the occurrences of the + constants with their corresponding symbols. + + This pass uses the results of two other passes, [Inconstant_idents] and + [Alias_analysis]. The relationship between these two deserves some + attention. + + [Inconstant_idents] is a "backwards" analysis that propagates implications + about inconstantness of variables and set of closures IDs. + + [Alias_analysis] is a "forwards" analysis that is analogous to the + propagation of [Simple_value_approx.t] values during [Inline_and_simplify]. + It gives us information about relationships between values but not actually + about their constantness. + + Combining these two into a single pass has been attempted previously, + but was not thought to be successful; this experiment could be repeated in + the future. (If "constant" is considered as "top" and "inconstant" is + considered as "bottom", then [Alias_analysis] corresponds to a least fixed + point and [Inconstant_idents] corresponds to a greatest fixed point.) + + At a high level, this pass operates as follows. Symbols are assigned to + variables known to be constant and their defining expressions examined. + Based on the results of [Alias_analysis], we simplify the destructive + elements within the defining expressions (specifically, projection of + fields from blocks), to eventually yield [Flambda.constant_defining_value]s + that are entirely constructive. These will be bound to symbols in the + resulting program. + + Another approach to this pass could be to only use the results of + [Inconstant_idents] and then repeatedly lift constants and run + [Inline_and_simplify] until a fixpoint. It was thought more robust to + instead use [Alias_analysis], where the fixpointing involves a less + complicated function. + + We still run [Inline_and_simplify] once after this pass since the lifting + of constants may enable more functions to become closed; the simplification + pass provides an easy way of cleaning up (e.g. making sure [free_vars] + maps in sets of closures are correct). +*) + +val lift_constants + : Flambda.program + -> backend:(module Backend_intf.S) + -> Flambda.program diff --git a/middle_end/flambda/lift_let_to_initialize_symbol.ml b/middle_end/flambda/lift_let_to_initialize_symbol.ml new file mode 100644 index 0000000000..ccef0d8a1f --- /dev/null +++ b/middle_end/flambda/lift_let_to_initialize_symbol.ml @@ -0,0 +1,298 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +type ('a, 'b) kind = + | Initialisation of (Symbol.t * Tag.t * Flambda.t list) + | Effect of 'b + +let should_copy (named:Flambda.named) = + match named with + | Symbol _ | Read_symbol_field _ | Const _ -> true + | _ -> false + +type extracted = + | Expr of Variable.t * Flambda.t + | Exprs of Variable.t list * Flambda.t + | Block of Variable.t * Tag.t * Variable.t list + +type accumulated = { + copied_lets : (Variable.t * Flambda.named) list; + extracted_lets : extracted list; + terminator : Flambda.expr; +} + +let rec accumulate ~substitution ~copied_lets ~extracted_lets + (expr : Flambda.t) = + match expr with + | Let { var; body = Var var'; _ } | Let_rec ([var, _], Var var') + when Variable.equal var var' -> + { copied_lets; extracted_lets; + terminator = Flambda_utils.toplevel_substitution substitution expr; + } + (* If the pattern is what lifting let_rec generates, prevent it from being + lifted again. *) + | Let_rec (defs, + Let { var; body = Var var'; + defining_expr = Prim (Pmakeblock _, fields, _); }) + when + Variable.equal var var' + && List.for_all (fun field -> + List.exists (fun (def_var, _) -> Variable.equal def_var field) defs) + fields -> + { copied_lets; extracted_lets; + terminator = Flambda_utils.toplevel_substitution substitution expr; + } + | Let { var; defining_expr = Expr (Var alias); body; _ } + | Let_rec ([var, Expr (Var alias)], body) -> + let alias = + match Variable.Map.find alias substitution with + | exception Not_found -> alias + | original_alias -> original_alias + in + accumulate + ~substitution:(Variable.Map.add var alias substitution) + ~copied_lets + ~extracted_lets + body + | Let { var; defining_expr = named; body; _ } + | Let_rec ([var, named], body) + when should_copy named -> + accumulate body + ~substitution + ~copied_lets:((var, named)::copied_lets) + ~extracted_lets + | Let { var; defining_expr = named; body; _ } -> + let extracted = + let renamed = Variable.rename var in + match named with + | Prim (Pmakeblock (tag, Asttypes.Immutable, _value_kind), args, _dbg) -> + let tag = Tag.create_exn tag in + let args = + List.map (fun v -> + try Variable.Map.find v substitution + with Not_found -> v) + args + in + Block (var, tag, args) + | named -> + let expr = + Flambda_utils.toplevel_substitution substitution + (Flambda.create_let renamed named (Var renamed)) + in + Expr (var, expr) + in + accumulate body + ~substitution + ~copied_lets + ~extracted_lets:(extracted::extracted_lets) + | Let_rec ([var, named], body) -> + let renamed = Variable.rename var in + let def_substitution = Variable.Map.add var renamed substitution in + let expr = + Flambda_utils.toplevel_substitution def_substitution + (Let_rec ([renamed, named], Var renamed)) + in + let extracted = Expr (var, expr) in + accumulate body + ~substitution + ~copied_lets + ~extracted_lets:(extracted::extracted_lets) + | Let_rec (defs, body) -> + let renamed_defs, def_substitution = + List.fold_right (fun (var, def) (acc, substitution) -> + let new_var = Variable.rename var in + (new_var, def) :: acc, + Variable.Map.add var new_var substitution) + defs ([], substitution) + in + let extracted = + let expr = + let name = Internal_variable_names.lifted_let_rec_block in + Flambda_utils.toplevel_substitution def_substitution + (Let_rec (renamed_defs, + Flambda_utils.name_expr ~name + (Prim (Pmakeblock (0, Immutable, None), + List.map fst renamed_defs, + Debuginfo.none)))) + in + Exprs (List.map fst defs, expr) + in + accumulate body + ~substitution + ~copied_lets + ~extracted_lets:(extracted::extracted_lets) + | _ -> + { copied_lets; + extracted_lets; + terminator = Flambda_utils.toplevel_substitution substitution expr; + } + +let rebuild_expr + ~(extracted_definitions : (Symbol.t * int list) Variable.Map.t) + ~(copied_definitions : Flambda.named Variable.Map.t) + ~(substitute : bool) + (expr : Flambda.t) = + let expr_with_read_symbols = + Flambda_utils.substitute_read_symbol_field_for_variables + extracted_definitions expr + in + let free_variables = Flambda.free_variables expr_with_read_symbols in + let substitution = + if substitute then + Variable.Map.of_set (fun x -> Variable.rename x) free_variables + else + Variable.Map.of_set (fun x -> x) free_variables + in + let expr_with_read_symbols = + Flambda_utils.toplevel_substitution substitution + expr_with_read_symbols + in + Variable.Map.fold (fun var declaration body -> + let definition = Variable.Map.find var copied_definitions in + Flambda.create_let declaration definition body) + substitution expr_with_read_symbols + +let rebuild (used_variables:Variable.Set.t) (accumulated:accumulated) = + let copied_definitions = Variable.Map.of_list accumulated.copied_lets in + let accumulated_extracted_lets = + List.map (fun decl -> + match decl with + | Block (var, _, _) | Expr (var, _) -> + Symbol.of_variable (Variable.rename var), decl + | Exprs _ -> + let name = Internal_variable_names.lifted_let_rec_block in + let var = Variable.create name in + Symbol.of_variable var, decl) + accumulated.extracted_lets + in + let extracted_definitions = + (* Blocks are lifted to direct top-level Initialize_block: + accessing the value be done directly through the symbol. + Other let bound variables are initialized inside a size + one static block: + accessing the value is done directly through the field 0 + of the symbol. + let rec of size more than one is represented as a block of + all the bound variables allocated inside a size one static + block: + accessing the value is done directly through the right + field of the field 0 of the symbol. *) + List.fold_left (fun map (symbol, decl) -> + match decl with + | Block (var, _tag, _fields) -> + Variable.Map.add var (symbol, []) map + | Expr (var, _expr) -> + Variable.Map.add var (symbol, [0]) map + | Exprs (vars, _expr) -> + let map, _ = + List.fold_left (fun (map, field) var -> + Variable.Map.add var (symbol, [field; 0]) map, + field + 1) + (map, 0) vars + in + map) + Variable.Map.empty accumulated_extracted_lets + in + let extracted = + List.map (fun (symbol, decl) -> + match decl with + | Expr (var, decl) -> + let expr = + rebuild_expr ~extracted_definitions ~copied_definitions + ~substitute:true decl + in + if Variable.Set.mem var used_variables then + Initialisation + (symbol, + Tag.create_exn 0, + [expr]) + else + Effect expr + | Exprs (_vars, decl) -> + let expr = + rebuild_expr ~extracted_definitions ~copied_definitions + ~substitute:true decl + in + Initialisation (symbol, Tag.create_exn 0, [expr]) + | Block (_var, tag, fields) -> + let fields = + List.map (fun var -> + rebuild_expr ~extracted_definitions ~copied_definitions + ~substitute:true (Var var)) + fields + in + Initialisation (symbol, tag, fields)) + accumulated_extracted_lets + in + let terminator = + (* We don't need to substitute the variables in the terminator, we + suppose that we did for every other occurrence. Avoiding this + substitution allows this transformation to be idempotent. *) + rebuild_expr ~extracted_definitions ~copied_definitions + ~substitute:false accumulated.terminator + in + List.rev extracted, terminator + +let introduce_symbols expr = + let accumulated = + accumulate expr + ~substitution:Variable.Map.empty + ~copied_lets:[] ~extracted_lets:[] + in + let used_variables = Flambda.used_variables expr in + let extracted, terminator = rebuild used_variables accumulated in + extracted, terminator + +let add_extracted introduced program = + List.fold_right (fun extracted program -> + match extracted with + | Initialisation (symbol, tag, def) -> + Flambda.Initialize_symbol (symbol, tag, def, program) + | Effect effect -> + Flambda.Effect (effect, program)) + introduced program + +let rec split_program (program : Flambda.program_body) : Flambda.program_body = + match program with + | End s -> End s + | Let_symbol (s, def, program) -> + Let_symbol (s, def, split_program program) + | Let_rec_symbol (defs, program) -> + Let_rec_symbol (defs, split_program program) + | Effect (expr, program) -> + let program = split_program program in + let introduced, expr = introduce_symbols expr in + add_extracted introduced (Flambda.Effect (expr, program)) + | Initialize_symbol (symbol, tag, ((_::_::_) as fields), program) -> + (* CR-someday pchambart: currently the only initialize_symbol with more + than 1 field is the module block. This could evolve, in that case + this pattern should be handled properly. *) + Initialize_symbol (symbol, tag, fields, split_program program) + | Initialize_symbol (sym, tag, [], program) -> + Let_symbol (sym, Block (tag, []), split_program program) + | Initialize_symbol (symbol, tag, [field], program) -> + let program = split_program program in + let introduced, field = introduce_symbols field in + add_extracted introduced + (Flambda.Initialize_symbol (symbol, tag, [field], program)) + +let lift ~backend:_ (program : Flambda.program) = + { program with + program_body = split_program program.program_body; + } diff --git a/middle_end/flambda/lift_let_to_initialize_symbol.mli b/middle_end/flambda/lift_let_to_initialize_symbol.mli new file mode 100644 index 0000000000..afb1c60f9c --- /dev/null +++ b/middle_end/flambda/lift_let_to_initialize_symbol.mli @@ -0,0 +1,38 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(** Lift toplevel [Let]-expressions to Flambda [program] constructions such + that the results of evaluation of such expressions may be accessed + directly, through symbols, rather than through closures. The + [Let]-expressions typically come from the compilation of modules (using + the bytecode strategy) in [Translmod]. + + This means of compilation supersedes the old "transl_store_" methodology + for native code. + + An [Initialize_symbol] construction generated by this pass may be + subsequently rewritten to [Let_symbol] if it is discovered that the + initializer is in fact constant. (See [Initialize_symbol_to_let_symbol].) + + The [program] constructions generated by this pass will be joined by + others that arise from the lifting of constants (see [Lift_constants]). +*) +val lift + : backend:(module Backend_intf.S) + -> Flambda.program + -> Flambda.program diff --git a/middle_end/flambda/parameter.ml b/middle_end/flambda/parameter.ml new file mode 100644 index 0000000000..0c916dd7ae --- /dev/null +++ b/middle_end/flambda/parameter.ml @@ -0,0 +1,69 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +[@@@ocaml.warning "+9"] +(* Warning 9 is enabled to ensure correct update of each function when + a field is added to type parameter *) + +type parameter = { + var : Variable.t; +} + +let wrap var = { var } + +let var p = p.var + +module M = + Identifiable.Make (struct + type t = parameter + + let compare { var = var1 } { var = var2 } = + Variable.compare var1 var2 + + let equal { var = var1 } { var = var2 } = + Variable.equal var1 var2 + + let hash { var } = + Variable.hash var + + let print ppf { var } = + Variable.print ppf var + + let output o { var } = + Variable.output o var + end) + +module T = M.T +include T + +module Map = M.Map +module Tbl = M.Tbl +module Set = struct + include M.Set + let vars l = Variable.Set.of_list (List.map var l) +end + +let rename ?current_compilation_unit p = + { var = Variable.rename ?current_compilation_unit p.var } + +let map_var f { var } = { var = f var } + +module List = struct + let vars params = List.map (fun { var } -> var) params +end diff --git a/middle_end/flambda/parameter.mli b/middle_end/flambda/parameter.mli new file mode 100644 index 0000000000..ceed16786b --- /dev/null +++ b/middle_end/flambda/parameter.mli @@ -0,0 +1,52 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(** [Parameter.t] carries a unique [Variable.t] used as function parameter. + It can also carry annotations about the usage of the variable. *) + +type t +type parameter = t + +(** Make a parameter from a variable with default attributes *) +val wrap : Variable.t -> t + +val var : t -> Variable.t + +(** Rename the inner variable of the parameter *) +val rename + : ?current_compilation_unit:Compilation_unit.t + -> t + -> t + +val map_var : (Variable.t -> Variable.t) -> t -> t + +module T : Identifiable.Thing with type t = t + +module Set : sig + include Identifiable.Set with module T := T + val vars : parameter list -> Variable.Set.t +end + +include Identifiable.S with type t := t + and module T := T + and module Set := Set + +module List : sig + (** extract variables from a list of parameters, preserving the order *) + val vars : t list -> Variable.t list +end diff --git a/middle_end/flambda/pass_wrapper.ml b/middle_end/flambda/pass_wrapper.ml new file mode 100644 index 0000000000..a20053326f --- /dev/null +++ b/middle_end/flambda/pass_wrapper.ml @@ -0,0 +1,35 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +let register ~pass_name = + Clflags.all_passes := pass_name :: !Clflags.all_passes + +let with_dump ~ppf_dump ~pass_name ~f ~input ~print_input ~print_output = + let dump = Clflags.dumped_pass pass_name in + let result = f () in + match result with + | None -> + if dump then Format.fprintf ppf_dump "%s: no-op.\n\n%!" pass_name; + None + | Some result -> + if dump then begin + Format.fprintf ppf_dump "Before %s:@ %a@.@." pass_name print_input input; + Format.fprintf ppf_dump "After %s:@ %a@.@." pass_name print_output result; + end; + Some result diff --git a/middle_end/flambda/pass_wrapper.mli b/middle_end/flambda/pass_wrapper.mli new file mode 100644 index 0000000000..3a30e61d6d --- /dev/null +++ b/middle_end/flambda/pass_wrapper.mli @@ -0,0 +1,26 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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. *) +(* *) +(**************************************************************************) + +val register : pass_name:string -> unit + +val with_dump + : ppf_dump:Format.formatter + -> pass_name:string + -> f:(unit -> 'b option) + -> input:'a + -> print_input:(Format.formatter -> 'a -> unit) + -> print_output:(Format.formatter -> 'b -> unit) + -> 'b option diff --git a/middle_end/flambda/projection.ml b/middle_end/flambda/projection.ml new file mode 100644 index 0000000000..2c660a2a28 --- /dev/null +++ b/middle_end/flambda/projection.ml @@ -0,0 +1,170 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +(* CR-someday mshinwell: Move these three types into their own modules. *) + +type project_closure = { + set_of_closures : Variable.t; + closure_id : Closure_id.t; +} + +type move_within_set_of_closures = { + closure : Variable.t; + start_from : Closure_id.t; + move_to : Closure_id.t; +} + +type project_var = { + closure : Variable.t; + closure_id : Closure_id.t; + var : Var_within_closure.t; +} + +let compare_project_var + ({ closure = closure1; closure_id = closure_id1; var = var1; } + : project_var) + ({ closure = closure2; closure_id = closure_id2; var = var2; } + : project_var) = + let c = Variable.compare closure1 closure2 in + if c <> 0 then c + else + let c = Closure_id.compare closure_id1 closure_id2 in + if c <> 0 then c + else + Var_within_closure.compare var1 var2 + +let compare_move_within_set_of_closures + ({ closure = closure1; start_from = start_from1; move_to = move_to1; } + : move_within_set_of_closures) + ({ closure = closure2; start_from = start_from2; move_to = move_to2; } + : move_within_set_of_closures) = + let c = Variable.compare closure1 closure2 in + if c <> 0 then c + else + let c = Closure_id.compare start_from1 start_from2 in + if c <> 0 then c + else + Closure_id.compare move_to1 move_to2 + +let compare_project_closure + ({ set_of_closures = set_of_closures1; closure_id = closure_id1; } + : project_closure) + ({ set_of_closures = set_of_closures2; closure_id = closure_id2; } + : project_closure) = + let c = Variable.compare set_of_closures1 set_of_closures2 in + if c <> 0 then c + else + Closure_id.compare closure_id1 closure_id2 + +let print_project_closure ppf (project_closure : project_closure) = + Format.fprintf ppf "@[<2>(project_closure@ %a@ from@ %a)@]" + Closure_id.print project_closure.closure_id + Variable.print project_closure.set_of_closures + +let print_move_within_set_of_closures ppf + (move_within_set_of_closures : move_within_set_of_closures) = + Format.fprintf ppf + "@[<2>(move_within_set_of_closures@ %a <-- %a@ (closure = %a))@]" + Closure_id.print move_within_set_of_closures.move_to + Closure_id.print move_within_set_of_closures.start_from + Variable.print move_within_set_of_closures.closure + +let print_project_var ppf (project_var : project_var) = + Format.fprintf ppf "@[<2>(project_var@ %a@ from %a=%a)@]" + Var_within_closure.print project_var.var + Closure_id.print project_var.closure_id + Variable.print project_var.closure + +type t = + | Project_var of project_var + | Project_closure of project_closure + | Move_within_set_of_closures of move_within_set_of_closures + | Field of int * Variable.t + +include Identifiable.Make (struct + type nonrec t = t + + let compare t1 t2 = + match t1, t2 with + | Project_var project_var1, Project_var project_var2 -> + compare_project_var project_var1 project_var2 + | Project_closure project_closure1, Project_closure project_closure2 -> + compare_project_closure project_closure1 project_closure2 + | Move_within_set_of_closures move1, Move_within_set_of_closures move2 -> + compare_move_within_set_of_closures move1 move2 + | Field (index1, var1), Field (index2, var2) -> + let c = compare index1 index2 in + if c <> 0 then c + else Variable.compare var1 var2 + | Project_var _, _ -> -1 + | _, Project_var _ -> 1 + | Project_closure _, _ -> -1 + | _, Project_closure _ -> 1 + | Move_within_set_of_closures _, _ -> -1 + | _, Move_within_set_of_closures _ -> 1 + + let equal t1 t2 = + (compare t1 t2) = 0 + + let hash = Hashtbl.hash + + let print ppf t = + match t with + | Project_closure (project_closure) -> + print_project_closure ppf project_closure + | Project_var (project_var) -> print_project_var ppf project_var + | Move_within_set_of_closures (move_within_set_of_closures) -> + print_move_within_set_of_closures ppf move_within_set_of_closures + | Field (field_index, var) -> + Format.fprintf ppf "Field %d of %a" field_index Variable.print var + + let output _ _ = failwith "Projection.output: not yet implemented" +end) + +let projecting_from t = + match t with + | Project_var { closure; _ } -> closure + | Project_closure { set_of_closures; _ } -> set_of_closures + | Move_within_set_of_closures { closure; _ } -> closure + | Field (_, var) -> var + +let map_projecting_from t ~f : t = + match t with + | Project_var project_var -> + let project_var : project_var = + { project_var with + closure = f project_var.closure; + } + in + Project_var project_var + | Project_closure project_closure -> + let project_closure : project_closure = + { project_closure with + set_of_closures = f project_closure.set_of_closures; + } + in + Project_closure project_closure + | Move_within_set_of_closures move -> + let move : move_within_set_of_closures = + { move with + closure = f move.closure; + } + in + Move_within_set_of_closures move + | Field (field_index, var) -> Field (field_index, f var) diff --git a/middle_end/flambda/projection.mli b/middle_end/flambda/projection.mli new file mode 100644 index 0000000000..1b251ca262 --- /dev/null +++ b/middle_end/flambda/projection.mli @@ -0,0 +1,80 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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. *) +(* *) +(**************************************************************************) + +(** Representation of projections from closures and blocks. *) + +(** The selection of one closure given a set of closures, required before + a function defined by said set of closures can be applied. See more + detailed documentation below on [set_of_closures]. *) +type project_closure = { + set_of_closures : Variable.t; (** must yield a set of closures *) + closure_id : Closure_id.t; +} + +(** The selection of one closure given another closure in the same set of + closures. See more detailed documentation below on [set_of_closures]. + The [move_to] closure must be part of the free variables of + [start_from]. *) +type move_within_set_of_closures = { + closure : Variable.t; (** must yield a closure *) + start_from : Closure_id.t; + move_to : Closure_id.t; +} + +(** The selection from a closure of a variable bound by said closure. + In other words, access to a function's environment. Also see more + detailed documentation below on [set_of_closures]. *) +type project_var = { + closure : Variable.t; (** must yield a closure *) + closure_id : Closure_id.t; + var : Var_within_closure.t; +} + +val print_project_closure + : Format.formatter + -> project_closure + -> unit + +val print_move_within_set_of_closures + : Format.formatter + -> move_within_set_of_closures + -> unit + +val print_project_var + : Format.formatter + -> project_var + -> unit + +val compare_project_var : project_var -> project_var -> int +val compare_project_closure : project_closure -> project_closure -> int +val compare_move_within_set_of_closures + : move_within_set_of_closures + -> move_within_set_of_closures + -> int + +type t = + | Project_var of project_var + | Project_closure of project_closure + | Move_within_set_of_closures of move_within_set_of_closures + | Field of int * Variable.t + +include Identifiable.S with type t := t + +(** Return which variable the given projection projects from. *) +val projecting_from : t -> Variable.t + +(** Change the variable that the given projection projects from. *) +val map_projecting_from : t -> f:(Variable.t -> Variable.t) -> t diff --git a/middle_end/flambda/ref_to_variables.ml b/middle_end/flambda/ref_to_variables.ml new file mode 100644 index 0000000000..f93948f912 --- /dev/null +++ b/middle_end/flambda/ref_to_variables.ml @@ -0,0 +1,199 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +let variables_not_used_as_local_reference (tree:Flambda.t) = + let set = ref Variable.Set.empty in + let rec loop_named (flam : Flambda.named) = + match flam with + (* Directly used block: does not prevent use as a variable *) + | Prim(Pfield _, [_], _) + | Prim(Poffsetref _, [_], _) -> () + | Prim(Psetfield _, [_block; v], _) -> + (* block is not prevented to be used as a local reference, but v is *) + set := Variable.Set.add v !set + | Prim(_, _, _) + | Symbol _ |Const _ | Allocated_const _ | Read_mutable _ + | Read_symbol_field _ | Project_closure _ + | Move_within_set_of_closures _ | Project_var _ -> + set := Variable.Set.union !set (Flambda.free_variables_named flam) + | Set_of_closures set_of_closures -> + set := Variable.Set.union !set (Flambda.free_variables_named flam); + Variable.Map.iter (fun _ (function_decl : Flambda.function_declaration) -> + loop function_decl.body) + set_of_closures.function_decls.funs + | Expr e -> + loop e + and loop (flam : Flambda.t) = + match flam with + | Let { defining_expr; body; _ } -> + loop_named defining_expr; + loop body + | Let_rec (defs, body) -> + List.iter (fun (_var, named) -> loop_named named) defs; + loop body + | Var v -> + set := Variable.Set.add v !set + | Let_mutable { initial_value = v; body } -> + set := Variable.Set.add v !set; + loop body + | If_then_else (cond, ifso, ifnot) -> + set := Variable.Set.add cond !set; + loop ifso; + loop ifnot + | Switch (cond, { consts; blocks; failaction }) -> + set := Variable.Set.add cond !set; + List.iter (fun (_, branch) -> loop branch) consts; + List.iter (fun (_, branch) -> loop branch) blocks; + Misc.may loop failaction + | String_switch (cond, branches, default) -> + set := Variable.Set.add cond !set; + List.iter (fun (_, branch) -> loop branch) branches; + Misc.may loop default + | Static_catch (_, _, body, handler) -> + loop body; + loop handler + | Try_with (body, _, handler) -> + loop body; + loop handler + | While (cond, body) -> + loop cond; + loop body + | For { bound_var = _; from_value; to_value; direction = _; body; } -> + set := Variable.Set.add from_value !set; + set := Variable.Set.add to_value !set; + loop body + | Static_raise (_, args) -> + set := Variable.Set.union (Variable.Set.of_list args) !set + | Proved_unreachable | Apply _ | Send _ | Assign _ -> + set := Variable.Set.union !set (Flambda.free_variables flam) + in + loop tree; + !set + +let variables_containing_ref (flam:Flambda.t) = + let map = ref Variable.Map.empty in + let aux (flam : Flambda.t) = + match flam with + | Let { var; + defining_expr = Prim(Pmakeblock(0, Asttypes.Mutable, _), l, _); + } -> + map := Variable.Map.add var (List.length l) !map + | _ -> () + in + Flambda_iterators.iter aux (fun _ -> ()) flam; + !map + +let eliminate_ref_of_expr flam = + let variables_not_used_as_local_reference = + variables_not_used_as_local_reference flam + in + let convertible_variables = + Variable.Map.filter + (fun v _ -> + not (Variable.Set.mem v variables_not_used_as_local_reference)) + (variables_containing_ref flam) + in + if Variable.Map.cardinal convertible_variables = 0 then flam + else + let convertible_variables = + Variable.Map.mapi (fun v size -> + Array.init size (fun _ -> Mutable_variable.create_from_variable v)) + convertible_variables + in + let convertible_variable v = Variable.Map.mem v convertible_variables in + let get_variable v field = + let arr = try Variable.Map.find v convertible_variables + with Not_found -> assert false in + if Array.length arr <= field + then None (* This case could apply when inlining code containing GADTS *) + else Some (arr.(field), Array.length arr) + in + let aux (flam : Flambda.t) : Flambda.t = + match flam with + | Let { var; + defining_expr = Prim(Pmakeblock(0, Asttypes.Mutable, shape), l,_); + body } + when convertible_variable var -> + let shape = match shape with + | None -> List.map (fun _ -> Lambda.Pgenval) l + | Some shape -> shape + in + let _, expr = + List.fold_left2 (fun (field,body) init kind -> + match get_variable var field with + | None -> assert false + | Some (field_var, _) -> + field+1, + (Let_mutable { var = field_var; + initial_value = init; + body; + contents_kind = kind } : Flambda.t)) + (0,body) l shape in + expr + | Let _ | Let_mutable _ + | Assign _ | Var _ | Apply _ + | Let_rec _ | Switch _ | String_switch _ + | Static_raise _ | Static_catch _ + | Try_with _ | If_then_else _ + | While _ | For _ | Send _ | Proved_unreachable -> + flam + and aux_named (named : Flambda.named) : Flambda.named = + match named with + | Prim(Pfield field, [v], _) + when convertible_variable v -> + (match get_variable v field with + | None -> Expr Proved_unreachable + | Some (var,_) -> Read_mutable var) + | Prim(Poffsetref delta, [v], dbg) + when convertible_variable v -> + (match get_variable v 0 with + | None -> Expr Proved_unreachable + | Some (var,size) -> + if size = 1 + then begin + let mut_name = Internal_variable_names.read_mutable in + let mut = Variable.create mut_name in + let new_value_name = Internal_variable_names.offsetted in + let new_value = Variable.create new_value_name in + let expr = + Flambda.create_let mut (Read_mutable var) + (Flambda.create_let new_value + (Prim(Poffsetint delta, [mut], dbg)) + (Assign { being_assigned = var; new_value })) + in + Expr expr + end + else + Expr Proved_unreachable) + | Prim(Psetfield (field, _, _), [v; new_value], _) + when convertible_variable v -> + (match get_variable v field with + | None -> Expr Proved_unreachable + | Some (being_assigned,_) -> + Expr (Assign { being_assigned; new_value })) + | Prim _ | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ + | Read_symbol_field _ | Set_of_closures _ | Project_closure _ + | Move_within_set_of_closures _ | Project_var _ | Expr _ -> + named + in + Flambda_iterators.map aux aux_named flam + +let eliminate_ref (program:Flambda.program) = + Flambda_iterators.map_exprs_at_toplevel_of_program program + ~f:eliminate_ref_of_expr diff --git a/middle_end/flambda/ref_to_variables.mli b/middle_end/flambda/ref_to_variables.mli new file mode 100644 index 0000000000..38d3688917 --- /dev/null +++ b/middle_end/flambda/ref_to_variables.mli @@ -0,0 +1,23 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(** Transform [let]-bound references into variables. *) + +val eliminate_ref + : Flambda.program + -> Flambda.program diff --git a/middle_end/flambda/remove_free_vars_equal_to_args.ml b/middle_end/flambda/remove_free_vars_equal_to_args.ml new file mode 100644 index 0000000000..6327d30cda --- /dev/null +++ b/middle_end/flambda/remove_free_vars_equal_to_args.ml @@ -0,0 +1,99 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +let pass_name = "remove-free-vars-equal-to-args" +let () = Pass_wrapper.register ~pass_name + +let rewrite_one_function_decl ~(function_decl : Flambda.function_declaration) + ~back_free_vars ~specialised_args = + let params_for_equal_free_vars = + List.fold_left (fun subst param -> + match Variable.Map.find param specialised_args with + | exception Not_found -> + (* param is not specialised *) + subst + | (spec_to : Flambda.specialised_to) -> + let outside_var = spec_to.var in + match Variable.Map.find outside_var back_free_vars with + | exception Not_found -> + (* No free variables equal to the param *) + subst + | set -> + (* Replace the free variables equal to a parameter *) + Variable.Set.fold (fun free_var subst -> + Variable.Map.add free_var param subst) + set subst) + Variable.Map.empty (Parameter.List.vars function_decl.params) + in + if Variable.Map.is_empty params_for_equal_free_vars then + function_decl + else + let body = + Flambda_utils.toplevel_substitution + params_for_equal_free_vars + function_decl.body + in + Flambda.update_function_declaration function_decl + ~params:function_decl.params ~body:body + +let rewrite_one_set_of_closures (set_of_closures : Flambda.set_of_closures) = + let back_free_vars = + Variable.Map.fold (fun var (outside_var : Flambda.specialised_to) map -> + let set = + match Variable.Map.find outside_var.var map with + | exception Not_found -> Variable.Set.singleton var + | set -> Variable.Set.add var set + in + Variable.Map.add outside_var.var set map) + set_of_closures.free_vars Variable.Map.empty + in + let done_something = ref false in + let funs = + Variable.Map.map (fun function_decl -> + let new_function_decl = + rewrite_one_function_decl ~function_decl ~back_free_vars + ~specialised_args:set_of_closures.specialised_args + in + if not (new_function_decl == function_decl) then begin + done_something := true + end; + new_function_decl) + set_of_closures.function_decls.funs + in + if not !done_something then + None + else + let function_decls = + Flambda.update_function_declarations + set_of_closures.function_decls ~funs + in + let set_of_closures = + Flambda.create_set_of_closures + ~function_decls + ~free_vars:set_of_closures.free_vars + ~specialised_args:set_of_closures.specialised_args + ~direct_call_surrogates:set_of_closures.direct_call_surrogates + in + Some set_of_closures + +let run ~ppf_dump set_of_closures = + Pass_wrapper.with_dump ~ppf_dump ~pass_name ~input:set_of_closures + ~print_input:Flambda.print_set_of_closures + ~print_output:Flambda.print_set_of_closures + ~f:(fun () -> rewrite_one_set_of_closures set_of_closures) diff --git a/middle_end/flambda/remove_free_vars_equal_to_args.mli b/middle_end/flambda/remove_free_vars_equal_to_args.mli new file mode 100644 index 0000000000..49f25ac106 --- /dev/null +++ b/middle_end/flambda/remove_free_vars_equal_to_args.mli @@ -0,0 +1,23 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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. *) +(* *) +(**************************************************************************) + +(** Replace free variables in closures known to be equal to specialised + arguments of such closures with those specialised arguments. *) + +val run + : ppf_dump:Format.formatter + -> Flambda.set_of_closures + -> Flambda.set_of_closures option diff --git a/middle_end/flambda/remove_unused_arguments.ml b/middle_end/flambda/remove_unused_arguments.ml new file mode 100644 index 0000000000..f70da729ae --- /dev/null +++ b/middle_end/flambda/remove_unused_arguments.ml @@ -0,0 +1,242 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +let pass_name = "remove-unused-arguments" +let () = Clflags.all_passes := pass_name :: !Clflags.all_passes + +let rename_var var = + Variable.rename var + ~current_compilation_unit:(Compilation_unit.get_current_exn ()) + +let remove_params unused (fun_decl: Flambda.function_declaration) + ~new_fun_var = + let unused_params, used_params = + List.partition (fun v -> Variable.Set.mem (Parameter.var v) unused) + fun_decl.params + in + let unused_params = List.filter (fun v -> + Variable.Set.mem (Parameter.var v) fun_decl.free_variables) unused_params + in + let body = + List.fold_left (fun body param -> + Flambda.create_let (Parameter.var param) (Const (Const_pointer 0)) body) + fun_decl.body + unused_params + in + Flambda.create_function_declaration ~params:used_params ~body + ~stub:fun_decl.stub ~dbg:fun_decl.dbg ~inline:fun_decl.inline + ~specialise:fun_decl.specialise ~is_a_functor:fun_decl.is_a_functor + ~closure_origin:(Closure_origin.create (Closure_id.wrap new_fun_var)) + +let make_stub unused var (fun_decl : Flambda.function_declaration) + ~specialised_args ~additional_specialised_args = + let renamed = rename_var var in + let args' = + List.map (fun param -> param, Parameter.rename param) fun_decl.params + in + let used_args' = + List.filter (fun (param, _) -> + not (Variable.Set.mem (Parameter.var param) unused)) args' + in + let args'_var = + List.map (fun (p1, p2) -> Parameter.var p1, Parameter.var p2) args' + in + let args_renaming = Variable.Map.of_list args'_var in + let additional_specialised_args = + List.fold_left (fun additional_specialised_args (original_arg,arg) -> + match Variable.Map.find original_arg specialised_args with + | exception Not_found -> additional_specialised_args + | (outer_var : Flambda.specialised_to) -> + (* CR-soon mshinwell: share with Augment_specialised_args *) + let outer_var : Flambda.specialised_to = + match outer_var.projection with + | None -> outer_var + | Some projection -> + let projection = + Projection.map_projecting_from projection ~f:(fun var -> + match Variable.Map.find var args_renaming with + | exception Not_found -> + (* Must always be a parameter of this + [function_decl]. *) + assert false + | wrapper_arg -> wrapper_arg) + in + { outer_var with + projection = Some projection; + } + in + Variable.Map.add arg outer_var additional_specialised_args) + additional_specialised_args args'_var + in + let args = List.map (fun (_, var) -> var) used_args' in + let kind = Flambda.Direct (Closure_id.wrap renamed) in + let body : Flambda.t = + Apply { + func = renamed; + args = Parameter.List.vars args; + kind; + dbg = fun_decl.dbg; + inline = Default_inline; + specialise = Default_specialise; + } + in + let function_decl = + Flambda.create_function_declaration ~params:(List.map snd args') ~body + ~stub:true ~dbg:fun_decl.dbg ~inline:Default_inline + ~specialise:Default_specialise ~is_a_functor:fun_decl.is_a_functor + ~closure_origin:fun_decl.closure_origin + in + function_decl, renamed, additional_specialised_args + +let separate_unused_arguments ~only_specialised + ~backend ~(set_of_closures : Flambda.set_of_closures) = + let function_decls = set_of_closures.function_decls in + let unused = Invariant_params.unused_arguments ~backend function_decls in + let non_stub_arguments = + Variable.Map.fold (fun _ (decl : Flambda.function_declaration) acc -> + if decl.stub then + acc + else + Variable.Set.union acc (Parameter.Set.vars decl.Flambda.params)) + function_decls.funs Variable.Set.empty + in + let unused = Variable.Set.inter non_stub_arguments unused in + let specialised_args = Variable.Map.keys set_of_closures.specialised_args in + let unused = + if only_specialised then Variable.Set.inter specialised_args unused + else unused + in + if Variable.Set.is_empty unused + then None + else begin + let funs, additional_specialised_args = + Variable.Map.fold (fun fun_id (fun_decl : Flambda.function_declaration) + (funs, additional_specialised_args) -> + if List.exists (fun v -> Variable.Set.mem (Parameter.var v) unused) + fun_decl.params + then begin + let stub, renamed_fun_id, additional_specialised_args = + make_stub unused fun_id fun_decl + ~specialised_args:set_of_closures.specialised_args + ~additional_specialised_args + in + let cleaned = + remove_params unused fun_decl ~new_fun_var:renamed_fun_id + in + Variable.Map.add fun_id stub + (Variable.Map.add renamed_fun_id cleaned funs), + additional_specialised_args + end + else + Variable.Map.add fun_id fun_decl funs, + additional_specialised_args + ) + function_decls.funs (Variable.Map.empty, Variable.Map.empty) + in + let specialised_args = + Variable.Map.disjoint_union additional_specialised_args + (Variable.Map.filter (fun param _ -> + not (Variable.Set.mem param unused)) + set_of_closures.specialised_args) + in + let specialised_args = + Flambda_utils.clean_projections ~which_variables:specialised_args + in + let function_decls = + Flambda.update_function_declarations function_decls ~funs + in + let set_of_closures = + Flambda.create_set_of_closures ~function_decls + ~free_vars:set_of_closures.free_vars ~specialised_args + (* CR-soon mshinwell: Use direct_call_surrogates for this + transformation. *) + ~direct_call_surrogates:set_of_closures.direct_call_surrogates + in + Some set_of_closures + end + +(* Splitting is not always beneficial. For instance when a function + is only indirectly called, suppressing unused arguments does not + benefit, and introduce an useless intermediate call. Specialised + args should always be beneficial since they should not be used in + indirect calls. *) +let should_split_only_specialised_args + (fun_decls : Flambda.function_declarations) + ~backend = + if not !Clflags.remove_unused_arguments then begin + true + end else begin + let no_recursive_functions = + Variable.Set.is_empty + (Find_recursive_functions.in_function_declarations fun_decls ~backend) + in + let number_of_non_stub_functions = + Variable.Map.cardinal + (Variable.Map.filter (fun _ { Flambda.stub } -> not stub) + fun_decls.funs) + in + (* CR-soon lwhite: this criteria could use some justification. + mshinwell: pchambart cannot remember how these criteria arose, + but we're going to leave this as-is for 4.03. *) + no_recursive_functions && (number_of_non_stub_functions <= 1) + end + +let separate_unused_arguments_in_set_of_closures set_of_closures ~backend = + let dump = Clflags.dumped_pass pass_name in + let only_specialised = + should_split_only_specialised_args + set_of_closures.Flambda.function_decls + ~backend + in + match separate_unused_arguments + ~only_specialised ~backend ~set_of_closures with + | None -> + if dump then + Format.eprintf "No change for Remove_unused_arguments:@ %a@.@." + Flambda.print_set_of_closures set_of_closures; + None + | Some result -> + if dump then + Format.eprintf "Before Remove_unused_arguments:@ %a@.@.\ + After Remove_unused_arguments:@ %a@.@." + Flambda.print_set_of_closures set_of_closures + Flambda.print_set_of_closures result; + Some result + +let separate_unused_arguments_in_closures_expr tree ~backend = + let aux_named (named : Flambda.named) : Flambda.named = + match named with + | Set_of_closures set_of_closures -> begin + let only_specialised = + should_split_only_specialised_args + set_of_closures.function_decls + ~backend + in + match separate_unused_arguments + ~only_specialised ~backend ~set_of_closures with + | None -> named + | Some set_of_closures -> Set_of_closures set_of_closures + end + | e -> e + in + Flambda_iterators.map_named aux_named tree + +let separate_unused_arguments_in_closures program ~backend = + Flambda_iterators.map_exprs_at_toplevel_of_program program ~f:(fun expr -> + separate_unused_arguments_in_closures_expr expr ~backend) diff --git a/middle_end/flambda/remove_unused_arguments.mli b/middle_end/flambda/remove_unused_arguments.mli new file mode 100644 index 0000000000..759b32f2d2 --- /dev/null +++ b/middle_end/flambda/remove_unused_arguments.mli @@ -0,0 +1,39 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(** Introduce a stub function to avoid depending on unused arguments. + + For instance, it turns + [let rec fact n unused = + if n = 0 then 1 + else n * fact (n-1) unused] + into + [let rec fact' n = + if n = 0 then 1 + else n * fact' (n-1) + and fact n unused = fact' n] +*) +val separate_unused_arguments_in_closures + : Flambda.program + -> backend:(module Backend_intf.S) + -> Flambda.program + +val separate_unused_arguments_in_set_of_closures + : Flambda.set_of_closures + -> backend:(module Backend_intf.S) + -> Flambda.set_of_closures option diff --git a/middle_end/flambda/remove_unused_closure_vars.ml b/middle_end/flambda/remove_unused_closure_vars.ml new file mode 100644 index 0000000000..0d4ad621dd --- /dev/null +++ b/middle_end/flambda/remove_unused_closure_vars.ml @@ -0,0 +1,125 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +(** A variable in a closure can either be used by the closure itself + or by an inlined version of the function. *) +let remove_unused_closure_variables ~remove_direct_call_surrogates program = + let used_vars_within_closure, used_closure_ids = + let used = Var_within_closure.Tbl.create 13 in + let used_fun = Closure_id.Tbl.create 13 in + let aux_named (named : Flambda.named) = + match named with + | Project_closure { set_of_closures = _; closure_id } -> + Closure_id.Tbl.add used_fun closure_id () + | Project_var { closure_id; var } -> + Var_within_closure.Tbl.add used var (); + Closure_id.Tbl.add used_fun closure_id () + | Move_within_set_of_closures { closure = _; start_from; move_to } -> + Closure_id.Tbl.add used_fun start_from (); + Closure_id.Tbl.add used_fun move_to () + | Symbol _ | Const _ | Set_of_closures _ | Prim _ | Expr _ + | Allocated_const _ | Read_mutable _ | Read_symbol_field _ -> () + in + Flambda_iterators.iter_named_of_program ~f:aux_named program; + used, used_fun + in + let aux_named _ (named : Flambda.named) : Flambda.named = + match named with + | Set_of_closures ({ function_decls; free_vars; _ } as set_of_closures) -> + let direct_call_surrogates = + if remove_direct_call_surrogates then Variable.Set.empty + else + Variable.Set.of_list + (Variable.Map.data set_of_closures.direct_call_surrogates) + in + let rec add_needed needed_funs remaining_funs free_vars_of_kept_funs = + let new_needed_funs, remaining_funs = + (* Keep a function if it is used either by the rest of the code, + (in used_closure_ids), or by any other kept function + (in free_vars_of_kept_funs) *) + Variable.Map.partition (fun fun_id _ -> + Variable.Set.mem fun_id free_vars_of_kept_funs + || Closure_id.Tbl.mem used_closure_ids + (Closure_id.wrap fun_id) + || Variable.Set.mem fun_id direct_call_surrogates) + remaining_funs + in + if Variable.Map.is_empty new_needed_funs then + (* If no new function is needed, we reached fixpoint *) + needed_funs, free_vars_of_kept_funs + else begin + let needed_funs = + Variable.Map.disjoint_union needed_funs new_needed_funs + in + let free_vars_of_kept_funs = + Variable.Map.fold (fun _ { Flambda. free_variables } acc -> + Variable.Set.union free_variables acc) + new_needed_funs + free_vars_of_kept_funs + in + add_needed needed_funs remaining_funs free_vars_of_kept_funs + end + in + let funs, free_vars_of_kept_funs = + add_needed Variable.Map.empty function_decls.funs Variable.Set.empty + in + let free_vars = + Variable.Map.filter (fun id _var -> + Variable.Set.mem id free_vars_of_kept_funs + || Var_within_closure.Tbl.mem + used_vars_within_closure + (Var_within_closure.wrap id)) + free_vars + in + let function_decls = + Flambda.update_function_declarations function_decls ~funs + in + let specialised_args = + (* Remove specialised args that are used by removed functions *) + let all_remaining_arguments = + Variable.Map.fold (fun _ { Flambda.params } set -> + Variable.Set.union set (Parameter.Set.vars params)) + funs Variable.Set.empty + in + Variable.Map.filter (fun arg _ -> + Variable.Set.mem arg all_remaining_arguments) + set_of_closures.specialised_args + in + let free_vars = + Flambda_utils.clean_projections ~which_variables:free_vars + in + let direct_call_surrogates = + (* Remove direct call surrogates where either the existing function + or the surrogate has been eliminated. *) + Variable.Map.fold (fun existing surrogate surrogates -> + if not (Variable.Map.mem existing funs) + || not (Variable.Map.mem surrogate funs) + then surrogates + else Variable.Map.add existing surrogate surrogates) + set_of_closures.direct_call_surrogates + Variable.Map.empty + in + let set_of_closures = + Flambda.create_set_of_closures ~function_decls + ~free_vars ~specialised_args ~direct_call_surrogates + in + Set_of_closures set_of_closures + | e -> e + in + Flambda_iterators.map_named_of_program ~f:aux_named program diff --git a/middle_end/flambda/remove_unused_closure_vars.mli b/middle_end/flambda/remove_unused_closure_vars.mli new file mode 100644 index 0000000000..225697a814 --- /dev/null +++ b/middle_end/flambda/remove_unused_closure_vars.mli @@ -0,0 +1,26 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(* CR-soon mshinwell: Rename this module. *) + +(** Eliminate variables bound by sets of closures that are not required. + Also eliminate functions within sets of closures that are not required. *) +val remove_unused_closure_variables + : remove_direct_call_surrogates:bool + -> Flambda.program + -> Flambda.program diff --git a/middle_end/flambda/remove_unused_program_constructs.ml b/middle_end/flambda/remove_unused_program_constructs.ml new file mode 100644 index 0000000000..059d68bcba --- /dev/null +++ b/middle_end/flambda/remove_unused_program_constructs.ml @@ -0,0 +1,111 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +let dependency (expr:Flambda.t) = Flambda.free_symbols expr + +(* CR-soon pchambart: copied from lift_constant. Needs remerging *) +let constant_dependencies (const:Flambda.constant_defining_value) = + let closure_dependencies (set_of_closures:Flambda.set_of_closures) = + Flambda.free_symbols_named (Set_of_closures set_of_closures) + in + match const with + | Allocated_const _ -> Symbol.Set.empty + | Block (_, fields) -> + let symbol_fields = + List.filter_map (function + | (Symbol s : Flambda.constant_defining_value_block_field) -> + Some s + | Flambda.Const _ -> None) + fields + in + Symbol.Set.of_list symbol_fields + | Set_of_closures set_of_closures -> closure_dependencies set_of_closures + | Project_closure (s, _) -> Symbol.Set.singleton s + +let let_rec_dep defs dep = + let add_deps l dep = + List.fold_left (fun dep (sym, sym_dep) -> + if Symbol.Set.mem sym dep then Symbol.Set.union dep sym_dep + else dep) + dep l + in + let defs_deps = + List.map (fun (sym, def) -> sym, constant_dependencies def) defs + in + let rec fixpoint dep = + let new_dep = add_deps defs_deps dep in + if Symbol.Set.equal dep new_dep then dep + else fixpoint new_dep + in + fixpoint dep + +let rec loop (program : Flambda.program_body) + : Flambda.program_body * Symbol.Set.t = + match program with + | Let_symbol (sym, def, program) -> + let program, dep = loop program in + if Symbol.Set.mem sym dep then + Let_symbol (sym, def, program), + Symbol.Set.union dep (constant_dependencies def) + else + program, dep + | Let_rec_symbol (defs, program) -> + let program, dep = loop program in + let dep = let_rec_dep defs dep in + let defs = + List.filter (fun (sym, _) -> Symbol.Set.mem sym dep) defs + in begin match defs with + | [] -> program, dep + | _ -> Let_rec_symbol (defs, program), dep + end + | Initialize_symbol (sym, tag, fields, program) -> + let program, dep = loop program in + if Symbol.Set.mem sym dep then + let dep = + List.fold_left (fun dep field -> + Symbol.Set.union dep (dependency field)) + dep fields + in + Initialize_symbol (sym, tag, fields, program), dep + else begin + List.fold_left + (fun (program, dep) field -> + if Effect_analysis.no_effects field then + program, dep + else + let new_dep = dependency field in + let dep = Symbol.Set.union new_dep dep in + Flambda.Effect (field, program), dep) + (program, dep) fields + end + | Effect (effect, program) -> + let program, dep = loop program in + if Effect_analysis.no_effects effect then begin + program, dep + end else begin + let new_dep = dependency effect in + let dep = Symbol.Set.union new_dep dep in + Effect (effect, program), dep + end + | End symbol -> program, Symbol.Set.singleton symbol + +let remove_unused_program_constructs (program : Flambda.program) = + { program with + program_body = fst (loop program.program_body); + } diff --git a/middle_end/flambda/remove_unused_program_constructs.mli b/middle_end/flambda/remove_unused_program_constructs.mli new file mode 100644 index 0000000000..3a722011bb --- /dev/null +++ b/middle_end/flambda/remove_unused_program_constructs.mli @@ -0,0 +1,24 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(* Remove unused [Flambda.program] constructs from the given program. + - Symbols (whose defining expressions have no effects) are eliminated + if unused. + - [Effect] constructs that turn out to have no effects are eliminated. +*) +val remove_unused_program_constructs : Flambda.program -> Flambda.program diff --git a/middle_end/flambda/share_constants.ml b/middle_end/flambda/share_constants.ml new file mode 100644 index 0000000000..2bbd7134b8 --- /dev/null +++ b/middle_end/flambda/share_constants.ml @@ -0,0 +1,130 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +module Constant_defining_value = Flambda.Constant_defining_value + +let update_constant_for_sharing sharing_symbol_tbl const + : Flambda.constant_defining_value = + let substitute_symbol sym = + match Symbol.Tbl.find sharing_symbol_tbl sym with + | exception Not_found -> sym + | symbol -> symbol + in + match (const:Flambda.constant_defining_value) with + | Allocated_const _ -> const + | Block (tag, fields) -> + let subst_field (field:Flambda.constant_defining_value_block_field) : + Flambda.constant_defining_value_block_field = + match field with + | Const _ -> field + | Symbol sym -> + Symbol (substitute_symbol sym) + in + let fields = List.map subst_field fields in + Block (tag, fields) + | Set_of_closures set_of_closures -> + Set_of_closures ( + Flambda_iterators.map_symbols_on_set_of_closures + ~f:substitute_symbol set_of_closures + ) + | Project_closure (sym, closure_id) -> + Project_closure (substitute_symbol sym, closure_id) + +let cannot_share (const : Flambda.constant_defining_value) = + match const with + (* Strings and float arrays are mutable; we never share them. *) + | Allocated_const ((String _) | (Float_array _)) -> true + | Allocated_const _ | Set_of_closures _ | Project_closure _ | Block _ -> + false + +let share_definition constant_to_symbol_tbl sharing_symbol_tbl + symbol def end_symbol = + let def = update_constant_for_sharing sharing_symbol_tbl def in + if cannot_share def || Symbol.equal symbol end_symbol then + (* The symbol exported by the unit (end_symbol), cannot be removed + from the module. We prevent it from being shared to avoid that. *) + Some def + else + begin match Constant_defining_value.Tbl.find constant_to_symbol_tbl def with + | exception Not_found -> + Constant_defining_value.Tbl.add constant_to_symbol_tbl def symbol; + Some def + | equal_symbol -> + Symbol.Tbl.add sharing_symbol_tbl symbol equal_symbol; + None + end + +let rec end_symbol (program : Flambda.program_body) = + match program with + | End symbol -> symbol + | Let_symbol (_, _, program) + | Let_rec_symbol (_, program) + | Initialize_symbol (_, _, _, program) + | Effect (_, program) -> + end_symbol program + +let share_constants (program : Flambda.program) = + let end_symbol = end_symbol program.program_body in + let sharing_symbol_tbl = Symbol.Tbl.create 42 in + let constant_to_symbol_tbl = Constant_defining_value.Tbl.create 42 in + let rec loop (program : Flambda.program_body) : Flambda.program_body = + match program with + | Let_symbol (symbol,def,program) -> + begin match + share_definition constant_to_symbol_tbl sharing_symbol_tbl symbol + def end_symbol + with + | None -> + loop program + | Some def' -> + Let_symbol (symbol,def',loop program) + end + | Let_rec_symbol (defs,program) -> + let defs = + List.map (fun (symbol, def) -> + let def = update_constant_for_sharing sharing_symbol_tbl def in + symbol, def) + defs + in + Let_rec_symbol (defs, loop program) + | Initialize_symbol (symbol,tag,fields,program) -> + let fields = + List.map (fun field -> + Flambda_iterators.map_symbols + ~f:(fun symbol -> + try Symbol.Tbl.find sharing_symbol_tbl symbol with + | Not_found -> symbol) + field) + fields + in + Initialize_symbol (symbol,tag,fields,loop program) + | Effect (expr,program) -> + let expr = + Flambda_iterators.map_symbols + ~f:(fun symbol -> + try Symbol.Tbl.find sharing_symbol_tbl symbol with + | Not_found -> symbol) + expr + in + Effect (expr, loop program) + | End root -> End root + in + { program with + program_body = loop program.program_body; + } diff --git a/middle_end/flambda/share_constants.mli b/middle_end/flambda/share_constants.mli new file mode 100644 index 0000000000..7fec22bc44 --- /dev/null +++ b/middle_end/flambda/share_constants.mli @@ -0,0 +1,22 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(** Share lifted constants that are eligible for sharing (e.g. not strings) + and have equal definitions. *) + +val share_constants : Flambda.program -> Flambda.program diff --git a/middle_end/flambda/simple_value_approx.ml b/middle_end/flambda/simple_value_approx.ml new file mode 100644 index 0000000000..34fc5ce056 --- /dev/null +++ b/middle_end/flambda/simple_value_approx.ml @@ -0,0 +1,1043 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +module U = Flambda_utils + +type 'a boxed_int = + | Int32 : int32 boxed_int + | Int64 : int64 boxed_int + | Nativeint : nativeint boxed_int + +type value_string = { + (* CR-soon mshinwell: use variant *) + contents : string option; (* None if unknown or mutable *) + size : int; +} + +type unresolved_value = + | Set_of_closures_id of Set_of_closures_id.t + | Symbol of Symbol.t + +type unknown_because_of = + | Unresolved_value of unresolved_value + | Other + +type t = { + descr : descr; + var : Variable.t option; + symbol : (Symbol.t * int option) option; +} + +and descr = + | Value_block of Tag.t * t array + | Value_int of int + | Value_char of char + | Value_constptr of int + | Value_float of float option + | Value_boxed_int : 'a boxed_int * 'a -> descr + | Value_set_of_closures of value_set_of_closures + | Value_closure of value_closure + | Value_string of value_string + | Value_float_array of value_float_array + | Value_unknown of unknown_because_of + | Value_bottom + | Value_extern of Export_id.t + | Value_symbol of Symbol.t + | Value_unresolved of unresolved_value + (* No description was found for this value *) + +and value_closure = { + set_of_closures : t; + closure_id : Closure_id.t; +} + +and function_declarations = { + is_classic_mode : bool; + set_of_closures_id : Set_of_closures_id.t; + set_of_closures_origin : Set_of_closures_origin.t; + funs : function_declaration Variable.Map.t; +} + +and function_body = { + free_variables : Variable.Set.t; + free_symbols : Symbol.Set.t; + stub : bool; + dbg : Debuginfo.t; + inline : Lambda.inline_attribute; + specialise : Lambda.specialise_attribute; + is_a_functor : bool; + body : Flambda.t; +} + +and function_declaration = { + closure_origin : Closure_origin.t; + params : Parameter.t list; + function_body : function_body option; +} + +and value_set_of_closures = { + function_decls : function_declarations; + bound_vars : t Var_within_closure.Map.t; + free_vars : Flambda.specialised_to Variable.Map.t; + invariant_params : Variable.Set.t Variable.Map.t Lazy.t; + recursive : Variable.Set.t Lazy.t; + size : int option Variable.Map.t Lazy.t; + specialised_args : Flambda.specialised_to Variable.Map.t; + freshening : Freshening.Project_var.t; + direct_call_surrogates : Closure_id.t Closure_id.Map.t; +} + +and value_float_array_contents = + | Contents of t array + | Unknown_or_mutable + +and value_float_array = { + contents : value_float_array_contents; + size : int; +} + +let descr t = t.descr + +let print_value_set_of_closures ppf + { function_decls = { funs }; invariant_params; freshening; size; _ } = + Format.fprintf ppf + "(set_of_closures:@ %a invariant_params=%a freshening=%a size=%a)" + (fun ppf -> Variable.Map.iter (fun id _ -> Variable.print ppf id)) funs + (Variable.Map.print Variable.Set.print) (Lazy.force invariant_params) + Freshening.Project_var.print freshening + (Variable.Map.print (fun ppf some_size -> + match some_size with + | None -> Format.fprintf ppf "None" + | Some size -> Format.fprintf ppf "Some %d" size)) + (Lazy.force size) + +let print_unresolved_value ppf = function + | Set_of_closures_id set -> + Format.fprintf ppf "Set_of_closures_id %a" Set_of_closures_id.print set + | Symbol symbol -> + Format.fprintf ppf "Symbol %a" Symbol.print symbol + +let print_function_declaration ppf var (f : function_declaration) = + let param ppf p = Variable.print ppf (Parameter.var p) in + let params ppf = List.iter (Format.fprintf ppf "@ %a" param) in + match f.function_body with + | None -> + Format.fprintf ppf "@[<2>(%a@ =@ fun@[<2>%a@])@]@ " + Variable.print var params f.params + | Some (b : function_body) -> + let stub = if b.stub then " *stub*" else "" in + let is_a_functor = if b.is_a_functor then " *functor*" else "" in + let inline = + match b.inline with + | Always_inline -> " *inline*" + | Never_inline -> " *never_inline*" + | Unroll _ -> " *unroll*" + | Default_inline -> "" + in + let specialise = + match b.specialise with + | Always_specialise -> " *specialise*" + | Never_specialise -> " *never_specialise*" + | Default_specialise -> "" + in + let print_body ppf _ = + Format.fprintf ppf "" + in + Format.fprintf ppf "@[<2>(%a%s%s%s%s@ =@ fun@[<2>%a@] ->@ @[<2><%a>@])@]@ " + Variable.print var stub is_a_functor inline specialise + params f.params + print_body b + +let print_function_declarations ppf (fd : function_declarations) = + let funs ppf = Variable.Map.iter (print_function_declaration ppf) in + Format.fprintf ppf "@[<2>(%a)@]" funs fd.funs + +let rec print_descr ppf = function + | Value_int i -> Format.pp_print_int ppf i + | Value_char c -> Format.fprintf ppf "%c" c + | Value_constptr i -> Format.fprintf ppf "%ia" i + | Value_block (tag,fields) -> + let p ppf fields = + Array.iter (fun v -> Format.fprintf ppf "%a@ " print v) fields in + Format.fprintf ppf "[%i:@ @[<1>%a@]]" (Tag.to_int tag) p fields + | Value_unknown reason -> + begin match reason with + | Unresolved_value value -> + Format.fprintf ppf "?(due to unresolved %a)" print_unresolved_value value + | Other -> Format.fprintf ppf "?" + end; + | Value_bottom -> Format.fprintf ppf "bottom" + | Value_extern id -> Format.fprintf ppf "_%a_" Export_id.print id + | Value_symbol sym -> Format.fprintf ppf "%a" Symbol.print sym + | Value_closure { set_of_closures; closure_id; } -> + Format.fprintf ppf "(closure:@ %a from@ %a)" Closure_id.print closure_id + print set_of_closures + | Value_set_of_closures set_of_closures -> + print_value_set_of_closures ppf set_of_closures + | Value_unresolved value -> + Format.fprintf ppf "(unresolved %a)" print_unresolved_value value + | Value_float (Some f) -> Format.pp_print_float ppf f + | Value_float None -> Format.pp_print_string ppf "float" + | Value_string { contents; size } -> begin + match contents with + | None -> + Format.fprintf ppf "string %i" size + | Some s -> + let s = + if size > 10 + then String.sub s 0 8 ^ "..." + else s + in + Format.fprintf ppf "string %i %S" size s + end + | Value_float_array float_array -> + begin match float_array.contents with + | Unknown_or_mutable -> + Format.fprintf ppf "float_array %i" float_array.size + | Contents _ -> + Format.fprintf ppf "float_array_imm %i" float_array.size + end + | Value_boxed_int (t, i) -> + match t with + | Int32 -> Format.fprintf ppf "%li" i + | Int64 -> Format.fprintf ppf "%Li" i + | Nativeint -> Format.fprintf ppf "%ni" i + +and print ppf { descr; var; symbol; } = + let print ppf = function + | None -> Symbol.print_opt ppf None + | Some (sym, None) -> Symbol.print ppf sym + | Some (sym, Some field) -> + Format.fprintf ppf "%a.(%i)" Symbol.print sym field + in + Format.fprintf ppf "{ descr=%a var=%a symbol=%a }" + print_descr descr + Variable.print_opt var + print symbol + +let approx descr = { descr; var = None; symbol = None } + +let augment_with_variable t var = { t with var = Some var } +let augment_with_symbol t symbol = { t with symbol = Some (symbol, None) } +let augment_with_symbol_field t symbol field = + match t.symbol with + | None -> { t with symbol = Some (symbol, Some field) } + | Some _ -> t +let replace_description t descr = { t with descr } + +let augment_with_kind t (kind:Lambda.value_kind) = + match kind with + | Pgenval -> t + | Pfloatval -> + begin match t.descr with + | Value_float _ -> + t + | Value_unknown _ | Value_unresolved _ -> + { t with descr = Value_float None } + | Value_block _ + | Value_int _ + | Value_char _ + | Value_constptr _ + | Value_boxed_int _ + | Value_set_of_closures _ + | Value_closure _ + | Value_string _ + | Value_float_array _ + | Value_bottom -> + (* Unreachable *) + { t with descr = Value_bottom } + | Value_extern _ | Value_symbol _ -> + (* We don't know yet *) + t + end + | _ -> t + +let augment_kind_with_approx t (kind:Lambda.value_kind) : Lambda.value_kind = + match t.descr with + | Value_float _ -> Pfloatval + | Value_int _ -> Pintval + | Value_boxed_int (Int32, _) -> Pboxedintval Pint32 + | Value_boxed_int (Int64, _) -> Pboxedintval Pint64 + | Value_boxed_int (Nativeint, _) -> Pboxedintval Pnativeint + | _ -> kind + +let value_unknown reason = approx (Value_unknown reason) +let value_int i = approx (Value_int i) +let value_char i = approx (Value_char i) +let value_constptr i = approx (Value_constptr i) +let value_float f = approx (Value_float (Some f)) +let value_any_float = approx (Value_float None) +let value_boxed_int bi i = approx (Value_boxed_int (bi,i)) + +let value_closure ?closure_var ?set_of_closures_var ?set_of_closures_symbol + value_set_of_closures closure_id = + let approx_set_of_closures = + { descr = Value_set_of_closures value_set_of_closures; + var = set_of_closures_var; + symbol = Misc.may_map (fun s -> s, None) set_of_closures_symbol; + } + in + let value_closure = + { set_of_closures = approx_set_of_closures; + closure_id; + } + in + { descr = Value_closure value_closure; + var = closure_var; + symbol = None; + } + +let create_value_set_of_closures + ~(function_decls : function_declarations) ~bound_vars ~free_vars + ~invariant_params ~recursive ~specialised_args ~freshening + ~direct_call_surrogates = + let size = + lazy ( + let functions = Variable.Map.keys function_decls.funs in + Variable.Map.fold + (fun fun_var function_decl sizes -> + match function_decl.function_body with + | None -> sizes + | Some function_body -> + let params = Parameter.Set.vars function_decl.params in + let free_vars = + Variable.Set.diff + (Variable.Set.diff function_body.free_variables params) + functions + in + let num_free_vars = Variable.Set.cardinal free_vars in + let max_size = + Inlining_cost.maximum_interesting_size_of_function_body + num_free_vars + in + let size = + Inlining_cost.lambda_smaller' function_body.body ~than:max_size + in + Variable.Map.add fun_var size sizes) + function_decls.funs Variable.Map.empty) + in + { function_decls; + bound_vars; + free_vars; + invariant_params; + recursive; + size; + specialised_args; + freshening; + direct_call_surrogates; + } + +let update_freshening_of_value_set_of_closures value_set_of_closures + ~freshening = + (* CR-someday mshinwell: We could maybe check that [freshening] is + reasonable. *) + { value_set_of_closures with freshening; } + +let value_set_of_closures ?set_of_closures_var value_set_of_closures = + { descr = Value_set_of_closures value_set_of_closures; + var = set_of_closures_var; + symbol = None; + } + +let value_block t b = approx (Value_block (t, b)) +let value_extern ex = approx (Value_extern ex) +let value_symbol sym = + { (approx (Value_symbol sym)) with symbol = Some (sym, None) } +let value_bottom = approx Value_bottom +let value_unresolved value = approx (Value_unresolved value) + +let value_string size contents = approx (Value_string {size; contents }) +let value_mutable_float_array ~size = + approx (Value_float_array { contents = Unknown_or_mutable; size; } ) +let value_immutable_float_array (contents:t array) = + let size = Array.length contents in + let contents = + Array.map (fun t -> augment_with_kind t Pfloatval) contents + in + approx (Value_float_array { contents = Contents contents; size; } ) + +let name_expr_fst (named, thing) ~name = + (Flambda_utils.name_expr named ~name), thing + +let make_const_int_named n : Flambda.named * t = + Const (Int n), value_int n +let make_const_int (n : int) = + let name = + match n with + | 0 -> Internal_variable_names.const_zero + | 1 -> Internal_variable_names.const_one + | _ -> Internal_variable_names.const_int + in + name_expr_fst (make_const_int_named n) ~name + +let make_const_char_named n : Flambda.named * t = + Const (Char n), value_char n +let make_const_char n = + let name = Internal_variable_names.const_char in + name_expr_fst (make_const_char_named n) ~name + +let make_const_ptr_named n : Flambda.named * t = + Const (Const_pointer n), value_constptr n +let make_const_ptr (n : int) = + let name = + match n with + | 0 -> Internal_variable_names.const_ptr_zero + | 1 -> Internal_variable_names.const_ptr_one + | _ -> Internal_variable_names.const_ptr + in + name_expr_fst (make_const_ptr_named n) ~name + +let make_const_bool_named b : Flambda.named * t = + make_const_ptr_named (if b then 1 else 0) +let make_const_bool b = + name_expr_fst (make_const_bool_named b) + ~name:Internal_variable_names.const_bool + +let make_const_float_named f : Flambda.named * t = + Allocated_const (Float f), value_float f +let make_const_float f = + name_expr_fst (make_const_float_named f) + ~name:Internal_variable_names.const_float + +let make_const_boxed_int_named (type bi) (t:bi boxed_int) (i:bi) + : Flambda.named * t = + let c : Allocated_const.t = + match t with + | Int32 -> Int32 i + | Int64 -> Int64 i + | Nativeint -> Nativeint i + in + Allocated_const c, value_boxed_int t i +let make_const_boxed_int t i = + name_expr_fst (make_const_boxed_int_named t i) + ~name:Internal_variable_names.const_boxed_int + +type simplification_summary = + | Nothing_done + | Replaced_term + +type simplification_result = Flambda.t * simplification_summary * t +type simplification_result_named = Flambda.named * simplification_summary * t + +let simplify t (lam : Flambda.t) : simplification_result = + if Effect_analysis.no_effects lam then + match t.descr with + | Value_int n -> + let const, approx = make_const_int n in + const, Replaced_term, approx + | Value_char n -> + let const, approx = make_const_char n in + const, Replaced_term, approx + | Value_constptr n -> + let const, approx = make_const_ptr n in + const, Replaced_term, approx + | Value_float (Some f) -> + let const, approx = make_const_float f in + const, Replaced_term, approx + | Value_boxed_int (t, i) -> + let const, approx = make_const_boxed_int t i in + const, Replaced_term, approx + | Value_symbol sym -> + let name = Internal_variable_names.symbol in + U.name_expr (Symbol sym) ~name, Replaced_term, t + | Value_string _ | Value_float_array _ | Value_float None + | Value_block _ | Value_set_of_closures _ | Value_closure _ + | Value_unknown _ | Value_bottom | Value_extern _ | Value_unresolved _ -> + lam, Nothing_done, t + else + lam, Nothing_done, t + +let simplify_named t (named : Flambda.named) : simplification_result_named = + if Effect_analysis.no_effects_named named then + match t.descr with + | Value_int n -> + let const, approx = make_const_int_named n in + const, Replaced_term, approx + | Value_char n -> + let const, approx = make_const_char_named n in + const, Replaced_term, approx + | Value_constptr n -> + let const, approx = make_const_ptr_named n in + const, Replaced_term, approx + | Value_float (Some f) -> + let const, approx = make_const_float_named f in + const, Replaced_term, approx + | Value_boxed_int (t, i) -> + let const, approx = make_const_boxed_int_named t i in + const, Replaced_term, approx + | Value_symbol sym -> + Symbol sym, Replaced_term, t + | Value_string _ | Value_float_array _ | Value_float None + | Value_block _ | Value_set_of_closures _ | Value_closure _ + | Value_unknown _ | Value_bottom | Value_extern _ | Value_unresolved _ -> + named, Nothing_done, t + else + named, Nothing_done, t + +(* CR-soon mshinwell: bad name. This function and its call site in + [Inline_and_simplify] is also messy. *) +let simplify_var t : (Flambda.named * t) option = + match t.descr with + | Value_int n -> Some (make_const_int_named n) + | Value_char n -> Some (make_const_char_named n) + | Value_constptr n -> Some (make_const_ptr_named n) + | Value_float (Some f) -> Some (make_const_float_named f) + | Value_boxed_int (t, i) -> Some (make_const_boxed_int_named t i) + | Value_symbol sym -> Some (Symbol sym, t) + | Value_string _ | Value_float_array _ | Value_float None + | Value_block _ | Value_set_of_closures _ | Value_closure _ + | Value_unknown _ | Value_bottom | Value_extern _ + | Value_unresolved _ -> + match t.symbol with + | Some (sym, None) -> Some (Symbol sym, t) + | Some (sym, Some field) -> Some (Read_symbol_field (sym, field), t) + | None -> None + +let join_summaries summary ~replaced_by_var_or_symbol = + match replaced_by_var_or_symbol, summary with + | true, Nothing_done + | true, Replaced_term + | false, Replaced_term -> Replaced_term + | false, Nothing_done -> Nothing_done + +let simplify_using_env t ~is_present_in_env flam = + let replaced_by_var_or_symbol, flam = + match t.var with + | Some var when is_present_in_env var -> true, Flambda.Var var + | _ -> + match t.symbol with + | Some (sym, None) -> + let name = Internal_variable_names.symbol in + (true, U.name_expr (Symbol sym) ~name) + | Some (sym, Some field) -> + let name = Internal_variable_names.symbol_field in + (true, U.name_expr (Read_symbol_field (sym, field)) ~name) + | None -> false, flam + in + let const, summary, approx = simplify t flam in + const, join_summaries summary ~replaced_by_var_or_symbol, approx + +let simplify_named_using_env t ~is_present_in_env named = + let replaced_by_var_or_symbol, named = + match t.var with + | Some var when is_present_in_env var -> + true, Flambda.Expr (Var var) + | _ -> + match t.symbol with + | Some (sym, None) -> true, (Flambda.Symbol sym:Flambda.named) + | Some (sym, Some field) -> + true, Flambda.Read_symbol_field (sym, field) + | None -> false, named + in + let const, summary, approx = simplify_named t named in + const, join_summaries summary ~replaced_by_var_or_symbol, approx + +let simplify_var_to_var_using_env t ~is_present_in_env = + match t.var with + | Some var when is_present_in_env var -> Some var + | _ -> None + +let known t = + match t.descr with + | Value_unresolved _ + | Value_unknown _ -> false + | Value_string _ | Value_float_array _ + | Value_bottom | Value_block _ | Value_int _ | Value_char _ + | Value_constptr _ | Value_set_of_closures _ | Value_closure _ + | Value_extern _ | Value_float _ | Value_boxed_int _ | Value_symbol _ -> true + +let useful t = + match t.descr with + | Value_unresolved _ | Value_unknown _ | Value_bottom -> false + | Value_string _ | Value_float_array _ | Value_block _ | Value_int _ + | Value_char _ | Value_constptr _ | Value_set_of_closures _ + | Value_float _ | Value_boxed_int _ | Value_closure _ | Value_extern _ + | Value_symbol _ -> true + +let all_not_useful ts = List.for_all (fun t -> not (useful t)) ts + +let warn_on_mutation t = + match t.descr with + | Value_block(_, fields) -> Array.length fields > 0 + | Value_string { contents = Some _ } + | Value_int _ | Value_char _ | Value_constptr _ + | Value_set_of_closures _ | Value_float _ | Value_boxed_int _ + | Value_closure _ -> true + | Value_string { contents = None } | Value_float_array _ + | Value_unresolved _ | Value_unknown _ | Value_bottom -> false + | Value_extern _ | Value_symbol _ -> assert false + +type get_field_result = + | Ok of t + | Unreachable + +let get_field t ~field_index:i : get_field_result = + match t.descr with + | Value_block (_tag, fields) -> + if i >= 0 && i < Array.length fields then begin + Ok fields.(i) + end else begin + (* This (unfortunately) cannot be a fatal error; it can happen if a + .cmx file is missing. However for debugging the compiler this can + be a useful point to put a [Misc.fatal_errorf]. *) + Unreachable + end + (* CR-someday mshinwell: This should probably return Unreachable in more + cases. I added a couple more. *) + | Value_bottom + | Value_int _ | Value_char _ | Value_constptr _ -> + (* Something seriously wrong is happening: either the user is doing + something exceptionally unsafe, or it is an unreachable branch. + We consider this as unreachable and mark the result accordingly. *) + Ok value_bottom + | Value_float_array _ -> + (* For the moment we return "unknown" even for immutable arrays, since + it isn't possible for user code to project from an immutable array. *) + (* CR-someday mshinwell: If Leo's array's patch lands, then we can + change this, although it's probably not Pfield that is used to + do the projection. *) + Ok (value_unknown Other) + | Value_string _ | Value_float _ | Value_boxed_int _ -> + (* The user is doing something unsafe. *) + Unreachable + | Value_set_of_closures _ | Value_closure _ + (* This is used by [CamlinternalMod]. *) + | Value_symbol _ | Value_extern _ -> + (* These should have been resolved. *) + Ok (value_unknown Other) + | Value_unknown reason -> + Ok (value_unknown reason) + | Value_unresolved value -> + (* We don't know anything, but we must remember that it comes + from another compilation unit in case it contains a closure. *) + Ok (value_unknown (Unresolved_value value)) + +type checked_approx_for_block = + | Wrong + | Ok of Tag.t * t array + +let check_approx_for_block t = + match t.descr with + | Value_block (tag, fields) -> + Ok (tag, fields) + | Value_bottom + | Value_int _ | Value_char _ | Value_constptr _ + | Value_float_array _ + | Value_string _ | Value_float _ | Value_boxed_int _ + | Value_set_of_closures _ | Value_closure _ + | Value_symbol _ | Value_extern _ + | Value_unknown _ + | Value_unresolved _ -> + Wrong + +let descrs approxs = List.map (fun v -> v.descr) approxs + +let equal_boxed_int (type t1) (type t2) + (bi1:t1 boxed_int) (i1:t1) + (bi2:t2 boxed_int) (i2:t2) = + match bi1, bi2 with + | Int32, Int32 -> Int32.equal i1 i2 + | Int64, Int64 -> Int64.equal i1 i2 + | Nativeint, Nativeint -> Nativeint.equal i1 i2 + | _ -> false + +let equal_floats f1 f2 = + match f1, f2 with + | None, None -> true + | None, Some _ | Some _, None -> false + | Some f1, Some f2 -> Allocated_const.compare_floats f1 f2 = 0 + +(* Closures and set of closures descriptions cannot be merged. + + let f x = + let g y -> x + y in + g + in + let v = + if ... + then f 1 + else f 2 + in + v 3 + + The approximation for [f 1] and [f 2] could both contain the + description of [g]. But if [f] where inlined, a new [g] would + be created in each branch, leading to incompatible description. + And we must never make the description for a function less + precise that it used to be: its information are needed for + rewriting [Project_var] and [Project_closure] constructions + in [Flambdainline.loop] +*) +let rec meet_descr ~really_import_approx d1 d2 = match d1, d2 with + | Value_int i, Value_int j when i = j -> + d1 + | Value_constptr i, Value_constptr j when i = j -> + d1 + | Value_symbol s1, Value_symbol s2 when Symbol.equal s1 s2 -> + d1 + | Value_extern e1, Value_extern e2 when Export_id.equal e1 e2 -> + d1 + | Value_float i, Value_float j when equal_floats i j -> + d1 + | Value_boxed_int (bi1, i1), Value_boxed_int (bi2, i2) when + equal_boxed_int bi1 i1 bi2 i2 -> + d1 + | Value_block (tag1, a1), Value_block (tag2, a2) + when Tag.compare tag1 tag2 = 0 && Array.length a1 = Array.length a2 -> + let fields = + Array.mapi (fun i v -> meet ~really_import_approx v a2.(i)) a1 + in + Value_block (tag1, fields) + | _ -> Value_unknown Other + +and meet ~really_import_approx a1 a2 = + match a1, a2 with + | { descr = Value_bottom }, a + | a, { descr = Value_bottom } -> a + | { descr = (Value_symbol _ | Value_extern _) }, _ + | _, { descr = (Value_symbol _ | Value_extern _) } -> + meet ~really_import_approx + (really_import_approx a1) (really_import_approx a2) + | _ -> + let var = + match a1.var, a2.var with + | None, _ | _, None -> None + | Some v1, Some v2 -> + if Variable.equal v1 v2 + then Some v1 + else None + in + let symbol = + match a1.symbol, a2.symbol with + | None, _ | _, None -> None + | Some (v1, field1), Some (v2, field2) -> + if Symbol.equal v1 v2 + then match field1, field2 with + | None, None -> a1.symbol + | Some f1, Some f2 when f1 = f2 -> + a1.symbol + | _ -> None + else None + in + { descr = meet_descr ~really_import_approx a1.descr a2.descr; + var; + symbol } + +(* Given a set-of-closures approximation and a closure ID, apply any + freshening specified in the approximation to the closure ID, and return + that new closure ID. A fatal error is produced if the new closure ID + does not correspond to a function declaration in the given approximation. *) +let freshen_and_check_closure_id + (value_set_of_closures : value_set_of_closures) closure_id = + let closure_id = + Freshening.Project_var.apply_closure_id + value_set_of_closures.freshening closure_id + in + try + ignore ( + Variable.Map.find (Closure_id.unwrap closure_id) + value_set_of_closures.function_decls.funs + ); + closure_id + with Not_found -> + Misc.fatal_error (Format.asprintf + "Function %a not found in the set of closures@ %a@.%a@." + Closure_id.print closure_id + print_value_set_of_closures value_set_of_closures + print_function_declarations value_set_of_closures.function_decls) + +type checked_approx_for_set_of_closures = + | Wrong + | Unresolved of unresolved_value + | Unknown + | Unknown_because_of_unresolved_value of unresolved_value + | Ok of Variable.t option * value_set_of_closures + +let check_approx_for_set_of_closures t : checked_approx_for_set_of_closures = + match t.descr with + | Value_unresolved value -> Unresolved value + | Value_unknown (Unresolved_value value) -> + Unknown_because_of_unresolved_value value + | Value_set_of_closures value_set_of_closures -> + (* Note that [var] might be [None]; we might be reaching the set of + closures via approximations only, with the variable originally bound + to the set now out of scope. *) + Ok (t.var, value_set_of_closures) + | Value_closure _ | Value_block _ | Value_int _ | Value_char _ + | Value_constptr _ | Value_float _ | Value_boxed_int _ | Value_unknown _ + | Value_bottom | Value_extern _ | Value_string _ | Value_float_array _ + | Value_symbol _ -> + Wrong + +type strict_checked_approx_for_set_of_closures = + | Wrong + | Ok of Variable.t option * value_set_of_closures + +let strict_check_approx_for_set_of_closures t + : strict_checked_approx_for_set_of_closures = + match check_approx_for_set_of_closures t with + | Ok (var, value_set_of_closures) -> Ok (var, value_set_of_closures) + | Wrong | Unresolved _ + | Unknown | Unknown_because_of_unresolved_value _ -> Wrong + +type checked_approx_for_closure_allowing_unresolved = + | Wrong + | Unresolved of unresolved_value + | Unknown + | Unknown_because_of_unresolved_value of unresolved_value + | Ok of value_closure * Variable.t option + * Symbol.t option * value_set_of_closures + +let check_approx_for_closure_allowing_unresolved t + : checked_approx_for_closure_allowing_unresolved = + match t.descr with + | Value_closure value_closure -> + begin match value_closure.set_of_closures.descr with + | Value_set_of_closures value_set_of_closures -> + let symbol = match value_closure.set_of_closures.symbol with + | Some (symbol, None) -> Some symbol + | None | Some (_, Some _) -> None + in + Ok (value_closure, value_closure.set_of_closures.var, + symbol, value_set_of_closures) + | Value_unresolved _ + | Value_closure _ | Value_block _ | Value_int _ | Value_char _ + | Value_constptr _ | Value_float _ | Value_boxed_int _ | Value_unknown _ + | Value_bottom | Value_extern _ | Value_string _ | Value_float_array _ + | Value_symbol _ -> + Wrong + end + | Value_unknown (Unresolved_value value) -> + Unknown_because_of_unresolved_value value + | Value_unresolved symbol -> Unresolved symbol + | Value_set_of_closures _ | Value_block _ | Value_int _ | Value_char _ + | Value_constptr _ | Value_float _ | Value_boxed_int _ + | Value_bottom | Value_extern _ | Value_string _ | Value_float_array _ + | Value_symbol _ -> + Wrong + (* CR-soon mshinwell: This should be unwound once the reason for a value + being unknown can be correctly propagated through the export info. *) + | Value_unknown Other -> Unknown + +type checked_approx_for_closure = + | Wrong + | Ok of value_closure * Variable.t option + * Symbol.t option * value_set_of_closures + +let check_approx_for_closure t : checked_approx_for_closure = + match check_approx_for_closure_allowing_unresolved t with + | Ok (value_closure, set_of_closures_var, set_of_closures_symbol, + value_set_of_closures) -> + Ok (value_closure, set_of_closures_var, set_of_closures_symbol, + value_set_of_closures) + | Wrong | Unknown | Unresolved _ | Unknown_because_of_unresolved_value _ -> + Wrong + +let approx_for_bound_var value_set_of_closures var = + try + Var_within_closure.Map.find var value_set_of_closures.bound_vars + with + | Not_found -> + Misc.fatal_errorf "The set-of-closures approximation %a@ does not \ + bind the variable %a@.%s@." + print_value_set_of_closures value_set_of_closures + Var_within_closure.print var + (Printexc.raw_backtrace_to_string (Printexc.get_callstack max_int)) + +let check_approx_for_float t : float option = + match t.descr with + | Value_float f -> f + | Value_unresolved _ + | Value_unknown _ | Value_string _ | Value_float_array _ + | Value_bottom | Value_block _ | Value_int _ | Value_char _ + | Value_constptr _ | Value_set_of_closures _ | Value_closure _ + | Value_extern _ | Value_boxed_int _ | Value_symbol _ -> + None + +let float_array_as_constant (t:value_float_array) : float list option = + match t.contents with + | Unknown_or_mutable -> None + | Contents contents -> + Array.fold_right (fun elt acc -> + match acc, elt.descr with + | Some acc, Value_float (Some f) -> + Some (f :: acc) + | None, _ + | Some _, + (Value_float None | Value_unresolved _ + | Value_unknown _ | Value_string _ | Value_float_array _ + | Value_bottom | Value_block _ | Value_int _ | Value_char _ + | Value_constptr _ | Value_set_of_closures _ | Value_closure _ + | Value_extern _ | Value_boxed_int _ | Value_symbol _) + -> None) + contents (Some []) + +let check_approx_for_string t : string option = + match t.descr with + | Value_string { contents } -> contents + | Value_float _ + | Value_unresolved _ + | Value_unknown _ | Value_float_array _ + | Value_bottom | Value_block _ | Value_int _ | Value_char _ + | Value_constptr _ | Value_set_of_closures _ | Value_closure _ + | Value_extern _ | Value_boxed_int _ | Value_symbol _ -> + None + +type switch_branch_selection = + | Cannot_be_taken + | Can_be_taken + | Must_be_taken + +let potentially_taken_const_switch_branch t branch = + match t.descr with + | Value_unresolved _ + | Value_unknown _ + | Value_extern _ + | Value_symbol _ -> + (* In theory symbol cannot contain integers but this shouldn't + matter as this will always be an imported approximation *) + Can_be_taken + | Value_constptr i | Value_int i when i = branch -> + Must_be_taken + | Value_char c when Char.code c = branch -> + Must_be_taken + | Value_constptr _ | Value_int _ | Value_char _ -> + Cannot_be_taken + | Value_block _ | Value_float _ | Value_float_array _ + | Value_string _ | Value_closure _ | Value_set_of_closures _ + | Value_boxed_int _ | Value_bottom -> + Cannot_be_taken + +let potentially_taken_block_switch_branch t tag = + match t.descr with + | (Value_unresolved _ + | Value_unknown _ + | Value_extern _ + | Value_symbol _) -> + Can_be_taken + | (Value_constptr _ | Value_int _| Value_char _) -> + Cannot_be_taken + | Value_block (block_tag, _) when Tag.to_int block_tag = tag -> + Must_be_taken + | Value_float _ when tag = Obj.double_tag -> + Must_be_taken + | Value_float_array _ when tag = Obj.double_array_tag -> + Must_be_taken + | Value_string _ when tag = Obj.string_tag -> + Must_be_taken + | (Value_closure _ | Value_set_of_closures _) + when tag = Obj.closure_tag || tag = Obj.infix_tag -> + Can_be_taken + | Value_boxed_int _ when tag = Obj.custom_tag -> + Must_be_taken + | Value_block _ | Value_float _ | Value_set_of_closures _ | Value_closure _ + | Value_string _ | Value_float_array _ | Value_boxed_int _ -> + Cannot_be_taken + | Value_bottom -> + Cannot_be_taken + +let function_arity (fun_decl : function_declaration) = + List.length fun_decl.params + +let function_declaration_approx ~keep_body fun_var + (fun_decl : Flambda.function_declaration) = + let function_body = + if not (keep_body fun_var fun_decl) then None + else begin + Some { body = fun_decl.body; + stub = fun_decl.stub; + inline = fun_decl.inline; + dbg = fun_decl.dbg; + specialise = fun_decl.specialise; + is_a_functor = fun_decl.is_a_functor; + free_variables = fun_decl.free_variables; + free_symbols = fun_decl.free_symbols; } + end + in + { function_body; + params = fun_decl.params; + closure_origin = fun_decl.closure_origin; } + +let function_declarations_approx ~keep_body + (fun_decls : Flambda.function_declarations) = + let funs = + Variable.Map.mapi (function_declaration_approx ~keep_body) fun_decls.funs + in + { funs; + is_classic_mode = fun_decls.is_classic_mode; + set_of_closures_id = fun_decls.set_of_closures_id; + set_of_closures_origin = fun_decls.set_of_closures_origin; } + +let import_function_declarations_for_pack function_decls + import_set_of_closures_id import_set_of_closures_origin = + { set_of_closures_id = + import_set_of_closures_id function_decls.set_of_closures_id; + set_of_closures_origin = + import_set_of_closures_origin function_decls.set_of_closures_origin; + funs = function_decls.funs; + is_classic_mode = function_decls.is_classic_mode; + } + +let update_function_declarations function_decls ~funs = + let compilation_unit = Compilation_unit.get_current_exn () in + let is_classic_mode = function_decls.is_classic_mode in + let set_of_closures_id = Set_of_closures_id.create compilation_unit in + let set_of_closures_origin = function_decls.set_of_closures_origin in + { is_classic_mode; + set_of_closures_id; + set_of_closures_origin; + funs; + } + +let clear_function_bodies (function_decls : function_declarations) = + let funs = + Variable.Map.map (fun (fun_decl : function_declaration) -> + match fun_decl.function_body with + | None | Some { stub = true; _ } -> + fun_decl + | Some _ -> + { fun_decl with function_body = None }) + function_decls.funs + in + { function_decls with funs } + +let update_function_declaration_body + (function_decl : function_declaration) + (f : Flambda.t -> Flambda.t) = + match function_decl.function_body with + | None -> function_decl + | Some function_body -> + let new_function_body = + let body = f function_body.body in + let free_variables = Flambda.free_variables body in + let free_symbols = Flambda.free_symbols body in + { function_body with free_variables; free_symbols; body; } + in + { function_decl with function_body = Some new_function_body } + +let make_closure_map input = + let map = ref Closure_id.Map.empty in + let add_set_of_closures _ (function_decls : function_declarations) = + Variable.Map.iter (fun var _ -> + let closure_id = Closure_id.wrap var in + map := Closure_id.Map.add closure_id function_decls !map) + function_decls.funs + in + Set_of_closures_id.Map.iter add_set_of_closures input; + !map diff --git a/middle_end/flambda/simple_value_approx.mli b/middle_end/flambda/simple_value_approx.mli new file mode 100644 index 0000000000..dd38652f5b --- /dev/null +++ b/middle_end/flambda/simple_value_approx.mli @@ -0,0 +1,501 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(** Simple approximations to the runtime results of computations. + This pass is designed for speed rather than accuracy; the performance + is important since it is used heavily during inlining. *) + +type 'a boxed_int = + | Int32 : int32 boxed_int + | Int64 : int64 boxed_int + | Nativeint : nativeint boxed_int + +type value_string = { + contents : string option; (* [None] if unknown or mutable *) + size : int; +} + +type unresolved_value = + | Set_of_closures_id of Set_of_closures_id.t + | Symbol of Symbol.t + +type unknown_because_of = + | Unresolved_value of unresolved_value + | Other + +(** A value of type [t] corresponds to an "approximation" of the result of + a computation in the program being compiled. That is to say, it + represents what knowledge we have about such a result at compile time. + The simplification pass exploits this information to partially evaluate + computations. + + At a high level, an approximation for a value [v] has three parts: + - the "description" (for example, "the constant integer 42"); + - an optional variable; + - an optional symbol or symbol field. + If the variable (resp. symbol) is present then that variable (resp. + symbol) may be used to obtain the value [v]. + + The exact semantics of the variable and symbol fields follows. + + Approximations are deduced at particular points in an expression tree, + but may subsequently be propagated to other locations. + + At the point at which an approximation is built for some value [v], we can + construct a set of variables (call the set [S]) that are known to alias the + same value [v]. Each member of [S] will have the same or a more precise + [descr] field in its approximation relative to the approximation for [v]. + (An increase in precision may currently be introduced for pattern + matches.) If [S] is non-empty then it is guaranteed that there is a + unique member of [S] that was declared in a scope further out ("earlier") + than all other members of [S]. If such a member exists then it is + recorded in the [var] field. Otherwise [var] is [None]. + + Analogous to the construction of the set [S], we can construct a set [T] + consisting of all symbols that are known to alias the value whose + approximation is being constructed. If [T] is non-empty then the + [symbol] field is set to some member of [T]; it does not matter which + one. (There is no notion of scope for symbols.) + + Note about mutable blocks: + + Mutable blocks are always represented by [Value_unknown] or + [Value_bottom]. Any other approximation could leave the door open to + a miscompilation. Such bad scenarios are most likely a user using + [Obj.magic] or [Obj.set_field] in an inappropriate situation. + Such a situation might be: + [let x = (1, 1) in + Obj.set_field (Obj.repr x) 0 (Obj.repr 2); + assert(fst x = 2)] + The user would probably expect the assertion to be true, but the + compiler could in fact propagate the value of [x] across the + [Obj.set_field]. + + Insisting that mutable blocks have [Value_unknown] or [Value_bottom] + approximations certainly won't always prevent this kind of error, but + should help catch many of them. + + It is possible that there may be some false positives, with correct + but unreachable code causing this check to fail. However the likelihood + of this seems sufficiently low, especially compared to the advantages + gained by performing the check, that we include it. + + An example of a pattern that might trigger a false positive is: + [type a = { a : int } + type b = { mutable b : int } + type _ t = + | A : a t + | B : b t + let f (type x) (v:x t) (r:x) = + match v with + | A -> r.a + | B -> r.b <- 2; 3 + + let v = + let r = + ref A in + r := A; (* Some pattern that the compiler can't understand *) + f !r { a = 1 }] + When inlining [f], the B branch is unreachable, yet the compiler + cannot prove it and must therefore keep it. +*) +type t = private { + descr : descr; + var : Variable.t option; + symbol : (Symbol.t * int option) option; +} + +and descr = private + | Value_block of Tag.t * t array + | Value_int of int + | Value_char of char + | Value_constptr of int + | Value_float of float option + | Value_boxed_int : 'a boxed_int * 'a -> descr + | Value_set_of_closures of value_set_of_closures + | Value_closure of value_closure + | Value_string of value_string + | Value_float_array of value_float_array + | Value_unknown of unknown_because_of + | Value_bottom + | Value_extern of Export_id.t + | Value_symbol of Symbol.t + | Value_unresolved of unresolved_value + (* No description was found for this value *) + +and value_closure = { + set_of_closures : t; + closure_id : Closure_id.t; +} + +and function_declarations = private { + is_classic_mode: bool; + set_of_closures_id : Set_of_closures_id.t; + set_of_closures_origin : Set_of_closures_origin.t; + funs : function_declaration Variable.Map.t; +} + +and function_body = private { + free_variables : Variable.Set.t; + free_symbols : Symbol.Set.t; + stub : bool; + dbg : Debuginfo.t; + inline : Lambda.inline_attribute; + specialise : Lambda.specialise_attribute; + is_a_functor : bool; + body : Flambda.t; +} + +and function_declaration = private { + closure_origin : Closure_origin.t; + params : Parameter.t list; + function_body : function_body option; +} + + +(* CR-soon mshinwell: add support for the approximations of the results, so we + can do all of the tricky higher-order cases. *) +(* when [is_classic_mode] is [false], functions in [function_declarations] + are guaranteed to have function bodies (ie: + [function_declaration.function_body] will be of the [Some] variant). + + When it [is_classic_mode] is [true], however, no guarantees about the + function_bodies are given. +*) +and value_set_of_closures = private { + function_decls : function_declarations; + bound_vars : t Var_within_closure.Map.t; + free_vars : Flambda.specialised_to Variable.Map.t; + invariant_params : Variable.Set.t Variable.Map.t Lazy.t; + recursive : Variable.Set.t Lazy.t; + size : int option Variable.Map.t Lazy.t; + (** For functions that are very likely to be inlined, the size of the + function's body. *) + specialised_args : Flambda.specialised_to Variable.Map.t; + (* Any freshening that has been applied to [function_decls]. *) + freshening : Freshening.Project_var.t; + direct_call_surrogates : Closure_id.t Closure_id.Map.t; +} + +and value_float_array_contents = + | Contents of t array + | Unknown_or_mutable + +and value_float_array = { + contents : value_float_array_contents; + size : int; +} + +(** Extraction of the description of approximation(s). *) +val descr : t -> descr +val descrs : t list -> descr list + +(** Pretty-printing of approximations to a formatter. *) +val print : Format.formatter -> t -> unit +val print_descr : Format.formatter -> descr -> unit +val print_value_set_of_closures + : Format.formatter + -> value_set_of_closures + -> unit +val print_function_declarations + : Format.formatter + -> function_declarations + -> unit + +val function_declarations_approx + : keep_body:(Variable.t -> Flambda.function_declaration -> bool) + -> Flambda.function_declarations + -> function_declarations + +val create_value_set_of_closures + : function_decls:function_declarations + -> bound_vars:t Var_within_closure.Map.t + -> free_vars:Flambda.specialised_to Variable.Map.t + -> invariant_params:Variable.Set.t Variable.Map.t lazy_t + -> recursive:Variable.Set.t Lazy.t + -> specialised_args:Flambda.specialised_to Variable.Map.t + -> freshening:Freshening.Project_var.t + -> direct_call_surrogates:Closure_id.t Closure_id.Map.t + -> value_set_of_closures + +val update_freshening_of_value_set_of_closures + : value_set_of_closures + -> freshening:Freshening.Project_var.t + -> value_set_of_closures + +(** Basic construction of approximations. *) +val value_unknown : unknown_because_of -> t +val value_int : int -> t +val value_char : char -> t +val value_float : float -> t +val value_any_float : t +val value_mutable_float_array : size:int -> t +val value_immutable_float_array : t array -> t +val value_string : int -> string option -> t +val value_boxed_int : 'i boxed_int -> 'i -> t +val value_constptr : int -> t +val value_block : Tag.t -> t array -> t +val value_extern : Export_id.t -> t +val value_symbol : Symbol.t -> t +val value_bottom : t +val value_unresolved : unresolved_value -> t + +(** Construct a closure approximation given the approximation of the + corresponding set of closures and the closure ID of the closure to + be projected from such set. [closure_var] and/or [set_of_closures_var] + may be specified to augment the approximation with variables that may + be used to access the closure value itself, so long as they are in + scope at the proposed point of use. *) +val value_closure + : ?closure_var:Variable.t + -> ?set_of_closures_var:Variable.t + -> ?set_of_closures_symbol:Symbol.t + -> value_set_of_closures + -> Closure_id.t + -> t + +(** Construct a set of closures approximation. [set_of_closures_var] is as for + the parameter of the same name in [value_closure], above. *) +val value_set_of_closures + : ?set_of_closures_var:Variable.t + -> value_set_of_closures + -> t + +(** Take the given constant and produce an appropriate approximation for it + together with an Flambda expression representing it. *) +val make_const_int : int -> Flambda.t * t +val make_const_char : char -> Flambda.t * t +val make_const_ptr : int -> Flambda.t * t +val make_const_bool : bool -> Flambda.t * t +val make_const_float : float -> Flambda.t * t +val make_const_boxed_int : 'i boxed_int -> 'i -> Flambda.t * t + +val make_const_int_named : int -> Flambda.named * t +val make_const_char_named : char -> Flambda.named * t +val make_const_ptr_named : int -> Flambda.named * t +val make_const_bool_named : bool -> Flambda.named * t +val make_const_float_named : float -> Flambda.named * t +val make_const_boxed_int_named : 'i boxed_int -> 'i -> Flambda.named * t + +(** Augment an approximation with a given variable (see comment above). + If the approximation was already augmented with a variable, the one + passed to this function replaces it within the approximation. *) +val augment_with_variable : t -> Variable.t -> t + +(** Like [augment_with_variable], but for symbol information. *) +val augment_with_symbol : t -> Symbol.t -> t + +(** Like [augment_with_symbol], but for symbol field information. *) +val augment_with_symbol_field : t -> Symbol.t -> int -> t + +(** Replace the description within an approximation. *) +val replace_description : t -> descr -> t + +(** Improve the description by taking the kind into account *) +val augment_with_kind : t -> Lambda.value_kind -> t + +(** Improve the kind by taking the description into account *) +val augment_kind_with_approx : t -> Lambda.value_kind -> Lambda.value_kind + +val equal_boxed_int : 'a boxed_int -> 'a -> 'b boxed_int -> 'b -> bool + +(* CR-soon mshinwell for pchambart: Add comment describing semantics. (Maybe + we should move the comment from the .ml file into here.) *) +val meet : really_import_approx:(t -> t) -> t -> t -> t + +(** An approximation is "known" iff it is not [Value_unknown]. *) +val known : t -> bool + +(** An approximation is "useful" iff it is neither unknown nor bottom. *) +val useful : t -> bool + +(** Whether all approximations in the given list do *not* satisfy [useful]. *) +val all_not_useful : t list -> bool + +(** Whether to warn on attempts to mutate a value. + It must have been resolved (it cannot be [Value_extern] or + [Value_symbol]). (See comment above for further explanation.) *) +val warn_on_mutation : t -> bool + +type simplification_summary = + | Nothing_done + | Replaced_term + +type simplification_result = Flambda.t * simplification_summary * t +type simplification_result_named = Flambda.named * simplification_summary * t + +(** Given an expression and its approximation, attempt to simplify the + expression to a constant (with associated approximation), taking into + account whether the expression has any side effects. *) +val simplify : t -> Flambda.t -> simplification_result + +(** As for [simplify], but also enables us to simplify based on equalities + between variables. The caller must provide a function that tells us + whether, if we simplify to a given variable, the value of that variable + will be accessible in the current environment. *) +val simplify_using_env + : t + -> is_present_in_env:(Variable.t -> bool) + -> Flambda.t + -> simplification_result + +val simplify_named : t -> Flambda.named -> simplification_result_named + +val simplify_named_using_env + : t + -> is_present_in_env:(Variable.t -> bool) + -> Flambda.named + -> simplification_result_named + +(** If the given approximation identifies another variable and + [is_present_in_env] deems it to be in scope, return that variable (wrapped + in a [Some]), otherwise return [None]. *) +val simplify_var_to_var_using_env + : t + -> is_present_in_env:(Variable.t -> bool) + -> Variable.t option + +val simplify_var : t -> (Flambda.named * t) option + +type get_field_result = + | Ok of t + | Unreachable + +(** Given the approximation [t] of a value, expected to correspond to a block + (in the [Pmakeblock] sense of the word), and a field index then return + an appropriate approximation for that field of the block (or + [Unreachable] if the code with the approximation [t] is unreachable). + N.B. Not all cases of unreachable code are returned as [Unreachable]. +*) +val get_field : t -> field_index:int -> get_field_result + +type checked_approx_for_block = + | Wrong + | Ok of Tag.t * t array + +(** Try to prove that a value with the given approximation may be used + as a block. *) +val check_approx_for_block : t -> checked_approx_for_block + +(** Find the approximation for a bound variable in a set-of-closures + approximation. A fatal error is produced if the variable is not bound in + the given approximation. *) +val approx_for_bound_var : value_set_of_closures -> Var_within_closure.t -> t + +(** Given a set-of-closures approximation and a closure ID, apply any + freshening specified by the approximation to the closure ID, and return + the resulting ID. Causes a fatal error if the resulting closure ID does + not correspond to any function declaration in the approximation. *) +val freshen_and_check_closure_id + : value_set_of_closures + -> Closure_id.t + -> Closure_id.t + +type strict_checked_approx_for_set_of_closures = + | Wrong + | Ok of Variable.t option * value_set_of_closures + +val strict_check_approx_for_set_of_closures + : t + -> strict_checked_approx_for_set_of_closures + +type checked_approx_for_set_of_closures = + | Wrong + | Unresolved of unresolved_value + | Unknown + | Unknown_because_of_unresolved_value of unresolved_value + (* In the [Ok] case, there may not be a variable associated with the set of + closures; it might be out of scope. *) + | Ok of Variable.t option * value_set_of_closures + +(** Try to prove that a value with the given approximation may be used as a + set of closures. Values coming from external compilation units with + unresolved approximations are permitted. *) +val check_approx_for_set_of_closures : t -> checked_approx_for_set_of_closures + +type checked_approx_for_closure = + | Wrong + | Ok of value_closure * Variable.t option + * Symbol.t option * value_set_of_closures + +(** Try to prove that a value with the given approximation may be used as a + closure. Values coming from external compilation units with unresolved + approximations are not permitted. *) +(* CR-someday mshinwell: naming is inconsistent: this is as "strict" + as "strict_check_approx_for_set_of_closures" *) +val check_approx_for_closure : t -> checked_approx_for_closure + +type checked_approx_for_closure_allowing_unresolved = + | Wrong + | Unresolved of unresolved_value + | Unknown + | Unknown_because_of_unresolved_value of unresolved_value + | Ok of value_closure * Variable.t option + * Symbol.t option * value_set_of_closures + +(** As for [check_approx_for_closure], but values coming from external + compilation units with unresolved approximations are permitted. *) +val check_approx_for_closure_allowing_unresolved + : t + -> checked_approx_for_closure_allowing_unresolved + +(** Returns the value if it can be proved to be a constant float *) +val check_approx_for_float : t -> float option + +(** Returns the value if it can be proved to be a constant float array *) +val float_array_as_constant : value_float_array -> float list option + +(** Returns the value if it can be proved to be a constant string *) +val check_approx_for_string : t -> string option + +type switch_branch_selection = + | Cannot_be_taken + | Can_be_taken + | Must_be_taken + +(** Check that the branch is compatible with the approximation *) +val potentially_taken_const_switch_branch : t -> int -> switch_branch_selection +val potentially_taken_block_switch_branch : t -> int -> switch_branch_selection + +val function_arity : function_declaration -> int + +(** Create a set of function declarations based on another set of function + declarations. *) +val update_function_declarations + : function_declarations + -> funs:function_declaration Variable.Map.t + -> function_declarations + +val import_function_declarations_for_pack + : function_declarations + -> (Set_of_closures_id.t -> Set_of_closures_id.t) + -> (Set_of_closures_origin.t -> Set_of_closures_origin.t) + -> function_declarations + +val update_function_declaration_body + : function_declaration + -> (Flambda.t -> Flambda.t) + -> function_declaration + +(** Creates a map from closure IDs to function declarations by iterating over + all sets of closures in the given map. *) +val make_closure_map + : function_declarations Set_of_closures_id.Map.t + -> function_declarations Closure_id.Map.t + +val clear_function_bodies : function_declarations -> function_declarations diff --git a/middle_end/flambda/simplify_boxed_integer_ops.ml b/middle_end/flambda/simplify_boxed_integer_ops.ml new file mode 100644 index 0000000000..1f95a1ec2d --- /dev/null +++ b/middle_end/flambda/simplify_boxed_integer_ops.ml @@ -0,0 +1,116 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +module S = Simplify_common + +(* Simplification of operations on boxed integers (nativeint, Int32, Int64). *) +module Simplify_boxed_integer_operator (I : sig + type t + val kind : Lambda.boxed_integer + val zero : t + val add : t -> t -> t + val sub : t -> t -> t + val mul : t -> t -> t + val div : t -> t -> t + val rem : t -> t -> t + val logand : t -> t -> t + val logor : t -> t -> t + val logxor : t -> t -> t + val shift_left : t -> int -> t + val shift_right : t -> int -> t + val shift_right_logical : t -> int -> t + val to_int : t -> int + val to_int32 : t -> Int32.t + val to_int64 : t -> Int64.t + val neg : t -> t + val swap : t -> t + val compare : t -> t -> int +end) : Simplify_boxed_integer_ops_intf.S with type t := I.t = struct + module A = Simple_value_approx + module C = Inlining_cost + + let equal_kind = Lambda.equal_boxed_integer + + let simplify_unop (p : Clambda_primitives.primitive) + (kind : I.t A.boxed_int) expr (n : I.t) = + let eval op = S.const_boxed_int_expr expr kind (op n) in + let eval_conv kind op = S.const_boxed_int_expr expr kind (op n) in + let eval_unboxed op = S.const_int_expr expr (op n) in + match p with + | Pintofbint kind when equal_kind kind I.kind -> eval_unboxed I.to_int + | Pcvtbint (kind, Pint32) when equal_kind kind I.kind -> + eval_conv A.Int32 I.to_int32 + | Pcvtbint (kind, Pint64) when equal_kind kind I.kind -> + eval_conv A.Int64 I.to_int64 + | Pnegbint kind when equal_kind kind I.kind -> eval I.neg + | Pbbswap kind when equal_kind kind I.kind -> eval I.swap + | _ -> expr, A.value_unknown Other, C.Benefit.zero + + let simplify_binop (p : Clambda_primitives.primitive) + (kind : I.t A.boxed_int) expr (n1 : I.t) (n2 : I.t) = + let eval op = S.const_boxed_int_expr expr kind (op n1 n2) in + let non_zero n = (I.compare I.zero n) <> 0 in + match p with + | Paddbint kind when equal_kind kind I.kind -> eval I.add + | Psubbint kind when equal_kind kind I.kind -> eval I.sub + | Pmulbint kind when equal_kind kind I.kind -> eval I.mul + | Pdivbint {size=kind} when equal_kind kind I.kind && non_zero n2 -> + eval I.div + | Pmodbint {size=kind} when equal_kind kind I.kind && non_zero n2 -> + eval I.rem + | Pandbint kind when equal_kind kind I.kind -> eval I.logand + | Porbint kind when equal_kind kind I.kind -> eval I.logor + | Pxorbint kind when equal_kind kind I.kind -> eval I.logxor + | Pbintcomp (kind, c) when equal_kind kind I.kind -> + S.const_integer_comparison_expr expr c n1 n2 + | _ -> expr, A.value_unknown Other, C.Benefit.zero + + let simplify_binop_int (p : Clambda_primitives.primitive) + (kind : I.t A.boxed_int) expr (n1 : I.t) (n2 : int) ~size_int = + let eval op = S.const_boxed_int_expr expr kind (op n1 n2) in + let precond = 0 <= n2 && n2 < 8 * size_int in + match p with + | Plslbint kind when equal_kind kind I.kind && precond -> eval I.shift_left + | Plsrbint kind when equal_kind kind I.kind && precond -> + eval I.shift_right_logical + | Pasrbint kind when equal_kind kind I.kind && precond -> eval I.shift_right + | _ -> expr, A.value_unknown Other, C.Benefit.zero +end + +module Simplify_boxed_nativeint = Simplify_boxed_integer_operator (struct + include Nativeint + let to_int64 = Int64.of_nativeint + let swap = S.swapnative + let kind = Lambda.Pnativeint +end) + +module Simplify_boxed_int32 = Simplify_boxed_integer_operator (struct + include Int32 + let to_int32 i = i + let to_int64 = Int64.of_int32 + let swap = S.swap32 + let kind = Lambda.Pint32 +end) + +module Simplify_boxed_int64 = Simplify_boxed_integer_operator (struct + include Int64 + let to_int64 i = i + let swap = S.swap64 + let kind = Lambda.Pint64 +end) diff --git a/middle_end/flambda/simplify_boxed_integer_ops.mli b/middle_end/flambda/simplify_boxed_integer_ops.mli new file mode 100644 index 0000000000..f3461043a1 --- /dev/null +++ b/middle_end/flambda/simplify_boxed_integer_ops.mli @@ -0,0 +1,28 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(* Simplification of operations on boxed integers (nativeint, Int32, Int64). *) + +module Simplify_boxed_nativeint : Simplify_boxed_integer_ops_intf.S + with type t := Nativeint.t + +module Simplify_boxed_int32 : Simplify_boxed_integer_ops_intf.S + with type t := Int32.t + +module Simplify_boxed_int64 : Simplify_boxed_integer_ops_intf.S + with type t := Int64.t diff --git a/middle_end/flambda/simplify_boxed_integer_ops_intf.mli b/middle_end/flambda/simplify_boxed_integer_ops_intf.mli new file mode 100644 index 0000000000..f30987ae11 --- /dev/null +++ b/middle_end/flambda/simplify_boxed_integer_ops_intf.mli @@ -0,0 +1,45 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +module type S = sig + type t + + val simplify_unop + : Clambda_primitives.primitive + -> t Simple_value_approx.boxed_int + -> Flambda.named + -> t + -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t + + val simplify_binop + : Clambda_primitives.primitive + -> t Simple_value_approx.boxed_int + -> Flambda.named + -> t + -> t + -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t + + val simplify_binop_int + : Clambda_primitives.primitive + -> t Simple_value_approx.boxed_int + -> Flambda.named + -> t + -> int + -> size_int:int + -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t +end diff --git a/middle_end/flambda/simplify_common.ml b/middle_end/flambda/simplify_common.ml new file mode 100644 index 0000000000..fcbbcfbcba --- /dev/null +++ b/middle_end/flambda/simplify_common.ml @@ -0,0 +1,86 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +module A = Simple_value_approx +module C = Inlining_cost + +external swap16 : int -> int = "%bswap16" +external swap32 : int32 -> int32 = "%bswap_int32" +external swap64 : int64 -> int64 = "%bswap_int64" +external swapnative : nativeint -> nativeint = "%bswap_native" + +let const_int_expr expr n = + if Effect_analysis.no_effects_named expr then + let (new_expr, approx) = A.make_const_int_named n in + new_expr, approx, C.Benefit.remove_code_named expr C.Benefit.zero + else expr, A.value_int n, C.Benefit.zero +let const_char_expr expr c = + if Effect_analysis.no_effects_named expr then + let (new_expr, approx) = A.make_const_char_named c in + new_expr, approx, C.Benefit.remove_code_named expr C.Benefit.zero + else expr, A.value_char c, C.Benefit.zero +let const_ptr_expr expr n = + if Effect_analysis.no_effects_named expr then + let (new_expr, approx) = A.make_const_ptr_named n in + new_expr, approx, C.Benefit.remove_code_named expr C.Benefit.zero + else expr, A.value_constptr n, C.Benefit.zero +let const_bool_expr expr b = + const_int_expr expr (if b then 1 else 0) +let const_float_expr expr f = + if Effect_analysis.no_effects_named expr then + let (new_expr, approx) = A.make_const_float_named f in + new_expr, approx, C.Benefit.remove_code_named expr C.Benefit.zero + else expr, A.value_float f, C.Benefit.zero +let const_boxed_int_expr expr t i = + if Effect_analysis.no_effects_named expr then + let (new_expr, approx) = A.make_const_boxed_int_named t i in + new_expr, approx, C.Benefit.remove_code_named expr C.Benefit.zero + else expr, A.value_boxed_int t i, C.Benefit.zero + +let const_integer_comparison_expr expr (cmp : Lambda.integer_comparison) x y = + (* Using the [Stdlib] comparison functions here in the compiler + coincides with the definitions of such functions in the code + compiled by the user, and is thus correct. *) + let open! Stdlib in + const_bool_expr expr + (match cmp with + | Ceq -> x = y + | Cne -> x <> y + | Clt -> x < y + | Cgt -> x > y + | Cle -> x <= y + | Cge -> x >= y) + +let const_float_comparison_expr expr (cmp : Lambda.float_comparison) x y = + (* Using the [Stdlib] comparison functions here in the compiler + coincides with the definitions of such functions in the code + compiled by the user, and is thus correct. *) + let open! Stdlib in + const_bool_expr expr + (match cmp with + | CFeq -> x = y + | CFneq -> not (x = y) + | CFlt -> x < y + | CFnlt -> not (x < y) + | CFgt -> x > y + | CFngt -> not (x > y) + | CFle -> x <= y + | CFnle -> not (x <= y) + | CFge -> x >= y + | CFnge -> not (x >= y)) diff --git a/middle_end/flambda/simplify_common.mli b/middle_end/flambda/simplify_common.mli new file mode 100644 index 0000000000..c667bfffe5 --- /dev/null +++ b/middle_end/flambda/simplify_common.mli @@ -0,0 +1,80 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(** [const_*_expr expr v annot], where the expression [expr] is known to + evaluate to the value [v], attempt to produce a more simple expression + together with its approximation and the benefit gained by replacing [expr] + with this new expression. This simplification is only performed if [expr] + is known to have no side effects. Otherwise, [expr] itself is returned, + with an appropriate approximation but zero benefit. + + [const_boxed_int_expr] takes an additional argument specifying the kind of + boxed integer to which the given expression evaluates. +*) + +val const_int_expr + : Flambda.named + -> int + -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t + +val const_char_expr + : Flambda.named + -> char + -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t + +val const_bool_expr + : Flambda.named + -> bool + -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t + +val const_ptr_expr + : Flambda.named + -> int + -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t + +val const_float_expr + : Flambda.named + -> float + -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t + +val const_boxed_int_expr + : Flambda.named + -> 'a Simple_value_approx.boxed_int + -> 'a + -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t + +val const_integer_comparison_expr + : Flambda.named + -> Lambda.integer_comparison + -> 'a + -> 'a + -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t + +val const_float_comparison_expr + : Flambda.named + -> Lambda.float_comparison + -> float + -> float + -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t + +(** Functions for transposing the order of bytes within words of various + sizes. *) +val swap16 : int -> int +val swap32 : int32 -> int32 +val swap64 : int64 -> int64 +val swapnative : nativeint -> nativeint diff --git a/middle_end/flambda/simplify_primitives.ml b/middle_end/flambda/simplify_primitives.ml new file mode 100644 index 0000000000..349d2f40ba --- /dev/null +++ b/middle_end/flambda/simplify_primitives.ml @@ -0,0 +1,302 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +module A = Simple_value_approx +module C = Inlining_cost +module I = Simplify_boxed_integer_ops +module S = Simplify_common + +let phys_equal (approxs:A.t list) = + match approxs with + | [] | [_] | _ :: _ :: _ :: _ -> + Misc.fatal_error "wrong number of arguments for equality" + | [a1; a2] -> + (* N.B. The following would be incorrect if the variables are not + bound in the environment: + match a1.var, a2.var with + | Some v1, Some v2 when Variable.equal v1 v2 -> true + | _ -> ... + *) + match a1.symbol, a2.symbol with + | Some (s1, None), Some (s2, None) -> Symbol.equal s1 s2 + | Some (s1, Some f1), Some (s2, Some f2) -> Symbol.equal s1 s2 && f1 = f2 + | _ -> false + +let is_known_to_be_some_kind_of_int (arg:A.descr) = + match arg with + | Value_int _ | Value_char _ | Value_constptr _ -> true + | Value_block (_, _) | Value_float _ | Value_set_of_closures _ + | Value_closure _ | Value_string _ | Value_float_array _ + | A.Value_boxed_int _ | Value_unknown _ | Value_extern _ + | Value_symbol _ | Value_unresolved _ | Value_bottom -> false + +let is_known_to_be_some_kind_of_block (arg:A.descr) = + match arg with + | Value_block _ | Value_float _ | Value_float_array _ | A.Value_boxed_int _ + | Value_closure _ | Value_string _ -> true + | Value_set_of_closures _ | Value_int _ | Value_char _ | Value_constptr _ + | Value_unknown _ | Value_extern _ | Value_symbol _ + | Value_unresolved _ | Value_bottom -> false + +let rec structurally_different (arg1:A.t) (arg2:A.t) = + match arg1.descr, arg2.descr with + | (Value_int n1 | Value_constptr n1), (Value_int n2 | Value_constptr n2) + when n1 <> n2 -> + true + | Value_block (tag1, fields1), Value_block (tag2, fields2) -> + not (Tag.equal tag1 tag2) + || (Array.length fields1 <> Array.length fields2) + || Misc.Stdlib.Array.exists2 structurally_different fields1 fields2 + | descr1, descr2 -> + (* This is not very precise as this won't allow to distinguish + blocks from strings for instance. This can be improved if it + is deemed valuable. *) + (is_known_to_be_some_kind_of_int descr1 + && is_known_to_be_some_kind_of_block descr2) + || (is_known_to_be_some_kind_of_block descr1 + && is_known_to_be_some_kind_of_int descr2) + +let phys_different (approxs:A.t list) = + match approxs with + | [] | [_] | _ :: _ :: _ :: _ -> + Misc.fatal_error "wrong number of arguments for equality" + | [a1; a2] -> + structurally_different a1 a2 + +let is_empty = function + | [] -> true + | _ :: _ -> false + +let is_pisint = function + | Clambda_primitives.Pisint -> true + | _ -> false + +let is_pstring_length = function + | Clambda_primitives.Pstringlength -> true + | _ -> false + +let is_pbytes_length = function + | Clambda_primitives.Pbyteslength -> true + | _ -> false + +let is_pstringrefs = function + | Clambda_primitives.Pstringrefs -> true + | _ -> false + +let is_pbytesrefs = function + | Clambda_primitives.Pbytesrefs -> true + | _ -> false + +let primitive (p : Clambda_primitives.primitive) (args, approxs) + expr dbg ~size_int + : Flambda.named * A.t * Inlining_cost.Benefit.t = + let fpc = !Clflags.float_const_prop in + match p with + | Pmakeblock(tag_int, Asttypes.Immutable, shape) -> + let tag = Tag.create_exn tag_int in + let shape = match shape with + | None -> List.map (fun _ -> Lambda.Pgenval) args + | Some shape -> shape + in + let approxs = List.map2 A.augment_with_kind approxs shape in + let shape = List.map2 A.augment_kind_with_approx approxs shape in + Prim (Pmakeblock(tag_int, Asttypes.Immutable, Some shape), args, dbg), + A.value_block tag (Array.of_list approxs), C.Benefit.zero + | Praise _ -> + expr, A.value_bottom, C.Benefit.zero + | Pmakearray(_, _) when is_empty approxs -> + Prim (Pmakeblock(0, Asttypes.Immutable, Some []), [], dbg), + A.value_block (Tag.create_exn 0) [||], C.Benefit.zero + | Pmakearray (Pfloatarray, Mutable) -> + let approx = + A.value_mutable_float_array ~size:(List.length args) + in + expr, approx, C.Benefit.zero + | Pmakearray (Pfloatarray, Immutable) -> + let approx = + A.value_immutable_float_array (Array.of_list approxs) + in + expr, approx, C.Benefit.zero + | Pintcomp Ceq when phys_equal approxs -> + S.const_bool_expr expr true + | Pintcomp Cne when phys_equal approxs -> + S.const_bool_expr expr false + (* N.B. Having [not (phys_equal approxs)] would not on its own tell us + anything about whether the two values concerned are unequal. To judge + that, it would be necessary to prove that the approximations are + different, which would in turn entail them being completely known. + + It may seem that in the case where we have two approximations each + annotated with a symbol that we should be able to judge inequality + even if part of the approximation description(s) are unknown. This is + unfortunately not the case. Here is an example: + + let a = f 1 + let b = f 1 + let c = a, a + let d = a, a + + If [Share_constants] is run before [f] is completely inlined (assuming + [f] always generates the same result; effects of [f] aren't in fact + relevant) then [c] and [d] will not be shared. However if [f] is + inlined later, [a] and [b] could be shared and thus [c] and [d] could + be too. As such, any intermediate non-aliasing judgement would be + invalid. *) + | Pintcomp Ceq when phys_different approxs -> + S.const_bool_expr expr false + | Pintcomp Cne when phys_different approxs -> + S.const_bool_expr expr true + (* If two values are structurally different we are certain they can never + be shared*) + | _ -> + match A.descrs approxs with + | [Value_int x] -> + begin match p with + | Pnot -> S.const_bool_expr expr (x = 0) + | Pnegint -> S.const_int_expr expr (-x) + | Pbswap16 -> S.const_int_expr expr (S.swap16 x) + | Poffsetint y -> S.const_int_expr expr (x + y) + | Pfloatofint when fpc -> S.const_float_expr expr (float_of_int x) + | Pbintofint Pnativeint -> + S.const_boxed_int_expr expr Nativeint (Nativeint.of_int x) + | Pbintofint Pint32 -> S.const_boxed_int_expr expr Int32 (Int32.of_int x) + | Pbintofint Pint64 -> S.const_boxed_int_expr expr Int64 (Int64.of_int x) + | _ -> expr, A.value_unknown Other, C.Benefit.zero + end + | [(Value_int x | Value_constptr x); (Value_int y | Value_constptr y)] -> + let shift_precond = 0 <= y && y < 8 * size_int in + begin match p with + | Paddint -> S.const_int_expr expr (x + y) + | Psubint -> S.const_int_expr expr (x - y) + | Pmulint -> S.const_int_expr expr (x * y) + | Pdivint _ when y <> 0 -> S.const_int_expr expr (x / y) + | Pmodint _ when y <> 0 -> S.const_int_expr expr (x mod y) + | Pandint -> S.const_int_expr expr (x land y) + | Porint -> S.const_int_expr expr (x lor y) + | Pxorint -> S.const_int_expr expr (x lxor y) + | Plslint when shift_precond -> S.const_int_expr expr (x lsl y) + | Plsrint when shift_precond -> S.const_int_expr expr (x lsr y) + | Pasrint when shift_precond -> S.const_int_expr expr (x asr y) + | Pintcomp cmp -> S.const_integer_comparison_expr expr cmp x y + | Pisout -> S.const_bool_expr expr (y > x || y < 0) + | _ -> expr, A.value_unknown Other, C.Benefit.zero + end + | [Value_char x; Value_char y] -> + begin match p with + | Pintcomp cmp -> S.const_integer_comparison_expr expr cmp x y + | _ -> expr, A.value_unknown Other, C.Benefit.zero + end + | [Value_constptr x] -> + begin match p with + (* [Pidentity] should probably never appear, but is here for + completeness. *) + | Pnot -> S.const_bool_expr expr (x = 0) + | Pisint -> S.const_bool_expr expr true + | Poffsetint y -> S.const_ptr_expr expr (x + y) + | _ -> expr, A.value_unknown Other, C.Benefit.zero + end + | [Value_float (Some x)] when fpc -> + begin match p with + | Pintoffloat -> S.const_int_expr expr (int_of_float x) + | Pnegfloat -> S.const_float_expr expr (-. x) + | Pabsfloat -> S.const_float_expr expr (abs_float x) + | _ -> expr, A.value_unknown Other, C.Benefit.zero + end + | [Value_float (Some n1); Value_float (Some n2)] when fpc -> + begin match p with + | Paddfloat -> S.const_float_expr expr (n1 +. n2) + | Psubfloat -> S.const_float_expr expr (n1 -. n2) + | Pmulfloat -> S.const_float_expr expr (n1 *. n2) + | Pdivfloat -> S.const_float_expr expr (n1 /. n2) + | Pfloatcomp c -> S.const_float_comparison_expr expr c n1 n2 + | _ -> expr, A.value_unknown Other, C.Benefit.zero + end + | [A.Value_boxed_int(A.Nativeint, n)] -> + I.Simplify_boxed_nativeint.simplify_unop p Nativeint expr n + | [A.Value_boxed_int(A.Int32, n)] -> + I.Simplify_boxed_int32.simplify_unop p Int32 expr n + | [A.Value_boxed_int(A.Int64, n)] -> + I.Simplify_boxed_int64.simplify_unop p Int64 expr n + | [A.Value_boxed_int(A.Nativeint, n1); + A.Value_boxed_int(A.Nativeint, n2)] -> + I.Simplify_boxed_nativeint.simplify_binop p Nativeint expr n1 n2 + | [A.Value_boxed_int(A.Int32, n1); A.Value_boxed_int(A.Int32, n2)] -> + I.Simplify_boxed_int32.simplify_binop p Int32 expr n1 n2 + | [A.Value_boxed_int(A.Int64, n1); A.Value_boxed_int(A.Int64, n2)] -> + I.Simplify_boxed_int64.simplify_binop p Int64 expr n1 n2 + | [A.Value_boxed_int(A.Nativeint, n1); Value_int n2] -> + I.Simplify_boxed_nativeint.simplify_binop_int p Nativeint expr n1 n2 + ~size_int + | [A.Value_boxed_int(A.Int32, n1); Value_int n2] -> + I.Simplify_boxed_int32.simplify_binop_int p Int32 expr n1 n2 + ~size_int + | [A.Value_boxed_int(A.Int64, n1); Value_int n2] -> + I.Simplify_boxed_int64.simplify_binop_int p Int64 expr n1 n2 + ~size_int + | [Value_block _] when is_pisint p -> + S.const_bool_expr expr false + | [Value_string { size }] + when (is_pstring_length p || is_pbytes_length p) -> + S.const_int_expr expr size + | [Value_string { size; contents = Some s }; + (Value_int x | Value_constptr x)] when x >= 0 && x < size -> + begin match p with + | Pstringrefu + | Pstringrefs + | Pbytesrefu + | Pbytesrefs -> + S.const_char_expr (Prim(Pstringrefu, args, dbg)) s.[x] + | _ -> expr, A.value_unknown Other, C.Benefit.zero + end + | [Value_string { size; contents = None }; + (Value_int x | Value_constptr x)] + when x >= 0 && x < size && is_pstringrefs p -> + Flambda.Prim (Pstringrefu, args, dbg), + A.value_unknown Other, + (* we improved it, but there is no way to account for that: *) + C.Benefit.zero + | [Value_string { size; contents = None }; + (Value_int x | Value_constptr x)] + when x >= 0 && x < size && is_pbytesrefs p -> + Flambda.Prim (Pbytesrefu, args, dbg), + A.value_unknown Other, + (* we improved it, but there is no way to account for that: *) + C.Benefit.zero + + | [Value_float_array { size; contents }] -> + begin match p with + | Parraylength _ -> S.const_int_expr expr size + | Pfloatfield i -> + begin match contents with + | A.Contents a when i >= 0 && i < size -> + begin match A.check_approx_for_float a.(i) with + | None -> expr, a.(i), C.Benefit.zero + | Some v -> S.const_float_expr expr v + end + | Contents _ | Unknown_or_mutable -> + expr, A.value_unknown Other, C.Benefit.zero + end + | _ -> expr, A.value_unknown Other, C.Benefit.zero + end + | _ -> + match Semantics_of_primitives.return_type_of_primitive p with + | Float -> + expr, A.value_any_float, C.Benefit.zero + | Other -> + expr, A.value_unknown Other, C.Benefit.zero diff --git a/middle_end/flambda/simplify_primitives.mli b/middle_end/flambda/simplify_primitives.mli new file mode 100644 index 0000000000..a6b6330c03 --- /dev/null +++ b/middle_end/flambda/simplify_primitives.mli @@ -0,0 +1,27 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(** Simplifies an application of a primitive based on approximation + information. *) +val primitive + : Clambda_primitives.primitive + -> (Variable.t list * (Simple_value_approx.t list)) + -> Flambda.named + -> Debuginfo.t + -> size_int:int + -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t diff --git a/middle_end/flambda/traverse_for_exported_symbols.ml b/middle_end/flambda/traverse_for_exported_symbols.ml new file mode 100644 index 0000000000..1b7ce57f54 --- /dev/null +++ b/middle_end/flambda/traverse_for_exported_symbols.ml @@ -0,0 +1,267 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fu Yong Quah, Jane Street Europe *) +(* *) +(* Copyright 2017 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-4-9-30-40-41-42"] + +module A = Simple_value_approx + +type queue_elem = + | Q_symbol of Symbol.t + | Q_set_of_closures_id of Set_of_closures_id.t + | Q_export_id of Export_id.t + +type symbols_to_export = + { symbols : Symbol.Set.t; + export_ids : Export_id.Set.t; + set_of_closure_ids : Set_of_closures_id.Set.t; + set_of_closure_ids_keep_declaration : Set_of_closures_id.Set.t; + relevant_imported_closure_ids : Closure_id.Set.t; + relevant_local_closure_ids : Closure_id.Set.t; + relevant_imported_vars_within_closure : Var_within_closure.Set.t; + relevant_local_vars_within_closure : Var_within_closure.Set.t; + } + +let traverse + ~(sets_of_closures_map : + Flambda.set_of_closures Set_of_closures_id.Map.t) + ~(closure_id_to_set_of_closures_id : + Set_of_closures_id.t Closure_id.Map.t) + ~(function_declarations_map : + A.function_declarations Set_of_closures_id.Map.t) + ~(values : Export_info.descr Export_id.Map.t) + ~(symbol_id : Export_id.t Symbol.Map.t) + ~(root_symbol: Symbol.t) = + let relevant_set_of_closures_declaration_only = + ref Set_of_closures_id.Set.empty + in + let relevant_symbols = ref (Symbol.Set.singleton root_symbol) in + let relevant_set_of_closures = ref Set_of_closures_id.Set.empty in + let relevant_export_ids = ref Export_id.Set.empty in + let relevant_imported_closure_ids = ref Closure_id.Set.empty in + let relevant_local_closure_ids = ref Closure_id.Set.empty in + let relevant_imported_vars_within_closure = + ref Var_within_closure.Set.empty + in + let relevant_local_vars_with_closure = ref Var_within_closure.Set.empty in + let (queue : queue_elem Queue.t) = Queue.create () in + let conditionally_add_symbol symbol = + if not (Symbol.Set.mem symbol !relevant_symbols) then begin + relevant_symbols := + Symbol.Set.add symbol !relevant_symbols; + Queue.add (Q_symbol symbol) queue + end + in + let conditionally_add_set_of_closures_id set_of_closures_id = + if not (Set_of_closures_id.Set.mem + set_of_closures_id !relevant_set_of_closures) then begin + relevant_set_of_closures := + Set_of_closures_id.Set.add set_of_closures_id + !relevant_set_of_closures; + Queue.add (Q_set_of_closures_id set_of_closures_id) queue + end + in + let conditionally_add_export_id export_id = + if not (Export_id.Set.mem export_id !relevant_export_ids) then begin + relevant_export_ids := + Export_id.Set.add export_id !relevant_export_ids; + Queue.add (Q_export_id export_id) queue + end + in + let process_approx (approx : Export_info.approx) = + match approx with + | Value_id export_id -> + conditionally_add_export_id export_id + | Value_symbol symbol -> + conditionally_add_symbol symbol + | Value_unknown -> () + in + let process_value_set_of_closures + (soc : Export_info.value_set_of_closures) = + conditionally_add_set_of_closures_id soc.set_of_closures_id; + Var_within_closure.Map.iter + (fun _ value -> process_approx value) soc.bound_vars; + Closure_id.Map.iter + (fun _ value -> process_approx value) soc.results; + begin match soc.aliased_symbol with + | None -> () + | Some symbol -> conditionally_add_symbol symbol + end + in + let process_function_body (function_body : A.function_body) = + Flambda_iterators.iter + (fun (term : Flambda.t) -> + match term with + | Flambda.Apply { kind ; _ } -> + begin match kind with + | Indirect -> () + | Direct closure_id -> + begin match + Closure_id.Map.find + closure_id + closure_id_to_set_of_closures_id + with + | exception Not_found -> + relevant_imported_closure_ids := + Closure_id.Set.add closure_id + !relevant_imported_closure_ids + | set_of_closures_id -> + relevant_local_closure_ids := + Closure_id.Set.add closure_id + !relevant_local_closure_ids; + conditionally_add_set_of_closures_id + set_of_closures_id + end + end + | _ -> ()) + (fun (named : Flambda.named) -> + let process_closure_id closure_id = + match + Closure_id.Map.find closure_id closure_id_to_set_of_closures_id + with + | exception Not_found -> + relevant_imported_closure_ids := + Closure_id.Set.add closure_id !relevant_imported_closure_ids + | set_of_closure_id -> + relevant_local_closure_ids := + Closure_id.Set.add closure_id !relevant_local_closure_ids; + relevant_set_of_closures_declaration_only := + Set_of_closures_id.Set.add + set_of_closure_id + !relevant_set_of_closures_declaration_only + in + match named with + | Symbol symbol + | Read_symbol_field (symbol, _) -> + conditionally_add_symbol symbol + | Set_of_closures soc -> + conditionally_add_set_of_closures_id + soc.function_decls.set_of_closures_id + | Project_closure { closure_id; _ } -> + process_closure_id closure_id + | Move_within_set_of_closures { start_from; move_to; _ } -> + process_closure_id start_from; + process_closure_id move_to + | Project_var { closure_id ; var; _ } -> + begin match + Closure_id.Map.find + closure_id closure_id_to_set_of_closures_id + with + | exception Not_found -> + relevant_imported_closure_ids := + Closure_id.Set.add closure_id + !relevant_imported_closure_ids; + relevant_imported_vars_within_closure := + Var_within_closure.Set.add var + !relevant_imported_vars_within_closure + | set_of_closure_id -> + relevant_local_closure_ids := + Closure_id.Set.add closure_id + !relevant_local_closure_ids; + relevant_local_vars_with_closure := + Var_within_closure.Set.add var + !relevant_local_vars_with_closure; + relevant_set_of_closures_declaration_only := + Set_of_closures_id.Set.add + set_of_closure_id + !relevant_set_of_closures_declaration_only + end + | Prim _ + | Expr _ + | Const _ + | Allocated_const _ + | Read_mutable _ -> ()) + function_body.body + in + let rec loop () = + if Queue.is_empty queue then + () + else begin + begin match Queue.pop queue with + | Q_export_id export_id -> + begin match Export_id.Map.find export_id values with + | exception Not_found -> () + | Value_block (_, approxes) -> + Array.iter process_approx approxes + | Value_closure value_closure -> + process_value_set_of_closures value_closure.set_of_closures + | Value_set_of_closures soc -> + process_value_set_of_closures soc + | _ -> () + end + | Q_symbol symbol -> + let compilation_unit = Symbol.compilation_unit symbol in + if Compilation_unit.is_current compilation_unit then begin + match Symbol.Map.find symbol symbol_id with + | exception Not_found -> + Misc.fatal_errorf "cannot find symbol's export id %a\n" + Symbol.print symbol + | export_id -> + conditionally_add_export_id export_id + end + | Q_set_of_closures_id set_of_closures_id -> + begin match + Set_of_closures_id.Map.find + set_of_closures_id function_declarations_map + with + | exception Not_found -> () + | function_declarations -> + Variable.Map.iter + (fun (_ : Variable.t) (fun_decl : A.function_declaration) -> + match fun_decl.function_body with + | None -> () + | Some function_body -> process_function_body function_body) + function_declarations.funs + end + end; + loop () + end + in + Queue.add (Q_symbol root_symbol) queue; + loop (); + + Closure_id.Map.iter (fun closure_id set_of_closure_id -> + if Set_of_closures_id.Set.mem + set_of_closure_id !relevant_set_of_closures + then begin + relevant_local_closure_ids := + Closure_id.Set.add closure_id !relevant_local_closure_ids + end) + closure_id_to_set_of_closures_id; + + Set_of_closures_id.Set.iter (fun set_of_closures_id -> + match + Set_of_closures_id.Map.find set_of_closures_id sets_of_closures_map + with + | exception Not_found -> () + | set_of_closures -> + Variable.Map.iter (fun var _ -> + relevant_local_vars_with_closure := + Var_within_closure.Set.add + (Var_within_closure.wrap var) + !relevant_local_vars_with_closure) + set_of_closures.free_vars) + !relevant_set_of_closures; + + { symbols = !relevant_symbols; + export_ids = !relevant_export_ids; + set_of_closure_ids = !relevant_set_of_closures; + set_of_closure_ids_keep_declaration = + !relevant_set_of_closures_declaration_only; + relevant_imported_closure_ids = !relevant_imported_closure_ids; + relevant_local_closure_ids = !relevant_local_closure_ids; + relevant_imported_vars_within_closure = + !relevant_imported_vars_within_closure; + relevant_local_vars_within_closure = + !relevant_local_vars_with_closure; + } diff --git a/middle_end/flambda/traverse_for_exported_symbols.mli b/middle_end/flambda/traverse_for_exported_symbols.mli new file mode 100644 index 0000000000..2825a38623 --- /dev/null +++ b/middle_end/flambda/traverse_for_exported_symbols.mli @@ -0,0 +1,41 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fu Yong Quah, Jane Street Europe *) +(* *) +(* Copyright 2017 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-4-9-30-40-41-42"] + +type symbols_to_export = + { symbols : Symbol.Set.t; + export_ids : Export_id.Set.t; + set_of_closure_ids : Set_of_closures_id.Set.t; + set_of_closure_ids_keep_declaration : Set_of_closures_id.Set.t; + relevant_imported_closure_ids : Closure_id.Set.t; + relevant_local_closure_ids : Closure_id.Set.t; + relevant_imported_vars_within_closure : Var_within_closure.Set.t; + relevant_local_vars_within_closure : Var_within_closure.Set.t; + } + +(** Computes the transitive closure in [Symbol.t], [Closure_id.t] and + [Set_of_closures_id.t] and determines which ones of those should be + exported (i.e: included in the cmx files). +**) +val traverse + : sets_of_closures_map: Flambda.set_of_closures Set_of_closures_id.Map.t + -> closure_id_to_set_of_closures_id: + Set_of_closures_id.t Closure_id.Map.t + -> function_declarations_map: + Simple_value_approx.function_declarations Set_of_closures_id.Map.t + -> values: Export_info.descr Export_id.Map.t + -> symbol_id: Export_id.t Symbol.Map.t + -> root_symbol: Symbol.t + -> symbols_to_export diff --git a/middle_end/flambda/un_anf.ml b/middle_end/flambda/un_anf.ml new file mode 100644 index 0000000000..50f9e7b1e2 --- /dev/null +++ b/middle_end/flambda/un_anf.ml @@ -0,0 +1,817 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-30-40-41-42"] + +(* CR-someday vlaviron for mshinwell: I believe that the phantom lets introduced + in un_anf (when the new debug_full flag is enabled) bind mostly variables + that were created in the middle-end. Is it relevant to generate debugging + information for such variables ? I expect later pull requests to refine the + generation of these phantom constructions anyway, but maybe it would already + make sense to restrict the phantom let generation to variables with an actual + provenance. +*) + +module V = Backend_var +module VP = Backend_var.With_provenance + +(* We say that an [V.t] is "linear" iff: + (a) it is used exactly once; + (b) it is never assigned to (using [Uassign]). +*) +type var_info = + { used : V.Set.t; + linear : V.Set.t; + assigned : V.Set.t; + closure_environment : V.Set.t; + let_bound_vars_that_can_be_moved : V.Set.t; + } + +let ignore_uconstant (_ : Clambda.uconstant) = () +let ignore_ulambda (_ : Clambda.ulambda) = () +let ignore_ulambda_list (_ : Clambda.ulambda list) = () +let ignore_uphantom_defining_expr_option + (_ : Clambda.uphantom_defining_expr option) = () +let ignore_function_label (_ : Clambda.function_label) = () +let ignore_debuginfo (_ : Debuginfo.t) = () +let ignore_int (_ : int) = () +let ignore_var (_ : V.t) = () +let ignore_var_option (_ : V.t option) = () +let ignore_primitive (_ : Clambda_primitives.primitive) = () +let ignore_string (_ : string) = () +let ignore_int_array (_ : int array) = () +let ignore_var_with_provenance (_ : VP.t) = () +let ignore_params_with_value_kind (_ : (VP.t * Lambda.value_kind) list) = () +let ignore_direction_flag (_ : Asttypes.direction_flag) = () +let ignore_meth_kind (_ : Lambda.meth_kind) = () +let ignore_value_kind (_ : Lambda.value_kind) = () + +(* CR-soon mshinwell: check we aren't traversing function bodies more than + once (need to analyse exactly what the calls are from Cmmgen into this + module). *) + +let closure_environment_var (ufunction:Clambda.ufunction) = + (* The argument after the arity is the environment *) + if List.length ufunction.params = ufunction.arity + 1 then + let (env_var, _) = List.nth ufunction.params ufunction.arity in + assert (VP.name env_var = "env"); + Some env_var + else + (* closed function, no environment *) + None + +let make_var_info (clam : Clambda.ulambda) : var_info = + let t : int V.Tbl.t = V.Tbl.create 42 in + let assigned_vars = ref V.Set.empty in + let environment_vars = ref V.Set.empty in + let rec loop : Clambda.ulambda -> unit = function + (* No underscores in the pattern match, to reduce the chance of failing + to traverse some subexpression. *) + | Uvar var -> + begin match V.Tbl.find t var with + | n -> V.Tbl.replace t var (n + 1) + | exception Not_found -> V.Tbl.add t var 1 + end + | Uconst const -> + (* The only variables that might occur in [const] are those in constant + closures---and those are all bound by such closures. It follows that + [const] cannot contain any variables that are bound in the current + scope, so we do not need to count them here. (The function bodies + of the closures will be traversed when this function is called from + [Cmmgen.transl_function].) *) + ignore_uconstant const + | Udirect_apply (label, args, dbg) -> + ignore_function_label label; + List.iter loop args; + ignore_debuginfo dbg + | Ugeneric_apply (func, args, dbg) -> + loop func; + List.iter loop args; + ignore_debuginfo dbg + | Uclosure (functions, captured_variables) -> + List.iter loop captured_variables; + List.iter (fun ( + { Clambda. label; arity; params; return; body; dbg; env; } as clos) -> + (match closure_environment_var clos with + | None -> () + | Some env_var -> + environment_vars := + V.Set.add (VP.var env_var) !environment_vars); + ignore_function_label label; + ignore_int arity; + ignore_params_with_value_kind params; + ignore_value_kind return; + loop body; + ignore_debuginfo dbg; + ignore_var_option env) + functions + | Uoffset (expr, offset) -> + loop expr; + ignore_int offset + | Ulet (_let_kind, _value_kind, _var, def, body) -> + loop def; + loop body + | Uphantom_let (var, defining_expr_opt, body) -> + ignore_var_with_provenance var; + ignore_uphantom_defining_expr_option defining_expr_opt; + loop body + | Uletrec (defs, body) -> + List.iter (fun (var, def) -> + ignore_var_with_provenance var; + loop def) + defs; + loop body + | Uprim (prim, args, dbg) -> + ignore_primitive prim; + List.iter loop args; + ignore_debuginfo dbg + | Uswitch (cond, { us_index_consts; us_actions_consts; + us_index_blocks; us_actions_blocks }, dbg) -> + loop cond; + ignore_int_array us_index_consts; + Array.iter loop us_actions_consts; + ignore_int_array us_index_blocks; + Array.iter loop us_actions_blocks; + ignore_debuginfo dbg + | Ustringswitch (cond, branches, default) -> + loop cond; + List.iter (fun (str, branch) -> + ignore_string str; + loop branch) + branches; + Misc.may loop default + | Ustaticfail (static_exn, args) -> + ignore_int static_exn; + List.iter loop args + | Ucatch (static_exn, vars, body, handler) -> + ignore_int static_exn; + ignore_params_with_value_kind vars; + loop body; + loop handler + | Utrywith (body, var, handler) -> + loop body; + ignore_var_with_provenance var; + loop handler + | Uifthenelse (cond, ifso, ifnot) -> + loop cond; + loop ifso; + loop ifnot + | Usequence (e1, e2) -> + loop e1; + loop e2 + | Uwhile (cond, body) -> + loop cond; + loop body + | Ufor (var, low, high, direction_flag, body) -> + ignore_var_with_provenance var; + loop low; + loop high; + ignore_direction_flag direction_flag; + loop body + | Uassign (var, expr) -> + assigned_vars := V.Set.add var !assigned_vars; + loop expr + | Usend (meth_kind, e1, e2, args, dbg) -> + ignore_meth_kind meth_kind; + loop e1; + loop e2; + List.iter loop args; + ignore_debuginfo dbg + | Uunreachable -> + () + in + loop clam; + let linear = + V.Tbl.fold (fun var n acc -> + assert (n >= 1); + if n = 1 && not (V.Set.mem var !assigned_vars) + then V.Set.add var acc + else acc) + t V.Set.empty + in + let assigned = !assigned_vars in + let used = + (* This doesn't work transitively and thus is somewhat restricted. In + particular, it does not allow us to get rid of useless chains of [let]s. + However it should be sufficient to remove the majority of unnecessary + [let] bindings that might hinder [Cmmgen]. *) + V.Tbl.fold (fun var _n acc -> V.Set.add var acc) + t assigned + in + { used; linear; assigned; closure_environment = !environment_vars; + let_bound_vars_that_can_be_moved = V.Set.empty; + } + +(* When sequences of [let]-bindings match the evaluation order in a subsequent + primitive or function application whose arguments are linearly-used + non-assigned variables bound by such lets (possibly interspersed with other + variables that are known to be constant), and it is known that there were no + intervening side-effects during the evaluation of the [let]-bindings, + permit substitution of the variables for their defining expressions. *) +let let_bound_vars_that_can_be_moved var_info (clam : Clambda.ulambda) = + let obviously_constant = ref V.Set.empty in + let can_move = ref V.Set.empty in + let let_stack = ref [] in + let examine_argument_list args = + let rec loop let_bound_vars (args : Clambda.ulambda list) = + match let_bound_vars, args with + | _, [] -> + (* We've matched all arguments and will not substitute (in the + current application being considered) any of the remaining + [let_bound_vars]. As such they may stay on the stack. *) + let_bound_vars + | [], _ -> + (* There are no more [let]-bindings to consider, so the stack + is left empty. *) + [] + | let_bound_vars, (Uvar arg)::args + when V.Set.mem arg !obviously_constant -> + loop let_bound_vars args + | let_bound_var::let_bound_vars, (Uvar arg)::args + when V.same let_bound_var arg + && not (V.Set.mem arg var_info.assigned) -> + assert (V.Set.mem arg var_info.used); + assert (V.Set.mem arg var_info.linear); + can_move := V.Set.add arg !can_move; + loop let_bound_vars args + | _::_, _::_ -> + (* The [let] sequence has ceased to match the evaluation order + or we have encountered some complicated argument. In this case + we empty the stack to ensure that we do not end up moving an + outer [let] across a side effect. *) + [] + in + (* Start at the most recent let binding and the leftmost argument + (the last argument to be evaluated). *) + let_stack := loop !let_stack args + in + let rec loop : Clambda.ulambda -> unit = function + | Uvar var -> + if V.Set.mem var var_info.assigned then begin + let_stack := [] + end + | Uconst const -> + ignore_uconstant const + | Udirect_apply (label, args, dbg) -> + ignore_function_label label; + examine_argument_list args; + (* We don't currently traverse [args]; they should all be variables + anyway. If this is added in the future, take care to traverse [args] + following the evaluation order. *) + ignore_debuginfo dbg + | Ugeneric_apply (func, args, dbg) -> + examine_argument_list (args @ [func]); + ignore_debuginfo dbg + | Uclosure (functions, captured_variables) -> + ignore_ulambda_list captured_variables; + (* Start a new let stack for speed. *) + List.iter (fun {Clambda. label; arity; params; return; body; dbg; env} -> + ignore_function_label label; + ignore_int arity; + ignore_params_with_value_kind params; + ignore_value_kind return; + let_stack := []; + loop body; + let_stack := []; + ignore_debuginfo dbg; + ignore_var_option env) + functions + | Uoffset (expr, offset) -> + (* [expr] should usually be a variable. *) + examine_argument_list [expr]; + ignore_int offset + | Ulet (_let_kind, _value_kind, var, def, body) -> + let var = VP.var var in + begin match def with + | Uconst _ -> + (* The defining expression is obviously constant, so we don't + have to put this [let] on the stack, and we don't have to + traverse the defining expression either. *) + obviously_constant := V.Set.add var !obviously_constant; + loop body + | _ -> + loop def; + if V.Set.mem var var_info.linear then begin + let_stack := var::!let_stack + end else begin + (* If we encounter a non-linear [let]-binding then we must clear + the let stack, since we cannot now move any previous binding + across the non-linear one. *) + let_stack := [] + end; + loop body + end + | Uphantom_let (var, _defining_expr, body) -> + ignore_var_with_provenance var; + loop body + | Uletrec (defs, body) -> + (* Evaluation order for [defs] is not defined, and this case + probably isn't important for [Cmmgen] anyway. *) + let_stack := []; + List.iter (fun (var, def) -> + ignore_var_with_provenance var; + loop def; + let_stack := []) + defs; + loop body + | Uprim (prim, args, dbg) -> + ignore_primitive prim; + examine_argument_list args; + ignore_debuginfo dbg + | Uswitch (cond, { us_index_consts; us_actions_consts; + us_index_blocks; us_actions_blocks }, dbg) -> + examine_argument_list [cond]; + ignore_int_array us_index_consts; + Array.iter (fun action -> + let_stack := []; + loop action) + us_actions_consts; + ignore_int_array us_index_blocks; + Array.iter (fun action -> + let_stack := []; + loop action) + us_actions_blocks; + ignore_debuginfo dbg; + let_stack := [] + | Ustringswitch (cond, branches, default) -> + examine_argument_list [cond]; + List.iter (fun (str, branch) -> + ignore_string str; + let_stack := []; + loop branch) + branches; + let_stack := []; + Misc.may loop default; + let_stack := [] + | Ustaticfail (static_exn, args) -> + ignore_int static_exn; + examine_argument_list args + | Ucatch (static_exn, vars, body, handler) -> + ignore_int static_exn; + ignore_params_with_value_kind vars; + let_stack := []; + loop body; + let_stack := []; + loop handler; + let_stack := [] + | Utrywith (body, var, handler) -> + let_stack := []; + loop body; + let_stack := []; + ignore_var_with_provenance var; + loop handler; + let_stack := [] + | Uifthenelse (cond, ifso, ifnot) -> + examine_argument_list [cond]; + let_stack := []; + loop ifso; + let_stack := []; + loop ifnot; + let_stack := [] + | Usequence (e1, e2) -> + loop e1; + let_stack := []; + loop e2; + let_stack := [] + | Uwhile (cond, body) -> + let_stack := []; + loop cond; + let_stack := []; + loop body; + let_stack := [] + | Ufor (var, low, high, direction_flag, body) -> + ignore_var_with_provenance var; + (* Cmmgen generates code that evaluates low before high, + but we don't do anything here at the moment anyway. *) + ignore_ulambda low; + ignore_ulambda high; + ignore_direction_flag direction_flag; + let_stack := []; + loop body; + let_stack := [] + | Uassign (var, expr) -> + ignore_var var; + ignore_ulambda expr; + let_stack := [] + | Usend (meth_kind, e1, e2, args, dbg) -> + ignore_meth_kind meth_kind; + ignore_ulambda e1; + ignore_ulambda e2; + ignore_ulambda_list args; + let_stack := []; + ignore_debuginfo dbg + | Uunreachable -> + let_stack := [] + in + loop clam; + !can_move + +(* Substitution of an expression for a let-moveable variable can cause the + surrounding expression to become fixed. To avoid confusion, do the + let-moveable substitutions first. *) +let rec substitute_let_moveable is_let_moveable env (clam : Clambda.ulambda) + : Clambda.ulambda = + match clam with + | Uvar var -> + if not (V.Set.mem var is_let_moveable) then + clam + else + begin match V.Map.find var env with + | clam -> clam + | exception Not_found -> + Misc.fatal_errorf "substitute_let_moveable: Unbound variable %a" + V.print var + end + | Uconst _ -> clam + | Udirect_apply (label, args, dbg) -> + let args = substitute_let_moveable_list is_let_moveable env args in + Udirect_apply (label, args, dbg) + | Ugeneric_apply (func, args, dbg) -> + let func = substitute_let_moveable is_let_moveable env func in + let args = substitute_let_moveable_list is_let_moveable env args in + Ugeneric_apply (func, args, dbg) + | Uclosure (functions, variables_bound_by_the_closure) -> + let functions = + List.map (fun (ufunction : Clambda.ufunction) -> + { ufunction with + body = substitute_let_moveable is_let_moveable env ufunction.body; + }) + functions + in + let variables_bound_by_the_closure = + substitute_let_moveable_list is_let_moveable env + variables_bound_by_the_closure + in + Uclosure (functions, variables_bound_by_the_closure) + | Uoffset (clam, n) -> + let clam = substitute_let_moveable is_let_moveable env clam in + Uoffset (clam, n) + | Ulet (let_kind, value_kind, var, def, body) -> + let def = substitute_let_moveable is_let_moveable env def in + if V.Set.mem (VP.var var) is_let_moveable then + let env = V.Map.add (VP.var var) def env in + let body = substitute_let_moveable is_let_moveable env body in + (* If we are about to delete a [let] in debug mode, keep it for the + debugger. *) + (* CR-someday mshinwell: find out why some closure constructions were + not leaving phantom lets behind after substitution. *) + if not !Clflags.debug_full then + body + else + match def with + | Uconst const -> + Uphantom_let (var, Some (Clambda.Uphantom_const const), body) + | Uvar alias_of -> + Uphantom_let (var, Some (Clambda.Uphantom_var alias_of), body) + | _ -> + Uphantom_let (var, None, body) + else + Ulet (let_kind, value_kind, + var, def, substitute_let_moveable is_let_moveable env body) + | Uphantom_let (var, defining_expr, body) -> + let body = substitute_let_moveable is_let_moveable env body in + Uphantom_let (var, defining_expr, body) + | Uletrec (defs, body) -> + let defs = + List.map (fun (var, def) -> + var, substitute_let_moveable is_let_moveable env def) + defs + in + let body = substitute_let_moveable is_let_moveable env body in + Uletrec (defs, body) + | Uprim (prim, args, dbg) -> + let args = substitute_let_moveable_list is_let_moveable env args in + Uprim (prim, args, dbg) + | Uswitch (cond, sw, dbg) -> + let cond = substitute_let_moveable is_let_moveable env cond in + let sw = + { sw with + us_actions_consts = + substitute_let_moveable_array is_let_moveable env + sw.us_actions_consts; + us_actions_blocks = + substitute_let_moveable_array is_let_moveable env + sw.us_actions_blocks; + } + in + Uswitch (cond, sw, dbg) + | Ustringswitch (cond, branches, default) -> + let cond = substitute_let_moveable is_let_moveable env cond in + let branches = + List.map (fun (s, branch) -> + s, substitute_let_moveable is_let_moveable env branch) + branches + in + let default = + Misc.may_map (substitute_let_moveable is_let_moveable env) default + in + Ustringswitch (cond, branches, default) + | Ustaticfail (n, args) -> + let args = substitute_let_moveable_list is_let_moveable env args in + Ustaticfail (n, args) + | Ucatch (n, vars, body, handler) -> + let body = substitute_let_moveable is_let_moveable env body in + let handler = substitute_let_moveable is_let_moveable env handler in + Ucatch (n, vars, body, handler) + | Utrywith (body, var, handler) -> + let body = substitute_let_moveable is_let_moveable env body in + let handler = substitute_let_moveable is_let_moveable env handler in + Utrywith (body, var, handler) + | Uifthenelse (cond, ifso, ifnot) -> + let cond = substitute_let_moveable is_let_moveable env cond in + let ifso = substitute_let_moveable is_let_moveable env ifso in + let ifnot = substitute_let_moveable is_let_moveable env ifnot in + Uifthenelse (cond, ifso, ifnot) + | Usequence (e1, e2) -> + let e1 = substitute_let_moveable is_let_moveable env e1 in + let e2 = substitute_let_moveable is_let_moveable env e2 in + Usequence (e1, e2) + | Uwhile (cond, body) -> + let cond = substitute_let_moveable is_let_moveable env cond in + let body = substitute_let_moveable is_let_moveable env body in + Uwhile (cond, body) + | Ufor (var, low, high, direction, body) -> + let low = substitute_let_moveable is_let_moveable env low in + let high = substitute_let_moveable is_let_moveable env high in + let body = substitute_let_moveable is_let_moveable env body in + Ufor (var, low, high, direction, body) + | Uassign (var, expr) -> + let expr = substitute_let_moveable is_let_moveable env expr in + Uassign (var, expr) + | Usend (kind, e1, e2, args, dbg) -> + let e1 = substitute_let_moveable is_let_moveable env e1 in + let e2 = substitute_let_moveable is_let_moveable env e2 in + let args = substitute_let_moveable_list is_let_moveable env args in + Usend (kind, e1, e2, args, dbg) + | Uunreachable -> + Uunreachable + +and substitute_let_moveable_list is_let_moveable env clams = + List.map (substitute_let_moveable is_let_moveable env) clams + +and substitute_let_moveable_array is_let_moveable env clams = + Array.map (substitute_let_moveable is_let_moveable env) clams + +(* We say that an expression is "moveable" iff it has neither effects nor + coeffects. (See semantics_of_primitives.mli.) +*) +type moveable = Fixed | Constant | Moveable + +let both_moveable a b = + match a, b with + | Constant, Constant -> Constant + | Constant, Moveable + | Moveable, Constant + | Moveable, Moveable -> Moveable + | Constant, Fixed + | Moveable, Fixed + | Fixed, Constant + | Fixed, Moveable + | Fixed, Fixed -> Fixed + +let primitive_moveable (prim : Clambda_primitives.primitive) + (args : Clambda.ulambda list) + (var_info : var_info) = + match prim, args with + | Pfield _, [Uconst (Uconst_ref (_, _))] -> + (* CR-someday mshinwell: Actually, maybe this shouldn't be needed; these + should have been simplified to [Read_symbol_field], which doesn't yield + a Clambda let. This might be fixed when Inline_and_simplify can + turn Pfield into Read_symbol_field. *) + (* Allow field access of symbols to be moveable. (The comment in + flambda.mli on [Read_symbol_field] may be helpful to the reader.) *) + Moveable + | Pfield _, [Uvar var] when V.Set.mem var var_info.closure_environment -> + (* accesses to the function environment is coeffect free: this block + is never mutated *) + Moveable + | _ -> + match Semantics_of_primitives.for_primitive prim with + | No_effects, No_coeffects -> Moveable + | No_effects, Has_coeffects + | Only_generative_effects, No_coeffects + | Only_generative_effects, Has_coeffects + | Arbitrary_effects, No_coeffects + | Arbitrary_effects, Has_coeffects -> Fixed + +type moveable_for_env = Constant | Moveable + +(** Eliminate, through substitution, [let]-bindings of linear variables with + moveable defining expressions. *) +let rec un_anf_and_moveable var_info env (clam : Clambda.ulambda) + : Clambda.ulambda * moveable = + match clam with + | Uvar var -> + begin match V.Map.find var env with + | Constant, def -> def, Constant + | Moveable, def -> def, Moveable + | exception Not_found -> + let moveable : moveable = + if V.Set.mem var var_info.assigned then + Fixed + else + Moveable + in + clam, moveable + end + | Uconst _ -> + (* Constant closures are rewritten separately. *) + clam, Constant + | Udirect_apply (label, args, dbg) -> + let args = un_anf_list var_info env args in + Udirect_apply (label, args, dbg), Fixed + | Ugeneric_apply (func, args, dbg) -> + let func = un_anf var_info env func in + let args = un_anf_list var_info env args in + Ugeneric_apply (func, args, dbg), Fixed + | Uclosure (functions, variables_bound_by_the_closure) -> + let functions = + List.map (fun (ufunction : Clambda.ufunction) -> + { ufunction with + body = un_anf var_info env ufunction.body; + }) + functions + in + let variables_bound_by_the_closure = + un_anf_list var_info env variables_bound_by_the_closure + in + Uclosure (functions, variables_bound_by_the_closure), Fixed + | Uoffset (clam, n) -> + let clam, moveable = un_anf_and_moveable var_info env clam in + Uoffset (clam, n), both_moveable Moveable moveable + | Ulet (_let_kind, _value_kind, var, def, Uvar var') + when V.same (VP.var var) var' -> + un_anf_and_moveable var_info env def + | Ulet (let_kind, value_kind, var, def, body) -> + let def, def_moveable = un_anf_and_moveable var_info env def in + let is_linear = V.Set.mem (VP.var var) var_info.linear in + let is_used = V.Set.mem (VP.var var) var_info.used in + let is_assigned = V.Set.mem (VP.var var) var_info.assigned in + let maybe_for_debugger (body, moveable) : Clambda.ulambda * moveable = + if not !Clflags.debug_full then + body, moveable + else + match def with + | Uconst const -> + Uphantom_let (var, Some (Clambda.Uphantom_const const), + body), moveable + | Uvar alias_of -> + Uphantom_let (var, Some (Clambda.Uphantom_var alias_of), body), + moveable + | _ -> + Uphantom_let (var, None, body), moveable + in + begin match def_moveable, is_linear, is_used, is_assigned with + | (Constant | Moveable), _, false, _ -> + (* A moveable expression that is never used may be eliminated. + However, if in debug mode and the defining expression is + appropriate, keep the let (as a phantom let) for the debugger. *) + maybe_for_debugger (un_anf_and_moveable var_info env body) + | Constant, _, true, false + (* A constant expression bound to an unassigned variable can replace any + occurrences of the variable. The same comment as above concerning + phantom lets applies. *) + | Moveable, true, true, false -> + (* A moveable expression bound to a linear unassigned [V.t] + may replace the single occurrence of the variable. The same comment + as above concerning phantom lets applies. *) + let def_moveable = + match def_moveable with + | Moveable -> Moveable + | Constant -> Constant + | Fixed -> assert false + in + let env = V.Map.add (VP.var var) (def_moveable, def) env in + maybe_for_debugger (un_anf_and_moveable var_info env body) + | (Constant | Moveable), _, _, true + (* Constant or Moveable but assigned. *) + | Moveable, false, _, _ + (* Moveable but not used linearly. *) + | Fixed, _, _, _ -> + let body, body_moveable = un_anf_and_moveable var_info env body in + Ulet (let_kind, value_kind, var, def, body), + both_moveable def_moveable body_moveable + end + | Uphantom_let (var, defining_expr, body) -> + let body, body_moveable = un_anf_and_moveable var_info env body in + Uphantom_let (var, defining_expr, body), body_moveable + | Uletrec (defs, body) -> + let defs = + List.map (fun (var, def) -> var, un_anf var_info env def) defs + in + let body = un_anf var_info env body in + Uletrec (defs, body), Fixed + | Uprim (prim, args, dbg) -> + let args, args_moveable = un_anf_list_and_moveable var_info env args in + let moveable = + both_moveable args_moveable (primitive_moveable prim args var_info) + in + Uprim (prim, args, dbg), moveable + | Uswitch (cond, sw, dbg) -> + let cond = un_anf var_info env cond in + let sw = + { sw with + us_actions_consts = un_anf_array var_info env sw.us_actions_consts; + us_actions_blocks = un_anf_array var_info env sw.us_actions_blocks; + } + in + Uswitch (cond, sw, dbg), Fixed + | Ustringswitch (cond, branches, default) -> + let cond = un_anf var_info env cond in + let branches = + List.map (fun (s, branch) -> s, un_anf var_info env branch) + branches + in + let default = Misc.may_map (un_anf var_info env) default in + Ustringswitch (cond, branches, default), Fixed + | Ustaticfail (n, args) -> + let args = un_anf_list var_info env args in + Ustaticfail (n, args), Fixed + | Ucatch (n, vars, body, handler) -> + let body = un_anf var_info env body in + let handler = un_anf var_info env handler in + Ucatch (n, vars, body, handler), Fixed + | Utrywith (body, var, handler) -> + let body = un_anf var_info env body in + let handler = un_anf var_info env handler in + Utrywith (body, var, handler), Fixed + | Uifthenelse (cond, ifso, ifnot) -> + let cond, cond_moveable = un_anf_and_moveable var_info env cond in + let ifso, ifso_moveable = un_anf_and_moveable var_info env ifso in + let ifnot, ifnot_moveable = un_anf_and_moveable var_info env ifnot in + let moveable = + both_moveable cond_moveable + (both_moveable ifso_moveable ifnot_moveable) + in + Uifthenelse (cond, ifso, ifnot), moveable + | Usequence (e1, e2) -> + let e1 = un_anf var_info env e1 in + let e2 = un_anf var_info env e2 in + Usequence (e1, e2), Fixed + | Uwhile (cond, body) -> + let cond = un_anf var_info env cond in + let body = un_anf var_info env body in + Uwhile (cond, body), Fixed + | Ufor (var, low, high, direction, body) -> + let low = un_anf var_info env low in + let high = un_anf var_info env high in + let body = un_anf var_info env body in + Ufor (var, low, high, direction, body), Fixed + | Uassign (var, expr) -> + let expr = un_anf var_info env expr in + Uassign (var, expr), Fixed + | Usend (kind, e1, e2, args, dbg) -> + let e1 = un_anf var_info env e1 in + let e2 = un_anf var_info env e2 in + let args = un_anf_list var_info env args in + Usend (kind, e1, e2, args, dbg), Fixed + | Uunreachable -> + Uunreachable, Fixed + +and un_anf var_info env clam : Clambda.ulambda = + let clam, _moveable = un_anf_and_moveable var_info env clam in + clam + +and un_anf_list_and_moveable var_info env clams + : Clambda.ulambda list * moveable = + List.fold_right (fun clam (l, acc_moveable) -> + let clam, moveable = un_anf_and_moveable var_info env clam in + clam :: l, both_moveable moveable acc_moveable) + clams ([], (Moveable : moveable)) + +and un_anf_list var_info env clams : Clambda.ulambda list = + let clams, _moveable = un_anf_list_and_moveable var_info env clams in + clams + +and un_anf_array var_info env clams : Clambda.ulambda array = + Array.map (un_anf var_info env) clams + +let apply ~ppf_dump clam ~what = + let var_info = make_var_info clam in + let let_bound_vars_that_can_be_moved = + let_bound_vars_that_can_be_moved var_info clam + in + let clam = + substitute_let_moveable let_bound_vars_that_can_be_moved + V.Map.empty clam + in + let var_info = make_var_info clam in + let clam = un_anf var_info V.Map.empty clam in + if !Clflags.dump_clambda then begin + Format.fprintf ppf_dump + "@.un-anf (%s):@ %a@." what Printclambda.clambda clam + end; + clam diff --git a/middle_end/flambda/un_anf.mli b/middle_end/flambda/un_anf.mli new file mode 100644 index 0000000000..92ea06cd03 --- /dev/null +++ b/middle_end/flambda/un_anf.mli @@ -0,0 +1,23 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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. *) +(* *) +(**************************************************************************) + +(** Expand ANF-like constructs so that pattern matches in [Cmmgen] will + work correctly. *) +val apply + : ppf_dump:Format.formatter + -> Clambda.ulambda + -> what:string + -> Clambda.ulambda diff --git a/middle_end/flambda/unbox_closures.ml b/middle_end/flambda/unbox_closures.ml new file mode 100644 index 0000000000..5c86bed3da --- /dev/null +++ b/middle_end/flambda/unbox_closures.ml @@ -0,0 +1,87 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +module ASA = Augment_specialised_args +module W = ASA.What_to_specialise +module E = Inline_and_simplify_aux.Env + +module Transform = struct + let pass_name = "unbox-closures" + + let precondition ~env ~(set_of_closures : Flambda.set_of_closures) = + !Clflags.unbox_closures + && not (E.at_toplevel env) + && not (Variable.Map.is_empty set_of_closures.free_vars) + + let what_to_specialise ~env ~(set_of_closures : Flambda.set_of_closures) = + let what_to_specialise = W.create ~set_of_closures in + if not (precondition ~env ~set_of_closures) then + what_to_specialise + else begin + let round = E.round env in + let num_closure_vars = Variable.Map.cardinal set_of_closures.free_vars in + let module B = Inlining_cost.Benefit in + let saved_by_not_building_closure = + (* For the moment assume that we're going to cause all functions in the + set to become closed. *) + B.remove_prims (B.remove_call B.zero) num_closure_vars + in + Flambda_iterators.fold_function_decls_ignoring_stubs set_of_closures + ~init:what_to_specialise + ~f:(fun ~fun_var ~(function_decl : Flambda.function_declaration) + what_to_specialise -> + let body_size = Inlining_cost.lambda_size function_decl.body in + (* If the function is small enough, make a direct call surrogate + for it, so that indirect calls are not penalised by having to + bounce through the stub. (Making such a surrogate involves + duplicating the function.) *) + let small_enough_to_duplicate = + let module W = Inlining_cost.Whether_sufficient_benefit in + let wsb = + W.create_estimate ~original_size:0 + ~toplevel:false + ~branch_depth:0 + ~new_size:((body_size / !Clflags.unbox_closures_factor) + 1) + ~benefit:saved_by_not_building_closure + ~lifting:false + ~round + in + W.evaluate wsb + in + let what_to_specialise = + if small_enough_to_duplicate then + W.make_direct_call_surrogate_for what_to_specialise ~fun_var + else + what_to_specialise + in + let bound_by_the_closure = + Flambda_utils.variables_bound_by_the_closure + (Closure_id.wrap fun_var) + set_of_closures.function_decls + in + Variable.Set.fold (fun inner_free_var what_to_specialise -> + W.new_specialised_arg what_to_specialise + ~fun_var ~group:inner_free_var + ~definition:(Existing_inner_free_var inner_free_var)) + bound_by_the_closure + what_to_specialise) + end +end + +include ASA.Make (Transform) diff --git a/middle_end/flambda/unbox_closures.mli b/middle_end/flambda/unbox_closures.mli new file mode 100644 index 0000000000..fb935a622b --- /dev/null +++ b/middle_end/flambda/unbox_closures.mli @@ -0,0 +1,33 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(** Turn free variables of closures into specialised arguments. + The aim is to cause the closure to become closed. *) + +val rewrite_set_of_closures + : env:Inline_and_simplify_aux.Env.t + (* CR-soon mshinwell: eliminate superfluous parameter *) + -> duplicate_function:( + env:Inline_and_simplify_aux.Env.t + -> set_of_closures:Flambda.set_of_closures + -> fun_var:Variable.t + -> new_fun_var:Variable.t + -> Flambda.function_declaration + * Flambda.specialised_to Variable.Map.t) + -> set_of_closures:Flambda.set_of_closures + -> (Flambda.expr * Inlining_cost.Benefit.t) option diff --git a/middle_end/flambda/unbox_free_vars_of_closures.ml b/middle_end/flambda/unbox_free_vars_of_closures.ml new file mode 100644 index 0000000000..7a4e48ed44 --- /dev/null +++ b/middle_end/flambda/unbox_free_vars_of_closures.ml @@ -0,0 +1,170 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +module B = Inlining_cost.Benefit + +let pass_name = "unbox-free-vars-of-closures" +let () = Pass_wrapper.register ~pass_name + +(* CR-someday mshinwell: Nearly but not quite the same as something that + Augment_specialised_args uses. *) +let add_lifted_projections_around_set_of_closures + ~set_of_closures ~existing_inner_to_outer_vars ~benefit + ~definitions_indexed_by_new_inner_vars = + let body = + Flambda_utils.name_expr (Set_of_closures set_of_closures) + ~name:Internal_variable_names.unbox_free_vars_of_closures + in + Variable.Map.fold (fun new_inner_var (projection : Projection.t) + (expr, benefit) -> + let find_outer_var inner_var = + match + Variable.Map.find inner_var existing_inner_to_outer_vars + with + | (outer_var : Flambda.specialised_to) -> outer_var.var + | exception Not_found -> + Misc.fatal_errorf "(UFV) find_outer_var: expected %a \ + to be in [existing_inner_to_outer_vars], but it is \ + not. (The projection was: %a)" + Variable.print inner_var + Projection.print projection + in + let benefit = B.add_projection projection benefit in + let named : Flambda.named = + (* The lifted projection must be in terms of outer variables, + not inner variables. *) + let projection = + Projection.map_projecting_from projection ~f:find_outer_var + in + Flambda_utils.projection_to_named projection + in + let expr = + Flambda.create_let (find_outer_var new_inner_var) named expr + in + (expr, benefit)) + definitions_indexed_by_new_inner_vars + (body, benefit) + +let run ~env ~(set_of_closures : Flambda.set_of_closures) = + if not !Clflags.unbox_free_vars_of_closures then + None + else + let definitions_indexed_by_new_inner_vars, _, free_vars, done_something = + let all_existing_definitions = + Variable.Map.fold (fun _inner_var (outer_var : Flambda.specialised_to) + all_existing_definitions -> + match outer_var.projection with + | None -> all_existing_definitions + | Some projection -> + Projection.Set.add projection all_existing_definitions) + set_of_closures.free_vars + Projection.Set.empty + in + Flambda_iterators.fold_function_decls_ignoring_stubs set_of_closures + ~init:(Variable.Map.empty, all_existing_definitions, + set_of_closures.free_vars, false) + ~f:(fun ~fun_var:_ ~function_decl result -> + let extracted = + Extract_projections.from_function_decl ~env ~function_decl + ~which_variables:set_of_closures.free_vars + in + Projection.Set.fold (fun projection + ((definitions_indexed_by_new_inner_vars, + all_existing_definitions_including_added_ones, + additional_free_vars, _done_something) as result) -> + (* Don't add a new free variable if there already exists a + free variable with the desired projection. We need to + dedup not only across the existing free variables but + also across newly-added ones (unlike in + [Augment_specialised_args]), since free variables are + not local to a function declaration but rather to a + set of closures. *) + if Projection.Set.mem projection + all_existing_definitions_including_added_ones + then begin + result + end else begin + (* Add a new free variable. This needs both a fresh + "new inner" and a fresh "new outer" var, since we know + the definition is not a duplicate. *) + let projecting_from = Projection.projecting_from projection in + let new_inner_var = Variable.rename projecting_from in + let new_outer_var = Variable.rename projecting_from in + let definitions_indexed_by_new_inner_vars = + Variable.Map.add new_inner_var projection + definitions_indexed_by_new_inner_vars + in + let all_existing_definitions_including_added_ones = + Projection.Set.add projection + all_existing_definitions_including_added_ones + in + let new_outer_var : Flambda.specialised_to = + { var = new_outer_var; + projection = Some projection; + } + in + let additional_free_vars = + Variable.Map.add new_inner_var new_outer_var + additional_free_vars + in + definitions_indexed_by_new_inner_vars, + all_existing_definitions_including_added_ones, + additional_free_vars, + true + end) + extracted + result) + in + if not done_something then + None + else + (* CR-someday mshinwell: could consider doing the grouping thing + similar to Augment_specialised_args *) + let num_free_vars_before = + Variable.Map.cardinal set_of_closures.free_vars + in + let num_free_vars_after = + Variable.Map.cardinal free_vars + in + assert (num_free_vars_after > num_free_vars_before); + (* Don't let the closure grow too large. *) + if num_free_vars_after > 2 * num_free_vars_before then + None + else + let set_of_closures = + Flambda.create_set_of_closures + ~function_decls:set_of_closures.function_decls + ~free_vars + ~specialised_args:set_of_closures.specialised_args + ~direct_call_surrogates:set_of_closures.direct_call_surrogates + in + let expr, benefit = + add_lifted_projections_around_set_of_closures ~set_of_closures + ~benefit:B.zero + ~existing_inner_to_outer_vars:set_of_closures.free_vars + ~definitions_indexed_by_new_inner_vars + in + Some (expr, benefit) + +let run ~env ~set_of_closures = + Pass_wrapper.with_dump ~ppf_dump:(Inline_and_simplify_aux.Env.ppf_dump env) + ~pass_name ~input:set_of_closures + ~print_input:Flambda.print_set_of_closures + ~print_output:(fun ppf (expr, _) -> Flambda.print ppf expr) + ~f:(fun () -> run ~env ~set_of_closures) diff --git a/middle_end/flambda/unbox_free_vars_of_closures.mli b/middle_end/flambda/unbox_free_vars_of_closures.mli new file mode 100644 index 0000000000..3ee181ee3c --- /dev/null +++ b/middle_end/flambda/unbox_free_vars_of_closures.mli @@ -0,0 +1,26 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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. *) +(* *) +(**************************************************************************) + +(** When approximations of free variables of closures indicate that they + are closures or blocks, rewrite projections from such blocks to new + variables (which become free in the closures), with the defining + expressions of the projections lifted out of the corresponding sets + of closures. *) + +val run + : env:Inline_and_simplify_aux.Env.t + -> set_of_closures:Flambda.set_of_closures + -> (Flambda.expr * Inlining_cost.Benefit.t) option diff --git a/middle_end/flambda/unbox_specialised_args.ml b/middle_end/flambda/unbox_specialised_args.ml new file mode 100644 index 0000000000..70eb87601a --- /dev/null +++ b/middle_end/flambda/unbox_specialised_args.ml @@ -0,0 +1,103 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +module ASA = Augment_specialised_args +module W = ASA.What_to_specialise + +module Transform = struct + let pass_name = "unbox-specialised-args" + + let precondition ~env:_ ~(set_of_closures : Flambda.set_of_closures) = + !Clflags.unbox_specialised_args + && not (Variable.Map.is_empty set_of_closures.specialised_args) + + let what_to_specialise ~env ~(set_of_closures : Flambda.set_of_closures) = + let what_to_specialise = W.create ~set_of_closures in + if not (precondition ~env ~set_of_closures) then + what_to_specialise + else + let projections_by_function = + Variable.Map.filter_map set_of_closures.function_decls.funs + ~f:(fun _fun_var (function_decl : Flambda.function_declaration) -> + if function_decl.stub then None + else + Some (Extract_projections.from_function_decl ~env + ~function_decl + ~which_variables:set_of_closures.specialised_args)) + in + (* CR-soon mshinwell: consider caching the Invariant_params *relation* + as well as the "_in_recursion" map *) + let invariant_params_flow = + Invariant_params.invariant_param_sources set_of_closures.function_decls + ~backend:(Inline_and_simplify_aux.Env.backend env) + in + Variable.Map.fold (fun fun_var extractions what_to_specialise -> + Projection.Set.fold (fun (projection : Projection.t) + what_to_specialise -> + let group = Projection.projecting_from projection in + assert (Variable.Map.mem group set_of_closures.specialised_args); + let what_to_specialise = + W.new_specialised_arg what_to_specialise ~fun_var ~group + ~definition:(Projection_from_existing_specialised_arg + projection) + in + match Variable.Map.find group invariant_params_flow with + | exception Not_found -> what_to_specialise + | flow -> + (* If for function [f] we would extract a projection expression + [e] from some specialised argument [x] of [f], and we know + from [Invariant_params] that a specialised argument [y] of + another function [g] flows to [x], we will add [e] with + [y] substituted for [x] throughout as a newly-specialised + argument for [g]. This should help reduce the number of + simplification rounds required for mutually-recursive + functions. *) + Variable.Pair.Set.fold (fun (target_fun_var, target_spec_arg) + what_to_specialise -> + if Variable.equal fun_var target_fun_var + || not (Variable.Map.mem target_spec_arg + set_of_closures.specialised_args) + then begin + what_to_specialise + end else begin + (* Rewrite the projection (that was in terms of an inner + specialised arg of [fun_var]) to be in terms of the + corresponding inner specialised arg of + [target_fun_var]. (The outer vars referenced in the + projection remain unchanged.) *) + let projection = + Projection.map_projecting_from projection + ~f:(fun var -> + assert (Variable.equal var group); + target_spec_arg) + in + W.new_specialised_arg what_to_specialise + ~fun_var:target_fun_var ~group + ~definition: + (Projection_from_existing_specialised_arg projection) + end) + flow + what_to_specialise) + extractions + what_to_specialise) + projections_by_function + what_to_specialise +end + +include ASA.Make (Transform) diff --git a/middle_end/flambda/unbox_specialised_args.mli b/middle_end/flambda/unbox_specialised_args.mli new file mode 100644 index 0000000000..f019176482 --- /dev/null +++ b/middle_end/flambda/unbox_specialised_args.mli @@ -0,0 +1,50 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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. *) +(* *) +(**************************************************************************) + +(** When approximations of specialised arguments indicate that they are + closures or blocks, add more specialised arguments corresponding to + the projections from such blocks (with definitions of such projections + lifted out), such that the original specialised arguments may later be + eliminated. + + This in particular enables elimination of closure allocations in + examples such as: + + let rec map f = function + | [] -> [] + | a::l -> let r = f a in r :: map f l + + let g x = + map (fun y -> x + y) [1; 2; 3; 4] + + Here, the specialised version of [map] initially has a specialised + argument [f]; and upon inlining there will be a projection of [x] from + the closure of [f]. This pass adds a new specialised argument to carry + that projection, at which point the closure of [f] is redundant. +*) + +val rewrite_set_of_closures + : env:Inline_and_simplify_aux.Env.t + (* CR-soon mshinwell: eliminate superfluous parameter *) + -> duplicate_function:( + env:Inline_and_simplify_aux.Env.t + -> set_of_closures:Flambda.set_of_closures + -> fun_var:Variable.t + -> new_fun_var:Variable.t + -> Flambda.function_declaration + * Flambda.specialised_to Variable.Map.t) + -> set_of_closures:Flambda.set_of_closures + -> (Flambda.expr * Inlining_cost.Benefit.t) option diff --git a/middle_end/flambda_invariants.ml b/middle_end/flambda_invariants.ml deleted file mode 100644 index 250a2e9af7..0000000000 --- a/middle_end/flambda_invariants.ml +++ /dev/null @@ -1,800 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -type flambda_kind = - | Normal - | Lifted - -(* Explicit "ignore" functions. We name every pattern variable, avoiding - underscores, to try to avoid accidentally failing to handle (for example) - a particular variable. - We also avoid explicit record field access during the checking functions, - preferring instead to use exhaustive record matches. -*) -(* CR-someday pchambart: for sum types, we should probably add an exhaustive - pattern in ignores functions to be reminded if a type change *) -let already_added_bound_variable_to_env (_ : Variable.t) = () -let will_traverse_named_expression_later (_ : Flambda.named) = () -let ignore_variable (_ : Variable.t) = () -let ignore_call_kind (_ : Flambda.call_kind) = () -let ignore_debuginfo (_ : Debuginfo.t) = () -let ignore_meth_kind (_ : Lambda.meth_kind) = () -let ignore_int (_ : int) = () -let ignore_int_set (_ : Numbers.Int.Set.t) = () -let ignore_bool (_ : bool) = () -let ignore_string (_ : string) = () -let ignore_static_exception (_ : Static_exception.t) = () -let ignore_direction_flag (_ : Asttypes.direction_flag) = () -let ignore_primitive ( _ : Clambda_primitives.primitive) = () -let ignore_const (_ : Flambda.const) = () -let ignore_allocated_const (_ : Allocated_const.t) = () -let ignore_set_of_closures_id (_ : Set_of_closures_id.t) = () -let ignore_set_of_closures_origin (_ : Set_of_closures_origin.t) = () -let ignore_closure_id (_ : Closure_id.t) = () -let ignore_var_within_closure (_ : Var_within_closure.t) = () -let ignore_tag (_ : Tag.t) = () -let ignore_inline_attribute (_ : Lambda.inline_attribute) = () -let ignore_specialise_attribute (_ : Lambda.specialise_attribute) = () -let ignore_value_kind (_ : Lambda.value_kind) = () - -exception Binding_occurrence_not_from_current_compilation_unit of Variable.t -exception Mutable_binding_occurrence_not_from_current_compilation_unit of - Mutable_variable.t -exception Binding_occurrence_of_variable_already_bound of Variable.t -exception Binding_occurrence_of_mutable_variable_already_bound of - Mutable_variable.t -exception Binding_occurrence_of_symbol_already_bound of Symbol.t -exception Unbound_variable of Variable.t -exception Unbound_mutable_variable of Mutable_variable.t -exception Unbound_symbol of Symbol.t -exception Vars_in_function_body_not_bound_by_closure_or_params of - Variable.Set.t * Flambda.set_of_closures * Variable.t -exception Function_decls_have_overlapping_parameters of Variable.Set.t -exception Specialised_arg_that_is_not_a_parameter of Variable.t -exception Projection_must_be_a_free_var of Projection.t -exception Projection_must_be_a_specialised_arg of Projection.t -exception Free_variables_set_is_lying of - Variable.t * Variable.Set.t * Variable.Set.t * Flambda.function_declaration -exception Set_of_closures_free_vars_map_has_wrong_range of Variable.Set.t -exception Static_exception_not_caught of Static_exception.t -exception Static_exception_caught_in_multiple_places of Static_exception.t -exception Sequential_logical_operator_primitives_must_be_expanded of - Clambda_primitives.primitive -exception Var_within_closure_bound_multiple_times of Var_within_closure.t -exception Declared_closure_from_another_unit of Compilation_unit.t -exception Closure_id_is_bound_multiple_times of Closure_id.t -exception Set_of_closures_id_is_bound_multiple_times of Set_of_closures_id.t -exception Unbound_closure_ids of Closure_id.Set.t -exception Unbound_vars_within_closures of Var_within_closure.Set.t -exception Move_to_a_closure_not_in_the_free_variables - of Variable.t * Variable.Set.t - -exception Flambda_invariants_failed - -(* CR-someday mshinwell: We should make "direct applications should not have - overapplication" be an invariant throughout. At the moment I think this is - only true after [Inline_and_simplify] has split overapplications. *) - -(* CR-someday mshinwell: What about checks for shadowed variables and - symbols? *) - -let variable_and_symbol_invariants (program : Flambda.program) = - let all_declared_variables = ref Variable.Set.empty in - let declare_variable var = - if Variable.Set.mem var !all_declared_variables then - raise (Binding_occurrence_of_variable_already_bound var); - all_declared_variables := Variable.Set.add var !all_declared_variables - in - let declare_variables vars = - Variable.Set.iter declare_variable vars - in - let all_declared_mutable_variables = ref Mutable_variable.Set.empty in - let declare_mutable_variable mut_var = - if Mutable_variable.Set.mem mut_var !all_declared_mutable_variables then - raise (Binding_occurrence_of_mutable_variable_already_bound mut_var); - all_declared_mutable_variables := - Mutable_variable.Set.add mut_var !all_declared_mutable_variables - in - let add_binding_occurrence (var_env, mut_var_env, sym_env) var = - let compilation_unit = Compilation_unit.get_current_exn () in - if not (Variable.in_compilation_unit var compilation_unit) then - raise (Binding_occurrence_not_from_current_compilation_unit var); - declare_variable var; - Variable.Set.add var var_env, mut_var_env, sym_env - in - let add_mutable_binding_occurrence (var_env, mut_var_env, sym_env) mut_var = - let compilation_unit = Compilation_unit.get_current_exn () in - if not (Mutable_variable.in_compilation_unit mut_var compilation_unit) then - raise (Mutable_binding_occurrence_not_from_current_compilation_unit - mut_var); - declare_mutable_variable mut_var; - var_env, Mutable_variable.Set.add mut_var mut_var_env, sym_env - in - let add_binding_occurrence_of_symbol (var_env, mut_var_env, sym_env) sym = - if Symbol.Set.mem sym sym_env then - raise (Binding_occurrence_of_symbol_already_bound sym) - else - var_env, mut_var_env, Symbol.Set.add sym sym_env - in - let add_binding_occurrences env vars = - List.fold_left (fun env var -> add_binding_occurrence env var) env vars - in - let check_variable_is_bound (var_env, _, _) var = - if not (Variable.Set.mem var var_env) then raise (Unbound_variable var) - in - let check_symbol_is_bound (_, _, sym_env) sym = - if not (Symbol.Set.mem sym sym_env) then raise (Unbound_symbol sym) - in - let check_variables_are_bound env vars = - List.iter (check_variable_is_bound env) vars - in - let check_mutable_variable_is_bound (_, mut_var_env, _) mut_var = - if not (Mutable_variable.Set.mem mut_var mut_var_env) then begin - raise (Unbound_mutable_variable mut_var) - end - in - let rec loop env (flam : Flambda.t) = - match flam with - (* Expressions that can bind [Variable.t]s: *) - | Let { var; defining_expr; body; _ } -> - loop_named env defining_expr; - loop (add_binding_occurrence env var) body - | Let_mutable { var = mut_var; initial_value = var; - body; contents_kind } -> - ignore_value_kind contents_kind; - check_variable_is_bound env var; - loop (add_mutable_binding_occurrence env mut_var) body - | Let_rec (defs, body) -> - let env = - List.fold_left (fun env (var, def) -> - will_traverse_named_expression_later def; - add_binding_occurrence env var) - env defs - in - List.iter (fun (var, def) -> - already_added_bound_variable_to_env var; - loop_named env def) defs; - loop env body - | For { bound_var; from_value; to_value; direction; body; } -> - ignore_direction_flag direction; - check_variable_is_bound env from_value; - check_variable_is_bound env to_value; - loop (add_binding_occurrence env bound_var) body - | Static_catch (static_exn, vars, body, handler) -> - ignore_static_exception static_exn; - loop env body; - loop (add_binding_occurrences env vars) handler - | Try_with (body, var, handler) -> - loop env body; - loop (add_binding_occurrence env var) handler - (* Everything else: *) - | Var var -> check_variable_is_bound env var - | Apply { func; args; kind; dbg; inline; specialise; } -> - check_variable_is_bound env func; - check_variables_are_bound env args; - ignore_call_kind kind; - ignore_debuginfo dbg; - ignore_inline_attribute inline; - ignore_specialise_attribute specialise - | Assign { being_assigned; new_value; } -> - check_mutable_variable_is_bound env being_assigned; - check_variable_is_bound env new_value - | Send { kind; meth; obj; args; dbg; } -> - ignore_meth_kind kind; - check_variable_is_bound env meth; - check_variable_is_bound env obj; - check_variables_are_bound env args; - ignore_debuginfo dbg - | If_then_else (cond, ifso, ifnot) -> - check_variable_is_bound env cond; - loop env ifso; - loop env ifnot - | Switch (arg, { numconsts; consts; numblocks; blocks; failaction; }) -> - check_variable_is_bound env arg; - ignore_int_set numconsts; - ignore_int_set numblocks; - List.iter (fun (n, e) -> - ignore_int n; - loop env e) - (consts @ blocks); - Misc.may (loop env) failaction - | String_switch (arg, cases, e_opt) -> - check_variable_is_bound env arg; - List.iter (fun (label, case) -> - ignore_string label; - loop env case) - cases; - Misc.may (loop env) e_opt - | Static_raise (static_exn, es) -> - ignore_static_exception static_exn; - List.iter (check_variable_is_bound env) es - | While (e1, e2) -> - loop env e1; - loop env e2 - | Proved_unreachable -> () - and loop_named env (named : Flambda.named) = - match named with - | Symbol symbol -> check_symbol_is_bound env symbol - | Const const -> ignore_const const - | Allocated_const const -> ignore_allocated_const const - | Read_mutable mut_var -> - check_mutable_variable_is_bound env mut_var - | Read_symbol_field (symbol, index) -> - check_symbol_is_bound env symbol; - assert (index >= 0) (* CR-someday mshinwell: add proper error *) - | Set_of_closures set_of_closures -> - loop_set_of_closures env set_of_closures - | Project_closure { set_of_closures; closure_id; } -> - check_variable_is_bound env set_of_closures; - ignore_closure_id closure_id - | Move_within_set_of_closures { closure; start_from; move_to; } -> - check_variable_is_bound env closure; - ignore_closure_id start_from; - ignore_closure_id move_to; - | Project_var { closure; closure_id; var; } -> - check_variable_is_bound env closure; - ignore_closure_id closure_id; - ignore_var_within_closure var - | Prim (prim, args, dbg) -> - ignore_primitive prim; - check_variables_are_bound env args; - ignore_debuginfo dbg - | Expr expr -> - loop env expr - and loop_set_of_closures env - ({ Flambda.function_decls; free_vars; specialised_args; - direct_call_surrogates = _; } as set_of_closures) = - (* CR-soon mshinwell: check [direct_call_surrogates] *) - let { Flambda. is_classic_mode; - set_of_closures_id; set_of_closures_origin; funs; } = - function_decls - in - ignore (is_classic_mode : bool); - ignore_set_of_closures_id set_of_closures_id; - ignore_set_of_closures_origin set_of_closures_origin; - let functions_in_closure = Variable.Map.keys funs in - let variables_in_closure = - Variable.Map.fold (fun var (var_in_closure : Flambda.specialised_to) - variables_in_closure -> - (* [var] may occur in the body, but will effectively be renamed - to [var_in_closure], so the latter is what we check to make - sure it's bound. *) - ignore_variable var; - check_variable_is_bound env var_in_closure.var; - Variable.Set.add var variables_in_closure) - free_vars Variable.Set.empty - in - let all_params, all_free_vars = - Variable.Map.fold (fun fun_var function_decl acc -> - let all_params, all_free_vars = acc in - (* CR-soon mshinwell: check function_decl.all_symbols *) - let { Flambda.params; body; free_variables; stub; dbg; _ } = - function_decl - in - assert (Variable.Set.mem fun_var functions_in_closure); - ignore_bool stub; - ignore_debuginfo dbg; - (* Check that [free_variables], which is only present as an - optimization, is not lying. *) - let free_variables' = Flambda.free_variables body in - if not (Variable.Set.subset free_variables' free_variables) then - raise (Free_variables_set_is_lying (fun_var, - free_variables, free_variables', function_decl)); - (* Check that every variable free in the body of the function is - bound by either the set of closures or the parameter list. *) - let acceptable_free_variables = - Variable.Set.union - (Variable.Set.union variables_in_closure functions_in_closure) - (Parameter.Set.vars params) - in - let bad = - Variable.Set.diff free_variables acceptable_free_variables - in - if not (Variable.Set.is_empty bad) then begin - raise (Vars_in_function_body_not_bound_by_closure_or_params - (bad, set_of_closures, fun_var)) - end; - (* Check that parameters are unique across all functions in the - declaration. *) - let old_all_params_size = Variable.Set.cardinal all_params in - let params = Parameter.Set.vars params in - let params_size = Variable.Set.cardinal params in - let all_params = Variable.Set.union all_params params in - let all_params_size = Variable.Set.cardinal all_params in - if all_params_size <> old_all_params_size + params_size then begin - raise (Function_decls_have_overlapping_parameters all_params) - end; - (* Check that parameters and function variables are not - bound somewhere else in the program *) - declare_variables params; - declare_variable fun_var; - (* Check that the body of the functions is correctly structured *) - let body_env = - let (var_env, _, sym_env) = env in - let var_env = - Variable.Set.fold (fun var -> Variable.Set.add var) - free_variables var_env - in - (* Mutable variables cannot be captured by closures *) - let mut_env = Mutable_variable.Set.empty in - (var_env, mut_env, sym_env) - in - loop body_env body; - all_params, Variable.Set.union free_variables all_free_vars) - funs (Variable.Set.empty, Variable.Set.empty) - in - (* CR-soon pchambart: This is not a property that we can certainly - ensure. - If the function get inlined, it is possible for the inlined version - to still use that variable. To be able to ensure that, we need to - also ensure that the inlined version will certainly be transformed - in a same way that can drop the dependency. - mshinwell: This should get some thought after the first release to - decide for sure what to do. *) - (* Check that the free variables rewriting map in the set of closures - does not contain variables in its domain that are not actually free - variables of any of the function bodies. *) - let bad_free_vars = - Variable.Set.diff (Variable.Map.keys free_vars) all_free_vars - in -(* - if not (Variable.Set.is_empty bad_free_vars) then begin - raise (Set_of_closures_free_vars_map_has_wrong_range bad_free_vars) - end; -*) - (* CR-someday pchambart: Ignore it to avoid the warning: get rid of that - when the case is settled *) - ignore (Set_of_closures_free_vars_map_has_wrong_range bad_free_vars); - (* Check that free variables are not bound somewhere - else in the program *) - declare_variables (Variable.Map.keys free_vars); - (* Check that every "specialised arg" is a parameter of one of the - functions being declared, and that the variable to which the - parameter is being specialised is bound. *) - Variable.Map.iter (fun _inner_var - (specialised_to : Flambda.specialised_to) -> - check_variable_is_bound env specialised_to.var; - match specialised_to.projection with - | None -> () - | Some projection -> - let projecting_from = Projection.projecting_from projection in - if not (Variable.Map.mem projecting_from free_vars) - then begin - raise (Projection_must_be_a_free_var projection) - end) - free_vars; - Variable.Map.iter (fun being_specialised - (specialised_to : Flambda.specialised_to) -> - if not (Variable.Set.mem being_specialised all_params) then begin - raise (Specialised_arg_that_is_not_a_parameter being_specialised) - end; - check_variable_is_bound env specialised_to.var; - match specialised_to.projection with - | None -> () - | Some projection -> - let projecting_from = Projection.projecting_from projection in - if not (Variable.Map.mem projecting_from specialised_args) - then begin - raise (Projection_must_be_a_specialised_arg projection) - end) - specialised_args - in - let loop_constant_defining_value env - (const : Flambda.constant_defining_value) = - match const with - | Flambda.Allocated_const c -> - ignore_allocated_const c - | Flambda.Block (tag,fields) -> - ignore_tag tag; - List.iter (fun (fields : Flambda.constant_defining_value_block_field) -> - match fields with - | Const c -> ignore_const c - | Symbol s -> check_symbol_is_bound env s) - fields - | Flambda.Set_of_closures set_of_closures -> - loop_set_of_closures env set_of_closures; - (* Constant set of closures must not have free variables *) - if not (Variable.Map.is_empty set_of_closures.free_vars) then - assert false; (* TODO: correct error *) - if not (Variable.Map.is_empty set_of_closures.specialised_args) then - assert false; (* TODO: correct error *) - | Flambda.Project_closure (symbol,closure_id) -> - ignore_closure_id closure_id; - check_symbol_is_bound env symbol - in - let rec loop_program_body env (program : Flambda.program_body) = - match program with - | Let_rec_symbol (defs, program) -> - let env = - List.fold_left (fun env (symbol, _) -> - add_binding_occurrence_of_symbol env symbol) - env defs - in - List.iter (fun (_, def) -> - loop_constant_defining_value env def) - defs; - loop_program_body env program - | Let_symbol (symbol, def, program) -> - loop_constant_defining_value env def; - let env = add_binding_occurrence_of_symbol env symbol in - loop_program_body env program - | Initialize_symbol (symbol, _tag, fields, program) -> - List.iter (loop env) fields; - let env = add_binding_occurrence_of_symbol env symbol in - loop_program_body env program - | Effect (expr, program) -> - loop env expr; - loop_program_body env program - | End root -> - check_symbol_is_bound env root - in - let env = - Symbol.Set.fold (fun symbol env -> - add_binding_occurrence_of_symbol env symbol) - program.imported_symbols - (Variable.Set.empty, Mutable_variable.Set.empty, Symbol.Set.empty) - in - loop_program_body env program.program_body - -let primitive_invariants flam = - Flambda_iterators.iter_named (function - | Prim (prim, _, _) -> - begin match prim with - | Psequand | Psequor -> - raise (Sequential_logical_operator_primitives_must_be_expanded prim) - | _ -> () - end - | _ -> ()) - flam - -let declared_var_within_closure (flam:Flambda.program) = - let bound = ref Var_within_closure.Set.empty in - let bound_multiple_times = ref None in - let add_and_check var = - if Var_within_closure.Set.mem var !bound then begin - bound_multiple_times := Some var - end; - bound := Var_within_closure.Set.add var !bound - in - Flambda_iterators.iter_on_set_of_closures_of_program - ~f:(fun ~constant:_ { Flambda. free_vars; _ } -> - Variable.Map.iter (fun id _ -> - let var = Var_within_closure.wrap id in - add_and_check var) - free_vars) - flam; - !bound, !bound_multiple_times - -let no_var_within_closure_is_bound_multiple_times (flam:Flambda.program) = - match declared_var_within_closure flam with - | _, Some var -> raise (Var_within_closure_bound_multiple_times var) - | _, None -> () - -let every_declared_closure_is_from_current_compilation_unit flam = - let current_compilation_unit = Compilation_unit.get_current_exn () in - Flambda_iterators.iter_on_sets_of_closures (fun - { Flambda. function_decls; _ } -> - let compilation_unit = - Set_of_closures_id.get_compilation_unit - function_decls.set_of_closures_id - in - if not (Compilation_unit.equal compilation_unit current_compilation_unit) - then raise (Declared_closure_from_another_unit compilation_unit)) - flam - -let declared_closure_ids program = - let bound = ref Closure_id.Set.empty in - let bound_multiple_times = ref None in - let add_and_check var = - if Closure_id.Set.mem var !bound - then bound_multiple_times := Some var; - bound := Closure_id.Set.add var !bound - in - Flambda_iterators.iter_on_set_of_closures_of_program program - ~f:(fun ~constant:_ { Flambda. function_decls; _; } -> - Variable.Map.iter (fun id _ -> - let var = Closure_id.wrap id in - add_and_check var) - function_decls.funs); - !bound, !bound_multiple_times - -let no_closure_id_is_bound_multiple_times program = - match declared_closure_ids program with - | _, Some closure_id -> - raise (Closure_id_is_bound_multiple_times closure_id) - | _, None -> () - -let declared_set_of_closures_ids program = - let bound = ref Set_of_closures_id.Set.empty in - let bound_multiple_times = ref None in - let add_and_check var = - if Set_of_closures_id.Set.mem var !bound - then bound_multiple_times := Some var; - bound := Set_of_closures_id.Set.add var !bound - in - Flambda_iterators.iter_on_set_of_closures_of_program program - ~f:(fun ~constant:_ { Flambda. function_decls; _; } -> - add_and_check function_decls.set_of_closures_id); - !bound, !bound_multiple_times - -let no_set_of_closures_id_is_bound_multiple_times program = - match declared_set_of_closures_ids program with - | _, Some set_of_closures_id -> - raise (Set_of_closures_id_is_bound_multiple_times set_of_closures_id) - | _, None -> () - -let used_closure_ids (program:Flambda.program) = - let used = ref Closure_id.Set.empty in - let f (flam : Flambda.named) = - match flam with - | Project_closure { closure_id; _} -> - used := Closure_id.Set.add closure_id !used; - | Move_within_set_of_closures { closure = _; start_from; move_to; } -> - used := Closure_id.Set.add start_from !used; - used := Closure_id.Set.add move_to !used - | Project_var { closure = _; closure_id; var = _ } -> - used := Closure_id.Set.add closure_id !used - | Set_of_closures _ | Symbol _ | Const _ | Allocated_const _ - | Prim _ | Expr _ | Read_mutable _ | Read_symbol_field _ -> () - in - (* CR-someday pchambart: check closure_ids of constant_defining_values' - project_closures *) - Flambda_iterators.iter_named_of_program ~f program; - !used - -let used_vars_within_closures (flam:Flambda.program) = - let used = ref Var_within_closure.Set.empty in - let f (flam : Flambda.named) = - match flam with - | Project_var { closure = _; closure_id = _; var; } -> - used := Var_within_closure.Set.add var !used - | _ -> () - in - Flambda_iterators.iter_named_of_program ~f flam; - !used - -let every_used_function_from_current_compilation_unit_is_declared - (program:Flambda.program) = - let current_compilation_unit = Compilation_unit.get_current_exn () in - let declared, _ = declared_closure_ids program in - let used = used_closure_ids program in - let used_from_current_unit = - Closure_id.Set.filter (fun cu -> - Closure_id.in_compilation_unit cu current_compilation_unit) - used - in - let counter_examples = - Closure_id.Set.diff used_from_current_unit declared - in - if Closure_id.Set.is_empty counter_examples - then () - else raise (Unbound_closure_ids counter_examples) - -let every_used_var_within_closure_from_current_compilation_unit_is_declared - (flam:Flambda.program) = - let current_compilation_unit = Compilation_unit.get_current_exn () in - let declared, _ = declared_var_within_closure flam in - let used = used_vars_within_closures flam in - let used_from_current_unit = - Var_within_closure.Set.filter (fun cu -> - Var_within_closure.in_compilation_unit cu current_compilation_unit) - used - in - let counter_examples = - Var_within_closure.Set.diff used_from_current_unit declared in - if Var_within_closure.Set.is_empty counter_examples - then () - else raise (Unbound_vars_within_closures counter_examples) - -let every_static_exception_is_caught flam = - let check env (flam : Flambda.t) = - match flam with - | Static_raise (exn, _) -> - if not (Static_exception.Set.mem exn env) - then raise (Static_exception_not_caught exn) - | _ -> () - in - let rec loop env (flam : Flambda.t) = - match flam with - | Static_catch (i, _, body, handler) -> - let env = Static_exception.Set.add i env in - loop env handler; - loop env body - | exp -> - check env exp; - Flambda_iterators.apply_on_subexpressions (loop env) - (fun (_ : Flambda.named) -> ()) exp - in - loop Static_exception.Set.empty flam - -let every_static_exception_is_caught_at_a_single_position flam = - let caught = ref Static_exception.Set.empty in - let f (flam : Flambda.t) = - match flam with - | Static_catch (i, _, _body, _handler) -> - if Static_exception.Set.mem i !caught then - raise (Static_exception_caught_in_multiple_places i); - caught := Static_exception.Set.add i !caught - | _ -> () - in - Flambda_iterators.iter f (fun (_ : Flambda.named) -> ()) flam - -let _every_move_within_set_of_closures_is_to_a_function_in_the_free_vars - program = - let moves = ref Closure_id.Map.empty in - Flambda_iterators.iter_named_of_program program - ~f:(function - | Move_within_set_of_closures { start_from; move_to; _ } -> - let moved_to = - try Closure_id.Map.find start_from !moves with - | Not_found -> Closure_id.Set.empty - in - moves := - Closure_id.Map.add start_from - (Closure_id.Set.add move_to moved_to) - !moves - | _ -> ()); - Flambda_iterators.iter_on_set_of_closures_of_program program - ~f:(fun ~constant:_ { Flambda.function_decls = { funs; _ }; _ } -> - Variable.Map.iter (fun fun_var { Flambda.free_variables; _ } -> - match Closure_id.Map.find (Closure_id.wrap fun_var) !moves with - | exception Not_found -> () - | moved_to -> - let missing_dependencies = - Variable.Set.diff (Closure_id.unwrap_set moved_to) - free_variables - in - if not (Variable.Set.is_empty missing_dependencies) then - raise (Move_to_a_closure_not_in_the_free_variables - (fun_var, missing_dependencies))) - funs) - -let check_exn ?(kind=Normal) (flam:Flambda.program) = - ignore kind; - try - variable_and_symbol_invariants flam; - no_closure_id_is_bound_multiple_times flam; - no_set_of_closures_id_is_bound_multiple_times flam; - every_used_function_from_current_compilation_unit_is_declared flam; - no_var_within_closure_is_bound_multiple_times flam; - every_used_var_within_closure_from_current_compilation_unit_is_declared - flam; - (* CR-soon pchambart: This invariant is not maintained. It should be - either relaxed or reformulated. Currently, it is safe to disable it as - the potential related errors would result in fatal errors, not in - miscompilations *) - (* every_move_within_set_of_closures_is_to_a_function_in_the_free_vars - flam; *) - Flambda_iterators.iter_exprs_at_toplevel_of_program flam ~f:(fun flam -> - primitive_invariants flam; - every_static_exception_is_caught flam; - every_static_exception_is_caught_at_a_single_position flam; - every_declared_closure_is_from_current_compilation_unit flam) - with exn -> begin - (* CR-someday split printing code into its own function *) - begin match exn with - | Binding_occurrence_not_from_current_compilation_unit var -> - Format.eprintf ">> Binding occurrence of variable marked as not being \ - from the current compilation unit: %a" - Variable.print var - | Mutable_binding_occurrence_not_from_current_compilation_unit mut_var -> - Format.eprintf ">> Binding occurrence of mutable variable marked as not \ - being from the current compilation unit: %a" - Mutable_variable.print mut_var - | Binding_occurrence_of_variable_already_bound var -> - Format.eprintf ">> Binding occurrence of variable that was already \ - bound: %a" - Variable.print var - | Binding_occurrence_of_mutable_variable_already_bound mut_var -> - Format.eprintf ">> Binding occurrence of mutable variable that was \ - already bound: %a" - Mutable_variable.print mut_var - | Binding_occurrence_of_symbol_already_bound sym -> - Format.eprintf ">> Binding occurrence of symbol that was already \ - bound: %a" - Symbol.print sym - | Unbound_variable var -> - Format.eprintf ">> Unbound variable: %a" Variable.print var - | Unbound_mutable_variable mut_var -> - Format.eprintf ">> Unbound mutable variable: %a" - Mutable_variable.print mut_var - | Unbound_symbol sym -> - Format.eprintf ">> Unbound symbol: %a %s" - Symbol.print sym - (Printexc.raw_backtrace_to_string (Printexc.get_callstack 100)) - | Vars_in_function_body_not_bound_by_closure_or_params - (vars, set_of_closures, fun_var) -> - Format.eprintf ">> Variable(s) (%a) in the body of a function \ - declaration (fun_var = %a) that is not bound by either the closure \ - or the function's parameter list. Set of closures: %a" - Variable.Set.print vars - Variable.print fun_var - Flambda.print_set_of_closures set_of_closures - | Function_decls_have_overlapping_parameters vars -> - Format.eprintf ">> Function declarations whose parameters overlap: \ - %a" - Variable.Set.print vars - | Specialised_arg_that_is_not_a_parameter var -> - Format.eprintf ">> Variable in [specialised_args] that is not a \ - parameter of any of the function(s) in the corresponding \ - declaration(s): %a" - Variable.print var - | Projection_must_be_a_free_var var -> - Format.eprintf ">> Projection %a in [free_vars] from a variable that is \ - not a (inner) free variable of the set of closures" - Projection.print var - | Projection_must_be_a_specialised_arg var -> - Format.eprintf ">> Projection %a in [specialised_args] from a variable \ - that is not a (inner) specialised argument variable of the set of \ - closures" - Projection.print var - | Free_variables_set_is_lying (var, claimed, calculated, function_decl) -> - Format.eprintf ">> Function declaration whose [free_variables] set (%a) \ - is not a superset of the result of [Flambda.free_variables] \ - applied to the body of the function (%a). Declaration: %a" - Variable.Set.print claimed - Variable.Set.print calculated - Flambda.print_function_declaration (var, function_decl) - | Set_of_closures_free_vars_map_has_wrong_range vars -> - Format.eprintf ">> [free_vars] map in set of closures has in its range \ - variables that are not free variables of the corresponding \ - functions: %a" - Variable.Set.print vars - | Sequential_logical_operator_primitives_must_be_expanded prim -> - Format.eprintf ">> Sequential logical operator primitives must be \ - expanded (see closure_conversion.ml): %a" - Printclambda_primitives.primitive prim - | Var_within_closure_bound_multiple_times var -> - Format.eprintf ">> Variable within a closure is bound multiple times: \ - %a" - Var_within_closure.print var - | Closure_id_is_bound_multiple_times closure_id -> - Format.eprintf ">> Closure ID is bound multiple times: %a" - Closure_id.print closure_id - | Set_of_closures_id_is_bound_multiple_times set_of_closures_id -> - Format.eprintf ">> Set of closures ID is bound multiple times: %a" - Set_of_closures_id.print set_of_closures_id - | Declared_closure_from_another_unit compilation_unit -> - Format.eprintf ">> Closure declared as being from another compilation \ - unit: %a" - Compilation_unit.print compilation_unit - | Unbound_closure_ids closure_ids -> - Format.eprintf ">> Unbound closure ID(s) from the current compilation \ - unit: %a" - Closure_id.Set.print closure_ids - | Unbound_vars_within_closures vars_within_closures -> - Format.eprintf ">> Unbound variable(s) within closure(s) from the \ - current compilation_unit: %a" - Var_within_closure.Set.print vars_within_closures - | Static_exception_not_caught static_exn -> - Format.eprintf ">> Uncaught static exception: %a" - Static_exception.print static_exn - | Static_exception_caught_in_multiple_places static_exn -> - Format.eprintf ">> Static exception caught in multiple places: %a" - Static_exception.print static_exn - | Move_to_a_closure_not_in_the_free_variables (start_from, move_to) -> - Format.eprintf ">> A Move_within_set_of_closures from the closure %a \ - to closures that are not parts of its free variables: %a" - Variable.print start_from - Variable.Set.print move_to - | exn -> raise exn - end; - Format.eprintf "\n@?"; - raise Flambda_invariants_failed - end diff --git a/middle_end/flambda_invariants.mli b/middle_end/flambda_invariants.mli deleted file mode 100644 index 252578e88e..0000000000 --- a/middle_end/flambda_invariants.mli +++ /dev/null @@ -1,28 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -type flambda_kind = - | Normal - | Lifted - -(** Checking of invariants on Flambda expressions. Raises an exception if - a check fails. *) -val check_exn - : ?kind:flambda_kind - -> Flambda.program - -> unit diff --git a/middle_end/flambda_iterators.ml b/middle_end/flambda_iterators.ml deleted file mode 100644 index a69575da63..0000000000 --- a/middle_end/flambda_iterators.ml +++ /dev/null @@ -1,808 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -let apply_on_subexpressions f f_named (flam : Flambda.t) = - match flam with - | Var _ | Apply _ | Assign _ | Send _ | Proved_unreachable - | Static_raise _ -> () - | Let { defining_expr; body; _ } -> - f_named defining_expr; - f body - | Let_mutable { body; _ } -> - f body - | Let_rec (defs, body) -> - List.iter (fun (_,l) -> f_named l) defs; - f body - | Switch (_, sw) -> - List.iter (fun (_,l) -> f l) sw.consts; - List.iter (fun (_,l) -> f l) sw.blocks; - Misc.may f sw.failaction - | String_switch (_, sw, def) -> - List.iter (fun (_,l) -> f l) sw; - Misc.may f def - | Static_catch (_,_,f1,f2) -> - f f1; f f2; - | Try_with (f1,_,f2) -> - f f1; f f2 - | If_then_else (_,f1, f2) -> - f f1;f f2 - | While (f1,f2) -> - f f1; f f2 - | For { body; _ } -> f body - -let rec list_map_sharing f l = - match l with - | [] -> l - | h :: t -> - let new_t = list_map_sharing f t in - let new_h = f h in - if h == new_h && t == new_t then - l - else - new_h :: new_t - -let may_map_sharing f v = - match v with - | None -> v - | Some s -> - let new_s = f s in - if s == new_s then - v - else - Some new_s - -let map_snd_sharing f ((a, b) as cpl) = - let new_b = f a b in - if b == new_b then - cpl - else - (a, new_b) - -let map_subexpressions f f_named (tree:Flambda.t) : Flambda.t = - match tree with - | Var _ | Apply _ | Assign _ | Send _ | Proved_unreachable - | Static_raise _ -> tree - | Let { var; defining_expr; body; _ } -> - let new_named = f_named var defining_expr in - let new_body = f body in - if new_named == defining_expr && new_body == body then - tree - else - Flambda.create_let var new_named new_body - | Let_rec (defs, body) -> - let new_defs = - list_map_sharing (map_snd_sharing f_named) defs - in - let new_body = f body in - if new_defs == defs && new_body == body then - tree - else - Let_rec (new_defs, new_body) - | Let_mutable mutable_let -> - let new_body = f mutable_let.body in - if new_body == mutable_let.body then - tree - else - Let_mutable { mutable_let with body = new_body } - | Switch (arg, sw) -> - let aux = map_snd_sharing (fun _ v -> f v) in - let new_consts = list_map_sharing aux sw.consts in - let new_blocks = list_map_sharing aux sw.blocks in - let new_failaction = may_map_sharing f sw.failaction in - if sw.failaction == new_failaction && - new_consts == sw.consts && - new_blocks == sw.blocks then - tree - else - let sw = - { sw with - failaction = new_failaction; - consts = new_consts; - blocks = new_blocks; - } - in - Switch (arg, sw) - | String_switch (arg, sw, def) -> - let new_sw = list_map_sharing (map_snd_sharing (fun _ v -> f v)) sw in - let new_def = may_map_sharing f def in - if sw == new_sw && def == new_def then - tree - else - String_switch(arg, new_sw, new_def) - | Static_catch (i, vars, body, handler) -> - let new_body = f body in - let new_handler = f handler in - if new_body == body && new_handler == handler then - tree - else - Static_catch (i, vars, new_body, new_handler) - | Try_with(body, id, handler) -> - let new_body = f body in - let new_handler = f handler in - if body == new_body && handler == new_handler then - tree - else - Try_with(new_body, id, new_handler) - | If_then_else(arg, ifso, ifnot) -> - let new_ifso = f ifso in - let new_ifnot = f ifnot in - if new_ifso == ifso && new_ifnot == ifnot then - tree - else - If_then_else(arg, new_ifso, new_ifnot) - | While(cond, body) -> - let new_cond = f cond in - let new_body = f body in - if new_cond == cond && new_body == body then - tree - else - While(new_cond, new_body) - | For { bound_var; from_value; to_value; direction; body; } -> - let new_body = f body in - if new_body == body then - tree - else - For { bound_var; from_value; to_value; direction; body = new_body; } - -let iter_general = Flambda.iter_general - -let iter f f_named t = iter_general ~toplevel:false f f_named (Is_expr t) -let iter_expr f t = iter f (fun _ -> ()) t -let iter_on_named f f_named t = - iter_general ~toplevel:false f f_named (Is_named t) -let iter_named f_named t = iter (fun (_ : Flambda.t) -> ()) f_named t -let iter_named_on_named f_named named = - iter_general ~toplevel:false (fun (_ : Flambda.t) -> ()) f_named - (Is_named named) - -let iter_toplevel f f_named t = - iter_general ~toplevel:true f f_named (Is_expr t) -let iter_named_toplevel f f_named named = - iter_general ~toplevel:true f f_named (Is_named named) - -let iter_all_immutable_let_and_let_rec_bindings t ~f = - iter_expr (function - | Let { var; defining_expr; _ } -> f var defining_expr - | Let_rec (defs, _) -> List.iter (fun (var, named) -> f var named) defs - | _ -> ()) - t - -let iter_all_toplevel_immutable_let_and_let_rec_bindings t ~f = - iter_general ~toplevel:true - (function - | Let { var; defining_expr; _ } -> f var defining_expr - | Let_rec (defs, _) -> List.iter (fun (var, named) -> f var named) defs - | _ -> ()) - (fun _ -> ()) - (Is_expr t) - -let iter_on_sets_of_closures f t = - iter_named (function - | Set_of_closures clos -> f clos - | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ - | Read_symbol_field _ - | Project_closure _ | Move_within_set_of_closures _ | Project_var _ - | Prim _ | Expr _ -> ()) - t - -let iter_exprs_at_toplevel_of_program (program : Flambda.program) ~f = - let rec loop (program : Flambda.program_body) = - match program with - | Let_symbol (_, Set_of_closures set_of_closures, program) -> - Variable.Map.iter (fun _ (function_decl : Flambda.function_declaration) -> - f function_decl.body) - set_of_closures.function_decls.funs; - loop program - | Let_rec_symbol (defs, program) -> - List.iter (function - | (_, Flambda.Set_of_closures set_of_closures) -> - Variable.Map.iter - (fun _ (function_decl : Flambda.function_declaration) -> - f function_decl.body) - set_of_closures.function_decls.funs - | _ -> ()) defs; - loop program - | Let_symbol (_, _, program) -> - loop program - | Initialize_symbol (_, _, fields, program) -> - List.iter f fields; - loop program - | Effect (expr, program) -> - f expr; - loop program - | End _ -> () - in - loop program.program_body - -let iter_named_of_program program ~f = - iter_exprs_at_toplevel_of_program program ~f:(iter_named f) - -let iter_on_set_of_closures_of_program (program : Flambda.program) ~f = - let rec loop (program : Flambda.program_body) = - match program with - | Let_symbol (_, Set_of_closures set_of_closures, program) -> - f ~constant:true set_of_closures; - Variable.Map.iter (fun _ (function_decl : Flambda.function_declaration) -> - iter_on_sets_of_closures (f ~constant:false) function_decl.body) - set_of_closures.function_decls.funs; - loop program - | Let_rec_symbol (defs, program) -> - List.iter (function - | (_, Flambda.Set_of_closures set_of_closures) -> - f ~constant:true set_of_closures; - Variable.Map.iter - (fun _ (function_decl : Flambda.function_declaration) -> - iter_on_sets_of_closures (f ~constant:false) function_decl.body) - set_of_closures.function_decls.funs - | _ -> ()) defs; - loop program - | Let_symbol (_, _, program) -> - loop program - | Initialize_symbol (_, _, fields, program) -> - List.iter (iter_on_sets_of_closures (f ~constant:false)) fields; - loop program - | Effect (expr, program) -> - iter_on_sets_of_closures (f ~constant:false) expr; - loop program - | End _ -> () - in - loop program.program_body - -let iter_constant_defining_values_on_program (program : Flambda.program) ~f = - let rec loop (program : Flambda.program_body) = - match program with - | Let_symbol (_, const, program) -> - f const; - loop program - | Let_rec_symbol (defs, program) -> - List.iter (fun (_, const) -> f const) defs; - loop program - | Initialize_symbol (_, _, _, program) -> - loop program - | Effect (_, program) -> - loop program - | End _ -> () - in - loop program.program_body - -let map_general ~toplevel f f_named tree = - let rec aux (tree : Flambda.t) = - match tree with - | Let _ -> - Flambda.map_lets tree ~for_defining_expr:aux_named ~for_last_body:aux - ~after_rebuild:f - | _ -> - let exp : Flambda.t = - match tree with - | Var _ | Apply _ | Assign _ | Send _ | Proved_unreachable - | Static_raise _ -> tree - | Let _ -> assert false - | Let_mutable mutable_let -> - let new_body = aux mutable_let.body in - if new_body == mutable_let.body then - tree - else - Let_mutable { mutable_let with body = new_body } - | Let_rec (defs, body) -> - let done_something = ref false in - let defs = - List.map (fun (id, lam) -> - id, aux_named_done_something id lam done_something) - defs - in - let body = aux_done_something body done_something in - if not !done_something then - tree - else - Let_rec (defs, body) - | Switch (arg, sw) -> - let done_something = ref false in - let sw = - { sw with - failaction = - begin match sw.failaction with - | None -> None - | Some failaction -> - Some (aux_done_something failaction done_something) - end; - consts = - List.map (fun (i, v) -> - i, aux_done_something v done_something) - sw.consts; - blocks = - List.map (fun (i, v) -> - i, aux_done_something v done_something) - sw.blocks; - } - in - if not !done_something then - tree - else - Switch (arg, sw) - | String_switch (arg, sw, def) -> - let done_something = ref false in - let sw = - List.map (fun (i, v) -> i, aux_done_something v done_something) sw - in - let def = - match def with - | None -> None - | Some def -> Some (aux_done_something def done_something) - in - if not !done_something then - tree - else - String_switch(arg, sw, def) - | Static_catch (i, vars, body, handler) -> - let new_body = aux body in - let new_handler = aux handler in - if new_body == body && new_handler == handler then - tree - else - Static_catch (i, vars, new_body, new_handler) - | Try_with(body, id, handler) -> - let new_body = aux body in - let new_handler = aux handler in - if new_body == body && new_handler == handler then - tree - else - Try_with (new_body, id, new_handler) - | If_then_else (arg, ifso, ifnot) -> - let new_ifso = aux ifso in - let new_ifnot = aux ifnot in - if new_ifso == ifso && new_ifnot == ifnot then - tree - else - If_then_else (arg, new_ifso, new_ifnot) - | While (cond, body) -> - let new_cond = aux cond in - let new_body = aux body in - if new_cond == cond && new_body == body then - tree - else - While (new_cond, new_body) - | For { bound_var; from_value; to_value; direction; body; } -> - let new_body = aux body in - if new_body == body then - tree - else - For { bound_var; from_value; to_value; direction; - body = new_body; } - in - f exp - and aux_done_something expr done_something = - let new_expr = aux expr in - if not (new_expr == expr) then begin - done_something := true - end; - new_expr - and aux_named (id : Variable.t) (named : Flambda.named) = - let named : Flambda.named = - match named with - | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ - | Project_closure _ | Move_within_set_of_closures _ | Project_var _ - | Prim _ | Read_symbol_field _ -> named - | Set_of_closures ({ function_decls; free_vars; specialised_args; - direct_call_surrogates }) -> - if toplevel then named - else begin - let done_something = ref false in - let funs = - Variable.Map.map (fun (func_decl : Flambda.function_declaration) -> - let new_body = aux func_decl.body in - if new_body == func_decl.body then begin - func_decl - end else begin - done_something := true; - Flambda.update_function_declaration func_decl - ~params:func_decl.params ~body:new_body - end) - function_decls.funs - in - if not !done_something then - named - else - let function_decls = - Flambda.update_function_declarations function_decls ~funs - in - let set_of_closures = - Flambda.create_set_of_closures ~function_decls ~free_vars - ~specialised_args ~direct_call_surrogates - in - Set_of_closures set_of_closures - end - | Expr expr -> - let new_expr = aux expr in - if new_expr == expr then named - else Expr new_expr - in - f_named id named - and aux_named_done_something id named done_something = - let new_named = aux_named id named in - if not (new_named == named) then begin - done_something := true - end; - new_named - in - aux tree - -let iter_apply_on_program program ~f = - iter_exprs_at_toplevel_of_program program ~f:(fun expr -> - iter (function - | Apply apply -> f apply - | _ -> ()) - (fun _ -> ()) - expr) - -let map f f_named tree = - map_general ~toplevel:false f (fun _ n -> f_named n) tree -let map_expr f tree = map f (fun named -> named) tree -let map_named f_named tree = map (fun expr -> expr) f_named tree -let map_named_with_id f_named tree = - map_general ~toplevel:false (fun expr -> expr) f_named tree -let map_toplevel f f_named tree = - map_general ~toplevel:true f (fun _ n -> f_named n) tree -let map_toplevel_expr f_expr tree = - map_toplevel f_expr (fun named -> named) tree -let map_toplevel_named f_named tree = - map_toplevel (fun tree -> tree) f_named tree - -let map_symbols tree ~f = - map_named (function - | (Symbol sym) as named -> - let new_sym = f sym in - if new_sym == sym then - named - else - Symbol new_sym - | ((Read_symbol_field (sym, field)) as named) -> - let new_sym = f sym in - if new_sym == sym then - named - else - Read_symbol_field (new_sym, field) - | (Const _ | Allocated_const _ | Set_of_closures _ | Read_mutable _ - | Project_closure _ | Move_within_set_of_closures _ | Project_var _ - | Prim _ | Expr _) as named -> named) - tree - -let map_symbols_on_set_of_closures - ({ Flambda.function_decls; free_vars; specialised_args; - direct_call_surrogates; } as - set_of_closures) - ~f = - let done_something = ref false in - let funs = - Variable.Map.map (fun (func_decl : Flambda.function_declaration) -> - let body = map_symbols func_decl.body ~f in - if not (body == func_decl.body) then begin - done_something := true; - end; - Flambda.update_function_declaration func_decl - ~params:func_decl.params ~body) - function_decls.funs - in - if not !done_something then - set_of_closures - else - let function_decls = - Flambda.update_function_declarations function_decls ~funs - in - Flambda.create_set_of_closures ~function_decls ~free_vars - ~specialised_args ~direct_call_surrogates - -let map_toplevel_sets_of_closures tree ~f = - map_toplevel_named (function - | (Set_of_closures set_of_closures) as named -> - let new_set_of_closures = f set_of_closures in - if new_set_of_closures == set_of_closures then - named - else - Set_of_closures new_set_of_closures - | (Symbol _ | Const _ | Allocated_const _ | Read_mutable _ - | Read_symbol_field _ - | Project_closure _ | Move_within_set_of_closures _ | Project_var _ - | Prim _ | Expr _) as named -> named) - tree - -let map_apply tree ~f = - map (function - | (Apply apply) as expr -> - let new_apply = f apply in - if new_apply == apply then - expr - else - Apply new_apply - | expr -> expr) - (fun named -> named) - tree - -let map_sets_of_closures tree ~f = - map_named (function - | (Set_of_closures set_of_closures) as named -> - let new_set_of_closures = f set_of_closures in - if new_set_of_closures == set_of_closures then - named - else - Set_of_closures new_set_of_closures - | (Symbol _ | Const _ | Allocated_const _ | Project_closure _ - | Move_within_set_of_closures _ | Project_var _ - | Prim _ | Expr _ | Read_mutable _ - | Read_symbol_field _) as named -> named) - tree - -let map_project_var_to_expr_opt tree ~f = - map_named (function - | (Project_var project_var) as named -> - begin match f project_var with - | None -> named - | Some expr -> Expr expr - end - | (Symbol _ | Const _ | Allocated_const _ - | Set_of_closures _ | Project_closure _ | Move_within_set_of_closures _ - | Prim _ | Expr _ | Read_mutable _ | Read_symbol_field _) - as named -> named) - tree - -let map_project_var_to_named_opt tree ~f = - map_named (function - | (Project_var project_var) as named -> - begin match f project_var with - | None -> named - | Some named -> named - end - | (Symbol _ | Const _ | Allocated_const _ - | Set_of_closures _ | Project_closure _ | Move_within_set_of_closures _ - | Prim _ | Expr _ | Read_mutable _ | Read_symbol_field _) - as named -> named) - tree - -let map_function_bodies (set_of_closures : Flambda.set_of_closures) ~f = - let done_something = ref false in - let funs = - Variable.Map.map (fun (function_decl : Flambda.function_declaration) -> - let new_body = f function_decl.body in - if new_body == function_decl.body then - function_decl - else begin - done_something := true; - Flambda.update_function_declaration function_decl - ~body:new_body ~params:function_decl.params - end) - set_of_closures.function_decls.funs - in - if not !done_something then - set_of_closures - else - let function_decls = - Flambda.update_function_declarations set_of_closures.function_decls ~funs - in - Flambda.create_set_of_closures - ~function_decls - ~free_vars:set_of_closures.free_vars - ~specialised_args:set_of_closures.specialised_args - ~direct_call_surrogates:set_of_closures.direct_call_surrogates - -let map_sets_of_closures_of_program (program : Flambda.program) - ~(f : Flambda.set_of_closures -> Flambda.set_of_closures) = - let rec loop (program : Flambda.program_body) : Flambda.program_body = - let map_constant_set_of_closures (set_of_closures:Flambda.set_of_closures) = - let done_something = ref false in - let function_decls = - let funs = - Variable.Map.map (fun - (function_decl : Flambda.function_declaration) -> - let body = map_sets_of_closures ~f function_decl.body in - if body == function_decl.body then - function_decl - else begin - done_something := true; - Flambda.update_function_declaration function_decl - ~body ~params:function_decl.params - end) - set_of_closures.function_decls.funs - in - if not !done_something then - set_of_closures.function_decls - else - Flambda.update_function_declarations set_of_closures.function_decls - ~funs - in - let new_set_of_closures = f set_of_closures in - if new_set_of_closures == set_of_closures then - set_of_closures - else - Flambda.create_set_of_closures ~function_decls - ~free_vars:set_of_closures.free_vars - ~specialised_args:set_of_closures.specialised_args - ~direct_call_surrogates:set_of_closures.direct_call_surrogates - in - match program with - | Let_symbol (symbol, Set_of_closures set_of_closures, program') -> - let new_set_of_closures = map_constant_set_of_closures set_of_closures in - let new_program' = loop program' in - if new_set_of_closures == set_of_closures - && new_program' == program' then - program - else - Let_symbol (symbol, Set_of_closures new_set_of_closures, new_program') - | Let_symbol (symbol, const, program') -> - let new_program' = loop program' in - if new_program' == program' then - program - else - Let_symbol (symbol, const, new_program') - | Let_rec_symbol (defs, program') -> - let done_something = ref false in - let defs = - List.map (function - | (var, Flambda.Set_of_closures set_of_closures) -> - let new_set_of_closures = - map_constant_set_of_closures set_of_closures - in - if not (new_set_of_closures == set_of_closures) then begin - done_something := true - end; - var, Flambda.Set_of_closures new_set_of_closures - | def -> def) - defs - in - let new_program' = loop program' in - if new_program' == program' && not !done_something then - program - else - Let_rec_symbol (defs, loop program') - | Initialize_symbol (symbol, tag, fields, program') -> - let done_something = ref false in - let fields = - List.map (fun field -> - let new_field = map_sets_of_closures field ~f in - if not (new_field == field) then begin - done_something := true - end; - new_field) - fields - in - let new_program' = loop program' in - if new_program' == program' && not !done_something then - program - else - Initialize_symbol (symbol, tag, fields, new_program') - | Effect (expr, program') -> - let new_expr = map_sets_of_closures expr ~f in - let new_program' = loop program' in - if new_expr == expr && new_program' == program' then - program - else - Effect (new_expr, new_program') - | End _ -> program - in - { program with - program_body = loop program.program_body; - } - -let map_exprs_at_toplevel_of_program (program : Flambda.program) - ~(f : Flambda.t -> Flambda.t) = - let rec loop (program : Flambda.program_body) : Flambda.program_body = - let map_constant_set_of_closures (set_of_closures:Flambda.set_of_closures) = - let done_something = ref false in - let funs = - Variable.Map.map (fun (function_decl : Flambda.function_declaration) -> - let body = f function_decl.body in - if body == function_decl.body then - function_decl - else begin - done_something := true; - Flambda.update_function_declaration function_decl - ~body ~params:function_decl.params - end) - set_of_closures.function_decls.funs - in - if not !done_something then - set_of_closures - else - let function_decls = - Flambda.update_function_declarations set_of_closures.function_decls - ~funs - in - Flambda.create_set_of_closures ~function_decls - ~free_vars:set_of_closures.free_vars - ~specialised_args:set_of_closures.specialised_args - ~direct_call_surrogates:set_of_closures.direct_call_surrogates - in - (* CR-soon mshinwell: code very similar to the above function *) - match program with - | Let_symbol (symbol, Set_of_closures set_of_closures, program') -> - let new_set_of_closures = map_constant_set_of_closures set_of_closures in - let new_program' = loop program' in - if new_set_of_closures == set_of_closures - && new_program' == program' then - program - else - Let_symbol (symbol, Set_of_closures new_set_of_closures, new_program') - | Let_symbol (symbol, const, program') -> - let new_program' = loop program' in - if new_program' == program' then - program - else - Let_symbol (symbol, const, new_program') - | Let_rec_symbol (defs, program') -> - let done_something = ref false in - let defs = - List.map (function - | (var, Flambda.Set_of_closures set_of_closures) -> - let new_set_of_closures = - map_constant_set_of_closures set_of_closures - in - if not (new_set_of_closures == set_of_closures) then begin - done_something := true - end; - var, Flambda.Set_of_closures new_set_of_closures - | def -> def) - defs - in - let new_program' = loop program' in - if new_program' == program' && not !done_something then - program - else - Let_rec_symbol (defs, new_program') - | Initialize_symbol (symbol, tag, fields, program') -> - let done_something = ref false in - let fields = - List.map (fun field -> - let new_field = f field in - if not (new_field == field) then begin - done_something := true - end; - new_field) - fields - in - let new_program' = loop program' in - if new_program' == program' && not !done_something then - program - else - Initialize_symbol (symbol, tag, fields, new_program') - | Effect (expr, program') -> - let new_expr = f expr in - let new_program' = loop program' in - if new_expr == expr && new_program' == program' then - program - else - Effect (new_expr, new_program') - | End _ -> program - in - { program with - program_body = loop program.program_body; - } - -let map_named_of_program (program : Flambda.program) - ~(f : Variable.t -> Flambda.named -> Flambda.named) : Flambda.program = - map_exprs_at_toplevel_of_program program - ~f:(fun expr -> map_named_with_id f expr) - -let map_all_immutable_let_and_let_rec_bindings (expr : Flambda.t) - ~(f : Variable.t -> Flambda.named -> Flambda.named) : Flambda.t = - map_named_with_id f expr - -let fold_function_decls_ignoring_stubs - (set_of_closures : Flambda.set_of_closures) ~init ~f = - Variable.Map.fold (fun fun_var function_decl acc -> - f ~fun_var ~function_decl acc) - set_of_closures.function_decls.funs - init diff --git a/middle_end/flambda_iterators.mli b/middle_end/flambda_iterators.mli deleted file mode 100644 index 02fe685097..0000000000 --- a/middle_end/flambda_iterators.mli +++ /dev/null @@ -1,227 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -(* CR-soon mshinwell: we need to document whether these iterators follow any - particular order. *) - -(** Apply the given functions to the immediate subexpressions of the given - Flambda expression. For avoidance of doubt, if a subexpression is - [Expr], it is passed to the function taking [Flambda.named], rather - than being followed and passed to the function taking [Flambda.t]. *) -val apply_on_subexpressions - : (Flambda.t -> unit) - -> (Flambda.named -> unit) - -> Flambda.t - -> unit - -val map_subexpressions - : (Flambda.t -> Flambda.t) - -> (Variable.t -> Flambda.named -> Flambda.named) - -> Flambda.t - -> Flambda.t - -(* CR-soon lwhite: add comment to clarify that these recurse unlike the - ones above *) -val iter - : (Flambda.t -> unit) - -> (Flambda.named -> unit) - -> Flambda.t - -> unit - -val iter_expr - : (Flambda.t -> unit) - -> Flambda.t - -> unit - -val iter_on_named - : (Flambda.t -> unit) - -> (Flambda.named -> unit) - -> Flambda.named - -> unit - -(* CR-someday mshinwell: we might need to add the corresponding variable to - the parameters of the user function for [iter_named] *) -val iter_named - : (Flambda.named -> unit) - -> Flambda.t - -> unit - -(* CR-someday lwhite: These names are pretty indecipherable, perhaps - create submodules for the normal and "on_named" variants of each - function. *) - -val iter_named_on_named - : (Flambda.named -> unit) - -> Flambda.named - -> unit - -(** [iter_toplevel f t] applies [f] on every toplevel subexpression of [t]. - In particular, it never applies [f] to the body of a function (which - will always be contained within an [Set_of_closures] expression). *) -val iter_toplevel - : (Flambda.t -> unit) - -> (Flambda.named -> unit) - -> Flambda.t - -> unit - -val iter_named_toplevel - : (Flambda.t -> unit) - -> (Flambda.named -> unit) - -> Flambda.named - -> unit - -val iter_on_sets_of_closures - : (Flambda.set_of_closures -> unit) - -> Flambda.t - -> unit - -val iter_on_set_of_closures_of_program - : Flambda.program - -> f:(constant:bool -> Flambda.set_of_closures -> unit) - -> unit - -val iter_all_immutable_let_and_let_rec_bindings - : Flambda.t - -> f:(Variable.t -> Flambda.named -> unit) - -> unit - -val iter_all_toplevel_immutable_let_and_let_rec_bindings - : Flambda.t - -> f:(Variable.t -> Flambda.named -> unit) - -> unit - -val iter_exprs_at_toplevel_of_program - : Flambda.program - -> f:(Flambda.t -> unit) - -> unit - -val iter_named_of_program - : Flambda.program - -> f:(Flambda.named -> unit) - -> unit - -val iter_constant_defining_values_on_program - : Flambda.program - -> f:(Flambda.constant_defining_value -> unit) - -> unit - -val iter_apply_on_program - : Flambda.program - -> f:(Flambda.apply -> unit) - -> unit - -val map - : (Flambda.t -> Flambda.t) - -> (Flambda.named -> Flambda.named) - -> Flambda.t - -> Flambda.t - -val map_expr - : (Flambda.t -> Flambda.t) - -> Flambda.t - -> Flambda.t - -val map_named - : (Flambda.named -> Flambda.named) - -> Flambda.t - -> Flambda.t - -val map_toplevel - : (Flambda.t -> Flambda.t) - -> (Flambda.named -> Flambda.named) - -> Flambda.t - -> Flambda.t - -val map_toplevel_expr - : (Flambda.t -> Flambda.t) - -> Flambda.t - -> Flambda.t - -val map_toplevel_named - : (Flambda.named -> Flambda.named) - -> Flambda.t - -> Flambda.t - -val map_symbols - : Flambda.t - -> f:(Symbol.t -> Symbol.t) - -> Flambda.t - -val map_symbols_on_set_of_closures - : Flambda.set_of_closures - -> f:(Symbol.t -> Symbol.t) - -> Flambda.set_of_closures - -val map_toplevel_sets_of_closures - : Flambda.t - -> f:(Flambda.set_of_closures -> Flambda.set_of_closures) - -> Flambda.t - -val map_apply - : Flambda.t - -> f:(Flambda.apply -> Flambda.apply) - -> Flambda.t - -val map_function_bodies - : Flambda.set_of_closures - -> f:(Flambda.t -> Flambda.t) - -> Flambda.set_of_closures - -val map_sets_of_closures - : Flambda.t - -> f:(Flambda.set_of_closures -> Flambda.set_of_closures) - -> Flambda.t - -val map_sets_of_closures_of_program - : Flambda.program - -> f:(Flambda.set_of_closures -> Flambda.set_of_closures) - -> Flambda.program - -val map_project_var_to_expr_opt - : Flambda.t - -> f:(Flambda.project_var -> Flambda.t option) - -> Flambda.t - -val map_project_var_to_named_opt - : Flambda.t - -> f:(Flambda.project_var -> Flambda.named option) - -> Flambda.t - -val map_exprs_at_toplevel_of_program - : Flambda.program - -> f:(Flambda.t -> Flambda.t) - -> Flambda.program - -val map_named_of_program - : Flambda.program - -> f:(Variable.t -> Flambda.named -> Flambda.named) - -> Flambda.program - -val map_all_immutable_let_and_let_rec_bindings - : Flambda.t - -> f:(Variable.t -> Flambda.named -> Flambda.named) - -> Flambda.t - -val fold_function_decls_ignoring_stubs - : Flambda.set_of_closures - -> init:'a - -> f:(fun_var:Variable.t - -> function_decl:Flambda.function_declaration - -> 'a - -> 'a) - -> 'a diff --git a/middle_end/flambda_utils.ml b/middle_end/flambda_utils.ml deleted file mode 100644 index c204f5e67c..0000000000 --- a/middle_end/flambda_utils.ml +++ /dev/null @@ -1,929 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -let name_expr ~name (named : Flambda.named) : Flambda.t = - let var = - Variable.create - ~current_compilation_unit:(Compilation_unit.get_current_exn ()) - name - in - Flambda.create_let var named (Var var) - -let name_expr_from_var ~var (named : Flambda.named) : Flambda.t = - let var = - Variable.rename - ~current_compilation_unit:(Compilation_unit.get_current_exn ()) - var - in - Flambda.create_let var named (Var var) - -let find_declaration cf ({ funs } : Flambda.function_declarations) = - Variable.Map.find (Closure_id.unwrap cf) funs - -let find_declaration_variable cf ({ funs } : Flambda.function_declarations) = - let var = Closure_id.unwrap cf in - if not (Variable.Map.mem var funs) - then raise Not_found - else var - -let find_free_variable cv ({ free_vars } : Flambda.set_of_closures) = - let var : Flambda.specialised_to = - Variable.Map.find (Var_within_closure.unwrap cv) free_vars - in - var.var - -let function_arity (f : Flambda.function_declaration) = List.length f.params - -let variables_bound_by_the_closure cf - (decls : Flambda.function_declarations) = - let func = find_declaration cf decls in - let params = Parameter.Set.vars func.params in - let functions = Variable.Map.keys decls.funs in - Variable.Set.diff - (Variable.Set.diff func.free_variables params) - functions - -let description_of_toplevel_node (expr : Flambda.t) = - match expr with - | Var id -> Format.asprintf "var %a" Variable.print id - | Apply _ -> "apply" - | Assign _ -> "assign" - | Send _ -> "send" - | Proved_unreachable -> "unreachable" - | Let { var; _ } -> Format.asprintf "let %a" Variable.print var - | Let_mutable _ -> "let_mutable" - | Let_rec _ -> "letrec" - | If_then_else _ -> "if" - | Switch _ -> "switch" - | String_switch _ -> "stringswitch" - | Static_raise _ -> "staticraise" - | Static_catch _ -> "catch" - | Try_with _ -> "trywith" - | While _ -> "while" - | For _ -> "for" - -let equal_direction_flag - (x : Asttypes.direction_flag) - (y : Asttypes.direction_flag) = - match x, y with - | Upto, Upto -> true - | Downto, Downto -> true - | (Upto | Downto), _ -> false - -let rec same (l1 : Flambda.t) (l2 : Flambda.t) = - l1 == l2 || (* it is ok for the string case: if they are physically the same, - it is the same original branch *) - match (l1, l2) with - | Var v1 , Var v2 -> Variable.equal v1 v2 - | Var _, _ | _, Var _ -> false - | Apply a1 , Apply a2 -> - Flambda.equal_call_kind a1.kind a2.kind - && Variable.equal a1.func a2.func - && Misc.Stdlib.List.equal Variable.equal a1.args a2.args - | Apply _, _ | _, Apply _ -> false - | Let { var = var1; defining_expr = defining_expr1; body = body1; _ }, - Let { var = var2; defining_expr = defining_expr2; body = body2; _ } -> - Variable.equal var1 var2 && same_named defining_expr1 defining_expr2 - && same body1 body2 - | Let _, _ | _, Let _ -> false - | Let_mutable {var = mv1; initial_value = v1; contents_kind = ck1; body = b1}, - Let_mutable {var = mv2; initial_value = v2; contents_kind = ck2; body = b2} - -> - Mutable_variable.equal mv1 mv2 - && Variable.equal v1 v2 - && Lambda.equal_value_kind ck1 ck2 - && same b1 b2 - | Let_mutable _, _ | _, Let_mutable _ -> false - | Let_rec (bl1, a1), Let_rec (bl2, a2) -> - Misc.Stdlib.List.equal samebinding bl1 bl2 && same a1 a2 - | Let_rec _, _ | _, Let_rec _ -> false - | Switch (a1, s1), Switch (a2, s2) -> - Variable.equal a1 a2 && sameswitch s1 s2 - | Switch _, _ | _, Switch _ -> false - | String_switch (a1, s1, d1), String_switch (a2, s2, d2) -> - Variable.equal a1 a2 - && Misc.Stdlib.List.equal - (fun (s1, e1) (s2, e2) -> String.equal s1 s2 && same e1 e2) s1 s2 - && Option.equal same d1 d2 - | String_switch _, _ | _, String_switch _ -> false - | Static_raise (e1, a1), Static_raise (e2, a2) -> - Static_exception.equal e1 e2 && Misc.Stdlib.List.equal Variable.equal a1 a2 - | Static_raise _, _ | _, Static_raise _ -> false - | Static_catch (s1, v1, a1, b1), Static_catch (s2, v2, a2, b2) -> - Static_exception.equal s1 s2 - && Misc.Stdlib.List.equal Variable.equal v1 v2 - && same a1 a2 - && same b1 b2 - | Static_catch _, _ | _, Static_catch _ -> false - | Try_with (a1, v1, b1), Try_with (a2, v2, b2) -> - same a1 a2 && Variable.equal v1 v2 && same b1 b2 - | Try_with _, _ | _, Try_with _ -> false - | If_then_else (a1, b1, c1), If_then_else (a2, b2, c2) -> - Variable.equal a1 a2 && same b1 b2 && same c1 c2 - | If_then_else _, _ | _, If_then_else _ -> false - | While (a1, b1), While (a2, b2) -> - same a1 a2 && same b1 b2 - | While _, _ | _, While _ -> false - | For { bound_var = bound_var1; from_value = from_value1; - to_value = to_value1; direction = direction1; body = body1; }, - For { bound_var = bound_var2; from_value = from_value2; - to_value = to_value2; direction = direction2; body = body2; } -> - Variable.equal bound_var1 bound_var2 - && Variable.equal from_value1 from_value2 - && Variable.equal to_value1 to_value2 - && equal_direction_flag direction1 direction2 - && same body1 body2 - | For _, _ | _, For _ -> false - | Assign { being_assigned = being_assigned1; new_value = new_value1; }, - Assign { being_assigned = being_assigned2; new_value = new_value2; } -> - Mutable_variable.equal being_assigned1 being_assigned2 - && Variable.equal new_value1 new_value2 - | Assign _, _ | _, Assign _ -> false - | Send { kind = kind1; meth = meth1; obj = obj1; args = args1; dbg = _; }, - Send { kind = kind2; meth = meth2; obj = obj2; args = args2; dbg = _; } -> - Lambda.equal_meth_kind kind1 kind2 - && Variable.equal meth1 meth2 - && Variable.equal obj1 obj2 - && Misc.Stdlib.List.equal Variable.equal args1 args2 - | Send _, _ | _, Send _ -> false - | Proved_unreachable, Proved_unreachable -> true - -and same_named (named1 : Flambda.named) (named2 : Flambda.named) = - match named1, named2 with - | Symbol s1 , Symbol s2 -> Symbol.equal s1 s2 - | Symbol _, _ | _, Symbol _ -> false - | Const c1, Const c2 -> Flambda.compare_const c1 c2 = 0 - | Const _, _ | _, Const _ -> false - | Allocated_const c1, Allocated_const c2 -> - Allocated_const.compare c1 c2 = 0 - | Allocated_const _, _ | _, Allocated_const _ -> false - | Read_mutable mv1, Read_mutable mv2 -> Mutable_variable.equal mv1 mv2 - | Read_mutable _, _ | _, Read_mutable _ -> false - | Read_symbol_field (s1, i1), Read_symbol_field (s2, i2) -> - Symbol.equal s1 s2 && i1 = i2 - | Read_symbol_field _, _ | _, Read_symbol_field _ -> false - | Set_of_closures s1, Set_of_closures s2 -> same_set_of_closures s1 s2 - | Set_of_closures _, _ | _, Set_of_closures _ -> false - | Project_closure f1, Project_closure f2 -> same_project_closure f1 f2 - | Project_closure _, _ | _, Project_closure _ -> false - | Project_var v1, Project_var v2 -> - Variable.equal v1.closure v2.closure - && Closure_id.equal v1.closure_id v2.closure_id - && Var_within_closure.equal v1.var v2.var - | Project_var _, _ | _, Project_var _ -> false - | Move_within_set_of_closures m1, Move_within_set_of_closures m2 -> - same_move_within_set_of_closures m1 m2 - | Move_within_set_of_closures _, _ | _, Move_within_set_of_closures _ -> - false - | Prim (p1, al1, _), Prim (p2, al2, _) -> - Clambda_primitives.equal p1 p2 - && Misc.Stdlib.List.equal Variable.equal al1 al2 - | Prim _, _ | _, Prim _ -> false - | Expr e1, Expr e2 -> same e1 e2 - -and sameclosure (c1 : Flambda.function_declaration) - (c2 : Flambda.function_declaration) = - Misc.Stdlib.List.equal Parameter.equal c1.params c2.params - && same c1.body c2.body - -and same_set_of_closures (c1 : Flambda.set_of_closures) - (c2 : Flambda.set_of_closures) = - Variable.Map.equal sameclosure c1.function_decls.funs c2.function_decls.funs - && Variable.Map.equal Flambda.equal_specialised_to - c1.free_vars c2.free_vars - && Variable.Map.equal Flambda.equal_specialised_to c1.specialised_args - c2.specialised_args - -and same_project_closure (s1 : Flambda.project_closure) - (s2 : Flambda.project_closure) = - Variable.equal s1.set_of_closures s2.set_of_closures - && Closure_id.equal s1.closure_id s2.closure_id - -and same_move_within_set_of_closures (m1 : Flambda.move_within_set_of_closures) - (m2 : Flambda.move_within_set_of_closures) = - Variable.equal m1.closure m2.closure - && Closure_id.equal m1.start_from m2.start_from - && Closure_id.equal m1.move_to m2.move_to - -and samebinding (v1, n1) (v2, n2) = - Variable.equal v1 v2 && same_named n1 n2 - -and sameswitch (fs1 : Flambda.switch) (fs2 : Flambda.switch) = - let samecase (n1, a1) (n2, a2) = n1 = n2 && same a1 a2 in - Numbers.Int.Set.equal fs1.numconsts fs2.numconsts - && Numbers.Int.Set.equal fs1.numblocks fs2.numblocks - && Misc.Stdlib.List.equal samecase fs1.consts fs2.consts - && Misc.Stdlib.List.equal samecase fs1.blocks fs2.blocks - && Option.equal same fs1.failaction fs2.failaction - -let can_be_merged = same - -(* CR-soon mshinwell: this should use the explicit ignore functions *) -let toplevel_substitution sb tree = - let sb' = sb in - let sb v = try Variable.Map.find v sb with Not_found -> v in - let aux (flam : Flambda.t) : Flambda.t = - match flam with - | Var var -> - let var = sb var in - Var var - | Let_mutable mutable_let -> - let initial_value = sb mutable_let.initial_value in - Let_mutable { mutable_let with initial_value } - | Assign { being_assigned; new_value; } -> - let new_value = sb new_value in - Assign { being_assigned; new_value; } - | Apply { func; args; kind; dbg; inline; specialise; } -> - let func = sb func in - let args = List.map sb args in - Apply { func; args; kind; dbg; inline; specialise; } - | If_then_else (cond, e1, e2) -> - let cond = sb cond in - If_then_else (cond, e1, e2) - | Switch (cond, sw) -> - let cond = sb cond in - Switch (cond, sw) - | String_switch (cond, branches, def) -> - let cond = sb cond in - String_switch (cond, branches, def) - | Send { kind; meth; obj; args; dbg } -> - let meth = sb meth in - let obj = sb obj in - let args = List.map sb args in - Send { kind; meth; obj; args; dbg } - | For { bound_var; from_value; to_value; direction; body } -> - let from_value = sb from_value in - let to_value = sb to_value in - For { bound_var; from_value; to_value; direction; body } - | Static_raise (static_exn, args) -> - let args = List.map sb args in - Static_raise (static_exn, args) - | Static_catch _ | Try_with _ | While _ - | Let _ | Let_rec _ | Proved_unreachable -> flam - in - let aux_named (named : Flambda.named) : Flambda.named = - match named with - | Symbol _ | Const _ | Expr _ -> named - | Allocated_const _ | Read_mutable _ -> named - | Read_symbol_field _ -> named - | Set_of_closures set_of_closures -> - let set_of_closures = - Flambda.create_set_of_closures - ~function_decls:set_of_closures.function_decls - ~free_vars: - (Variable.Map.map (fun (spec_to : Flambda.specialised_to) -> - { spec_to with var = sb spec_to.var; }) - set_of_closures.free_vars) - ~specialised_args: - (Variable.Map.map (fun (spec_to : Flambda.specialised_to) -> - { spec_to with var = sb spec_to.var; }) - set_of_closures.specialised_args) - ~direct_call_surrogates:set_of_closures.direct_call_surrogates - in - Set_of_closures set_of_closures - | Project_closure project_closure -> - Project_closure { - project_closure with - set_of_closures = sb project_closure.set_of_closures; - } - | Move_within_set_of_closures move_within_set_of_closures -> - Move_within_set_of_closures { - move_within_set_of_closures with - closure = sb move_within_set_of_closures.closure; - } - | Project_var project_var -> - Project_var { - project_var with - closure = sb project_var.closure; - } - | Prim (prim, args, dbg) -> - Prim (prim, List.map sb args, dbg) - in - if Variable.Map.is_empty sb' then tree - else Flambda_iterators.map_toplevel aux aux_named tree - -(* CR-someday mshinwell: Fix [Flambda_iterators] so this can be implemented - properly. *) -let toplevel_substitution_named sb named = - let name = Internal_variable_names.toplevel_substitution_named in - let expr = name_expr named ~name in - match toplevel_substitution sb expr with - | Let let_expr -> let_expr.defining_expr - | _ -> assert false - -let make_closure_declaration - ~is_classic_mode ~id ~body ~params ~stub : Flambda.t = - let free_variables = Flambda.free_variables body in - let param_set = Parameter.Set.vars params in - if not (Variable.Set.subset param_set free_variables) then begin - Misc.fatal_error "Flambda_utils.make_closure_declaration" - end; - let sb = - Variable.Set.fold - (fun id sb -> Variable.Map.add id (Variable.rename id) sb) - free_variables Variable.Map.empty - in - (* CR-soon mshinwell: try to eliminate this [toplevel_substitution]. This - function is only called from [Inline_and_simplify], so we should be able - to do something similar to what happens in [Inlining_transforms] now. *) - let body = toplevel_substitution sb body in - let subst id = Variable.Map.find id sb in - let subst_param param = Parameter.map_var subst param in - let function_declaration = - Flambda.create_function_declaration ~params:(List.map subst_param params) - ~body ~stub ~dbg:Debuginfo.none ~inline:Default_inline - ~specialise:Default_specialise ~is_a_functor:false - ~closure_origin:(Closure_origin.create (Closure_id.wrap id)) - in - assert (Variable.Set.equal (Variable.Set.map subst free_variables) - function_declaration.free_variables); - let free_vars = - Variable.Map.fold (fun id id' fv' -> - let spec_to : Flambda.specialised_to = - { var = id; - projection = None; - } - in - Variable.Map.add id' spec_to fv') - (Variable.Map.filter - (fun id _ -> not (Variable.Set.mem id param_set)) - sb) - Variable.Map.empty - in - let compilation_unit = Compilation_unit.get_current_exn () in - let set_of_closures_var = - Variable.create Internal_variable_names.set_of_closures - ~current_compilation_unit:compilation_unit - in - let set_of_closures = - let function_decls = - Flambda.create_function_declarations - ~is_classic_mode - ~funs:(Variable.Map.singleton id function_declaration) - in - Flambda.create_set_of_closures ~function_decls ~free_vars - ~specialised_args:Variable.Map.empty - ~direct_call_surrogates:Variable.Map.empty - in - let project_closure : Flambda.named = - Project_closure { - set_of_closures = set_of_closures_var; - closure_id = Closure_id.wrap id; - } - in - let project_closure_var = - Variable.create Internal_variable_names.project_closure - ~current_compilation_unit:compilation_unit - in - Flambda.create_let set_of_closures_var (Set_of_closures set_of_closures) - (Flambda.create_let project_closure_var project_closure - (Var (project_closure_var))) - -let bind ~bindings ~body = - List.fold_left (fun expr (var, var_def) -> - Flambda.create_let var var_def expr) - body bindings - -let all_lifted_constants (program : Flambda.program) = - let rec loop (program : Flambda.program_body) = - match program with - | Let_symbol (symbol, decl, program) -> (symbol, decl) :: (loop program) - | Let_rec_symbol (decls, program) -> - List.fold_left (fun l (symbol, decl) -> (symbol, decl) :: l) - (loop program) - decls - | Initialize_symbol (_, _, _, program) - | Effect (_, program) -> loop program - | End _ -> [] - in - loop program.program_body - -let all_lifted_constants_as_map program = - Symbol.Map.of_list (all_lifted_constants program) - -let initialize_symbols (program : Flambda.program) = - let rec loop (program : Flambda.program_body) = - match program with - | Initialize_symbol (symbol, tag, fields, program) -> - (symbol, tag, fields) :: (loop program) - | Effect (_, program) - | Let_symbol (_, _, program) - | Let_rec_symbol (_, program) -> loop program - | End _ -> [] - in - loop program.program_body - -let imported_symbols (program : Flambda.program) = - program.imported_symbols - -let needed_import_symbols (program : Flambda.program) = - let dependencies = Flambda.free_symbols_program program in - let defined_symbol = - Symbol.Set.union - (Symbol.Set.of_list - (List.map fst (all_lifted_constants program))) - (Symbol.Set.of_list - (List.map (fun (s, _, _) -> s) (initialize_symbols program))) - in - Symbol.Set.diff dependencies defined_symbol - -let introduce_needed_import_symbols program : Flambda.program = - { program with - imported_symbols = needed_import_symbols program; - } - -let root_symbol (program : Flambda.program) = - let rec loop (program : Flambda.program_body) = - match program with - | Effect (_, program) - | Let_symbol (_, _, program) - | Let_rec_symbol (_, program) - | Initialize_symbol (_, _, _, program) -> loop program - | End root -> - root - in - loop program.program_body - -let might_raise_static_exn flam stexn = - try - Flambda_iterators.iter_on_named - (function - | Flambda.Static_raise (ex, _) when Static_exception.equal ex stexn -> - raise Exit - | _ -> ()) - (fun _ -> ()) - flam; - false - with Exit -> true - -let make_closure_map program = - let map = ref Closure_id.Map.empty in - let add_set_of_closures ~constant:_ : Flambda.set_of_closures -> unit = fun - { function_decls } -> - Variable.Map.iter (fun var _ -> - let closure_id = Closure_id.wrap var in - let set_of_closures_id = function_decls.set_of_closures_id in - map := Closure_id.Map.add closure_id set_of_closures_id !map) - function_decls.funs - in - Flambda_iterators.iter_on_set_of_closures_of_program - program - ~f:add_set_of_closures; - !map - -let all_lifted_constant_closures program = - List.fold_left (fun unchanged flambda -> - match flambda with - | (_, Flambda.Set_of_closures { function_decls = { funs } }) -> - Variable.Map.fold - (fun key (_ : Flambda.function_declaration) acc -> - Closure_id.Set.add (Closure_id.wrap key) acc) - funs - unchanged - | _ -> unchanged) - Closure_id.Set.empty - (all_lifted_constants program) - -let all_lifted_constant_sets_of_closures program = - let set = ref Set_of_closures_id.Set.empty in - List.iter (function - | (_, Flambda.Set_of_closures { - function_decls = { set_of_closures_id } }) -> - set := Set_of_closures_id.Set.add set_of_closures_id !set - | _ -> ()) - (all_lifted_constants program); - !set - -let all_sets_of_closures program = - let list = ref [] in - Flambda_iterators.iter_on_set_of_closures_of_program program - ~f:(fun ~constant:_ set_of_closures -> - list := set_of_closures :: !list); - !list - -let all_sets_of_closures_map program = - let r = ref Set_of_closures_id.Map.empty in - Flambda_iterators.iter_on_set_of_closures_of_program program - ~f:(fun ~constant:_ set_of_closures -> - r := Set_of_closures_id.Map.add - set_of_closures.function_decls.set_of_closures_id - set_of_closures !r); - !r - -let substitute_read_symbol_field_for_variables - (substitution : (Symbol.t * int list) Variable.Map.t) - (expr : Flambda.t) = - let bind var fresh_var (expr:Flambda.t) : Flambda.t = - let symbol, path = Variable.Map.find var substitution in - let rec make_named (path:int list) : Flambda.named = - match path with - | [] -> Symbol symbol - | [i] -> Read_symbol_field (symbol, i) - | h :: t -> - let block_name = Internal_variable_names.symbol_field_block in - let block = Variable.create block_name in - let field_name = Internal_variable_names.get_symbol_field in - let field = Variable.create field_name in - Expr ( - Flambda.create_let block (make_named t) - (Flambda.create_let field - (Prim (Pfield h, [block], Debuginfo.none)) - (Var field))) - in - Flambda.create_let fresh_var (make_named path) expr - in - let substitute_named bindings (named:Flambda.named) : Flambda.named = - let sb to_substitute = - try Variable.Map.find to_substitute bindings with - | Not_found -> - to_substitute - in - match named with - | Symbol _ | Const _ | Expr _ -> named - | Allocated_const _ | Read_mutable _ -> named - | Read_symbol_field _ -> named - | Set_of_closures set_of_closures -> - let set_of_closures = - Flambda.create_set_of_closures - ~function_decls:set_of_closures.function_decls - ~free_vars: - (Variable.Map.map (fun (spec_to : Flambda.specialised_to) -> - { spec_to with var = sb spec_to.var; }) - set_of_closures.free_vars) - ~specialised_args: - (Variable.Map.map (fun (spec_to : Flambda.specialised_to) -> - { spec_to with var = sb spec_to.var; }) - set_of_closures.specialised_args) - ~direct_call_surrogates:set_of_closures.direct_call_surrogates - in - Set_of_closures set_of_closures - | Project_closure project_closure -> - Project_closure { - project_closure with - set_of_closures = sb project_closure.set_of_closures; - } - | Move_within_set_of_closures move_within_set_of_closures -> - Move_within_set_of_closures { - move_within_set_of_closures with - closure = sb move_within_set_of_closures.closure; - } - | Project_var project_var -> - Project_var { - project_var with - closure = sb project_var.closure; - } - | Prim (prim, args, dbg) -> - Prim (prim, List.map sb args, dbg) - in - let make_var_subst var = - if Variable.Map.mem var substitution then - let fresh = Variable.rename var in - fresh, (fun expr -> bind var fresh expr) - else - var, (fun x -> x) - in - let f (expr:Flambda.t) : Flambda.t = - match expr with - | Var v when Variable.Map.mem v substitution -> - let fresh = Variable.rename v in - bind v fresh (Var fresh) - | Var _ -> expr - | Let ({ var = v; defining_expr = named; _ } as let_expr) -> - let to_substitute = - Variable.Set.filter - (fun v -> Variable.Map.mem v substitution) - (Flambda.free_variables_named named) - in - if Variable.Set.is_empty to_substitute then - expr - else - let bindings = - Variable.Map.of_set (fun var -> Variable.rename var) to_substitute - in - let named = - substitute_named bindings named - in - let expr = - let module W = Flambda.With_free_variables in - W.create_let_reusing_body v named (W.of_body_of_let let_expr) - in - Variable.Map.fold (fun to_substitute fresh expr -> - bind to_substitute fresh expr) - bindings expr - | Let_mutable let_mutable when - Variable.Map.mem let_mutable.initial_value substitution -> - let fresh = Variable.rename let_mutable.initial_value in - bind let_mutable.initial_value fresh - (Let_mutable { let_mutable with initial_value = fresh }) - | Let_mutable _ -> - expr - | Let_rec (defs, body) -> - let free_variables_of_defs = - List.fold_left (fun set (_, named) -> - Variable.Set.union set (Flambda.free_variables_named named)) - Variable.Set.empty defs - in - let to_substitute = - Variable.Set.filter - (fun v -> Variable.Map.mem v substitution) - free_variables_of_defs - in - if Variable.Set.is_empty to_substitute then - expr - else begin - let bindings = - Variable.Map.of_set (fun var -> Variable.rename var) to_substitute - in - let defs = - List.map (fun (var, named) -> - var, substitute_named bindings named) - defs - in - let expr = - Flambda.Let_rec (defs, body) - in - Variable.Map.fold (fun to_substitute fresh expr -> - bind to_substitute fresh expr) - bindings expr - end - | If_then_else (cond, ifso, ifnot) - when Variable.Map.mem cond substitution -> - let fresh = Variable.rename cond in - bind cond fresh (If_then_else (fresh, ifso, ifnot)) - | If_then_else _ -> - expr - | Switch (cond, sw) when Variable.Map.mem cond substitution -> - let fresh = Variable.rename cond in - bind cond fresh (Switch (fresh, sw)) - | Switch _ -> - expr - | String_switch (cond, sw, def) when Variable.Map.mem cond substitution -> - let fresh = Variable.rename cond in - bind cond fresh (String_switch (fresh, sw, def)) - | String_switch _ -> - expr - | Assign { being_assigned; new_value } - when Variable.Map.mem new_value substitution -> - let fresh = Variable.rename new_value in - bind new_value fresh (Assign { being_assigned; new_value = fresh }) - | Assign _ -> - expr - | Static_raise (exn, args) -> - let args, bind_args = - List.split (List.map make_var_subst args) - in - List.fold_right (fun f expr -> f expr) bind_args @@ - Flambda.Static_raise (exn, args) - | For { bound_var; from_value; to_value; direction; body } -> - let from_value, bind_from_value = make_var_subst from_value in - let to_value, bind_to_value = make_var_subst to_value in - bind_from_value @@ - bind_to_value @@ - Flambda.For { bound_var; from_value; to_value; direction; body } - | Apply { func; args; kind; dbg; inline; specialise } -> - let func, bind_func = make_var_subst func in - let args, bind_args = - List.split (List.map make_var_subst args) - in - bind_func @@ - List.fold_right (fun f expr -> f expr) bind_args @@ - Flambda.Apply { func; args; kind; dbg; inline; specialise } - | Send { kind; meth; obj; args; dbg } -> - let meth, bind_meth = make_var_subst meth in - let obj, bind_obj = make_var_subst obj in - let args, bind_args = - List.split (List.map make_var_subst args) - in - bind_meth @@ - bind_obj @@ - List.fold_right (fun f expr -> f expr) bind_args @@ - Flambda.Send { kind; meth; obj; args; dbg } - | Proved_unreachable - | While _ - | Try_with _ - | Static_catch _ -> - (* No variables directly used in those expressions *) - expr - in - Flambda_iterators.map_toplevel f (fun v -> v) expr - -module Switch_storer = Switch.Store (struct - type t = Flambda.t - - (* An easily-comparable subset of [Flambda.t]: currently this only - supports that required to share switch branches. *) - type key = - | Var of Variable.t - | Let of Variable.t * key_named * key - | Static_raise of Static_exception.t * Variable.t list - and key_named = - | Symbol of Symbol.t - | Const of Flambda.const - | Prim of Clambda_primitives.primitive * Variable.t list - | Expr of key - - exception Not_comparable - - let rec make_expr_key (expr : Flambda.t) : key = - match expr with - | Var v -> Var v - | Let { var; defining_expr; body; } -> - Let (var, make_named_key defining_expr, make_expr_key body) - | Static_raise (e, args) -> Static_raise (e, args) - | _ -> raise Not_comparable - and make_named_key (named:Flambda.named) : key_named = - match named with - | Symbol s -> Symbol s - | Const c -> Const c - | Expr e -> Expr (make_expr_key e) - | Prim (prim, args, _dbg) -> Prim (prim, args) - | _ -> raise Not_comparable - - let make_key expr = - match make_expr_key expr with - | exception Not_comparable -> None - | key -> Some key - - let compare_key e1 e2 = - (* The environment [env] maps variables bound in [e2] to the corresponding - bound variables in [e1]. Every variable to compare in [e2] must have an - equivalent in [e1], otherwise the comparison wouldn't have gone - past the [Let] binding. Hence [Variable.Map.find] is safe here. *) - let compare_var env v1 v2 = - match Variable.Map.find v2 env with - | exception Not_found -> - (* The variable is free in the expression [e2], hence we can - compare it with [v1] directly. *) - Variable.compare v1 v2 - | bound -> - Variable.compare v1 bound - in - let rec compare_expr env (e1 : key) (e2 : key) : int = - match e1, e2 with - | Var v1, Var v2 -> - compare_var env v1 v2 - | Var _, (Let _| Static_raise _) -> -1 - | (Let _| Static_raise _), Var _ -> 1 - | Let (v1, n1, b1), Let (v2, n2, b2) -> - let comp_named = compare_named env n1 n2 in - if comp_named <> 0 then comp_named - else - let env = Variable.Map.add v2 v1 env in - compare_expr env b1 b2 - | Let _, Static_raise _ -> -1 - | Static_raise _, Let _ -> 1 - | Static_raise (sexn1, args1), Static_raise (sexn2, args2) -> - let comp_sexn = Static_exception.compare sexn1 sexn2 in - if comp_sexn <> 0 then comp_sexn - else Misc.Stdlib.List.compare (compare_var env) args1 args2 - and compare_named env (n1:key_named) (n2:key_named) : int = - match n1, n2 with - | Symbol s1, Symbol s2 -> Symbol.compare s1 s2 - | Symbol _, (Const _ | Expr _ | Prim _) -> -1 - | (Const _ | Expr _ | Prim _), Symbol _ -> 1 - | Const c1, Const c2 -> Flambda.compare_const c1 c2 - | Const _, (Expr _ | Prim _) -> -1 - | (Expr _ | Prim _), Const _ -> 1 - | Expr e1, Expr e2 -> compare_expr env e1 e2 - | Expr _, Prim _ -> -1 - | Prim _, Expr _ -> 1 - | Prim (prim1, args1), Prim (prim2, args2) -> - let comp_prim = Stdlib.compare prim1 prim2 in - if comp_prim <> 0 then comp_prim - else Misc.Stdlib.List.compare (compare_var env) args1 args2 - in - compare_expr Variable.Map.empty e1 e2 -end) - -let fun_vars_referenced_in_decls - (function_decls : Flambda.function_declarations) ~closure_symbol = - let fun_vars = Variable.Map.keys function_decls.funs in - let symbols_to_fun_vars = - Variable.Set.fold (fun fun_var symbols_to_fun_vars -> - let closure_id = Closure_id.wrap fun_var in - let symbol = closure_symbol closure_id in - Symbol.Map.add symbol fun_var symbols_to_fun_vars) - fun_vars - Symbol.Map.empty - in - Variable.Map.map (fun (func_decl : Flambda.function_declaration) -> - let from_symbols = - Symbol.Set.fold (fun symbol fun_vars' -> - match Symbol.Map.find symbol symbols_to_fun_vars with - | exception Not_found -> fun_vars' - | fun_var -> - assert (Variable.Set.mem fun_var fun_vars); - Variable.Set.add fun_var fun_vars') - func_decl.free_symbols - Variable.Set.empty - in - let from_variables = - Variable.Set.inter func_decl.free_variables fun_vars - in - Variable.Set.union from_symbols from_variables) - function_decls.funs - -let closures_required_by_entry_point ~(entry_point : Closure_id.t) - ~closure_symbol (function_decls : Flambda.function_declarations) = - let dependencies = - fun_vars_referenced_in_decls function_decls ~closure_symbol - in - let set = ref Variable.Set.empty in - let queue = Queue.create () in - let add v = - if not (Variable.Set.mem v !set) then begin - set := Variable.Set.add v !set; - Queue.push v queue - end - in - add (Closure_id.unwrap entry_point); - while not (Queue.is_empty queue) do - let fun_var = Queue.pop queue in - match Variable.Map.find fun_var dependencies with - | exception Not_found -> () - | fun_dependencies -> - Variable.Set.iter (fun dep -> - if Variable.Map.mem dep function_decls.funs then - add dep) - fun_dependencies - done; - !set - -let all_functions_parameters (function_decls : Flambda.function_declarations) = - Variable.Map.fold (fun _ ({ params } : Flambda.function_declaration) set -> - Variable.Set.union set (Parameter.Set.vars params)) - function_decls.funs Variable.Set.empty - -let all_free_symbols (function_decls : Flambda.function_declarations) = - Variable.Map.fold (fun _ (function_decl : Flambda.function_declaration) - syms -> - Symbol.Set.union syms function_decl.free_symbols) - function_decls.funs Symbol.Set.empty - -let contains_stub (fun_decls : Flambda.function_declarations) = - let number_of_stub_functions = - Variable.Map.cardinal - (Variable.Map.filter (fun _ { Flambda.stub } -> stub) - fun_decls.funs) - in - number_of_stub_functions > 0 - -let clean_projections ~which_variables = - Variable.Map.map (fun (spec_to : Flambda.specialised_to) -> - match spec_to.projection with - | None -> spec_to - | Some projection -> - let from = Projection.projecting_from projection in - if Variable.Map.mem from which_variables then - spec_to - else - ({ spec_to with projection = None; } : Flambda.specialised_to)) - which_variables - -let projection_to_named (projection : Projection.t) : Flambda.named = - match projection with - | Project_var project_var -> Project_var project_var - | Project_closure project_closure -> Project_closure project_closure - | Move_within_set_of_closures move -> Move_within_set_of_closures move - | Field (field_index, var) -> - Prim (Pfield field_index, [var], Debuginfo.none) - -type specialised_to_same_as = - | Not_specialised - | Specialised_and_aliased_to of Variable.Set.t - -let parameters_specialised_to_the_same_variable - ~(function_decls : Flambda.function_declarations) - ~(specialised_args : Flambda.specialised_to Variable.Map.t) = - let specialised_arg_aliasing = - (* For each external variable involved in a specialisation, which - internal variable(s) it maps to via that specialisation. *) - Variable.Map.transpose_keys_and_data_set - (Variable.Map.map (fun ({ var; _ } : Flambda.specialised_to) -> var) - specialised_args) - in - Variable.Map.map (fun ({ params; _ } : Flambda.function_declaration) -> - List.map (fun param -> - match Variable.Map.find (Parameter.var param) specialised_args with - | exception Not_found -> Not_specialised - | { var; _ } -> - Specialised_and_aliased_to - (Variable.Map.find var specialised_arg_aliasing)) - params) - function_decls.funs diff --git a/middle_end/flambda_utils.mli b/middle_end/flambda_utils.mli deleted file mode 100644 index 0f7b318627..0000000000 --- a/middle_end/flambda_utils.mli +++ /dev/null @@ -1,220 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -(** Utility functions for the Flambda intermediate language. *) - -(** Access functions *) - -(** [find_declaration f decl] raises [Not_found] if [f] is not in [decl]. *) -val find_declaration : - Closure_id.t -> Flambda.function_declarations -> Flambda.function_declaration - -(** [find_declaration_variable f decl] raises [Not_found] if [f] is not in - [decl]. *) -val find_declaration_variable : - Closure_id.t -> Flambda.function_declarations -> Variable.t - -(** [find_free_variable v clos] raises [Not_found] if [c] is not in [clos]. *) -val find_free_variable : - Var_within_closure.t -> Flambda.set_of_closures -> Variable.t - -(** Utility functions *) - -val function_arity : Flambda.function_declaration -> int - -(** Variables "bound by a closure" are those variables free in the - corresponding function's body that are neither: - - bound as parameters of that function; nor - - bound by the [let] binding that introduces the function declaration(s). - In particular, if [f], [g] and [h] are being introduced by a - simultaneous, possibly mutually-recursive [let] binding then none of - [f], [g] or [h] are bound in any of the closures for [f], [g] and [h]. -*) -val variables_bound_by_the_closure : - Closure_id.t -> Flambda.function_declarations -> Variable.Set.t - -(** If [can_be_merged f1 f2] is [true], it is safe to merge switch - branches containing [f1] and [f2]. *) -val can_be_merged : Flambda.t -> Flambda.t -> bool - -val description_of_toplevel_node : Flambda.t -> string - -(* Given an expression, freshen all variables within it, and form a function - whose body is the resulting expression. The variables specified by - [params] will become the parameters of the function; the closure will be - identified by [id]. [params] must only reference variables that are - free variables of [body]. *) -(* CR-soon mshinwell: consider improving name and names of arguments - lwhite: the params restriction seems odd, perhaps give a reason - in the comment. *) -val make_closure_declaration - : is_classic_mode:bool - -> id:Variable.t - -> body:Flambda.t - -> params:Parameter.t list - -> stub:bool - -> Flambda.t - -val toplevel_substitution - : Variable.t Variable.Map.t - -> Flambda.expr - -> Flambda.expr - -val toplevel_substitution_named - : Variable.t Variable.Map.t - -> Flambda.named - -> Flambda.named - -(** [bind [var1, expr1; ...; varN, exprN] body] binds using - [Immutable] [Let] expressions the given [(var, expr)] pairs around the - body. *) -val bind - : bindings:(Variable.t * Flambda.named) list - -> body:Flambda.t - -> Flambda.t - -val name_expr - : name:Internal_variable_names.t - -> Flambda.named - -> Flambda.t - -val name_expr_from_var - : var:Variable.t - -> Flambda.named - -> Flambda.t - -val initialize_symbols - : Flambda.program - -> (Symbol.t * Tag.t * Flambda.t list) list - -val imported_symbols : Flambda.program -> Symbol.Set.t - -val needed_import_symbols : Flambda.program -> Symbol.Set.t - -val introduce_needed_import_symbols : Flambda.program -> Flambda.program - -val root_symbol : Flambda.program -> Symbol.t - -(** Returns [true] iff the given term might raise the given static - exception. *) -val might_raise_static_exn : Flambda.named -> Static_exception.t -> bool - -(** Creates a map from closure IDs to set_of_closure IDs by iterating over - all sets of closures in the given program. *) -val make_closure_map - : Flambda.program - -> Set_of_closures_id.t Closure_id.Map.t - -(** The definitions of all constants that have been lifted out to [Let_symbol] - or [Let_rec_symbol] constructions. *) -val all_lifted_constants - : Flambda.program - -> (Symbol.t * Flambda.constant_defining_value) list - -(** Like [all_lifted_constant_symbols], but returns a map instead of a list. *) -val all_lifted_constants_as_map - : Flambda.program - -> Flambda.constant_defining_value Symbol.Map.t - -(** The identifiers of all constant sets of closures that have been lifted out - to [Let_symbol] or [Let_rec_symbol] constructions. *) -val all_lifted_constant_sets_of_closures - : Flambda.program - -> Set_of_closures_id.Set.t - -val all_lifted_constant_closures : Flambda.program -> Closure_id.Set.t - -(** All sets of closures in the given program (whether or not bound to a - symbol.) *) -val all_sets_of_closures : Flambda.program -> Flambda.set_of_closures list - -val all_sets_of_closures_map - : Flambda.program - -> Flambda.set_of_closures Set_of_closures_id.Map.t - - -(* CR-someday pchambart: A more general version of this function might - take a [named] instead of a symbol and be called with - [Read_symbol_field (symbol, 0)]. *) -val substitute_read_symbol_field_for_variables - : (Symbol.t * int list) Variable.Map.t - -> Flambda.t - -> Flambda.t - -(** For the compilation of switch statements. *) -module Switch_storer : sig - val mk_store : unit -> (Flambda.t, unit) Switch.t_store -end - -(** Within a set of function declarations there is a set of function bodies, - each of which may (or may not) reference one of the other functions in - the same set. Initially such intra-set references are by [Var]s (known - as "fun_var"s) but if the function is lifted by [Lift_constants] then the - references will be translated to [Symbol]s. This means that optimization - passes that need to identify whether a given "fun_var" (i.e. a key in the - [funs] map in a value of type [function_declarations]) is used in one of - the function bodies need to examine the [free_symbols] as well as the - [free_variables] members of [function_declarations]. This function makes - that process easier by computing all used "fun_var"s in the bodies of - the given set of function declarations, including the cases where the - references are [Symbol]s. The returned value is a map from "fun_var"s - to the "fun_var"s (if any) used in the body of the function associated - with that "fun_var". -*) -val fun_vars_referenced_in_decls - : Flambda.function_declarations - -> closure_symbol:(Closure_id.t -> Symbol.t) - -> Variable.Set.t Variable.Map.t - -(** Computes the set of closure_id in the set of closures that are - required used (transitively) the entry_point *) -val closures_required_by_entry_point - : entry_point:Closure_id.t - -> closure_symbol:(Closure_id.t -> Symbol.t) - -> Flambda.function_declarations - -> Variable.Set.t - -val all_functions_parameters : Flambda.function_declarations -> Variable.Set.t - -val all_free_symbols : Flambda.function_declarations -> Symbol.Set.t - -val contains_stub : Flambda.function_declarations -> bool - -(* Ensure that projection information is suitably erased from - free_vars and specialised_args if we have deleted the variable being - projected from. *) -val clean_projections - : which_variables : Flambda.specialised_to Variable.Map.t - -> Flambda.specialised_to Variable.Map.t - -val projection_to_named : Projection.t -> Flambda.named - -type specialised_to_same_as = - | Not_specialised - | Specialised_and_aliased_to of Variable.Set.t - -(** For each parameter in a given set of function declarations and the usual - specialised-args mapping, determine which other parameters are specialised - to the same variable as that parameter. - The result is presented as a map from [fun_vars] to lists, corresponding - componentwise to the usual [params] list in the corresponding function - declaration. *) -val parameters_specialised_to_the_same_variable - : function_decls:Flambda.function_declarations - -> specialised_args:Flambda.specialised_to Variable.Map.t - -> specialised_to_same_as list Variable.Map.t diff --git a/middle_end/freshening.ml b/middle_end/freshening.ml deleted file mode 100644 index 891861a33e..0000000000 --- a/middle_end/freshening.ml +++ /dev/null @@ -1,458 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -type tbl = { - sb_var : Variable.t Variable.Map.t; - sb_mutable_var : Mutable_variable.t Mutable_variable.Map.t; - sb_exn : Static_exception.t Static_exception.Map.t; - (* Used to handle substitution sequences: we cannot call the substitution - recursively because there can be name clashes. *) - back_var : Variable.t list Variable.Map.t; - back_mutable_var : Mutable_variable.t list Mutable_variable.Map.t; -} - -type t = - | Inactive - | Active of tbl - -type subst = t - -let empty_tbl = { - sb_var = Variable.Map.empty; - sb_mutable_var = Mutable_variable.Map.empty; - sb_exn = Static_exception.Map.empty; - back_var = Variable.Map.empty; - back_mutable_var = Mutable_variable.Map.empty; -} - -let print ppf = function - | Inactive -> Format.fprintf ppf "Inactive" - | Active tbl -> - Format.fprintf ppf "Active:@ "; - Variable.Map.iter (fun var1 var2 -> - Format.fprintf ppf "%a -> %a@ " - Variable.print var1 - Variable.print var2) - tbl.sb_var; - Mutable_variable.Map.iter (fun mut_var1 mut_var2 -> - Format.fprintf ppf "(mutable) %a -> %a@ " - Mutable_variable.print mut_var1 - Mutable_variable.print mut_var2) - tbl.sb_mutable_var; - Variable.Map.iter (fun var vars -> - Format.fprintf ppf "%a -> %a@ " - Variable.print var - Variable.Set.print (Variable.Set.of_list vars)) - tbl.back_var; - Mutable_variable.Map.iter (fun mut_var mut_vars -> - Format.fprintf ppf "(mutable) %a -> %a@ " - Mutable_variable.print mut_var - Mutable_variable.Set.print (Mutable_variable.Set.of_list mut_vars)) - tbl.back_mutable_var - -let empty = Inactive - -let is_empty = function - | Inactive -> true - | Active _ -> false - -let empty_preserving_activation_state = function - | Inactive -> Inactive - | Active _ -> Active empty_tbl - -let activate = function - | Inactive -> Active empty_tbl - | Active _ as t -> t - -let rec add_sb_var sb id id' = - let sb = { sb with sb_var = Variable.Map.add id id' sb.sb_var } in - let sb = - try let pre_vars = Variable.Map.find id sb.back_var in - List.fold_left (fun sb pre_id -> add_sb_var sb pre_id id') sb pre_vars - with Not_found -> sb in - let back_var = - let l = try Variable.Map.find id' sb.back_var with Not_found -> [] in - Variable.Map.add id' (id :: l) sb.back_var in - { sb with back_var } - -let rec add_sb_mutable_var sb id id' = - let sb = - { sb with - sb_mutable_var = Mutable_variable.Map.add id id' sb.sb_mutable_var; - } - in - let sb = - try - let pre_vars = Mutable_variable.Map.find id sb.back_mutable_var in - List.fold_left (fun sb pre_id -> add_sb_mutable_var sb pre_id id') - sb pre_vars - with Not_found -> sb in - let back_mutable_var = - let l = - try Mutable_variable.Map.find id' sb.back_mutable_var - with Not_found -> [] - in - Mutable_variable.Map.add id' (id :: l) sb.back_mutable_var - in - { sb with back_mutable_var } - -let apply_static_exception t i = - match t with - | Inactive -> - i - | Active t -> - try Static_exception.Map.find i t.sb_exn - with Not_found -> i - -let add_static_exception t i = - match t with - | Inactive -> i, t - | Active t -> - let i' = Static_exception.create () in - let sb_exn = - Static_exception.Map.add i i' t.sb_exn - in - i', Active { t with sb_exn; } - -let active_add_variable t id = - let id' = Variable.rename id in - let t = add_sb_var t id id' in - id', t - -let active_add_parameter t param = - let param' = Parameter.rename param in - let t = add_sb_var t (Parameter.var param) (Parameter.var param') in - param', t - -let add_variable t id = - match t with - | Inactive -> id, t - | Active t -> - let id', t = active_add_variable t id in - id', Active t - -let active_add_parameters' t (params:Parameter.t list) = - List.fold_right (fun param (params, t) -> - let param', t = active_add_parameter t param in - param' :: params, t) - params ([], t) - -let add_variables t defs = - List.fold_right (fun (id, data) (defs, t) -> - let id', t = add_variable t id in - (id', data) :: defs, t) defs ([], t) - -let add_variables' t ids = - List.fold_right (fun id (ids, t) -> - let id', t = add_variable t id in - id' :: ids, t) ids ([], t) - -let active_add_mutable_variable t id = - let id' = Mutable_variable.rename id in - let t = add_sb_mutable_var t id id' in - id', t - -let add_mutable_variable t id = - match t with - | Inactive -> id, t - | Active t -> - let id', t = active_add_mutable_variable t id in - id', Active t - -let active_find_var_exn t id = - try Variable.Map.find id t.sb_var with - | Not_found -> - Misc.fatal_error (Format.asprintf "find_var: can't find %a@." - Variable.print id) - -let apply_variable t var = - match t with - | Inactive -> var - | Active t -> - try Variable.Map.find var t.sb_var with - | Not_found -> var - -let apply_mutable_variable t mut_var = - match t with - | Inactive -> mut_var - | Active t -> - try Mutable_variable.Map.find mut_var t.sb_mutable_var with - | Not_found -> mut_var - -let rewrite_recursive_calls_with_symbols t - (function_declarations : Flambda.function_declarations) - ~make_closure_symbol = - match t with - | Inactive -> function_declarations - | Active _ -> - let all_free_symbols = - Variable.Map.fold - (fun _ (function_decl : Flambda.function_declaration) - syms -> - Symbol.Set.union syms function_decl.free_symbols) - function_declarations.funs Symbol.Set.empty - in - let closure_symbols_used = ref false in - let closure_symbols = - Variable.Map.fold (fun var _ map -> - let closure_id = Closure_id.wrap var in - let sym = make_closure_symbol closure_id in - if Symbol.Set.mem sym all_free_symbols then begin - closure_symbols_used := true; - Symbol.Map.add sym var map - end else begin - map - end) - function_declarations.funs Symbol.Map.empty - in - if not !closure_symbols_used then begin - (* Don't waste time rewriting the function declaration(s) if there - are no occurrences of any of the closure symbols. *) - function_declarations - end else begin - let funs = - Variable.Map.map (fun (ffun : Flambda.function_declaration) -> - let body = - Flambda_iterators.map_toplevel_named - (* CR-someday pchambart: This may be worth deep substituting - below the closures, but that means that we need to take care - of functions' free variables. *) - (function - | Symbol sym when Symbol.Map.mem sym closure_symbols -> - Expr (Var (Symbol.Map.find sym closure_symbols)) - | e -> e) - ffun.body - in - Flambda.update_body_of_function_declaration ffun ~body) - function_declarations.funs - in - Flambda.update_function_declarations function_declarations ~funs - end - -module Project_var = struct - type t = - { vars_within_closure : Var_within_closure.t Var_within_closure.Map.t; - closure_id : Closure_id.t Closure_id.Map.t } - - let empty = - { vars_within_closure = Var_within_closure.Map.empty; - closure_id = Closure_id.Map.empty; - } - - let print ppf t = - Format.fprintf ppf "{ vars_within_closure %a, closure_id %a }" - (Var_within_closure.Map.print Var_within_closure.print) - t.vars_within_closure - (Closure_id.Map.print Closure_id.print) - t.closure_id - - let new_subst_fv t id subst = - match subst with - | Inactive -> id, subst, t - | Active subst -> - let id' = Variable.rename id in - let subst = add_sb_var subst id id' in - let off = Var_within_closure.wrap id in - let off' = Var_within_closure.wrap id' in - let off_sb = Var_within_closure.Map.add off off' t.vars_within_closure in - id', Active subst, { t with vars_within_closure = off_sb; } - - let new_subst_fun t id subst = - let id' = Variable.rename id in - let subst = add_sb_var subst id id' in - let off = Closure_id.wrap id in - let off' = Closure_id.wrap id' in - let off_sb = Closure_id.Map.add off off' t.closure_id in - id', subst, { t with closure_id = off_sb; } - - (** Returns : - * The map of new_identifiers -> expression - * The new environment with added substitution - * a fresh ffunction_subst with only the substitution of free variables - *) - let subst_free_vars fv subst ~only_freshen_parameters - : (Flambda.specialised_to * _) Variable.Map.t * _ * _ = - Variable.Map.fold (fun id lam (fv, subst, t) -> - let id, subst, t = - if only_freshen_parameters then - id, subst, t - else - new_subst_fv t id subst - in - Variable.Map.add id lam fv, subst, t) - fv - (Variable.Map.empty, subst, empty) - - (** Returns : - * The function_declaration with renamed function identifiers - * The new environment with added substitution - * The ffunction_subst completed with function substitution - - subst_free_vars must have been used to build off_sb - *) - let func_decls_subst t (subst : subst) - (func_decls : Flambda.function_declarations) - ~only_freshen_parameters = - match subst with - | Inactive -> func_decls, subst, t - | Active subst -> - let subst_func_decl _fun_id (func_decl : Flambda.function_declaration) - subst = - let params, subst = active_add_parameters' subst func_decl.params in - (* Since all parameters are distinct, even between functions, we can - just use a single substitution. *) - let body = - Flambda_utils.toplevel_substitution subst.sb_var func_decl.body - in - let function_decl = - Flambda.create_function_declaration ~params ~body - ~stub:func_decl.stub ~dbg:func_decl.dbg - ~inline:func_decl.inline ~specialise:func_decl.specialise - ~is_a_functor:func_decl.is_a_functor - ~closure_origin:func_decl.closure_origin - in - function_decl, subst - in - let subst, t = - if only_freshen_parameters then - subst, t - else - Variable.Map.fold (fun orig_id _func_decl (subst, t) -> - let _id, subst, t = new_subst_fun t orig_id subst in - subst, t) - func_decls.funs - (subst, t) - in - let funs, subst = - Variable.Map.fold (fun orig_id func_decl (funs, subst) -> - let func_decl, subst = subst_func_decl orig_id func_decl subst in - let id = - if only_freshen_parameters then orig_id - else active_find_var_exn subst orig_id - in - let funs = Variable.Map.add id func_decl funs in - funs, subst) - func_decls.funs - (Variable.Map.empty, subst) - in - let function_decls = - Flambda.update_function_declarations func_decls ~funs - in - function_decls, Active subst, t - - let apply_closure_id t closure_id = - try Closure_id.Map.find closure_id t.closure_id - with Not_found -> closure_id - - let apply_var_within_closure t var_in_closure = - try Var_within_closure.Map.find var_in_closure t.vars_within_closure - with Not_found -> var_in_closure - - module Compose (T : Identifiable.S) = struct - let compose ~earlier ~later = - if (T.Map.equal T.equal) earlier later - || T.Map.cardinal later = 0 - then - earlier - else - T.Map.mapi (fun src_var var -> - if T.Map.mem src_var later then begin - Misc.fatal_errorf "Freshening.Project_var.compose: domains \ - of substitutions must be disjoint. earlier=%a later=%a" - (T.Map.print T.print) earlier - (T.Map.print T.print) later - end; - match T.Map.find var later with - | exception Not_found -> var - | var -> var) - earlier - end - - module V = Compose (Var_within_closure) - module C = Compose (Closure_id) - - let compose ~earlier ~later : t = - { vars_within_closure = - V.compose ~earlier:earlier.vars_within_closure - ~later:later.vars_within_closure; - closure_id = - C.compose ~earlier:earlier.closure_id - ~later:later.closure_id; - } -end - -let apply_function_decls_and_free_vars t fv func_decls - ~only_freshen_parameters = - let module I = Project_var in - let fv, t, of_closures = I.subst_free_vars fv t ~only_freshen_parameters in - let func_decls, t, of_closures = - I.func_decls_subst of_closures t func_decls ~only_freshen_parameters - in - fv, func_decls, t, of_closures - -let does_not_freshen t vars = - match t with - | Inactive -> true - | Active subst -> - not (List.exists (fun var -> Variable.Map.mem var subst.sb_var) vars) - -let freshen_projection (projection : Projection.t) ~freshening - ~closure_freshening : Projection.t = - match projection with - | Project_var { closure; closure_id; var; } -> - Project_var { - closure = apply_variable freshening closure; - closure_id = Project_var.apply_closure_id closure_freshening closure_id; - var = Project_var.apply_var_within_closure closure_freshening var; - } - | Project_closure { set_of_closures; closure_id; } -> - Project_closure { - set_of_closures = apply_variable freshening set_of_closures; - closure_id = Project_var.apply_closure_id closure_freshening closure_id; - } - | Move_within_set_of_closures { closure; start_from; move_to; } -> - Move_within_set_of_closures { - closure = apply_variable freshening closure; - start_from = Project_var.apply_closure_id closure_freshening start_from; - move_to = Project_var.apply_closure_id closure_freshening move_to; - } - | Field (field_index, var) -> - Field (field_index, apply_variable freshening var) - -let freshen_projection_relation relation ~freshening ~closure_freshening = - Variable.Map.map (fun (spec_to : Flambda.specialised_to) -> - let projection = - match spec_to.projection with - | None -> None - | Some projection -> - Some (freshen_projection projection ~freshening ~closure_freshening) - in - { spec_to with projection; }) - relation - -let freshen_projection_relation' relation ~freshening ~closure_freshening = - Variable.Map.map (fun ((spec_to : Flambda.specialised_to), data) -> - let projection = - match spec_to.projection with - | None -> None - | Some projection -> - Some (freshen_projection projection ~freshening ~closure_freshening) - in - { spec_to with projection; }, data) - relation diff --git a/middle_end/freshening.mli b/middle_end/freshening.mli deleted file mode 100644 index 1550797ac1..0000000000 --- a/middle_end/freshening.mli +++ /dev/null @@ -1,167 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -(** Freshening of various identifiers. *) - -(** A table used for freshening variables and static exception identifiers. *) -type t -type subst = t - -(** The freshening that does nothing. This is the unique inactive - freshening. *) -val empty : t - -val is_empty : t -> bool - -(** Activate the freshening. Without activation, operations to request - freshenings have no effect (cf. the documentation below for - [add_variable]). As such, the inactive renaming is unique. *) -val activate : t -> t - -(** Given the inactive freshening, return the same; otherwise, return an - empty active freshening. *) -val empty_preserving_activation_state : t -> t - -(** [add_variable t var] - If [t] is active: - It returns a fresh variable [new_var] and adds [var] -> [new_var] - to the freshening. - If a renaming [other_var] -> [var] or [symbol] -> [var] was already - present in [t], it will also add [other_var] -> [new_var] and - [symbol] -> [new_var]. - If [t] is inactive, this is the identity. -*) -val add_variable : t -> Variable.t -> Variable.t * t - -(** Like [add_variable], but for multiple variables, each freshened - separately. *) -val add_variables' - : t - -> Variable.t list - -> Variable.t list * t - -(** Like [add_variables'], but passes through the second component of the - input list unchanged. *) -val add_variables - : t - -> (Variable.t * 'a) list - -> (Variable.t * 'a) list * t - -(** Like [add_variable], but for mutable variables. *) -val add_mutable_variable : t -> Mutable_variable.t -> Mutable_variable.t * t - -(** As for [add_variable], but for static exception identifiers. *) -val add_static_exception : t -> Static_exception.t -> Static_exception.t * t - -(** [apply_variable t var] applies the freshening [t] to [var]. - If no renaming is specified in [t] for [var] it is returned unchanged. *) -val apply_variable : t -> Variable.t -> Variable.t - -(** As for [apply_variable], but for mutable variables. *) -val apply_mutable_variable : t -> Mutable_variable.t -> Mutable_variable.t - -(** As for [apply_variable], but for static exception identifiers. *) -val apply_static_exception : t -> Static_exception.t -> Static_exception.t - -(** Replace recursive accesses to the closures in the set through - [Symbol] by the corresponding [Var]. This is used to recover - the recursive call when importing code from another compilation unit. - - If the renaming is inactive, this is the identity. -*) -val rewrite_recursive_calls_with_symbols - : t - -> Flambda.function_declarations - -> make_closure_symbol:(Closure_id.t -> Symbol.t) - -> Flambda.function_declarations - -(* CR-soon mshinwell for mshinwell: maybe inaccurate module name, it freshens - closure IDs as well. Check use points though *) -module Project_var : sig - (** A table used for freshening of identifiers in [Project_closure] and - [Move_within_set_of_closures] ("ids of closures"); and [Project_var] - ("bound vars of closures") expressions. - - This information is propagated bottom up and populated when inlining a - function containing a closure declaration. - - For instance, - [let f x = - let g y = ... x ... in - ... g.x ... (Project_var x) - ... g 1 ... (Apply (Project_closure g ...)) - ] - - If f is inlined, g is renamed. The approximation of g will carry this - table such that later the access to the field x of g and selection of - g in the closure can be substituted. - *) - type t - - (* The freshening that does nothing. *) - val empty : t - - (** Composition of two freshenings. *) - val compose : earlier:t -> later:t -> t - - (** Freshen a closure ID based on the given renaming. The same ID is - returned if the renaming does not affect it. - If dealing with approximations, you probably want to use - [Simple_value_approx.freshen_and_check_closure_id] instead of this - function. - *) - val apply_closure_id : t -> Closure_id.t -> Closure_id.t - - (** Like [apply_closure_id], but for variables within closures. *) - val apply_var_within_closure - : t - -> Var_within_closure.t - -> Var_within_closure.t - - val print : Format.formatter -> t -> unit -end - -(* CR-soon mshinwell for mshinwell: add comment *) -val apply_function_decls_and_free_vars - : t - -> (Flambda.specialised_to * 'a) Variable.Map.t - -> Flambda.function_declarations - -> only_freshen_parameters:bool - -> (Flambda.specialised_to * 'a) Variable.Map.t - * Flambda.function_declarations - * t - * Project_var.t - -val does_not_freshen : t -> Variable.t list -> bool - -val print : Format.formatter -> t -> unit - -(** N.B. This does not freshen the domain of the supplied map, only the - range. *) -(* CR-someday mshinwell: consider fixing that *) -val freshen_projection_relation - : Flambda.specialised_to Variable.Map.t - -> freshening:t - -> closure_freshening:Project_var.t - -> Flambda.specialised_to Variable.Map.t - -val freshen_projection_relation' - : (Flambda.specialised_to * 'a) Variable.Map.t - -> freshening:t - -> closure_freshening:Project_var.t - -> (Flambda.specialised_to * 'a) Variable.Map.t diff --git a/middle_end/inconstant_idents.ml b/middle_end/inconstant_idents.ml deleted file mode 100644 index 59f8aa8a8c..0000000000 --- a/middle_end/inconstant_idents.ml +++ /dev/null @@ -1,502 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -(* This cannot be done in a single simple pass due to expressions like: - - let rec ... = - ... - let rec f1 x = - let f2 y = - f1 rec_list - in - f2 v - and rec_list = f1 :: rec_list in - ... - - and v = ... - - f1, f2 and rec_list are constants iff v is a constant. - - To handle this we populate both a 'not constant' set NC and a set of - implications between variables. - - For example, the above code would generate the implications: - - f1 in NC => rec_list in NC - f2 in NC => f1 in NC - rec_list in NC => f2 in NC - v in NC => f1 in NC - - then if v is found to be in NC this will be propagated to place - f1, f2 and rec_list in NC as well. - -*) - -(* CR-someday lwhite: I think this pass could be combined with - alias_analysis and other parts of lift_constants into a single - type-based analysis which infers a "type" for each variable that is - either an allocated_constant expression or "not constant". Recursion - would be handled with unification variables. *) - -module Int = Numbers.Int -module Symbol_field = struct - type t = Symbol.t * Int.t - include Identifiable.Make (Identifiable.Pair (Symbol) (Int)) -end - -type dep = - | Closure of Set_of_closures_id.t - | Var of Variable.t - | Symbol of Symbol.t - | Symbol_field of Symbol_field.t - -type state = - | Not_constant - | Implication of dep list - -type result = { - id : state Variable.Tbl.t; - closure : state Set_of_closures_id.Tbl.t; -} - -module type Param = sig - val program : Flambda.program - val compilation_unit : Compilation_unit.t -end - -(* CR-soon mshinwell: consider removing functor *) -module Inconstants (P:Param) (Backend:Backend_intf.S) = struct - let program = P.program - let compilation_unit = P.compilation_unit - let imported_symbols = Flambda_utils.imported_symbols program - - (* Sets representing NC *) - let variables : state Variable.Tbl.t = Variable.Tbl.create 42 - let closures : state Set_of_closures_id.Tbl.t = - Set_of_closures_id.Tbl.create 42 - let symbols : state Symbol.Tbl.t = Symbol.Tbl.create 42 - let symbol_fields : state Symbol_field.Tbl.t = Symbol_field.Tbl.create 42 - - let mark_queue = Queue.create () - - (* CR-soon pchambart: We could probably improve that quite a lot by adding - (the future annotation) [@unrolled] at the right call sites. Or more - directly mark mark_dep as [@inline] and call it instead of mark_curr in - some situations. - *) - - (* adds 'dep in NC' *) - let rec mark_dep = function - | Var id -> begin - match Variable.Tbl.find variables id with - | Not_constant -> () - | Implication deps -> - Variable.Tbl.replace variables id Not_constant; - Queue.push deps mark_queue - | exception Not_found -> - Variable.Tbl.add variables id Not_constant - end - | Closure cl -> begin - match Set_of_closures_id.Tbl.find closures cl with - | Not_constant -> () - | Implication deps -> - Set_of_closures_id.Tbl.replace closures cl Not_constant; - Queue.push deps mark_queue - | exception Not_found -> - Set_of_closures_id.Tbl.add closures cl Not_constant - end - | Symbol s -> begin - match Symbol.Tbl.find symbols s with - | Not_constant -> () - | Implication deps -> - Symbol.Tbl.replace symbols s Not_constant; - Queue.push deps mark_queue - | exception Not_found -> - Symbol.Tbl.add symbols s Not_constant - end - | Symbol_field s -> begin - match Symbol_field.Tbl.find symbol_fields s with - | Not_constant -> () - | Implication deps -> - Symbol_field.Tbl.replace symbol_fields s Not_constant; - Queue.push deps mark_queue - | exception Not_found -> - Symbol_field.Tbl.add symbol_fields s Not_constant - end - - and mark_deps deps = - List.iter mark_dep deps - - and complete_marking () = - while not (Queue.is_empty mark_queue) do - let deps = - try - Queue.take mark_queue - with Not_found -> [] - in - mark_deps deps; - done - - (* adds 'curr in NC' *) - let mark_curr curr = - mark_deps curr; - complete_marking () - - (* adds in the tables 'dep in NC => curr in NC' *) - let register_implication ~in_nc:dep ~implies_in_nc:curr = - match dep with - | Var id -> begin - match Variable.Tbl.find variables id with - | Not_constant -> - mark_deps curr; - complete_marking (); - | Implication deps -> - let deps = List.rev_append curr deps in - Variable.Tbl.replace variables id (Implication deps) - | exception Not_found -> - Variable.Tbl.add variables id (Implication curr); - end - | Closure cl -> begin - match Set_of_closures_id.Tbl.find closures cl with - | Not_constant -> - mark_deps curr; - complete_marking (); - | Implication deps -> - let deps = List.rev_append curr deps in - Set_of_closures_id.Tbl.replace closures cl (Implication deps) - | exception Not_found -> - Set_of_closures_id.Tbl.add closures cl (Implication curr); - end - | Symbol symbol -> begin - match Symbol.Tbl.find symbols symbol with - | Not_constant -> - mark_deps curr; - complete_marking (); - | Implication deps -> - let deps = List.rev_append curr deps in - Symbol.Tbl.replace symbols symbol (Implication deps) - | exception Not_found -> - Symbol.Tbl.add symbols symbol (Implication curr); - end - | Symbol_field ((symbol, _) as field) -> begin - match Symbol_field.Tbl.find symbol_fields field with - | Not_constant -> - mark_deps curr; - complete_marking (); - | Implication deps -> - let deps = List.rev_append curr deps in - Symbol_field.Tbl.replace symbol_fields field (Implication deps) - | exception Not_found -> - (* There is no information available about the contents of imported - symbols, so we must consider all their fields as inconstant. *) - (* CR-someday pchambart: recover that from the cmx information *) - if Symbol.Set.mem symbol imported_symbols then begin - Symbol_field.Tbl.add symbol_fields field Not_constant; - mark_deps curr; - complete_marking (); - end else begin - Symbol_field.Tbl.add symbol_fields field (Implication curr) - end - end - - (* First loop: iterates on the tree to mark dependencies. - - curr is the variables or closures to which we add constraints like - '... in NC => curr in NC' or 'curr in NC' - - It can be empty when no constraint can be added like in the toplevel - expression or in the body of a function. - *) - let rec mark_loop ~toplevel (curr : dep list) (flam : Flambda.t) = - match flam with - | Let { var; defining_expr = lam; body; _ } -> - mark_named ~toplevel [Var var] lam; - (* adds 'var in NC => curr in NC' - This is not really necessary, but compiling this correctly is - trickier than eliminating that earlier. *) - mark_var var curr; - mark_loop ~toplevel curr body - | Let_mutable { initial_value = var; body } -> - mark_var var curr; - mark_loop ~toplevel curr body - | Let_rec(defs, body) -> - List.iter (fun (var, def) -> - mark_named ~toplevel [Var var] def; - (* adds 'var in NC => curr in NC' same remark as let case *) - mark_var var curr) - defs; - mark_loop ~toplevel curr body - | Var var -> mark_var var curr - (* Not constant cases: we mark directly 'curr in NC' and mark - bound variables as in NC also *) - | Assign _ -> - mark_curr curr - | Try_with (f1,id,f2) -> - mark_curr [Var id]; - mark_curr curr; - mark_loop ~toplevel [] f1; - mark_loop ~toplevel [] f2 - | Static_catch (_,ids,f1,f2) -> - List.iter (fun id -> mark_curr [Var id]) ids; - mark_curr curr; - mark_loop ~toplevel [] f1; - mark_loop ~toplevel [] f2 - (* CR-someday pchambart: If recursive staticcatch is introduced: - this becomes ~toplevel:false *) - | For { bound_var; from_value; to_value; direction = _; body; } -> - mark_curr [Var bound_var]; - mark_var from_value curr; - mark_var to_value curr; - mark_curr curr; - mark_loop ~toplevel:false [] body - | While (f1,body) -> - mark_curr curr; - mark_loop ~toplevel [] f1; - mark_loop ~toplevel:false [] body - | If_then_else (f1,f2,f3) -> - mark_curr curr; - mark_curr [Var f1]; - mark_loop ~toplevel [] f2; - mark_loop ~toplevel [] f3 - | Static_raise (_,l) -> - mark_curr curr; - List.iter (fun v -> mark_var v curr) l - | Apply ({func; args; _ }) -> - mark_curr curr; - mark_var func curr; - mark_vars args curr; - | Switch (arg,sw) -> - mark_curr curr; - mark_var arg curr; - List.iter (fun (_,l) -> mark_loop ~toplevel [] l) sw.consts; - List.iter (fun (_,l) -> mark_loop ~toplevel [] l) sw.blocks; - Misc.may (fun l -> mark_loop ~toplevel [] l) sw.failaction - | String_switch (arg,sw,def) -> - mark_curr curr; - mark_var arg curr; - List.iter (fun (_,l) -> mark_loop ~toplevel [] l) sw; - Misc.may (fun l -> mark_loop ~toplevel [] l) def - | Send { kind = _; meth; obj; args; dbg = _; } -> - mark_curr curr; - mark_var meth curr; - mark_var obj curr; - List.iter (fun arg -> mark_var arg curr) args - | Proved_unreachable -> - mark_curr curr - - and mark_named ~toplevel curr (named : Flambda.named) = - match named with - | Set_of_closures (set_of_closures) -> - mark_loop_set_of_closures ~toplevel curr set_of_closures - | Const _ | Allocated_const _ -> () - | Read_mutable _ -> mark_curr curr - | Symbol symbol -> begin - let current_unit = Compilation_unit.get_current_exn () in - if Compilation_unit.equal current_unit (Symbol.compilation_unit symbol) - then - () - else - match (Backend.import_symbol symbol).descr with - | Value_unresolved _ -> - (* Constant when 'for_clambda' means: can be a symbol (which is - obviously the case here) with a known approximation. If this - condition is not satisfied we mark as inconstant to reflect - the fact that the symbol's contents are unknown and thus - prevent attempts to examine it. (This is a bit of a hack.) *) - mark_curr curr - | _ -> - () - end - | Read_symbol_field (symbol, index) -> - register_implication ~in_nc:(Symbol_field (symbol, index)) - ~implies_in_nc:curr - (* Constant constructors: those expressions are constant if all their - parameters are: - - makeblock is compiled to a constant block - - offset is compiled to a pointer inside a constant closure. - See Cmmgen for the details - - makeblock(Mutable) can be a 'constant' if it is allocated at - toplevel: if this expression is evaluated only once. - *) - | Prim (Pmakeblock (_tag, Asttypes.Immutable, _value_kind), args, - _dbg) -> - mark_vars args curr -(* (* CR-someday pchambart: If global mutables are allowed: *) - | Prim(Lambda.Pmakeblock(_tag, Asttypes.Mutable), args, _dbg, _) - when toplevel -> - List.iter (mark_loop ~toplevel curr) args -*) - | Prim (Pmakearray (Pfloatarray, Immutable), args, _) -> - mark_vars args curr - | Prim (Pmakearray (Pfloatarray, Mutable), args, _) -> - (* CR-someday pchambart: Toplevel float arrays could always be - statically allocated using an equivalent of the - Initialize_symbol construction. - Toplevel non-float arrays could also be turned into an - Initialize_symbol, but only when declared as immutable since - preallocated symbols does not allow mutation after - initialisation - *) - if toplevel then mark_vars args curr - else mark_curr curr - | Prim (Pduparray (Pfloatarray, Immutable), [arg], _) -> - mark_var arg curr - | Prim (Pduparray (Pfloatarray, Mutable), [arg], _) -> - if toplevel then mark_var arg curr - else mark_curr curr - | Prim (Pduparray _, _, _) -> - (* See Lift_constants *) - mark_curr curr - | Project_closure ({ set_of_closures; closure_id; }) -> - if Closure_id.in_compilation_unit closure_id compilation_unit then - mark_var set_of_closures curr - else - mark_curr curr - | Move_within_set_of_closures ({ closure; start_from; move_to; }) -> - (* CR-someday mshinwell: We should be able to deem these projections - (same for the cases below) as constant when from another - compilation unit, but there isn't code to handle this yet. (Note - that for Project_var we cannot yet generate a projection from a - closure in another compilation unit, since we only lift closed - closures.) *) - if Closure_id.in_compilation_unit start_from compilation_unit then begin - assert (Closure_id.in_compilation_unit move_to compilation_unit); - mark_var closure curr - end else begin - mark_curr curr - end - | Project_var ({ closure; closure_id; var = _ }) -> - if Closure_id.in_compilation_unit closure_id compilation_unit then - mark_var closure curr - else - mark_curr curr - | Prim (Pfield _, [f1], _) -> - mark_curr curr; - mark_var f1 curr - | Prim (_, args, _) -> - mark_curr curr; - mark_vars args curr - | Expr flam -> - mark_loop ~toplevel curr flam - - and mark_var var curr = - (* adds 'id in NC => curr in NC' *) - register_implication ~in_nc:(Var var) ~implies_in_nc:curr - - and mark_vars vars curr = - (* adds 'id in NC => curr in NC' *) - List.iter (fun var -> mark_var var curr) vars - - (* [toplevel] is intended for allowing static allocations of mutable - blocks. This feature should be available in a future release once the - necessary GC changes have been merged. (See GPR#178.) *) - and mark_loop_set_of_closures ~toplevel:_ curr - { Flambda. function_decls; free_vars; specialised_args } = - (* If a function in the set of closures is specialised, do not consider - it constant, unless all specialised args are also constant. *) - Variable.Map.iter (fun _ (spec_arg : Flambda.specialised_to) -> - register_implication - ~in_nc:(Var spec_arg.var) - ~implies_in_nc:[Closure function_decls.set_of_closures_id]) - specialised_args; - (* adds 'function_decls in NC => curr in NC' *) - register_implication ~in_nc:(Closure function_decls.set_of_closures_id) - ~implies_in_nc:curr; - (* a closure is constant if its free variables are constants. *) - Variable.Map.iter (fun inner_id (var : Flambda.specialised_to) -> - register_implication ~in_nc:(Var var.var) - ~implies_in_nc:[ - Var inner_id; - Closure function_decls.set_of_closures_id - ]) - free_vars; - Variable.Map.iter (fun fun_id (ffunc : Flambda.function_declaration) -> - (* for each function f in a closure c 'c in NC => f' *) - register_implication ~in_nc:(Closure function_decls.set_of_closures_id) - ~implies_in_nc:[Var fun_id]; - (* function parameters are in NC unless specialised *) - List.iter (fun param -> - match Variable.Map.find param specialised_args with - | exception Not_found -> mark_curr [Var param] - | outer_var -> - register_implication ~in_nc:(Var outer_var.var) - ~implies_in_nc:[Var param]) - (Parameter.List.vars ffunc.params); - mark_loop ~toplevel:false [] ffunc.body) - function_decls.funs - - let mark_constant_defining_value (const:Flambda.constant_defining_value) = - match const with - | Allocated_const _ - | Block _ - | Project_closure _ -> () - | Set_of_closures set_of_closure -> - mark_loop_set_of_closures ~toplevel:true [] set_of_closure - - let mark_program (program : Flambda.program) = - let rec loop (program : Flambda.program_body) = - match program with - | End _ -> () - | Initialize_symbol (symbol,_tag,fields,program) -> - List.iteri (fun i field -> - mark_loop ~toplevel:true - [Symbol symbol; Symbol_field (symbol,i)] field) - fields; - loop program - | Effect (expr, program) -> - mark_loop ~toplevel:true [] expr; - loop program - | Let_symbol (_, def, program) -> - mark_constant_defining_value def; - loop program - | Let_rec_symbol (defs, program) -> - List.iter (fun (_, def) -> mark_constant_defining_value def) defs; - loop program - in - loop program.program_body - - let res = - mark_program program; - { id = variables; - closure = closures; - } -end - -let inconstants_on_program ~compilation_unit ~backend - (program : Flambda.program) = - let module P = struct - let program = program - let compilation_unit = compilation_unit - end in - let module Backend = (val backend : Backend_intf.S) in - let module I = Inconstants (P) (Backend) in - I.res - -let variable var { id; _ } = - match Variable.Tbl.find id var with - | Not_constant -> true - | Implication _ -> false - | exception Not_found -> false - -let closure cl { closure; _ } = - match Set_of_closures_id.Tbl.find closure cl with - | Not_constant -> true - | Implication _ -> false - | exception Not_found -> false diff --git a/middle_end/inconstant_idents.mli b/middle_end/inconstant_idents.mli deleted file mode 100644 index 2c5309e022..0000000000 --- a/middle_end/inconstant_idents.mli +++ /dev/null @@ -1,36 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -type result - -(** [inconstants_on_program] finds those variables and set-of-closures - identifiers that cannot be compiled to constants by [Flambda_to_clambda]. -*) -val inconstants_on_program - : compilation_unit:Compilation_unit.t - -> backend:(module Backend_intf.S) - -> Flambda.program - -> result - -(** [variable var res] returns [true] if [var] is marked as inconstant - in [res]. *) -val variable : Variable.t -> result -> bool - -(** [closure cl res] returns [true] if [cl] is marked as inconstant - in [res]. *) -val closure : Set_of_closures_id.t -> result -> bool diff --git a/middle_end/initialize_symbol_to_let_symbol.ml b/middle_end/initialize_symbol_to_let_symbol.ml deleted file mode 100644 index 31246b0d46..0000000000 --- a/middle_end/initialize_symbol_to_let_symbol.ml +++ /dev/null @@ -1,57 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -let constant_field (expr:Flambda.t) - : Flambda.constant_defining_value_block_field option = - match expr with - | Let { var; defining_expr = Const c; body = Var var' ; _ } -> - assert(Variable.equal var var'); - (* This must be true since var is the only variable in scope *) - Some (Flambda.Const c) - | Let { var; defining_expr = Symbol s; body = Var var' ; _ } -> - assert(Variable.equal var var'); - Some (Flambda.Symbol s) - | _ -> - None - -let rec loop (program : Flambda.program_body) : Flambda.program_body = - match program with - | Initialize_symbol (symbol, tag, fields, program) -> - let constant_fields = List.map constant_field fields in - begin - match Misc.Stdlib.List.some_if_all_elements_are_some constant_fields - with - | None -> - Initialize_symbol (symbol, tag, fields, loop program) - | Some fields -> - Let_symbol (symbol, Block (tag, fields), loop program) - end - | Let_symbol (symbol, const, program) -> - Let_symbol (symbol, const, loop program) - | Let_rec_symbol (defs, program) -> - Let_rec_symbol (defs, loop program) - | Effect (expr, program) -> - Effect (expr, loop program) - | End symbol -> - End symbol - -let run (program : Flambda.program) = - { program with - program_body = loop program.program_body; - } diff --git a/middle_end/initialize_symbol_to_let_symbol.mli b/middle_end/initialize_symbol_to_let_symbol.mli deleted file mode 100644 index fc54f76075..0000000000 --- a/middle_end/initialize_symbol_to_let_symbol.mli +++ /dev/null @@ -1,25 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -val constant_field - : Flambda.t - -> Flambda.constant_defining_value_block_field option - -(** Transform Initialize_symbol with only constant fields to - let_symbol construction. *) -val run : Flambda.program -> Flambda.program diff --git a/middle_end/inline_and_simplify.ml b/middle_end/inline_and_simplify.ml deleted file mode 100644 index 7d304cd88f..0000000000 --- a/middle_end/inline_and_simplify.ml +++ /dev/null @@ -1,1703 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -module A = Simple_value_approx -module B = Inlining_cost.Benefit -module E = Inline_and_simplify_aux.Env -module R = Inline_and_simplify_aux.Result - -(** Values of two types hold the information propagated during simplification: - - [E.t] "environments", top-down, almost always called "env"; - - [R.t] "results", bottom-up approximately following the evaluation order, - almost always called "r". These results come along with rewritten - Flambda terms. - The environments map variables to approximations, which enable various - simplifications to be performed; for example, some variable may be known - to always hold a particular constant. -*) - -let ret = R.set_approx - -type simplify_variable_result = - | No_binding of Variable.t - | Binding of Variable.t * (Flambda.named Flambda.With_free_variables.t) - -let simplify_free_variable_internal env original_var = - let var = Freshening.apply_variable (E.freshening env) original_var in - let original_var = var in - (* In the case where an approximation is useful, we introduce a [let] - to bind (e.g.) the constant or symbol replacing [var], unless this - would introduce a useless [let] as a consequence of [var] already being - in the current scope. - - Even when the approximation is not useful, this simplification helps. - In particular, it squashes aliases of the form: - let var1 = var2 in ... var2 ... - by replacing [var2] in the body with [var1]. Simplification can then - eliminate the [let]. - *) - let var = - let approx = E.find_exn env var in - match approx.var with - | Some var when E.mem env var -> var - | Some _ | None -> var - in - (* CR-soon mshinwell: Should we update [r] when we *add* code? - Aside from that, it looks like maybe we don't need [r] in this function, - because the approximation within it wouldn't be used by any of the - call sites. *) - match E.find_with_scope_exn env var with - | Current, approx -> No_binding var, approx (* avoid useless [let] *) - | Outer, approx -> - match A.simplify_var approx with - | None -> No_binding var, approx - | Some (named, approx) -> - let module W = Flambda.With_free_variables in - Binding (original_var, W.of_named named), approx - -let simplify_free_variable env var ~f : Flambda.t * R.t = - match simplify_free_variable_internal env var with - | No_binding var, approx -> f env var approx - | Binding (var, named), approx -> - let module W = Flambda.With_free_variables in - let var = Variable.rename var in - let env = E.add env var approx in - let body, r = f env var approx in - (W.create_let_reusing_defining_expr var named body), r - -let simplify_free_variables env vars ~f : Flambda.t * R.t = - let rec collect_bindings vars env bound_vars approxs : Flambda.t * R.t = - match vars with - | [] -> f env (List.rev bound_vars) (List.rev approxs) - | var::vars -> - match simplify_free_variable_internal env var with - | No_binding var, approx -> - collect_bindings vars env (var::bound_vars) (approx::approxs) - | Binding (var, named), approx -> - let module W = Flambda.With_free_variables in - let var = Variable.rename var in - let env = E.add env var approx in - let body, r = - collect_bindings vars env (var::bound_vars) (approx::approxs) - in - (W.create_let_reusing_defining_expr var named body), r - in - collect_bindings vars env [] [] - -let simplify_free_variables_named env vars ~f : Flambda.named * R.t = - let rec collect_bindings vars env bound_vars approxs - : Flambda.maybe_named * R.t = - match vars with - | [] -> - let named, r = f env (List.rev bound_vars) (List.rev approxs) in - Is_named named, r - | var::vars -> - match simplify_free_variable_internal env var with - | No_binding var, approx -> - collect_bindings vars env (var::bound_vars) (approx::approxs) - | Binding (var, named), approx -> - let module W = Flambda.With_free_variables in - let var = Variable.rename var in - let env = E.add env var approx in - let body, r = - collect_bindings vars env (var::bound_vars) (approx::approxs) - in - let body = - match body with - | Is_named body -> - let name = Internal_variable_names.simplify_fv in - Flambda_utils.name_expr body ~name - | Is_expr body -> body - in - Is_expr (W.create_let_reusing_defining_expr var named body), r - in - let named_or_expr, r = collect_bindings vars env [] [] in - match named_or_expr with - | Is_named named -> named, r - | Is_expr expr -> Expr expr, r - -(* CR-soon mshinwell: tidy this up *) -let simplify_free_variable_named env var ~f : Flambda.named * R.t = - simplify_free_variables_named env [var] ~f:(fun env vars vars_approxs -> - match vars, vars_approxs with - | [var], [approx] -> f env var approx - | _ -> assert false) - -let simplify_named_using_approx r lam approx = - let lam, _summary, approx = A.simplify_named approx lam in - lam, R.set_approx r approx - -let simplify_using_approx_and_env env r original_lam approx = - let lam, summary, approx = - A.simplify_using_env approx ~is_present_in_env:(E.mem env) original_lam - in - let r = - let r = ret r approx in - match summary with - (* CR-soon mshinwell: Why is [r] not updated with the cost of adding the - new code? - mshinwell: similar to CR above *) - | Replaced_term -> R.map_benefit r (B.remove_code original_lam) - | Nothing_done -> r - in - lam, r - -let simplify_named_using_approx_and_env env r original_named approx = - let named, summary, approx = - A.simplify_named_using_env approx ~is_present_in_env:(E.mem env) - original_named - in - let r = - let r = ret r approx in - match summary with - | Replaced_term -> R.map_benefit r (B.remove_code_named original_named) - | Nothing_done -> r - in - named, r - -let simplify_const (const : Flambda.const) = - match const with - | Int i -> A.value_int i - | Char c -> A.value_char c - | Const_pointer i -> A.value_constptr i - -let approx_for_allocated_const (const : Allocated_const.t) = - match const with - | String s -> A.value_string (String.length s) None - | Immutable_string s -> A.value_string (String.length s) (Some s) - | Int32 i -> A.value_boxed_int Int32 i - | Int64 i -> A.value_boxed_int Int64 i - | Nativeint i -> A.value_boxed_int Nativeint i - | Float f -> A.value_float f - | Float_array a -> A.value_mutable_float_array ~size:(List.length a) - | Immutable_float_array a -> - A.value_immutable_float_array - (Array.map A.value_float (Array.of_list a)) - -type filtered_switch_branches = - | Must_be_taken of Flambda.t - | Can_be_taken of (int * Flambda.t) list - -(* Determine whether a given closure ID corresponds directly to a variable - (bound to a closure) in the given environment. This happens when the body - of a [let rec]-bound function refers to another in the same set of closures. - If we succeed in this process, we can change [Project_closure] - expressions into [Var] expressions, thus sharing closure projections. *) -let reference_recursive_function_directly env closure_id = - let closure_id = Closure_id.unwrap closure_id in - match E.find_opt env closure_id with - | None -> None - | Some approx -> Some (Flambda.Expr (Var closure_id), approx) - -(* Simplify an expression that takes a set of closures and projects an - individual closure from it. *) -let simplify_project_closure env r ~(project_closure : Flambda.project_closure) - : Flambda.named * R.t = - simplify_free_variable_named env project_closure.set_of_closures - ~f:(fun _env set_of_closures set_of_closures_approx -> - match A.check_approx_for_set_of_closures set_of_closures_approx with - | Wrong -> - Misc.fatal_errorf "Wrong approximation when projecting closure: %a" - Flambda.print_project_closure project_closure - | Unresolved value -> - (* A set of closures coming from another compilation unit, whose .cmx is - missing; as such, we cannot have rewritten the function and don't - need to do any freshening. *) - Project_closure { - set_of_closures; - closure_id = project_closure.closure_id; - }, ret r (A.value_unresolved value) - | Unknown -> - (* CR-soon mshinwell: see CR comment in e.g. simple_value_approx.ml - [check_approx_for_closure_allowing_unresolved] *) - Project_closure { - set_of_closures; - closure_id = project_closure.closure_id; - }, ret r (A.value_unknown Other) - | Unknown_because_of_unresolved_value value -> - Project_closure { - set_of_closures; - closure_id = project_closure.closure_id; - }, ret r (A.value_unknown (Unresolved_value value)) - | Ok (set_of_closures_var, value_set_of_closures) -> - let closure_id = - A.freshen_and_check_closure_id value_set_of_closures - project_closure.closure_id - in - let projecting_from = - match set_of_closures_var with - | None -> None - | Some set_of_closures_var -> - let projection : Projection.t = - Project_closure { - set_of_closures = set_of_closures_var; - closure_id; - } - in - match E.find_projection env ~projection with - | None -> None - | Some var -> Some (var, projection) - in - match projecting_from with - | Some (var, projection) -> - simplify_free_variable_named env var ~f:(fun _env var var_approx -> - let r = R.map_benefit r (B.remove_projection projection) in - Expr (Var var), ret r var_approx) - | None -> - match reference_recursive_function_directly env closure_id with - | Some (flam, approx) -> flam, ret r approx - | None -> - let set_of_closures_var = - match set_of_closures_var with - | Some set_of_closures_var' when E.mem env set_of_closures_var' -> - set_of_closures_var - | Some _ | None -> None - in - let approx = - A.value_closure ?set_of_closures_var value_set_of_closures - closure_id - in - Project_closure { set_of_closures; closure_id; }, ret r approx) - -(* Simplify an expression that, given one closure within some set of - closures, returns another closure (possibly the same one) within the - same set. *) -let simplify_move_within_set_of_closures env r - ~(move_within_set_of_closures : Flambda.move_within_set_of_closures) - : Flambda.named * R.t = - simplify_free_variable_named env move_within_set_of_closures.closure - ~f:(fun _env closure closure_approx -> - match A.check_approx_for_closure_allowing_unresolved closure_approx with - | Wrong -> - Misc.fatal_errorf "Wrong approximation when moving within set of \ - closures. Approximation: %a Term: %a" - A.print closure_approx - Flambda.print_move_within_set_of_closures move_within_set_of_closures - | Unresolved sym -> - Move_within_set_of_closures { - closure; - start_from = move_within_set_of_closures.start_from; - move_to = move_within_set_of_closures.move_to; - }, - ret r (A.value_unresolved sym) - | Unknown -> - Move_within_set_of_closures { - closure; - start_from = move_within_set_of_closures.start_from; - move_to = move_within_set_of_closures.move_to; - }, - ret r (A.value_unknown Other) - | Unknown_because_of_unresolved_value value -> - (* For example: a move upon a (move upon a closure whose .cmx file - is missing). *) - Move_within_set_of_closures { - closure; - start_from = move_within_set_of_closures.start_from; - move_to = move_within_set_of_closures.move_to; - }, - ret r (A.value_unknown (Unresolved_value value)) - | Ok (_value_closure, set_of_closures_var, set_of_closures_symbol, - value_set_of_closures) -> - let freshen = - (* CR-soon mshinwell: potentially misleading name---not freshening with - new names, but with previously fresh names *) - A.freshen_and_check_closure_id value_set_of_closures - in - let move_to = freshen move_within_set_of_closures.move_to in - let start_from = freshen move_within_set_of_closures.start_from in - let projection : Projection.t = - Move_within_set_of_closures { - closure; - start_from; - move_to; - } - in - match E.find_projection env ~projection with - | Some var -> - simplify_free_variable_named env var ~f:(fun _env var var_approx -> - let r = R.map_benefit r (B.remove_projection projection) in - Expr (Var var), ret r var_approx) - | None -> - match reference_recursive_function_directly env move_to with - | Some (flam, approx) -> flam, ret r approx - | None -> - if Closure_id.equal start_from move_to then - (* Moving from one closure to itself is a no-op. We can return an - [Var] since we already have a variable bound to the closure. *) - Expr (Var closure), ret r closure_approx - else - match set_of_closures_var with - | Some set_of_closures_var when E.mem env set_of_closures_var -> - (* A variable bound to the set of closures is in scope, - meaning we can rewrite the [Move_within_set_of_closures] to a - [Project_closure]. *) - let project_closure : Flambda.project_closure = - { set_of_closures = set_of_closures_var; - closure_id = move_to; - } - in - let approx = - A.value_closure ~set_of_closures_var value_set_of_closures - move_to - in - Project_closure project_closure, ret r approx - | Some _ | None -> - match set_of_closures_symbol with - | Some set_of_closures_symbol -> - let set_of_closures_var = - Variable.create Internal_variable_names.symbol - in - let project_closure : Flambda.project_closure = - { set_of_closures = set_of_closures_var; - closure_id = move_to; - } - in - let project_closure_var = - Variable.create Internal_variable_names.project_closure - in - let let1 = - Flambda.create_let project_closure_var - (Project_closure project_closure) - (Var project_closure_var) - in - let expr = - Flambda.create_let set_of_closures_var - (Symbol set_of_closures_symbol) - let1 - in - let approx = - A.value_closure ~set_of_closures_var ~set_of_closures_symbol - value_set_of_closures move_to - in - Expr expr, ret r approx - | None -> - (* The set of closures is not available in scope, and we - have no other information by which to simplify the move. *) - let move_within : Flambda.move_within_set_of_closures = - { closure; start_from; move_to; } - in - let approx = A.value_closure value_set_of_closures move_to in - Move_within_set_of_closures move_within, ret r approx) - -(* Transform an expression denoting an access to a variable bound in - a closure. Variables in the closure ([project_var.closure]) may - have been freshened since [expr] was constructed; as such, we - must ensure the same happens to [expr]. The renaming information is - contained within the approximation deduced from [closure] (as - such, that approximation *must* identify which closure it is). - - For instance in some imaginary syntax for flambda: - - [let f x = - let g y ~closure:{a} = a + y in - let closure = { a = x } in - g 12 ~closure] - - when [f] is traversed, [g] can be inlined, resulting in the - expression - - [let f z = - let g y ~closure:{a} = a + y in - let closure = { a = x } in - closure.a + 12] - - [closure.a] being a notation for: - - [Project_var{closure = closure; closure_id = g; var = a}] - - If [f] is inlined later, the resulting code will be - - [let x = ... in - let g' y' ~closure':{a'} = a' + y' in - let closure' = { a' = x } in - closure'.a' + 12] - - in particular the field [a] of the closure has been alpha renamed to [a']. - This information must be carried from the declaration to the use. - - If the function is declared outside of the alpha renamed part, there is - no need for renaming in the [Ffunction] and [Project_var]. - This is not usually the case, except when the closure declaration is a - symbol. - - What ensures that this information is available at [Project_var] - point is that those constructions can only be introduced by inlining, - which requires that same information. For this to still be valid, - other transformation must avoid transforming the information flow in - a way that the inline function can't propagate it. -*) -let rec simplify_project_var env r ~(project_var : Flambda.project_var) - : Flambda.named * R.t = - simplify_free_variable_named env project_var.closure - ~f:(fun _env closure approx -> - match A.check_approx_for_closure_allowing_unresolved approx with - | Ok (value_closure, _set_of_closures_var, _set_of_closures_symbol, - value_set_of_closures) -> - let module F = Freshening.Project_var in - let freshening = value_set_of_closures.freshening in - let var = F.apply_var_within_closure freshening project_var.var in - let closure_id = F.apply_closure_id freshening project_var.closure_id in - let closure_id_in_approx = value_closure.closure_id in - if not (Closure_id.equal closure_id closure_id_in_approx) then begin - Misc.fatal_errorf "When simplifying [Project_var], the closure ID %a \ - in the approximation of the set of closures did not match the \ - closure ID %a in the [Project_var] term. Approximation: %a@. \ - Var-within-closure being projected: %a@." - Closure_id.print closure_id_in_approx - Closure_id.print closure_id - Simple_value_approx.print approx - Var_within_closure.print var - end; - let projection : Projection.t = - Project_var { - closure; - closure_id; - var; - } - in - begin match E.find_projection env ~projection with - | Some var -> - simplify_free_variable_named env var ~f:(fun _env var var_approx -> - let r = R.map_benefit r (B.remove_projection projection) in - Expr (Var var), ret r var_approx) - | None -> - let approx = A.approx_for_bound_var value_set_of_closures var in - let expr : Flambda.named = Project_var { closure; closure_id; var; } in - let unwrapped = Var_within_closure.unwrap var in - let expr = - if E.mem env unwrapped then - Flambda.Expr (Var unwrapped) - else - expr - in - simplify_named_using_approx_and_env env r expr approx - end - | Unresolved symbol -> - (* This value comes from a symbol for which we couldn't find any - approximation, telling us that names within the closure couldn't - have been renamed. So we don't need to change the variable or - closure ID in the [Project_var] expression. *) - Project_var { project_var with closure }, - ret r (A.value_unresolved symbol) - | Unknown -> - Project_var { project_var with closure }, - ret r (A.value_unknown Other) - | Unknown_because_of_unresolved_value value -> - Project_var { project_var with closure }, - ret r (A.value_unknown (Unresolved_value value)) - | Wrong -> - (* We must have the correct approximation of the value to ensure - we take account of all freshenings. *) - Misc.fatal_errorf "[Project_var] from a value with wrong \ - approximation: %a@.closure=%a@.approx of closure=%a@." - Flambda.print_project_var project_var - Variable.print closure - Simple_value_approx.print approx) - -(* Transforms closure definitions by applying [loop] on the code of every - one of the set and on the expressions of the free variables. - If the substitution is activated, alpha renaming also occur on everything - defined by the set of closures: - * Variables bound by a closure of the set - * closure identifiers - * parameters - - The rewriting occurs in a clean environment without any of the variables - defined outside reachable. This helps increase robustness against - accidental, potentially unsound simplification of variable accesses by - [simplify_using_approx_and_env]. - - The rewriting occurs in an environment filled with: - * The approximation of the free variables - * An explicitly unknown approximation for function parameters, - except for those where it is known to be safe: those present in the - [specialised_args] set. - * An approximation for the closures in the set. It contains the code of - the functions before rewriting. - - The approximation of the currently defined closures is available to - allow marking recursives calls as direct and in some cases, allow - inlining of one closure from the set inside another one. For this to - be correct an alpha renaming is first applied on the expressions by - [apply_function_decls_and_free_vars]. - - For instance when rewriting the declaration - - [let rec f_1 x_1 = - let y_1 = x_1 + 1 in - g_1 y_1 - and g_1 z_1 = f_1 (f_1 z_1)] - - When rewriting this function, the first substitution will contain - some mapping: - { f_1 -> f_2; - g_1 -> g_2; - x_1 -> x_2; - z_1 -> z_2 } - - And the approximation for the closure will contain - - { f_2: - fun x_2 -> - let y_1 = x_2 + 1 in - g_2 y_1 - g_2: - fun z_2 -> f_2 (f_2 z_2) } - - Note that no substitution is applied to the let-bound variable [y_1]. - If [f_2] where to be inlined inside [g_2], we known that a new substitution - will be introduced in the current scope for [y_1] each time. - - - If the function where a recursive one coming from another compilation - unit, the code already went through [Flambdasym] that could have - replaced the function variable by the symbol identifying the function - (this occur if the function contains only constants in its closure). - To handle that case, we first replace those symbols by the original - variable. -*) -and simplify_set_of_closures original_env r - (set_of_closures : Flambda.set_of_closures) - : Flambda.set_of_closures * R.t * Freshening.Project_var.t = - let function_decls = - let module Backend = (val (E.backend original_env) : Backend_intf.S) in - (* CR-soon mshinwell: Does this affect - [reference_recursive_function_directly]? - mshinwell: This should be thought about as part of the wider issue of - references to functions via symbols or variables. *) - Freshening.rewrite_recursive_calls_with_symbols (E.freshening original_env) - set_of_closures.function_decls - ~make_closure_symbol:Backend.closure_symbol - in - let env = E.increase_closure_depth original_env in - let free_vars, specialised_args, function_decls, parameter_approximations, - internal_value_set_of_closures, set_of_closures_env = - Inline_and_simplify_aux.prepare_to_simplify_set_of_closures ~env - ~set_of_closures ~function_decls ~only_for_function_decl:None - ~freshen:true - in - let simplify_function fun_var (function_decl : Flambda.function_declaration) - (funs, used_params, r) - : Flambda.function_declaration Variable.Map.t * Variable.Set.t * R.t = - let closure_env = - Inline_and_simplify_aux.prepare_to_simplify_closure ~function_decl - ~free_vars ~specialised_args ~parameter_approximations - ~set_of_closures_env - in - let body, r = - E.enter_closure closure_env ~closure_id:(Closure_id.wrap fun_var) - ~inline_inside: - (Inlining_decision.should_inline_inside_declaration function_decl) - ~dbg:function_decl.dbg - ~f:(fun body_env -> - assert (E.inside_set_of_closures_declaration - function_decls.set_of_closures_origin body_env); - simplify body_env r function_decl.body) - in - let function_decl = - Flambda.create_function_declaration ~params:function_decl.params - ~body ~stub:function_decl.stub ~dbg:function_decl.dbg - ~inline:function_decl.inline ~specialise:function_decl.specialise - ~is_a_functor:function_decl.is_a_functor - ~closure_origin:function_decl.closure_origin - in - let used_params' = Flambda.used_params function_decl in - Variable.Map.add fun_var function_decl funs, - Variable.Set.union used_params used_params', r - in - let funs, _used_params, r = - Variable.Map.fold simplify_function function_decls.funs - (Variable.Map.empty, Variable.Set.empty, r) - in - let function_decls = - Flambda.update_function_declarations function_decls ~funs - in - let invariant_params = - lazy (Invariant_params.invariant_params_in_recursion function_decls - ~backend:(E.backend env)) - in - let recursive = - lazy (Find_recursive_functions.in_function_declarations function_decls - ~backend:(E.backend env)) - in - let keep_body = - Inline_and_simplify_aux.keep_body_check - ~is_classic_mode:function_decls.is_classic_mode ~recursive - in - let function_decls_approx = - A.function_declarations_approx ~keep_body function_decls - in - let value_set_of_closures = - A.create_value_set_of_closures - ~function_decls:function_decls_approx - ~bound_vars:internal_value_set_of_closures.bound_vars - ~invariant_params - ~recursive - ~specialised_args:internal_value_set_of_closures.specialised_args - ~free_vars:internal_value_set_of_closures.free_vars - ~freshening:internal_value_set_of_closures.freshening - ~direct_call_surrogates: - internal_value_set_of_closures.direct_call_surrogates - in - let direct_call_surrogates = - Closure_id.Map.fold (fun existing surrogate surrogates -> - Variable.Map.add (Closure_id.unwrap existing) - (Closure_id.unwrap surrogate) surrogates) - internal_value_set_of_closures.direct_call_surrogates - Variable.Map.empty - in - let set_of_closures = - Flambda.create_set_of_closures ~function_decls - ~free_vars:(Variable.Map.map fst free_vars) - ~specialised_args - ~direct_call_surrogates - in - let r = ret r (A.value_set_of_closures value_set_of_closures) in - set_of_closures, r, value_set_of_closures.freshening - -and simplify_apply env r ~(apply : Flambda.apply) : Flambda.t * R.t = - let { - Flambda. func = lhs_of_application; args; kind = _; dbg; - inline = inline_requested; specialise = specialise_requested; - } = apply in - let dbg = E.add_inlined_debuginfo env ~dbg in - simplify_free_variable env lhs_of_application - ~f:(fun env lhs_of_application lhs_of_application_approx -> - simplify_free_variables env args ~f:(fun env args args_approxs -> - (* By using the approximation of the left-hand side of the - application, attempt to determine which function is being applied - (even if the application is currently [Indirect]). If - successful---in which case we then have a direct - application---consider inlining. *) - match A.check_approx_for_closure lhs_of_application_approx with - | Ok (value_closure, set_of_closures_var, - set_of_closures_symbol, value_set_of_closures) -> - let lhs_of_application, closure_id_being_applied, - value_set_of_closures, env, wrap = - let closure_id_being_applied = value_closure.closure_id in - (* If the call site is a direct call to a function that has a - "direct call surrogate" (see inline_and_simplify_aux.mli), - repoint the call to the surrogate. *) - let surrogates = value_set_of_closures.direct_call_surrogates in - match Closure_id.Map.find closure_id_being_applied surrogates with - | exception Not_found -> - lhs_of_application, closure_id_being_applied, - value_set_of_closures, env, (fun expr -> expr) - | surrogate -> - let rec find_transitively surrogate = - match Closure_id.Map.find surrogate surrogates with - | exception Not_found -> surrogate - | surrogate -> find_transitively surrogate - in - let surrogate = find_transitively surrogate in - let surrogate_var = Variable.rename lhs_of_application in - let move_to_surrogate : Projection.move_within_set_of_closures = - { closure = lhs_of_application; - start_from = closure_id_being_applied; - move_to = surrogate; - } - in - let approx_for_surrogate = - A.value_closure ~closure_var:surrogate_var - ?set_of_closures_var ?set_of_closures_symbol - value_set_of_closures surrogate - in - let env = E.add env surrogate_var approx_for_surrogate in - let wrap expr = - Flambda.create_let surrogate_var - (Move_within_set_of_closures move_to_surrogate) - expr - in - surrogate_var, surrogate, value_set_of_closures, env, wrap - in - let function_decls = value_set_of_closures.function_decls in - let function_decl = - try - Variable.Map.find - (Closure_id.unwrap closure_id_being_applied) - function_decls.funs - with - | Not_found -> - Misc.fatal_errorf "When handling application expression, \ - approximation references non-existent closure %a@." - Closure_id.print closure_id_being_applied - in - let r = - match apply.kind with - | Indirect -> - R.map_benefit r Inlining_cost.Benefit.direct_call_of_indirect - | Direct _ -> r - in - let nargs = List.length args in - let arity = A.function_arity function_decl in - let result, r = - if nargs = arity then - simplify_full_application env r ~function_decls - ~lhs_of_application ~closure_id_being_applied ~function_decl - ~value_set_of_closures ~args ~args_approxs ~dbg - ~inline_requested ~specialise_requested - else if nargs > arity then - simplify_over_application env r ~args ~args_approxs - ~function_decls ~lhs_of_application ~closure_id_being_applied - ~function_decl ~value_set_of_closures ~dbg ~inline_requested - ~specialise_requested - else if nargs > 0 && nargs < arity then - simplify_partial_application env r ~lhs_of_application - ~closure_id_being_applied ~function_decl ~args ~dbg - ~inline_requested ~specialise_requested - else - Misc.fatal_errorf "Function with arity %d when simplifying \ - application expression: %a" - arity Flambda.print (Flambda.Apply apply) - in - wrap result, r - | Wrong -> (* Insufficient approximation information to simplify. *) - Apply ({ func = lhs_of_application; args; kind = Indirect; dbg; - inline = inline_requested; specialise = specialise_requested; }), - ret r (A.value_unknown Other))) - -and simplify_full_application env r ~function_decls ~lhs_of_application - ~closure_id_being_applied ~function_decl ~value_set_of_closures ~args - ~args_approxs ~dbg ~inline_requested ~specialise_requested = - Inlining_decision.for_call_site ~env ~r ~function_decls - ~lhs_of_application ~closure_id_being_applied ~function_decl - ~value_set_of_closures ~args ~args_approxs ~dbg ~simplify - ~inline_requested ~specialise_requested - -and simplify_partial_application env r ~lhs_of_application - ~closure_id_being_applied ~function_decl ~args ~dbg - ~inline_requested ~specialise_requested = - let arity = A.function_arity function_decl in - assert (arity > List.length args); - (* For simplicity, we disallow [@inline] attributes on partial - applications. The user may always write an explicit wrapper instead - with such an attribute. *) - (* CR-someday mshinwell: Pierre noted that we might like a function to be - inlined when applied to its first set of arguments, e.g. for some kind - of type class like thing. *) - begin match (inline_requested : Lambda.inline_attribute) with - | Always_inline | Never_inline -> - Location.prerr_warning (Debuginfo.to_location dbg) - (Warnings.Inlining_impossible "[@inlined] attributes may not be used \ - on partial applications") - | Unroll _ -> - Location.prerr_warning (Debuginfo.to_location dbg) - (Warnings.Inlining_impossible "[@unroll] attributes may not be used \ - on partial applications") - | Default_inline -> () - end; - begin match (specialise_requested : Lambda.specialise_attribute) with - | Always_specialise | Never_specialise -> - Location.prerr_warning (Debuginfo.to_location dbg) - (Warnings.Inlining_impossible "[@specialised] attributes may not be used \ - on partial applications") - | Default_specialise -> () - end; - let freshened_params = - List.map (fun p -> Parameter.rename p) function_decl.A.params - in - let applied_args, remaining_args = - Misc.Stdlib.List.map2_prefix (fun arg id' -> id', arg) - args freshened_params - in - let wrapper_accepting_remaining_args = - let body : Flambda.t = - Apply { - func = lhs_of_application; - args = Parameter.List.vars freshened_params; - kind = Direct closure_id_being_applied; - dbg; - inline = Default_inline; - specialise = Default_specialise; - } - in - let closure_variable = - Variable.rename - (Closure_id.unwrap closure_id_being_applied) - in - Flambda_utils.make_closure_declaration ~id:closure_variable - ~is_classic_mode:false - ~body - ~params:remaining_args - ~stub:true - in - let with_known_args = - Flambda_utils.bind - ~bindings:(List.map (fun (param, arg) -> - Parameter.var param, Flambda.Expr (Var arg)) applied_args) - ~body:wrapper_accepting_remaining_args - in - simplify env r with_known_args - -and simplify_over_application env r ~args ~args_approxs ~function_decls - ~lhs_of_application ~closure_id_being_applied ~function_decl - ~value_set_of_closures ~dbg ~inline_requested ~specialise_requested = - let arity = A.function_arity function_decl in - assert (arity < List.length args); - assert (List.length args = List.length args_approxs); - let full_app_args, remaining_args = - Misc.Stdlib.List.split_at arity args - in - let full_app_approxs, _ = - Misc.Stdlib.List.split_at arity args_approxs - in - let expr, r = - simplify_full_application env r ~function_decls ~lhs_of_application - ~closure_id_being_applied ~function_decl ~value_set_of_closures - ~args:full_app_args ~args_approxs:full_app_approxs ~dbg - ~inline_requested ~specialise_requested - in - let func_var = Variable.create Internal_variable_names.full_apply in - let expr : Flambda.t = - Flambda.create_let func_var (Expr expr) - (Apply { func = func_var; args = remaining_args; kind = Indirect; dbg; - inline = inline_requested; specialise = specialise_requested; }) - in - let expr = Lift_code.lift_lets_expr expr ~toplevel:true in - simplify (E.set_never_inline env) r expr - -and simplify_named env r (tree : Flambda.named) : Flambda.named * R.t = - match tree with - | Symbol sym -> - (* New Symbol construction could have been introduced during - transformation (by simplify_named_using_approx_and_env). - When this comes from another compilation unit, we must load it. *) - let approx = E.find_or_load_symbol env sym in - simplify_named_using_approx r tree approx - | Const cst -> tree, ret r (simplify_const cst) - | Allocated_const cst -> tree, ret r (approx_for_allocated_const cst) - | Read_mutable mut_var -> - (* See comment on the [Assign] case. *) - let mut_var = - Freshening.apply_mutable_variable (E.freshening env) mut_var - in - Read_mutable mut_var, ret r (A.value_unknown Other) - | Read_symbol_field (symbol, field_index) -> - let approx = E.find_or_load_symbol env symbol in - begin match A.get_field approx ~field_index with - (* CR-someday mshinwell: Think about [Unreachable] vs. [Value_bottom]. *) - | Unreachable -> (Flambda.Expr Proved_unreachable), r - | Ok approx -> - let approx = A.augment_with_symbol_field approx symbol field_index in - simplify_named_using_approx_and_env env r tree approx - end - | Set_of_closures set_of_closures -> begin - let backend = E.backend env in - let set_of_closures, r, first_freshening = - simplify_set_of_closures env r set_of_closures - in - let simplify env r expr ~pass_name : Flambda.named * R.t = - (* If simplifying a set of closures more than once during any given round - of simplification, the [Freshening.Project_var] substitutions arising - from each call to [simplify_set_of_closures] must be composed. - Note that this function only composes with [first_freshening] owing - to the structure of the code below (this new [simplify] is always - in tail position). *) - (* CR-someday mshinwell: It was mooted that maybe we could try - structurally-typed closures (i.e. where we would never rename the - closure elements), or something else, to try to remove - the "closure freshening" thing in the approximation which is hard - to deal with. *) - let expr, r = simplify (E.set_never_inline env) r expr in - let approx = R.approx r in - let value_set_of_closures = - match A.strict_check_approx_for_set_of_closures approx with - | Wrong -> - Misc.fatal_errorf "Unexpected approximation returned from \ - simplification of [%s] result: %a" - pass_name A.print approx - | Ok (_var, value_set_of_closures) -> - let freshening = - Freshening.Project_var.compose ~earlier:first_freshening - ~later:value_set_of_closures.freshening - in - A.update_freshening_of_value_set_of_closures value_set_of_closures - ~freshening - in - Expr expr, (ret r (A.value_set_of_closures value_set_of_closures)) - in - (* This does the actual substitutions of specialised args introduced - by [Unbox_closures] for free variables. (Apart from simplifying - the [Unbox_closures] output, this also prevents applying - [Unbox_closures] over and over.) *) - let set_of_closures = - let ppf_dump = Inline_and_simplify_aux.Env.ppf_dump env in - match Remove_free_vars_equal_to_args.run ~ppf_dump set_of_closures with - | None -> set_of_closures - | Some set_of_closures -> set_of_closures - in - (* Do [Unbox_closures] next to try to decide which things are - free variables and which things are specialised arguments before - unboxing them. *) - match - Unbox_closures.rewrite_set_of_closures ~env - ~duplicate_function ~set_of_closures - with - | Some (expr, benefit) -> - let r = R.add_benefit r benefit in - simplify env r expr ~pass_name:"Unbox_closures" - | None -> - match Unbox_free_vars_of_closures.run ~env ~set_of_closures with - | Some (expr, benefit) -> - let r = R.add_benefit r benefit in - simplify env r expr ~pass_name:"Unbox_free_vars_of_closures" - | None -> - (* CR-soon mshinwell: should maybe add one allocation for the stub *) - match - Unbox_specialised_args.rewrite_set_of_closures ~env - ~duplicate_function ~set_of_closures - with - | Some (expr, benefit) -> - let r = R.add_benefit r benefit in - simplify env r expr ~pass_name:"Unbox_specialised_args" - | None -> - match - Remove_unused_arguments. - separate_unused_arguments_in_set_of_closures - set_of_closures ~backend - with - | Some set_of_closures -> - let expr = - Flambda_utils.name_expr (Set_of_closures set_of_closures) - ~name:Internal_variable_names.remove_unused_arguments - in - simplify env r expr ~pass_name:"Remove_unused_arguments" - | None -> - Set_of_closures set_of_closures, r - end - | Project_closure project_closure -> - simplify_project_closure env r ~project_closure - | Project_var project_var -> simplify_project_var env r ~project_var - | Move_within_set_of_closures move_within_set_of_closures -> - simplify_move_within_set_of_closures env r ~move_within_set_of_closures - | Prim (prim, args, dbg) -> - let dbg = E.add_inlined_debuginfo env ~dbg in - simplify_free_variables_named env args ~f:(fun env args args_approxs -> - let tree = Flambda.Prim (prim, args, dbg) in - begin match prim, args, args_approxs with - (* CR-someday mshinwell: Optimise [Pfield_computed]. *) - | Pfield field_index, [arg], [arg_approx] -> - let projection : Projection.t = Field (field_index, arg) in - begin match E.find_projection env ~projection with - | Some var -> - simplify_free_variable_named env var ~f:(fun _env var var_approx -> - let r = R.map_benefit r (B.remove_projection projection) in - Expr (Var var), ret r var_approx) - | None -> - begin match A.get_field arg_approx ~field_index with - | Unreachable -> (Flambda.Expr Proved_unreachable, r) - | Ok approx -> - let tree, approx = - match arg_approx.symbol with - (* If the [Pfield] is projecting directly from a symbol, rewrite - the expression to [Read_symbol_field]. *) - | Some (symbol, None) -> - let approx = - A.augment_with_symbol_field approx symbol field_index - in - Flambda.Read_symbol_field (symbol, field_index), approx - | None | Some (_, Some _ ) -> - (* This [Pfield] is either not projecting from a symbol at all, - or it is the projection of a projection from a symbol. *) - let approx' = E.really_import_approx env approx in - tree, approx' - in - simplify_named_using_approx_and_env env r tree approx - end - end - | Pfield _, _, _ -> Misc.fatal_error "Pfield arity error" - | (Parraysetu kind | Parraysets kind), - [_block; _field; _value], - [block_approx; _field_approx; value_approx] -> - if A.warn_on_mutation block_approx then begin - Location.prerr_warning (Debuginfo.to_location dbg) - Warnings.Assignment_to_non_mutable_value - end; - let kind = - let check () = - match kind with - | Pfloatarray | Pgenarray -> () - | Paddrarray | Pintarray -> - (* CR pchambart: Do a proper warning here *) - Misc.fatal_errorf "Assignment of a float to a specialised \ - non-float array: %a" - Flambda.print_named tree - in - match A.descr block_approx, A.descr value_approx with - | (Value_float_array _, _) -> check (); Lambda.Pfloatarray - | (_, Value_float _) when Config.flat_float_array -> - check (); Lambda.Pfloatarray - (* CR pchambart: This should be accounted by the benefit *) - | _ -> - kind - in - let prim : Clambda_primitives.primitive = match prim with - | Parraysetu _ -> Parraysetu kind - | Parraysets _ -> Parraysets kind - | _ -> assert false - in - Prim (prim, args, dbg), ret r (A.value_unknown Other) - | Psetfield _, _block::_, block_approx::_ -> - if A.warn_on_mutation block_approx then begin - Location.prerr_warning (Debuginfo.to_location dbg) - Warnings.Assignment_to_non_mutable_value - end; - tree, ret r (A.value_unknown Other) - | (Psetfield _ | Parraysetu _ | Parraysets _), _, _ -> - Misc.fatal_error "Psetfield / Parraysetu / Parraysets arity error" - | (Psequand | Psequor), _, _ -> - Misc.fatal_error "Psequand and Psequor must be expanded (see handling \ - in closure_conversion.ml)" - | p, args, args_approxs -> - let expr, approx, benefit = - let module Backend = (val (E.backend env) : Backend_intf.S) in - Simplify_primitives.primitive p (args, args_approxs) tree dbg - ~size_int:Backend.size_int - in - let r = R.map_benefit r (B.(+) benefit) in - let approx = - match p with - | Popaque -> A.value_unknown Other - | _ -> approx - in - expr, ret r approx - end) - | Expr expr -> - let expr, r = simplify env r expr in - Expr expr, r - -and simplify env r (tree : Flambda.t) : Flambda.t * R.t = - match tree with - | Var var -> - let var = Freshening.apply_variable (E.freshening env) var in - (* If from the approximations we can simplify [var], then we will be - forced to insert [let]-expressions (done using [name_expr], in - [Simple_value_approx]) to bind a [named]. This has an important - consequence: it brings bindings of constants closer to their use - points. *) - simplify_using_approx_and_env env r (Var var) (E.find_exn env var) - | Apply apply -> - simplify_apply env r ~apply - | Let _ -> - let for_defining_expr (env, r) var defining_expr = - let defining_expr, r = simplify_named env r defining_expr in - let var, sb = Freshening.add_variable (E.freshening env) var in - let env = E.set_freshening env sb in - let env = E.add env var (R.approx r) in - (env, r), var, defining_expr - in - let for_last_body (env, r) body = - simplify env r body - in - let filter_defining_expr r var defining_expr free_vars_of_body = - if Variable.Set.mem var free_vars_of_body then - r, var, Some defining_expr - else if Effect_analysis.no_effects_named defining_expr then - let r = R.map_benefit r (B.remove_code_named defining_expr) in - r, var, None - else - r, var, Some defining_expr - in - Flambda.fold_lets_option tree - ~init:(env, r) - ~for_defining_expr - ~for_last_body - ~filter_defining_expr - | Let_mutable { var = mut_var; initial_value = var; body; contents_kind } -> - (* CR-someday mshinwell: add the dead let elimination, as above. *) - simplify_free_variable env var ~f:(fun env var _var_approx -> - let mut_var, sb = - Freshening.add_mutable_variable (E.freshening env) mut_var - in - let env = E.set_freshening env sb in - let body, r = - simplify (E.add_mutable env mut_var (A.value_unknown Other)) r body - in - Flambda.Let_mutable - { var = mut_var; - initial_value = var; - body; - contents_kind }, - r) - | Let_rec (defs, body) -> - let defs, sb = Freshening.add_variables (E.freshening env) defs in - let env = E.set_freshening env sb in - let def_env = - List.fold_left (fun env_acc (id, _lam) -> - E.add env_acc id (A.value_unknown Other)) - env defs - in - let defs, body_env, r = - List.fold_right (fun (id, lam) (defs, env_acc, r) -> - let lam, r = simplify_named def_env r lam in - let defs = (id, lam) :: defs in - let env_acc = E.add env_acc id (R.approx r) in - defs, env_acc, r) - defs ([], env, r) - in - let body, r = simplify body_env r body in - Let_rec (defs, body), r - | Static_raise (i, args) -> - let i = Freshening.apply_static_exception (E.freshening env) i in - simplify_free_variables env args ~f:(fun _env args _args_approxs -> - let r = R.use_static_exception r i in - Static_raise (i, args), ret r A.value_bottom) - | Static_catch (i, vars, body, handler) -> - begin - match body with - | Let { var; defining_expr = def; body; _ } - when not (Flambda_utils.might_raise_static_exn def i) -> - simplify env r - (Flambda.create_let var def (Static_catch (i, vars, body, handler))) - | _ -> - let i, sb = Freshening.add_static_exception (E.freshening env) i in - let env = E.set_freshening env sb in - let body, r = simplify env r body in - (* CR-soon mshinwell: for robustness, R.used_static_exceptions should - maybe be removed. *) - if not (Static_exception.Set.mem i (R.used_static_exceptions r)) then - (* If the static exception is not used, we can drop the declaration *) - body, r - else begin - match (body : Flambda.t) with - | Static_raise (j, args) -> - assert (Static_exception.equal i j); - let handler = - List.fold_left2 (fun body var arg -> - Flambda.create_let var (Expr (Var arg)) body) - handler vars args - in - let r = R.exit_scope_catch r i in - simplify env r handler - | _ -> - let vars, sb = Freshening.add_variables' (E.freshening env) vars in - let approx = R.approx r in - let env = - List.fold_left (fun env id -> - E.add env id (A.value_unknown Other)) - (E.set_freshening env sb) vars - in - let env = E.inside_branch env in - let handler, r = simplify env r handler in - let r = R.exit_scope_catch r i in - Static_catch (i, vars, body, handler), - R.meet_approx r env approx - end - end - | Try_with (body, id, handler) -> - let body, r = simplify env r body in - let id, sb = Freshening.add_variable (E.freshening env) id in - let env = E.add (E.set_freshening env sb) id (A.value_unknown Other) in - let env = E.inside_branch env in - let handler, r = simplify env r handler in - Try_with (body, id, handler), ret r (A.value_unknown Other) - | If_then_else (arg, ifso, ifnot) -> - (* When arg is the constant false or true (or something considered - as true), we can drop the if and replace it by a sequence. - if arg is not effectful we can also drop it. *) - simplify_free_variable env arg ~f:(fun env arg arg_approx -> - begin match arg_approx.descr with - | Value_constptr 0 | Value_int 0 -> (* Constant [false]: keep [ifnot] *) - let ifnot, r = simplify env r ifnot in - ifnot, R.map_benefit r B.remove_branch - | Value_constptr _ | Value_int _ - | Value_block _ -> (* Constant [true]: keep [ifso] *) - let ifso, r = simplify env r ifso in - ifso, R.map_benefit r B.remove_branch - | _ -> - let env = E.inside_branch env in - let ifso, r = simplify env r ifso in - let ifso_approx = R.approx r in - let ifnot, r = simplify env r ifnot in - If_then_else (arg, ifso, ifnot), - R.meet_approx r env ifso_approx - end) - | While (cond, body) -> - let cond, r = simplify env r cond in - let body, r = simplify env r body in - While (cond, body), ret r (A.value_unknown Other) - | Send { kind; meth; obj; args; dbg; } -> - let dbg = E.add_inlined_debuginfo env ~dbg in - simplify_free_variable env meth ~f:(fun env meth _meth_approx -> - simplify_free_variable env obj ~f:(fun env obj _obj_approx -> - simplify_free_variables env args ~f:(fun _env args _args_approx -> - Send { kind; meth; obj; args; dbg; }, - ret r (A.value_unknown Other)))) - | For { bound_var; from_value; to_value; direction; body; } -> - simplify_free_variable env from_value ~f:(fun env from_value _approx -> - simplify_free_variable env to_value ~f:(fun env to_value _approx -> - let bound_var, sb = - Freshening.add_variable (E.freshening env) bound_var - in - let env = - E.add (E.set_freshening env sb) bound_var - (A.value_unknown Other) - in - let body, r = simplify env r body in - For { bound_var; from_value; to_value; direction; body; }, - ret r (A.value_unknown Other))) - | Assign { being_assigned; new_value; } -> - (* No need to use something like [simplify_free_variable]: the - approximation of [being_assigned] is always unknown. *) - let being_assigned = - Freshening.apply_mutable_variable (E.freshening env) being_assigned - in - simplify_free_variable env new_value ~f:(fun _env new_value _approx -> - Assign { being_assigned; new_value; }, ret r (A.value_unknown Other)) - | Switch (arg, sw) -> - (* When [arg] is known to be a variable whose approximation is that of a - block with a fixed tag or a fixed integer, we can eliminate the - [Switch]. (This should also make the [Let] that binds [arg] redundant, - meaning that it too can be eliminated.) *) - simplify_free_variable env arg ~f:(fun env arg arg_approx -> - let rec filter_branches filter branches compatible_branches = - match branches with - | [] -> Can_be_taken compatible_branches - | (c, lam) as branch :: branches -> - match filter arg_approx c with - | A.Cannot_be_taken -> - filter_branches filter branches compatible_branches - | A.Can_be_taken -> - filter_branches filter branches (branch :: compatible_branches) - | A.Must_be_taken -> - Must_be_taken lam - in - let filtered_consts = - filter_branches A.potentially_taken_const_switch_branch sw.consts [] - in - let filtered_blocks = - filter_branches A.potentially_taken_block_switch_branch sw.blocks [] - in - begin match filtered_consts, filtered_blocks with - | Must_be_taken _, Must_be_taken _ -> - assert false - | Must_be_taken branch, _ - | _, Must_be_taken branch -> - let lam, r = simplify env r branch in - lam, R.map_benefit r B.remove_branch - | Can_be_taken consts, Can_be_taken blocks -> - match consts, blocks, sw.failaction with - | [], [], None -> - (* If the switch is applied to a statically-known value that does not - match any case: - * if there is a default action take that case; - * otherwise this is something that is guaranteed not to - be reachable by the type checker. For example: - [type 'a t = Int : int -> int t | Float : float -> float t - match Int 1 with - | Int _ -> ... - | Float f as v -> - match v with <-- This match is unreachable - | Float f -> ...] - *) - Proved_unreachable, ret r A.value_bottom - | [_, branch], [], None - | [], [_, branch], None - | [], [], Some branch -> - let lam, r = simplify env r branch in - lam, R.map_benefit r B.remove_branch - | _ -> - let env = E.inside_branch env in - let f (i, v) (acc, r) = - let approx = R.approx r in - let lam, r = simplify env r v in - (i, lam)::acc, - R.meet_approx r env approx - in - let r = R.set_approx r A.value_bottom in - let consts, r = List.fold_right f consts ([], r) in - let blocks, r = List.fold_right f blocks ([], r) in - let failaction, r = - match sw.failaction with - | None -> None, r - | Some l -> - let approx = R.approx r in - let l, r = simplify env r l in - Some l, - R.meet_approx r env approx - in - let sw = { sw with failaction; consts; blocks; } in - Switch (arg, sw), r - end) - | String_switch (arg, sw, def) -> - simplify_free_variable env arg ~f:(fun env arg arg_approx -> - match A.check_approx_for_string arg_approx with - | None -> - let env = E.inside_branch env in - let sw, r = - List.fold_right (fun (str, lam) (sw, r) -> - let approx = R.approx r in - let lam, r = simplify env r lam in - (str, lam)::sw, - R.meet_approx r env approx) - sw - ([], r) - in - let def, r = - match def with - | None -> def, r - | Some def -> - let approx = R.approx r in - let def, r = simplify env r def in - Some def, - R.meet_approx r env approx - in - String_switch (arg, sw, def), ret r (A.value_unknown Other) - | Some arg_string -> - let branch = - match List.find (fun (str, _) -> String.equal str arg_string) sw with - | (_, branch) -> branch - | exception Not_found -> - match def with - | None -> - Flambda.Proved_unreachable - | Some def -> - def - in - let branch, r = simplify env r branch in - branch, R.map_benefit r B.remove_branch) - | Proved_unreachable -> tree, ret r A.value_bottom - -and simplify_list env r l = - match l with - | [] -> [], [], r - | h::t -> - let t', approxs, r = simplify_list env r t in - let h', r = simplify env r h in - let approxs = (R.approx r) :: approxs in - if t' == t && h' == h - then l, approxs, r - else h' :: t', approxs, r - -and duplicate_function ~env ~(set_of_closures : Flambda.set_of_closures) - ~fun_var ~new_fun_var = - let function_decl = - match Variable.Map.find fun_var set_of_closures.function_decls.funs with - | exception Not_found -> - Misc.fatal_errorf "duplicate_function: cannot find function %a" - Variable.print fun_var - | function_decl -> function_decl - in - let env = E.activate_freshening (E.set_never_inline env) in - let free_vars, specialised_args, function_decls, parameter_approximations, - _internal_value_set_of_closures, set_of_closures_env = - Inline_and_simplify_aux.prepare_to_simplify_set_of_closures ~env - ~set_of_closures ~function_decls:set_of_closures.function_decls - ~freshen:false ~only_for_function_decl:(Some function_decl) - in - let function_decl = - match Variable.Map.find fun_var function_decls.funs with - | exception Not_found -> - Misc.fatal_errorf "duplicate_function: cannot find function %a (2)" - Variable.print fun_var - | function_decl -> function_decl - in - let closure_env = - Inline_and_simplify_aux.prepare_to_simplify_closure ~function_decl - ~free_vars ~specialised_args ~parameter_approximations - ~set_of_closures_env - in - let body, _r = - E.enter_closure closure_env - ~closure_id:(Closure_id.wrap fun_var) - ~inline_inside:false - ~dbg:function_decl.dbg - ~f:(fun body_env -> - assert (E.inside_set_of_closures_declaration - function_decls.set_of_closures_origin body_env); - simplify body_env (R.create ()) function_decl.body) - in - let function_decl = - Flambda.create_function_declaration ~params:function_decl.params - ~body ~stub:function_decl.stub ~dbg:function_decl.dbg - ~inline:function_decl.inline ~specialise:function_decl.specialise - ~is_a_functor:function_decl.is_a_functor - ~closure_origin:(Closure_origin.create (Closure_id.wrap new_fun_var)) - in - function_decl, specialised_args - -let constant_defining_value_approx - env - (constant_defining_value:Flambda.constant_defining_value) = - match constant_defining_value with - | Allocated_const const -> - approx_for_allocated_const const - | Block (tag, fields) -> - let fields = - List.map - (function - | Flambda.Symbol sym -> begin - match E.find_symbol_opt env sym with - | Some approx -> approx - | None -> A.value_unresolved (Symbol sym) - end - | Flambda.Const cst -> simplify_const cst) - fields - in - A.value_block tag (Array.of_list fields) - | Set_of_closures { function_decls; free_vars; specialised_args } -> - (* At toplevel, there is no freshening currently happening (this - cannot be the body of a currently inlined function), so we can - keep the original set_of_closures in the approximation. *) - assert(Freshening.is_empty (E.freshening env)); - assert(Variable.Map.is_empty free_vars); - assert(Variable.Map.is_empty specialised_args); - let invariant_params = - lazy (Invariant_params.invariant_params_in_recursion function_decls - ~backend:(E.backend env)) - in - let recursive = - lazy (Find_recursive_functions.in_function_declarations function_decls - ~backend:(E.backend env)) - in - let value_set_of_closures = - let keep_body = - Inline_and_simplify_aux.keep_body_check - ~is_classic_mode:function_decls.is_classic_mode ~recursive - in - let function_decls = - A.function_declarations_approx ~keep_body function_decls - in - A.create_value_set_of_closures ~function_decls - ~bound_vars:Var_within_closure.Map.empty - ~invariant_params - ~recursive - ~specialised_args:Variable.Map.empty - ~free_vars:Variable.Map.empty - ~freshening:Freshening.Project_var.empty - ~direct_call_surrogates:Closure_id.Map.empty - in - A.value_set_of_closures value_set_of_closures - | Project_closure (set_of_closures_symbol, closure_id) -> begin - match E.find_symbol_opt env set_of_closures_symbol with - | None -> - A.value_unresolved (Symbol set_of_closures_symbol) - | Some set_of_closures_approx -> - let checked_approx = - A.check_approx_for_set_of_closures set_of_closures_approx - in - match checked_approx with - | Ok (_, value_set_of_closures) -> - let closure_id = - A.freshen_and_check_closure_id value_set_of_closures closure_id - in - A.value_closure value_set_of_closures closure_id - | Unresolved sym -> A.value_unresolved sym - | Unknown -> A.value_unknown Other - | Unknown_because_of_unresolved_value value -> - A.value_unknown (Unresolved_value value) - | Wrong -> - Misc.fatal_errorf "Wrong approximation for [Project_closure] \ - when being used as a [constant_defining_value]: %a" - Flambda.print_constant_defining_value constant_defining_value - end - -(* See documentation on [Let_rec_symbol] in flambda.mli. *) -let define_let_rec_symbol_approx orig_env defs = - (* First declare an empty version of the symbols *) - let init_env = - List.fold_left (fun building_env (symbol, _) -> - E.add_symbol building_env symbol (A.value_unresolved (Symbol symbol))) - orig_env defs - in - let rec loop times lookup_env = - if times <= 0 then - lookup_env - else - let env = - List.fold_left (fun building_env (symbol, constant_defining_value) -> - let approx = - constant_defining_value_approx lookup_env constant_defining_value - in - let approx = A.augment_with_symbol approx symbol in - E.add_symbol building_env symbol approx) - orig_env defs - in - loop (times-1) env - in - loop 2 init_env - -let simplify_constant_defining_value - env r symbol - (constant_defining_value:Flambda.constant_defining_value) = - let r, constant_defining_value, approx = - match constant_defining_value with - (* No simplifications are possible for [Allocated_const] or [Block]. *) - | Allocated_const const -> - r, constant_defining_value, approx_for_allocated_const const - | Block (tag, fields) -> - let fields = List.map - (function - | Flambda.Symbol sym -> E.find_symbol_exn env sym - | Flambda.Const cst -> simplify_const cst) - fields - in - r, constant_defining_value, A.value_block tag (Array.of_list fields) - | Set_of_closures set_of_closures -> - if Variable.Map.cardinal set_of_closures.free_vars <> 0 then begin - Misc.fatal_errorf "Set of closures bound by [Let_symbol] is not \ - closed: %a" - Flambda.print_set_of_closures set_of_closures - end; - let set_of_closures, r, _freshening = - simplify_set_of_closures env r set_of_closures - in - r, ((Set_of_closures set_of_closures) : Flambda.constant_defining_value), - R.approx r - | Project_closure (set_of_closures_symbol, closure_id) -> - (* No simplifications are necessary here. *) - let set_of_closures_approx = - E.find_symbol_exn env set_of_closures_symbol - in - let closure_approx = - match A.check_approx_for_set_of_closures set_of_closures_approx with - | Ok (_, value_set_of_closures) -> - let closure_id = - A.freshen_and_check_closure_id value_set_of_closures closure_id - in - A.value_closure value_set_of_closures closure_id - | Unresolved sym -> A.value_unresolved sym - | Unknown -> A.value_unknown Other - | Unknown_because_of_unresolved_value value -> - A.value_unknown (Unresolved_value value) - | Wrong -> - Misc.fatal_errorf "Wrong approximation for [Project_closure] \ - when being used as a [constant_defining_value]: %a" - Flambda.print_constant_defining_value constant_defining_value - in - r, constant_defining_value, closure_approx - in - let approx = A.augment_with_symbol approx symbol in - let r = ret r approx in - r, constant_defining_value, approx - -let rec simplify_program_body env r (program : Flambda.program_body) - : Flambda.program_body * R.t = - match program with - | Let_rec_symbol (defs, program) -> - let set_of_closures_defs, other_defs = - List.partition - (function - | (_, Flambda.Set_of_closures _) -> true - | _ -> false) - defs in - let process_defs ~lookup_env ~env r defs = - List.fold_left (fun (building_env, r, defs) (symbol, def) -> - let r, def, approx = - simplify_constant_defining_value lookup_env r symbol def - in - let approx = A.augment_with_symbol approx symbol in - let building_env = E.add_symbol building_env symbol approx in - (building_env, r, (symbol, def) :: defs)) - (env, r, []) defs - in - let env, r, set_of_closures_defs = - let lookup_env = define_let_rec_symbol_approx env defs in - process_defs ~lookup_env ~env r set_of_closures_defs - in - let env, r, other_defs = - let lookup_env = define_let_rec_symbol_approx env other_defs in - process_defs ~lookup_env ~env r other_defs - in - let program, r = simplify_program_body env r program in - Let_rec_symbol (set_of_closures_defs @ other_defs, program), r - | Let_symbol (symbol, constant_defining_value, program) -> - let r, constant_defining_value, approx = - simplify_constant_defining_value env r symbol constant_defining_value - in - let approx = A.augment_with_symbol approx symbol in - let env = E.add_symbol env symbol approx in - let program, r = simplify_program_body env r program in - Let_symbol (symbol, constant_defining_value, program), r - | Initialize_symbol (symbol, tag, fields, program) -> - let fields, approxs, r = simplify_list env r fields in - let approx = - A.augment_with_symbol (A.value_block tag (Array.of_list approxs)) symbol - in - let module Backend = (val (E.backend env) : Backend_intf.S) in - let env = E.add_symbol env symbol approx in - let program, r = simplify_program_body env r program in - Initialize_symbol (symbol, tag, fields, program), r - | Effect (expr, program) -> - let expr, r = simplify env r expr in - let program, r = simplify_program_body env r program in - Effect (expr, program), r - | End root -> End root, r - -let simplify_program env r (program : Flambda.program) = - let env, r = - Symbol.Set.fold (fun symbol (env, r) -> - let env, approx = - match E.find_symbol_exn env symbol with - | exception Not_found -> - let module Backend = (val (E.backend env) : Backend_intf.S) in - (* CR-someday mshinwell for mshinwell: Is there a reason we cannot - use [simplify_named_using_approx_and_env] here? *) - let approx = Backend.import_symbol symbol in - E.add_symbol env symbol approx, approx - | approx -> env, approx - in - env, ret r approx) - program.imported_symbols - (env, r) - in - let program_body, r = simplify_program_body env r program.program_body in - let program = { program with program_body; } in - program, r - -let add_predef_exns_to_environment ~env ~backend = - let module Backend = (val backend : Backend_intf.S) in - List.fold_left (fun env predef_exn -> - assert (Ident.is_predef predef_exn); - let symbol = Backend.symbol_for_global' predef_exn in - let name = Ident.name predef_exn in - let approx = - A.value_block Tag.object_tag - [| A.value_string (String.length name) (Some name); - A.value_unknown Other; - |] - in - E.add_symbol env symbol (A.augment_with_symbol approx symbol)) - env - Predef.all_predef_exns - -let run ~never_inline ~backend ~prefixname ~round ~ppf_dump program = - let r = R.create () in - let report = !Clflags.inlining_report in - if never_inline then Clflags.inlining_report := false; - let initial_env = - add_predef_exns_to_environment - ~env:(E.create ~never_inline ~backend ~round ~ppf_dump) - ~backend - in - let result, r = simplify_program initial_env r program in - let result = Flambda_utils.introduce_needed_import_symbols result in - if not (Static_exception.Set.is_empty (R.used_static_exceptions r)) - then begin - Misc.fatal_error (Format.asprintf "Remaining static exceptions: %a@.%a@." - Static_exception.Set.print (R.used_static_exceptions r) - Flambda.print_program result) - end; - assert (Static_exception.Set.is_empty (R.used_static_exceptions r)); - if !Clflags.inlining_report then begin - let output_prefix = Printf.sprintf "%s.%d" prefixname round in - Inlining_stats.save_then_forget_decisions ~output_prefix - end; - Clflags.inlining_report := report; - result diff --git a/middle_end/inline_and_simplify.mli b/middle_end/inline_and_simplify.mli deleted file mode 100644 index 9a8e6e8b46..0000000000 --- a/middle_end/inline_and_simplify.mli +++ /dev/null @@ -1,40 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -(** Simplification of Flambda programs combined with function inlining: - for the most part a beta-reduction pass. - - Readers interested in the inlining strategy should read the - [Inlining_decision] module first. -*) -val run - : never_inline:bool - -> backend:(module Backend_intf.S) - -> prefixname:string - -> round:int - -> ppf_dump:Format.formatter - -> Flambda.program - -> Flambda.program - -val duplicate_function - : env:Inline_and_simplify_aux.Env.t - -> set_of_closures:Flambda.set_of_closures - -> fun_var:Variable.t - -> new_fun_var:Variable.t - -> Flambda.function_declaration - * Flambda.specialised_to Variable.Map.t (* new specialised arguments *) diff --git a/middle_end/inline_and_simplify_aux.ml b/middle_end/inline_and_simplify_aux.ml deleted file mode 100644 index bb725e8c64..0000000000 --- a/middle_end/inline_and_simplify_aux.ml +++ /dev/null @@ -1,738 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -module Env = struct - type scope = Current | Outer - - type t = { - backend : (module Backend_intf.S); - round : int; - ppf_dump : Format.formatter; - approx : (scope * Simple_value_approx.t) Variable.Map.t; - approx_mutable : Simple_value_approx.t Mutable_variable.Map.t; - approx_sym : Simple_value_approx.t Symbol.Map.t; - projections : Variable.t Projection.Map.t; - current_functions : Set_of_closures_origin.Set.t; - (* The functions currently being declared: used to avoid inlining - recursively *) - inlining_level : int; - (* Number of times "inline" has been called recursively *) - inside_branch : int; - freshening : Freshening.t; - never_inline : bool ; - never_inline_inside_closures : bool; - never_inline_outside_closures : bool; - unroll_counts : int Set_of_closures_origin.Map.t; - inlining_counts : int Closure_origin.Map.t; - actively_unrolling : int Set_of_closures_origin.Map.t; - closure_depth : int; - inlining_stats_closure_stack : Inlining_stats.Closure_stack.t; - inlined_debuginfo : Debuginfo.t; - } - - let create ~never_inline ~backend ~round ~ppf_dump = - { backend; - round; - ppf_dump; - approx = Variable.Map.empty; - approx_mutable = Mutable_variable.Map.empty; - approx_sym = Symbol.Map.empty; - projections = Projection.Map.empty; - current_functions = Set_of_closures_origin.Set.empty; - inlining_level = 0; - inside_branch = 0; - freshening = Freshening.empty; - never_inline; - never_inline_inside_closures = false; - never_inline_outside_closures = false; - unroll_counts = Set_of_closures_origin.Map.empty; - inlining_counts = Closure_origin.Map.empty; - actively_unrolling = Set_of_closures_origin.Map.empty; - closure_depth = 0; - inlining_stats_closure_stack = - Inlining_stats.Closure_stack.create (); - inlined_debuginfo = Debuginfo.none; - } - - let backend t = t.backend - let round t = t.round - let ppf_dump t = t.ppf_dump - - let local env = - { env with - approx = Variable.Map.empty; - projections = Projection.Map.empty; - freshening = Freshening.empty_preserving_activation_state env.freshening; - inlined_debuginfo = Debuginfo.none; - } - - let inlining_level_up env = - let max_level = - Clflags.Int_arg_helper.get ~key:(env.round) !Clflags.inline_max_depth - in - if (env.inlining_level + 1) > max_level then - Misc.fatal_error "Inlining level increased above maximum"; - { env with inlining_level = env.inlining_level + 1 } - - let print ppf t = - Format.fprintf ppf - "Environment maps: %a@.Projections: %a@.Freshening: %a@." - Variable.Set.print (Variable.Map.keys t.approx) - (Projection.Map.print Variable.print) t.projections - Freshening.print t.freshening - - let mem t var = Variable.Map.mem var t.approx - - let add_internal t var (approx : Simple_value_approx.t) ~scope = - let approx = - (* The semantics of this [match] are what preserve the property - described at the top of simple_value_approx.mli, namely that when a - [var] is mem on an approximation (amongst many possible [var]s), - it is the one with the outermost scope. *) - match approx.var with - | Some var when mem t var -> approx - | _ -> Simple_value_approx.augment_with_variable approx var - in - { t with approx = Variable.Map.add var (scope, approx) t.approx } - - let add t var approx = add_internal t var approx ~scope:Current - let add_outer_scope t var approx = add_internal t var approx ~scope:Outer - - let add_mutable t mut_var approx = - { t with approx_mutable = - Mutable_variable.Map.add mut_var approx t.approx_mutable; - } - - let really_import_approx t = - let module Backend = (val (t.backend) : Backend_intf.S) in - Backend.really_import_approx - - let really_import_approx_with_scope t (scope, approx) = - scope, really_import_approx t approx - - let find_symbol_exn t symbol = - really_import_approx t - (Symbol.Map.find symbol t.approx_sym) - - let find_symbol_opt t symbol = - try Some (really_import_approx t - (Symbol.Map.find symbol t.approx_sym)) - with Not_found -> None - - let find_symbol_fatal t symbol = - match find_symbol_exn t symbol with - | exception Not_found -> - Misc.fatal_errorf "Symbol %a is unbound. Maybe there is a missing \ - [Let_symbol], [Import_symbol] or similar?" - Symbol.print symbol - | approx -> approx - - let find_or_load_symbol t symbol = - match find_symbol_exn t symbol with - | exception Not_found -> - if Compilation_unit.equal - (Compilation_unit.get_current_exn ()) - (Symbol.compilation_unit symbol) - then - Misc.fatal_errorf "Symbol %a from the current compilation unit is \ - unbound. Maybe there is a missing [Let_symbol] or similar?" - Symbol.print symbol; - let module Backend = (val (t.backend) : Backend_intf.S) in - Backend.import_symbol symbol - | approx -> approx - - let add_projection t ~projection ~bound_to = - { t with - projections = - Projection.Map.add projection bound_to t.projections; - } - - let find_projection t ~projection = - match Projection.Map.find projection t.projections with - | exception Not_found -> None - | var -> Some var - - let does_not_bind t vars = - not (List.exists (mem t) vars) - - let does_not_freshen t vars = - Freshening.does_not_freshen t.freshening vars - - let add_symbol t symbol approx = - match find_symbol_exn t symbol with - | exception Not_found -> - { t with - approx_sym = Symbol.Map.add symbol approx t.approx_sym; - } - | _ -> - Misc.fatal_errorf "Attempt to redefine symbol %a (to %a) in environment \ - for [Inline_and_simplify]" - Symbol.print symbol - Simple_value_approx.print approx - - let redefine_symbol t symbol approx = - match find_symbol_exn t symbol with - | exception Not_found -> - assert false - | _ -> - { t with - approx_sym = Symbol.Map.add symbol approx t.approx_sym; - } - - let find_with_scope_exn t id = - try - really_import_approx_with_scope t - (Variable.Map.find id t.approx) - with Not_found -> - Misc.fatal_errorf "Env.find_with_scope_exn: Unbound variable \ - %a@.%s@. Environment: %a@." - Variable.print id - (Printexc.raw_backtrace_to_string (Printexc.get_callstack max_int)) - print t - - let find_exn t id = - snd (find_with_scope_exn t id) - - let find_mutable_exn t mut_var = - try Mutable_variable.Map.find mut_var t.approx_mutable - with Not_found -> - Misc.fatal_errorf "Env.find_mutable_exn: Unbound variable \ - %a@.%s@. Environment: %a@." - Mutable_variable.print mut_var - (Printexc.raw_backtrace_to_string (Printexc.get_callstack max_int)) - print t - - let find_list_exn t vars = - List.map (fun var -> find_exn t var) vars - - let find_opt t id = - try Some (really_import_approx t - (snd (Variable.Map.find id t.approx))) - with Not_found -> None - - let activate_freshening t = - { t with freshening = Freshening.activate t.freshening } - - let enter_set_of_closures_declaration t origin = - { t with - current_functions = - Set_of_closures_origin.Set.add origin t.current_functions; } - - let inside_set_of_closures_declaration origin t = - Set_of_closures_origin.Set.mem origin t.current_functions - - let at_toplevel t = - t.closure_depth = 0 - - let is_inside_branch env = env.inside_branch > 0 - - let branch_depth env = env.inside_branch - - let inside_branch t = - { t with inside_branch = t.inside_branch + 1 } - - let set_freshening t freshening = - { t with freshening; } - - let increase_closure_depth t = - let approx = - Variable.Map.map (fun (_scope, approx) -> Outer, approx) t.approx - in - { t with - approx; - closure_depth = t.closure_depth + 1; - } - - let set_never_inline t = - if t.never_inline then t - else { t with never_inline = true } - - let set_never_inline_inside_closures t = - if t.never_inline_inside_closures then t - else { t with never_inline_inside_closures = true } - - let unset_never_inline_inside_closures t = - if t.never_inline_inside_closures then - { t with never_inline_inside_closures = false } - else t - - let set_never_inline_outside_closures t = - if t.never_inline_outside_closures then t - else { t with never_inline_outside_closures = true } - - let unset_never_inline_outside_closures t = - if t.never_inline_outside_closures then - { t with never_inline_outside_closures = false } - else t - - let actively_unrolling t origin = - match Set_of_closures_origin.Map.find origin t.actively_unrolling with - | count -> Some count - | exception Not_found -> None - - let start_actively_unrolling t origin i = - let actively_unrolling = - Set_of_closures_origin.Map.add origin i t.actively_unrolling - in - { t with actively_unrolling } - - let continue_actively_unrolling t origin = - let unrolling = - try - Set_of_closures_origin.Map.find origin t.actively_unrolling - with Not_found -> - Misc.fatal_error "Unexpected actively unrolled function" - in - let actively_unrolling = - Set_of_closures_origin.Map.add origin (unrolling - 1) t.actively_unrolling - in - { t with actively_unrolling } - - let unrolling_allowed t origin = - let unroll_count = - try - Set_of_closures_origin.Map.find origin t.unroll_counts - with Not_found -> - Clflags.Int_arg_helper.get - ~key:t.round !Clflags.inline_max_unroll - in - unroll_count > 0 - - let inside_unrolled_function t origin = - let unroll_count = - try - Set_of_closures_origin.Map.find origin t.unroll_counts - with Not_found -> - Clflags.Int_arg_helper.get - ~key:t.round !Clflags.inline_max_unroll - in - let unroll_counts = - Set_of_closures_origin.Map.add - origin (unroll_count - 1) t.unroll_counts - in - { t with unroll_counts } - - let inlining_allowed t id = - let inlining_count = - try - Closure_origin.Map.find id t.inlining_counts - with Not_found -> - max 1 (Clflags.Int_arg_helper.get - ~key:t.round !Clflags.inline_max_unroll) - in - inlining_count > 0 - - let inside_inlined_function t id = - let inlining_count = - try - Closure_origin.Map.find id t.inlining_counts - with Not_found -> - max 1 (Clflags.Int_arg_helper.get - ~key:t.round !Clflags.inline_max_unroll) - in - let inlining_counts = - Closure_origin.Map.add id (inlining_count - 1) t.inlining_counts - in - { t with inlining_counts } - - let inlining_level t = t.inlining_level - let freshening t = t.freshening - let never_inline t = t.never_inline || t.never_inline_outside_closures - - let note_entering_closure t ~closure_id ~dbg = - if t.never_inline then t - else - { t with - inlining_stats_closure_stack = - Inlining_stats.Closure_stack.note_entering_closure - t.inlining_stats_closure_stack ~closure_id ~dbg; - } - - let note_entering_call t ~closure_id ~dbg = - if t.never_inline then t - else - { t with - inlining_stats_closure_stack = - Inlining_stats.Closure_stack.note_entering_call - t.inlining_stats_closure_stack ~closure_id ~dbg; - } - - let note_entering_inlined t = - if t.never_inline then t - else - { t with - inlining_stats_closure_stack = - Inlining_stats.Closure_stack.note_entering_inlined - t.inlining_stats_closure_stack; - } - - let note_entering_specialised t ~closure_ids = - if t.never_inline then t - else - { t with - inlining_stats_closure_stack = - Inlining_stats.Closure_stack.note_entering_specialised - t.inlining_stats_closure_stack ~closure_ids; - } - - let enter_closure t ~closure_id ~inline_inside ~dbg ~f = - let t = - if inline_inside && not t.never_inline_inside_closures then t - else set_never_inline t - in - let t = unset_never_inline_outside_closures t in - f (note_entering_closure t ~closure_id ~dbg) - - let record_decision t decision = - Inlining_stats.record_decision decision - ~closure_stack:t.inlining_stats_closure_stack - - let set_inline_debuginfo t ~dbg = - { t with inlined_debuginfo = dbg } - - let add_inlined_debuginfo t ~dbg = - Debuginfo.concat t.inlined_debuginfo dbg -end - -let initial_inlining_threshold ~round : Inlining_cost.Threshold.t = - let unscaled = - Clflags.Float_arg_helper.get ~key:round !Clflags.inline_threshold - in - (* CR-soon pchambart: Add a warning if this is too big - mshinwell: later *) - Can_inline_if_no_larger_than - (int_of_float - (unscaled *. float_of_int Inlining_cost.scale_inline_threshold_by)) - -let initial_inlining_toplevel_threshold ~round : Inlining_cost.Threshold.t = - let ordinary_threshold = - Clflags.Float_arg_helper.get ~key:round !Clflags.inline_threshold - in - let toplevel_threshold = - Clflags.Int_arg_helper.get ~key:round !Clflags.inline_toplevel_threshold - in - let unscaled = - (int_of_float ordinary_threshold) + toplevel_threshold - in - (* CR-soon pchambart: Add a warning if this is too big - mshinwell: later *) - Can_inline_if_no_larger_than - (unscaled * Inlining_cost.scale_inline_threshold_by) - -module Result = struct - type t = - { approx : Simple_value_approx.t; - used_static_exceptions : Static_exception.Set.t; - inlining_threshold : Inlining_cost.Threshold.t option; - benefit : Inlining_cost.Benefit.t; - num_direct_applications : int; - } - - let create () = - { approx = Simple_value_approx.value_unknown Other; - used_static_exceptions = Static_exception.Set.empty; - inlining_threshold = None; - benefit = Inlining_cost.Benefit.zero; - num_direct_applications = 0; - } - - let approx t = t.approx - let set_approx t approx = { t with approx } - - let meet_approx t env approx = - let really_import_approx = Env.really_import_approx env in - let meet = - Simple_value_approx.meet ~really_import_approx t.approx approx - in - set_approx t meet - - let use_static_exception t i = - { t with - used_static_exceptions = - Static_exception.Set.add i t.used_static_exceptions; - } - - let used_static_exceptions t = t.used_static_exceptions - - let exit_scope_catch t i = - { t with - used_static_exceptions = - Static_exception.Set.remove i t.used_static_exceptions; - } - - let map_benefit t f = - { t with benefit = f t.benefit } - - let add_benefit t b = - { t with benefit = Inlining_cost.Benefit.(+) t.benefit b } - - let benefit t = t.benefit - - let reset_benefit t = - { t with benefit = Inlining_cost.Benefit.zero; } - - let set_inlining_threshold t inlining_threshold = - { t with inlining_threshold } - - let add_inlining_threshold t j = - match t.inlining_threshold with - | None -> t - | Some i -> - let inlining_threshold = Some (Inlining_cost.Threshold.add i j) in - { t with inlining_threshold } - - let sub_inlining_threshold t j = - match t.inlining_threshold with - | None -> t - | Some i -> - let inlining_threshold = Some (Inlining_cost.Threshold.sub i j) in - { t with inlining_threshold } - - let inlining_threshold t = t.inlining_threshold - - let seen_direct_application t = - { t with num_direct_applications = t.num_direct_applications + 1; } - - let num_direct_applications t = - t.num_direct_applications -end - -module A = Simple_value_approx -module E = Env - -let keep_body_check ~is_classic_mode ~recursive = - if not is_classic_mode then begin - fun _ _ -> true - end else begin - let can_inline_non_rec_function (fun_decl : Flambda.function_declaration) = - (* In classic-inlining mode, the inlining decision is taken at - definition site (here). If the function is small enough - (below the -inline threshold) it will always be inlined. - - Closure gives a bonus of [8] to optional arguments. In classic - mode, however, we would inline functions with the "*opt*" argument - in all cases, as it is a stub. (This is ensured by - [middle_end/closure_conversion.ml]). - *) - let inlining_threshold = initial_inlining_threshold ~round:0 in - let bonus = Flambda_utils.function_arity fun_decl in - Inlining_cost.can_inline fun_decl.body inlining_threshold ~bonus - in - fun (var : Variable.t) (fun_decl : Flambda.function_declaration) -> - if fun_decl.stub then begin - true - end else if Variable.Set.mem var (Lazy.force recursive) then begin - false - end else begin - match fun_decl.inline with - | Default_inline -> can_inline_non_rec_function fun_decl - | Unroll factor -> factor > 0 - | Always_inline -> true - | Never_inline -> false - end - end - -let prepare_to_simplify_set_of_closures ~env - ~(set_of_closures : Flambda.set_of_closures) - ~function_decls ~freshen - ~(only_for_function_decl : Flambda.function_declaration option) = - let free_vars = - Variable.Map.map (fun (external_var : Flambda.specialised_to) -> - let var = - let var = - Freshening.apply_variable (E.freshening env) external_var.var - in - match - A.simplify_var_to_var_using_env (E.find_exn env var) - ~is_present_in_env:(fun var -> E.mem env var) - with - | None -> var - | Some var -> var - in - let approx = E.find_exn env var in - (* The projections are freshened below in one step, once we know - the closure freshening substitution. *) - let projection = external_var.projection in - ({ var; projection; } : Flambda.specialised_to), approx) - set_of_closures.free_vars - in - let specialised_args = - Variable.Map.filter_map set_of_closures.specialised_args - ~f:(fun param (spec_to : Flambda.specialised_to) -> - let keep = - match only_for_function_decl with - | None -> true - | Some function_decl -> - Variable.Set.mem param (Parameter.Set.vars function_decl.params) - in - if not keep then None - else - let external_var = spec_to.var in - let var = - Freshening.apply_variable (E.freshening env) external_var - in - let var = - match - A.simplify_var_to_var_using_env (E.find_exn env var) - ~is_present_in_env:(fun var -> E.mem env var) - with - | None -> var - | Some var -> var - in - let projection = spec_to.projection in - Some ({ var; projection; } : Flambda.specialised_to)) - in - let environment_before_cleaning = env in - (* [E.local] helps us to catch bugs whereby variables escape their scope. *) - let env = E.local env in - let free_vars, function_decls, sb, freshening = - Freshening.apply_function_decls_and_free_vars (E.freshening env) free_vars - function_decls ~only_freshen_parameters:(not freshen) - in - let env = E.set_freshening env sb in - let free_vars = - Freshening.freshen_projection_relation' free_vars - ~freshening:(E.freshening env) - ~closure_freshening:freshening - in - let specialised_args = - let specialised_args = - Variable.Map.map_keys (Freshening.apply_variable (E.freshening env)) - specialised_args - in - Freshening.freshen_projection_relation specialised_args - ~freshening:(E.freshening env) - ~closure_freshening:freshening - in - let parameter_approximations = - (* Approximations of parameters that are known to always hold the same - argument throughout the body of the function. *) - Variable.Map.map_keys (Freshening.apply_variable (E.freshening env)) - (Variable.Map.mapi (fun _id' (spec_to : Flambda.specialised_to) -> - E.find_exn environment_before_cleaning spec_to.var) - specialised_args) - in - let direct_call_surrogates = - Variable.Map.fold (fun existing surrogate surrogates -> - let existing = - Freshening.Project_var.apply_closure_id freshening - (Closure_id.wrap existing) - in - let surrogate = - Freshening.Project_var.apply_closure_id freshening - (Closure_id.wrap surrogate) - in - assert (not (Closure_id.Map.mem existing surrogates)); - Closure_id.Map.add existing surrogate surrogates) - set_of_closures.direct_call_surrogates - Closure_id.Map.empty - in - let env = - E.enter_set_of_closures_declaration env - function_decls.set_of_closures_origin - in - (* we use the previous closure for evaluating the functions *) - let internal_value_set_of_closures = - let bound_vars = - Variable.Map.fold (fun id (_, desc) map -> - Var_within_closure.Map.add (Var_within_closure.wrap id) desc map) - free_vars Var_within_closure.Map.empty - in - let free_vars = Variable.Map.map fst free_vars in - let invariant_params = lazy Variable.Map.empty in - let recursive = lazy (Variable.Map.keys function_decls.funs) in - let is_classic_mode = function_decls.is_classic_mode in - let keep_body = keep_body_check ~is_classic_mode ~recursive in - let function_decls = - A.function_declarations_approx ~keep_body function_decls - in - A.create_value_set_of_closures ~function_decls ~bound_vars - ~free_vars ~invariant_params ~recursive ~specialised_args - ~freshening ~direct_call_surrogates - in - (* Populate the environment with the approximation of each closure. - This part of the environment is shared between all of the closures in - the set of closures. *) - let set_of_closures_env = - Variable.Map.fold (fun closure _ env -> - let approx = - A.value_closure ~closure_var:closure internal_value_set_of_closures - (Closure_id.wrap closure) - in - E.add env closure approx - ) - function_decls.funs env - in - free_vars, specialised_args, function_decls, parameter_approximations, - internal_value_set_of_closures, set_of_closures_env - -(* This adds only the minimal set of approximations to the closures. - It is not strictly necessary to have this restriction, but it helps - to catch potential substitution bugs. *) -let populate_closure_approximations - ~(function_decl : Flambda.function_declaration) - ~(free_vars : (_ * A.t) Variable.Map.t) - ~(parameter_approximations : A.t Variable.Map.t) - ~set_of_closures_env = - (* Add approximations of free variables *) - let env = - Variable.Map.fold (fun id (_, desc) env -> - E.add_outer_scope env id desc) - free_vars set_of_closures_env - in - (* Add known approximations of function parameters *) - let env = - List.fold_left (fun env id -> - let approx = - try Variable.Map.find id parameter_approximations - with Not_found -> (A.value_unknown Other) - in - E.add env id approx) - env (Parameter.List.vars function_decl.params) - in - env - -let prepare_to_simplify_closure ~(function_decl : Flambda.function_declaration) - ~free_vars ~specialised_args ~parameter_approximations - ~set_of_closures_env = - let closure_env = - populate_closure_approximations ~function_decl ~free_vars - ~parameter_approximations ~set_of_closures_env - in - (* Add definitions of known projections to the environment. *) - let add_projections ~closure_env ~which_variables ~map = - Variable.Map.fold (fun inner_var spec_arg env -> - let (spec_arg : Flambda.specialised_to) = map spec_arg in - match spec_arg.projection with - | None -> env - | Some projection -> - let from = Projection.projecting_from projection in - if Variable.Set.mem from function_decl.free_variables then - E.add_projection env ~projection ~bound_to:inner_var - else - env) - which_variables - closure_env - in - let closure_env = - add_projections ~closure_env ~which_variables:specialised_args - ~map:(fun spec_to -> spec_to) - in - add_projections ~closure_env ~which_variables:free_vars - ~map:(fun (spec_to, _approx) -> spec_to) diff --git a/middle_end/inline_and_simplify_aux.mli b/middle_end/inline_and_simplify_aux.mli deleted file mode 100644 index 79d84a31b8..0000000000 --- a/middle_end/inline_and_simplify_aux.mli +++ /dev/null @@ -1,368 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -(** Environments and result structures used during inlining and - simplification. (See inline_and_simplify.ml.) *) - -module Env : sig - (** Environments follow the lexical scopes of the program. *) - type t - - (** Create a new environment. If [never_inline] is true then the returned - environment will prevent [Inline_and_simplify] from inlining. The - [backend] parameter is used for passing information about the compiler - backend being used. - Newly-created environments have inactive [Freshening]s (see below) and do - not initially hold any approximation information. *) - val create - : never_inline:bool - -> backend:(module Backend_intf.S) - -> round:int - -> ppf_dump:Format.formatter - -> t - - (** Obtain the first-class module that gives information about the - compiler backend being used for compilation. *) - val backend : t -> (module Backend_intf.S) - - (** Obtain the really_import_approx function from the backend module. *) - val really_import_approx - : t - -> (Simple_value_approx.t -> Simple_value_approx.t) - - (** Which simplification round we are currently in. *) - val round : t -> int - - (** Where to print intermediate asts and similar debug information *) - val ppf_dump : t -> Format.formatter - - (** Add the approximation of a variable---that is to say, some knowledge - about the value(s) the variable may take on at runtime---to the - environment. *) - val add : t -> Variable.t -> Simple_value_approx.t -> t - - val add_outer_scope : t -> Variable.t -> Simple_value_approx.t -> t - - (** Like [add], but for mutable variables. *) - val add_mutable : t -> Mutable_variable.t -> Simple_value_approx.t -> t - - (** Find the approximation of a given variable, raising a fatal error if - the environment does not know about the variable. Use [find_opt] - instead if you need to catch the failure case. *) - val find_exn : t -> Variable.t -> Simple_value_approx.t - - (** Like [find_exn], but for mutable variables. *) - val find_mutable_exn : t -> Mutable_variable.t -> Simple_value_approx.t - - type scope = Current | Outer - - val find_with_scope_exn : t -> Variable.t -> scope * Simple_value_approx.t - - (** Like [find_exn], but intended for use where the "not present in - environment" case is to be handled by the caller. *) - val find_opt : t -> Variable.t -> Simple_value_approx.t option - - (** Like [find_exn], but for a list of variables. *) - val find_list_exn : t -> Variable.t list -> Simple_value_approx.t list - - val does_not_bind : t -> Variable.t list -> bool - - val does_not_freshen : t -> Variable.t list -> bool - - val add_symbol : t -> Symbol.t -> Simple_value_approx.t -> t - val redefine_symbol : t -> Symbol.t -> Simple_value_approx.t -> t - val find_symbol_exn : t -> Symbol.t -> Simple_value_approx.t - val find_symbol_opt : t -> Symbol.t -> Simple_value_approx.t option - val find_symbol_fatal : t -> Symbol.t -> Simple_value_approx.t - - (* Like [find_symbol_exn], but load the symbol approximation using - the backend if not available in the environment. *) - val find_or_load_symbol : t -> Symbol.t -> Simple_value_approx.t - - (** Note that the given [bound_to] holds the given [projection]. *) - val add_projection - : t - -> projection:Projection.t - -> bound_to:Variable.t - -> t - - (** Determine if the environment knows about a variable that is bound - to the given [projection]. *) - val find_projection - : t - -> projection:Projection.t - -> Variable.t option - - (** Whether the environment has an approximation for the given variable. *) - val mem : t -> Variable.t -> bool - - (** Return the freshening that should be applied to variables when - rewriting code (in [Inline_and_simplify], etc.) using the given - environment. *) - val freshening : t -> Freshening.t - - (** Set the freshening that should be used as per [freshening], above. *) - val set_freshening : t -> Freshening.t -> t - - (** Causes every bound variable in code rewritten during inlining and - simplification, using the given environment, to be freshened. This is - used when descending into subexpressions substituted into existing - expressions. *) - val activate_freshening : t -> t - - (** Erase all variable approximation information and freshening information - from the given environment. However, the freshening activation state - is preserved. This function is used when rewriting inside a function - declaration, to avoid (due to a compiler bug) accidental use of - variables from outer scopes that are not accessible. *) - val local : t -> t - - (** Determine whether the inliner is currently inside a function body from - the given set of closures. This is used to detect whether a given - function call refers to a function which exists somewhere on the current - inlining stack. *) - val inside_set_of_closures_declaration : Set_of_closures_origin.t -> t -> bool - - (** Not inside a closure declaration. - Toplevel code is the one evaluated when the compilation unit is - loaded *) - val at_toplevel : t -> bool - - val is_inside_branch : t -> bool - val branch_depth : t -> int - val inside_branch : t -> t - - val increase_closure_depth : t -> t - - (** Mark that call sites contained within code rewritten using the given - environment should never be replaced by inlined (or unrolled) versions - of the callee(s). *) - val set_never_inline : t -> t - - (** Equivalent to [set_never_inline] but only applies to code inside - a set of closures. *) - val set_never_inline_inside_closures : t -> t - - (** Unset the restriction from [set_never_inline_inside_closures] *) - val unset_never_inline_inside_closures : t -> t - - (** Equivalent to [set_never_inline] but does not apply to code inside - a set of closures. *) - val set_never_inline_outside_closures : t -> t - - (** Unset the restriction from [set_never_inline_outside_closures] *) - val unset_never_inline_outside_closures : t -> t - - (** Return whether [set_never_inline] is currently in effect on the given - environment. *) - val never_inline : t -> bool - - val inlining_level : t -> int - - (** Mark that this environment is used to rewrite code for inlining. This is - used by the inlining heuristics to decide whether to continue. - Unconditionally inlined does not take this into account. *) - val inlining_level_up : t -> t - - (** Whether we are actively unrolling a given function. *) - val actively_unrolling : t -> Set_of_closures_origin.t -> int option - - (** Start actively unrolling a given function [n] times. *) - val start_actively_unrolling : t -> Set_of_closures_origin.t -> int -> t - - (** Unroll a function currently actively being unrolled. *) - val continue_actively_unrolling : t -> Set_of_closures_origin.t -> t - - (** Whether it is permissible to unroll a call to a recursive function - in the given environment. *) - val unrolling_allowed : t -> Set_of_closures_origin.t -> bool - - (** Whether the given environment is currently being used to rewrite the - body of an unrolled recursive function. *) - val inside_unrolled_function : t -> Set_of_closures_origin.t -> t - - (** Whether it is permissible to inline a call to a function in the given - environment. *) - val inlining_allowed : t -> Closure_origin.t -> bool - - (** Whether the given environment is currently being used to rewrite the - body of an inlined function. *) - val inside_inlined_function : t -> Closure_origin.t -> t - - (** If collecting inlining statistics, record that the inliner is about to - descend into [closure_id]. This information enables us to produce a - stack of closures that form a kind of context around an inlining - decision point. *) - val note_entering_closure - : t - -> closure_id:Closure_id.t - -> dbg:Debuginfo.t - -> t - - (** If collecting inlining statistics, record that the inliner is about to - descend into a call to [closure_id]. This information enables us to - produce a stack of closures that form a kind of context around an - inlining decision point. *) - val note_entering_call - : t - -> closure_id:Closure_id.t - -> dbg:Debuginfo.t - -> t - - (** If collecting inlining statistics, record that the inliner is about to - descend into an inlined function call. This requires that the inliner - has already entered the call with [note_entering_call]. *) - val note_entering_inlined : t -> t - - (** If collecting inlining statistics, record that the inliner is about to - descend into a specialised function definition. This requires that the - inliner has already entered the call with [note_entering_call]. *) - val note_entering_specialised : t -> closure_ids:Closure_id.Set.t -> t - - (** Update a given environment to record that the inliner is about to - descend into [closure_id] and pass the resulting environment to [f]. - If [inline_inside] is [false] then the environment passed to [f] will be - marked as [never_inline] (see above). *) - val enter_closure - : t - -> closure_id:Closure_id.t - -> inline_inside:bool - -> dbg:Debuginfo.t - -> f:(t -> 'a) - -> 'a - - (** If collecting inlining statistics, record an inlining decision for the - call at the top of the closure stack stored inside the given - environment. *) - val record_decision - : t - -> Inlining_stats_types.Decision.t - -> unit - - (** Print a human-readable version of the given environment. *) - val print : Format.formatter -> t -> unit - - (** The environment stores the call-site being inlined to produce - precise location information. This function sets the current - call-site being inlined. *) - val set_inline_debuginfo : t -> dbg:Debuginfo.t -> t - - (** Appends the locations of inlined call-sites to the [~dbg] argument *) - val add_inlined_debuginfo : t -> dbg:Debuginfo.t -> Debuginfo.t -end - -module Result : sig - (** Result structures approximately follow the evaluation order of the - program. They are returned by the simplification algorithm acting on - an Flambda subexpression. *) - type t - - val create : unit -> t - - (** The approximation of the subexpression that has just been - simplified. *) - val approx : t -> Simple_value_approx.t - - (** Set the approximation of the subexpression that has just been - simplified. Typically used just before returning from a case of the - simplification algorithm. *) - val set_approx : t -> Simple_value_approx.t -> t - - (** Set the approximation of the subexpression to the meet of the - current return approximation and the provided one. Typically - used just before returning from a branch case of the - simplification algorithm. *) - val meet_approx : t -> Env.t -> Simple_value_approx.t -> t - - (** All static exceptions for which [use_staticfail] has been called on - the given result structure. *) - val used_static_exceptions : t -> Static_exception.Set.t - - (** Mark that the given static exception has been used. *) - val use_static_exception : t -> Static_exception.t -> t - - (** Mark that we are moving up out of the scope of a static-catch block - that catches the given static exception identifier. This has the effect - of removing the identifier from the [used_staticfail] set. *) - val exit_scope_catch : t -> Static_exception.t -> t - - (** The benefit to be gained by inlining the subexpression whose - simplification yielded the given result structure. *) - val benefit : t -> Inlining_cost.Benefit.t - - (** Apply a transformation to the inlining benefit stored within the - given result structure. *) - val map_benefit - : t - -> (Inlining_cost.Benefit.t -> Inlining_cost.Benefit.t) - -> t - - (** Add some benefit to the inlining benefit stored within the - given result structure. *) - val add_benefit : t -> Inlining_cost.Benefit.t -> t - - (** Set the benefit of inlining the subexpression corresponding to the - given result structure to zero. *) - val reset_benefit : t -> t - - val set_inlining_threshold : - t -> Inlining_cost.Threshold.t option -> t - val add_inlining_threshold : - t -> Inlining_cost.Threshold.t -> t - val sub_inlining_threshold : - t -> Inlining_cost.Threshold.t -> t - val inlining_threshold : t -> Inlining_cost.Threshold.t option - - val seen_direct_application : t -> t - val num_direct_applications : t -> int -end - -(** Command line argument -inline *) -val initial_inlining_threshold : round:int -> Inlining_cost.Threshold.t - -(** Command line argument -inline-toplevel *) -val initial_inlining_toplevel_threshold - : round:int -> Inlining_cost.Threshold.t - -val prepare_to_simplify_set_of_closures - : env:Env.t - -> set_of_closures:Flambda.set_of_closures - -> function_decls:Flambda.function_declarations - -> freshen:bool - -> only_for_function_decl:Flambda.function_declaration option - -> (Flambda.specialised_to * Simple_value_approx.t) Variable.Map.t (* fvs *) - * Flambda.specialised_to Variable.Map.t (* specialised arguments *) - * Flambda.function_declarations - * Simple_value_approx.t Variable.Map.t (* parameter approximations *) - * Simple_value_approx.value_set_of_closures - * Env.t - -val prepare_to_simplify_closure - : function_decl:Flambda.function_declaration - -> free_vars:(Flambda.specialised_to * Simple_value_approx.t) Variable.Map.t - -> specialised_args:Flambda.specialised_to Variable.Map.t - -> parameter_approximations:Simple_value_approx.t Variable.Map.t - -> set_of_closures_env:Env.t - -> Env.t - -val keep_body_check - : is_classic_mode:bool - -> recursive:Variable.Set.t Lazy.t - -> Variable.t - -> Flambda.function_declaration - -> bool diff --git a/middle_end/inlining_cost.ml b/middle_end/inlining_cost.ml deleted file mode 100644 index 33e870f90a..0000000000 --- a/middle_end/inlining_cost.ml +++ /dev/null @@ -1,700 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -(* Simple approximation of the space cost of a primitive. *) - -let prim_size (prim : Clambda_primitives.primitive) args = - match prim with - | Pmakeblock _ -> 5 + List.length args - | Pfield _ -> 1 - | Psetfield (_, isptr, init) -> - begin match init with - | Root_initialization -> 1 (* never causes a write barrier hit *) - | Assignment | Heap_initialization -> - match isptr with - | Pointer -> 4 - | Immediate -> 1 - end - | Pfloatfield _ -> 1 - | Psetfloatfield _ -> 1 - | Pduprecord _ -> 10 + List.length args - | Pccall p -> (if p.Primitive.prim_alloc then 10 else 4) + List.length args - | Praise _ -> 4 - | Pstringlength -> 5 - | Pbyteslength -> 5 - | Pstringrefs -> 6 - | Pbytesrefs | Pbytessets -> 6 - | Pmakearray _ -> 5 + List.length args - | Parraylength Pgenarray -> 6 - | Parraylength _ -> 2 - | Parrayrefu Pgenarray -> 12 - | Parrayrefu _ -> 2 - | Parraysetu Pgenarray -> 16 - | Parraysetu _ -> 4 - | Parrayrefs Pgenarray -> 18 - | Parrayrefs _ -> 8 - | Parraysets Pgenarray -> 22 - | Parraysets _ -> 10 - | Pbigarrayref (_, ndims, _, _) -> 4 + ndims * 6 - | Pbigarrayset (_, ndims, _, _) -> 4 + ndims * 6 - | Psequand | Psequor -> - Misc.fatal_error "Psequand and Psequor are not allowed in Prim \ - expressions; translate out instead (cf. closure_conversion.ml)" - (* CR-soon mshinwell: This match must be made exhaustive. - mshinwell: Let's do this when we have the new size computation. *) - | _ -> 2 (* arithmetic and comparisons *) - -(* Simple approximation of the space cost of an Flambda expression. *) - -(* CR-soon mshinwell: Investigate revised size numbers. *) - -let direct_call_size = 4 -let project_size = 1 - -let lambda_smaller' lam ~than:threshold = - let size = ref 0 in - let rec lambda_size (lam : Flambda.t) = - if !size > threshold then raise Exit; - match lam with - | Var _ -> () - | Apply ({ func = _; args = _; kind = direct }) -> - let call_cost = - match direct with Indirect -> 6 | Direct _ -> direct_call_size - in - size := !size + call_cost - | Assign _ -> incr size - | Send _ -> size := !size + 8 - | Proved_unreachable -> () - | Let { defining_expr; body; _ } -> - lambda_named_size defining_expr; - lambda_size body - | Let_mutable { body } -> lambda_size body - | Let_rec (bindings, body) -> - List.iter (fun (_, lam) -> lambda_named_size lam) bindings; - lambda_size body - | Switch (_, sw) -> - let aux = function _::_::_ -> size := !size + 5 | _ -> () in - aux sw.consts; aux sw.blocks; - List.iter (fun (_, lam) -> lambda_size lam) sw.consts; - List.iter (fun (_, lam) -> lambda_size lam) sw.blocks; - Option.iter lambda_size sw.failaction - | String_switch (_, sw, def) -> - List.iter (fun (_, lam) -> - size := !size + 2; - lambda_size lam) - sw; - Misc.may lambda_size def - | Static_raise _ -> () - | Static_catch (_, _, body, handler) -> - incr size; lambda_size body; lambda_size handler - | Try_with (body, _, handler) -> - size := !size + 8; lambda_size body; lambda_size handler - | If_then_else (_, ifso, ifnot) -> - size := !size + 2; - lambda_size ifso; lambda_size ifnot - | While (cond, body) -> - size := !size + 2; lambda_size cond; lambda_size body - | For { body; _ } -> - size := !size + 4; lambda_size body - and lambda_named_size (named : Flambda.named) = - if !size > threshold then raise Exit; - match named with - | Symbol _ | Read_mutable _ -> () - | Const _ | Allocated_const _ -> incr size - | Read_symbol_field _ -> incr size - | Set_of_closures ({ function_decls = ffuns }) -> - Variable.Map.iter (fun _ (ffun : Flambda.function_declaration) -> - lambda_size ffun.body) - ffuns.funs - | Project_closure _ | Project_var _ -> - size := !size + project_size - | Move_within_set_of_closures _ -> - incr size - | Prim (prim, args, _) -> - size := !size + prim_size prim args - | Expr expr -> lambda_size expr - in - try - lambda_size lam; - if !size <= threshold then Some !size - else None - with Exit -> - None - -let lambda_size lam = - match lambda_smaller' lam ~than:max_int with - | Some size -> - size - | None -> - (* There is no way that an expression of size max_int could fit in - memory. *) - assert false - -module Threshold = struct - - type t = - | Never_inline - | Can_inline_if_no_larger_than of int - - let add t1 t2 = - match t1, t2 with - | Never_inline, t -> t - | t, Never_inline -> t - | Can_inline_if_no_larger_than i1, Can_inline_if_no_larger_than i2 -> - Can_inline_if_no_larger_than (i1 + i2) - - let sub t1 t2 = - match t1, t2 with - | Never_inline, _ -> Never_inline - | t, Never_inline -> t - | Can_inline_if_no_larger_than i1, Can_inline_if_no_larger_than i2 -> - if i1 > i2 then Can_inline_if_no_larger_than (i1 - i2) - else Never_inline - - let min t1 t2 = - match t1, t2 with - | Never_inline, _ -> Never_inline - | _, Never_inline -> Never_inline - | Can_inline_if_no_larger_than i1, Can_inline_if_no_larger_than i2 -> - Can_inline_if_no_larger_than (min i1 i2) - - let equal t1 t2 = - match t1, t2 with - | Never_inline, Never_inline -> true - | Can_inline_if_no_larger_than i1, Can_inline_if_no_larger_than i2 -> - i1 = i2 - | (Never_inline | Can_inline_if_no_larger_than _), _ -> - false - -end - -let can_try_inlining lam inlining_threshold ~number_of_arguments - ~size_from_approximation = - match inlining_threshold with - | Threshold.Never_inline -> Threshold.Never_inline - | Threshold.Can_inline_if_no_larger_than inlining_threshold -> - let bonus = - (* removing a call will reduce the size by at least the number - of arguments *) - number_of_arguments - in - let size = - let than = inlining_threshold + bonus in - match size_from_approximation with - | Some size -> if size <= than then Some size else None - | None -> lambda_smaller' lam ~than - in - match size with - | None -> Threshold.Never_inline - | Some size -> - Threshold.Can_inline_if_no_larger_than - (inlining_threshold - size + bonus) - -let lambda_smaller lam ~than = - match lambda_smaller' lam ~than with - | Some _ -> true - | None -> false - -let can_inline lam inlining_threshold ~bonus = - match inlining_threshold with - | Threshold.Never_inline -> false - | Threshold.Can_inline_if_no_larger_than inlining_threshold -> - lambda_smaller - lam - ~than:(inlining_threshold + bonus) - -let cost (flag : Clflags.Int_arg_helper.parsed) ~round = - Clflags.Int_arg_helper.get ~key:round flag - -let benefit_factor = 1 - -module Benefit = struct - type t = { - remove_call : int; - remove_alloc : int; - remove_prim : int; - remove_branch : int; - (* CR-someday pchambart: branch_benefit : t list; *) - direct_call_of_indirect : int; - requested_inline : int; - (* Benefit to compensate the size of functions marked for inlining *) - } - - let zero = { - remove_call = 0; - remove_alloc = 0; - remove_prim = 0; - remove_branch = 0; - direct_call_of_indirect = 0; - requested_inline = 0; - } - - let remove_call t = { t with remove_call = t.remove_call + 1; } - let remove_alloc t = { t with remove_alloc = t.remove_alloc + 1; } - let remove_prim t = { t with remove_prim = t.remove_prim + 1; } - let remove_prims t n = { t with remove_prim = t.remove_prim + n; } - let remove_branch t = { t with remove_branch = t.remove_branch + 1; } - let direct_call_of_indirect t = - { t with direct_call_of_indirect = t.direct_call_of_indirect + 1; } - let requested_inline t ~size_of = - let size = lambda_size size_of in - { t with requested_inline = t.requested_inline + size; } - - let remove_code_helper b (flam : Flambda.t) = - match flam with - | Assign _ -> b := remove_prim !b - | Switch _ | String_switch _ | Static_raise _ | Try_with _ - | If_then_else _ | While _ | For _ -> b := remove_branch !b - | Apply _ | Send _ -> b := remove_call !b - | Let _ | Let_mutable _ | Let_rec _ | Proved_unreachable | Var _ - | Static_catch _ -> () - - let remove_code_helper_named b (named : Flambda.named) = - match named with - | Set_of_closures _ - | Prim ((Pmakearray _ | Pmakeblock _ | Pduprecord _), _, _) -> - b := remove_alloc !b - (* CR-soon pchambart: should we consider that boxed integer and float - operations are allocations ? *) - | Prim _ | Project_closure _ | Project_var _ - | Move_within_set_of_closures _ - | Read_symbol_field _ -> b := remove_prim !b - | Symbol _ | Read_mutable _ | Allocated_const _ | Const _ | Expr _ -> () - - let remove_code lam b = - let b = ref b in - Flambda_iterators.iter_toplevel (remove_code_helper b) - (remove_code_helper_named b) lam; - !b - - let remove_code_named lam b = - let b = ref b in - Flambda_iterators.iter_named_toplevel (remove_code_helper b) - (remove_code_helper_named b) lam; - !b - - let remove_projection (_proj : Projection.t) b = - (* They are all primitives for the moment. The [Projection.t] argument - is here for future expansion. *) - remove_prim b - - let print ppf b = - Format.fprintf ppf "@[remove_call: %i@ remove_alloc: %i@ \ - remove_prim: %i@ remove_branch: %i@ \ - direct: %i@ requested: %i@]" - b.remove_call - b.remove_alloc - b.remove_prim - b.remove_branch - b.direct_call_of_indirect - b.requested_inline - - let evaluate t ~round : int = - benefit_factor * - (t.remove_call * (cost !Clflags.inline_call_cost ~round) - + t.remove_alloc * (cost !Clflags.inline_alloc_cost ~round) - + t.remove_prim * (cost !Clflags.inline_prim_cost ~round) - + t.remove_branch * (cost !Clflags.inline_branch_cost ~round) - + (t.direct_call_of_indirect - * (cost !Clflags.inline_indirect_cost ~round))) - + t.requested_inline - - let (+) t1 t2 = { - remove_call = t1.remove_call + t2.remove_call; - remove_alloc = t1.remove_alloc + t2.remove_alloc; - remove_prim = t1.remove_prim + t2.remove_prim; - remove_branch = t1.remove_branch + t2.remove_branch; - direct_call_of_indirect = - t1.direct_call_of_indirect + t2.direct_call_of_indirect; - requested_inline = t1.requested_inline + t2.requested_inline; - } - - let (-) t1 t2 = { - remove_call = t1.remove_call - t2.remove_call; - remove_alloc = t1.remove_alloc - t2.remove_alloc; - remove_prim = t1.remove_prim - t2.remove_prim; - remove_branch = t1.remove_branch - t2.remove_branch; - direct_call_of_indirect = - t1.direct_call_of_indirect - t2.direct_call_of_indirect; - requested_inline = t1.requested_inline - t2.requested_inline; - } - - let max ~round t1 t2 = - let c1 = evaluate ~round t1 in - let c2 = evaluate ~round t2 in - if c1 > c2 then t1 else t2 - - let add_code lam b = - b - (remove_code lam zero) - - let add_code_named lam b = - b - (remove_code_named lam zero) - - let add_projection proj b = - b - (remove_projection proj zero) - - (* Print out a benefit as a table *) - - let benefit_table = - [ "Calls", (fun b -> b.remove_call); - "Allocs", (fun b -> b.remove_alloc); - "Prims", (fun b -> b.remove_prim); - "Branches", (fun b -> b.remove_branch); - "Indirect calls", (fun b -> b.direct_call_of_indirect); - ] - - let benefits_table = - lazy begin - List.map - (fun (header, accessor) -> (header, accessor, String.length header)) - benefit_table - end - - let table_line = - lazy begin - let benefits_table = Lazy.force benefits_table in - let dashes = - List.map (fun (_, _, n) -> String.make n '-') benefits_table - in - "|-" ^ String.concat "-+-" dashes ^ "-|" - end - - let table_headers = - lazy begin - let benefits_table = Lazy.force benefits_table in - let headers = List.map (fun (head, _, _) -> head) benefits_table in - "| " ^ String.concat " | " headers ^ " |" - end - - let print_table_values ppf b = - let rec loop ppf = function - | [] -> Format.fprintf ppf "|" - | (_, accessor, width) :: rest -> - Format.fprintf ppf "| %*d %a" width (accessor b) loop rest - in - loop ppf (Lazy.force benefits_table) - - let print_table ppf b = - let table_line = Lazy.force table_line in - let table_headers = Lazy.force table_headers in - Format.fprintf ppf - "@[@[%s@]@;@[%s@]@;@[%s@]@;@[%a@]@;@[%s@]@]" - table_line table_headers table_line - print_table_values b - table_line -end - -module Whether_sufficient_benefit = struct - type t = { - round : int; - benefit : Benefit.t; - toplevel : bool; - branch_depth : int; - lifting : bool; - original_size : int; - new_size : int; - evaluated_benefit : int; - estimate : bool; - } - - let create ~original ~toplevel ~branch_depth lam ~benefit ~lifting ~round = - let evaluated_benefit = Benefit.evaluate benefit ~round in - { round; benefit; toplevel; branch_depth; lifting; - original_size = lambda_size original; - new_size = lambda_size lam; - evaluated_benefit; - estimate = false; - } - - let create_estimate ~original_size ~toplevel ~branch_depth ~new_size - ~benefit ~lifting ~round = - let evaluated_benefit = Benefit.evaluate benefit ~round in - { round; benefit; toplevel; branch_depth; lifting; original_size; - new_size; evaluated_benefit; estimate = true; - } - - let is_nan f = - match Float.classify_float f with - | FP_nan -> true - | FP_normal | FP_subnormal | FP_zero | FP_infinite -> false - - let correct_branch_factor f = - (not (is_nan f)) - && (Float.compare f 0. >= 0) - - let estimated_benefit t = - if t.toplevel && t.lifting && t.branch_depth = 0 then begin - let lifting_benefit = - Clflags.Int_arg_helper.get ~key:t.round !Clflags.inline_lifting_benefit - in - float (t.evaluated_benefit + lifting_benefit) - end else begin - (* The estimated benefit is the evaluated benefit times an - estimation of the probability that the branch does actually matter - for performance (i.e. is hot). The probability is very roughly - estimated by considering that under every branch the - sub-expressions have the same [1 / (1 + factor)] probability - [p] of being hot. Hence the probability for the current - call to be hot is [p ^ number of nested branches]. - The probability is expressed as [1 / (1 + factor)] rather - than letting the user directly provide [p], since for every - positive value of [factor] [p] is in [0, 1]. *) - let branch_taken_estimated_probability = - let inline_branch_factor = - let factor = - Clflags.Float_arg_helper.get ~key:t.round - !Clflags.inline_branch_factor - in - if is_nan factor then - Clflags.default_inline_branch_factor - else if Float.compare factor 0. < 0 then - 0. - else - factor - in - assert (correct_branch_factor inline_branch_factor); - 1. /. (1. +. inline_branch_factor) - in - let call_estimated_probability = - branch_taken_estimated_probability ** float t.branch_depth - in - float t.evaluated_benefit *. call_estimated_probability - end - - let evaluate t = - Float.compare - (float t.new_size -. estimated_benefit t) - (float t.original_size) <= 0 - - let to_string t = - let lifting = t.toplevel && t.lifting && t.branch_depth = 0 in - let evaluated_benefit = - if lifting then - let lifting_benefit = - Clflags.Int_arg_helper.get ~key:t.round - !Clflags.inline_lifting_benefit - in - t.evaluated_benefit + lifting_benefit - else t.evaluated_benefit - in - let estimate = if t.estimate then "<" else "=" in - Printf.sprintf "{benefit%s{call=%d,alloc=%d,prim=%i,branch=%i,\ - indirect=%i,req=%i,\ - lifting=%B}, orig_size=%d,new_size=%d,eval_size=%d,\ - eval_benefit%s%d,\ - branch_depth=%d}=%s" - estimate - t.benefit.remove_call - t.benefit.remove_alloc - t.benefit.remove_prim - t.benefit.remove_branch - t.benefit.direct_call_of_indirect - t.benefit.requested_inline - lifting - t.original_size - t.new_size - (t.original_size - t.new_size) - estimate - evaluated_benefit - t.branch_depth - (if evaluate t then "yes" else "no") - - let print_description ~subfunctions ppf t = - let pr_intro ppf = - let estimate = if t.estimate then " at most" else "" in - Format.pp_print_text ppf - "Specialisation of the function body"; - if subfunctions then - Format.pp_print_text ppf - ", including speculative inlining of other functions,"; - Format.pp_print_text ppf " removed"; - Format.pp_print_text ppf estimate; - Format.pp_print_text ppf " the following operations:" - in - let lifting = t.toplevel && t.lifting && t.branch_depth = 0 in - let requested = t.benefit.requested_inline in - let pr_requested ppf = - if requested > 0 then begin - Format.pp_open_box ppf 0; - Format.pp_print_text ppf - "and inlined user-annotated functions worth "; - Format.fprintf ppf "%d." requested; - Format.pp_close_box ppf (); - Format.pp_print_cut ppf (); - Format.pp_print_cut ppf () - end - in - let pr_lifting ppf = - if lifting then begin - Format.pp_open_box ppf 0; - Format.pp_print_text ppf - "Inlining the function would also \ - lift some definitions to toplevel."; - Format.pp_close_box ppf (); - Format.pp_print_cut ppf (); - Format.pp_print_cut ppf () - end - in - let total_benefit = - if lifting then - let lifting_benefit = - Clflags.Int_arg_helper.get ~key:t.round - !Clflags.inline_lifting_benefit - in - t.evaluated_benefit + lifting_benefit - else t.evaluated_benefit - in - let expected_benefit = estimated_benefit t in - let size_change = t.new_size - t.original_size in - let result = if evaluate t then "less" else "greater" in - let pr_conclusion ppf = - Format.pp_print_text ppf "This gives a total benefit of "; - Format.pp_print_int ppf total_benefit; - Format.pp_print_text ppf ". At a branch depth of "; - Format.pp_print_int ppf t.branch_depth; - Format.pp_print_text ppf " this produces an expected benefit of "; - Format.fprintf ppf "%.1f" expected_benefit; - Format.pp_print_text ppf ". The new code has size "; - Format.pp_print_int ppf t.new_size; - Format.pp_print_text ppf ", giving a change in code size of "; - Format.pp_print_int ppf size_change; - Format.pp_print_text ppf ". The change in code size is "; - Format.pp_print_text ppf result; - Format.pp_print_text ppf " than the expected benefit." - in - Format.fprintf ppf "%t@,@[@[@;%a@]@;@;%t%t@]%t" - pr_intro Benefit.print_table t.benefit pr_requested pr_lifting - pr_conclusion -end - -let scale_inline_threshold_by = 8 - -let default_toplevel_multiplier = 8 - - (* CR-soon mshinwell for mshinwell: hastily-written comment, to review *) - (* We may in [Inlining_decision] need to measure the size of functions - that are below the inlining threshold. We also need to measure with - regard to benefit (see [Inlining_decision.inline_non_recursive). The - intuition for having a cached size in the second case is as follows. - If a function's body exceeds some maximum size and its argument - approximations are unknown (meaning that we cannot materially simplify - it further), we can infer without examining the function's body that - it cannot be inlined. The aim is to speed up [Inlining_decision]. - - The "original size" is [Inlining_cost.direct_call_size]. The "new size" is - the size of the function's body plus [Inlining_cost.project_size] for each - free variable and mutually recursive function accessed through the closure. - - To be inlined we need: - - body_size - + (closure_accesses * project_size) <= direct_call_size - - (evaluated_benefit * call_prob) - - i.e.: - - body_size <= direct_call_size - + (evaluated_benefit * call_prob) - - (closure_accesses * project_size) - - In this case we would be removing a single call and a projection for each - free variable that can be accessed directly (i.e. not via the closure - or the internal variable). - - evaluated_benefit = - benefit_factor - * (inline_call_cost - + ((free_variables - indirect_accesses) * inline_prim_cost)) - - (For [inline_call_cost] and [inline_prim_cost], we use the maximum these - might be across any round.) - - Substituting: - - body_size <= direct_call_size - + (benefit_factor - * (inline_call_cost - + ((free_variables - indirect_accesses) - * inline_prim_cost))) - * call_prob - - (closure_accesses * project_size) - - Rearranging: - - body_size <= direct_call_size - + (inline_call_cost * benefit_factor * call_prob) - + (free_variables * inline_prim_cost - * benefit_factor * call_prob) - - (indirect_accesses * inline_prim_cost - * benefit_factor * call_prob) - - (closure_accesses * project_size) - - The upper bound for the right-hand side is when call_prob = 1.0, - indirect_accesses = 0 and closure_accesses = 0, giving: - - direct_call_size - + (inline_call_cost * benefit_factor) - + (free_variables * inline_prim_cost * benefit_factor) - - So we should measure all functions at or below this size, but also record - the size discovered, so we can later re-check (without examining the body) - when we know [call_prob], [indirect_accesses] and [closure_accesses]. - - This number is split into parts dependent and independent of the - number of free variables: - - base = direct_call_size + (inline_call_cost * benefit_factor) - - multiplier = inline_prim_cost * benefit_factor - - body_size <= base + free_variables * multiplier - - *) -let maximum_interesting_size_of_function_body_base = - lazy begin - let max_cost = ref 0 in - for round = 0 to (Clflags.rounds ()) - 1 do - let max_size = - let inline_call_cost = cost !Clflags.inline_call_cost ~round in - direct_call_size + (inline_call_cost * benefit_factor) - in - max_cost := max !max_cost max_size - done; - !max_cost - end - -let maximum_interesting_size_of_function_body_multiplier = - lazy begin - let max_cost = ref 0 in - for round = 0 to (Clflags.rounds ()) - 1 do - let max_size = - let inline_prim_cost = cost !Clflags.inline_prim_cost ~round in - inline_prim_cost * benefit_factor - in - max_cost := max !max_cost max_size - done; - !max_cost - end - -let maximum_interesting_size_of_function_body num_free_variables = - let base = Lazy.force maximum_interesting_size_of_function_body_base in - let multiplier = - Lazy.force maximum_interesting_size_of_function_body_multiplier - in - base + (num_free_variables * multiplier) diff --git a/middle_end/inlining_cost.mli b/middle_end/inlining_cost.mli deleted file mode 100644 index 345f67abad..0000000000 --- a/middle_end/inlining_cost.mli +++ /dev/null @@ -1,142 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -(** Measurement of the cost (including cost in space) of Flambda terms - in the context of inlining. *) - -module Threshold : sig - - (** The maximum size, in some abstract measure of space cost, that an - Flambda expression may be in order to be inlined. *) - type t = - | Never_inline - | Can_inline_if_no_larger_than of int - - val add : t -> t -> t - val sub : t -> t -> t - val min : t -> t -> t - val equal : t -> t -> bool - -end - -(* Determine whether the given Flambda expression has a sufficiently low space - cost so as to fit under the given [inlining_threshold]. The [bonus] is - added to the threshold before evaluation. *) -val can_inline - : Flambda.t - -> Threshold.t - -> bonus:int - -> bool - -(* CR-soon mshinwell for pchambart: I think the name of this function might be - misleading. It should probably reflect the functionality it provides, - not the use to which it is put in another module. *) -(* As for [can_inline], but returns the decision as an inlining threshold. - If [Never_inline] is returned, the expression was too large for the - input [inlining_threshold]. Otherwise, [Can_inline_if_no_larger_than] is - returned, with the constructor argument being the measured estimated size - of the expression. *) -val can_try_inlining - : Flambda.t - -> Threshold.t - -> number_of_arguments:int - -> size_from_approximation:int option - -> Threshold.t - -module Benefit : sig - (* A model of the benefit we gain by removing a particular combination - of operations. Such removals are typically performed by inlining (for - example, [remove_call]) and simplification (for example, [remove_alloc]) - passes. *) - - type t - - val zero : t - val (+) : t -> t -> t - val max : round:int -> t -> t -> t - - val remove_call : t -> t - (* CR-soon mshinwell: [remove_alloc] should take the size of the block - (to account for removal of initializing writes). *) - val remove_alloc : t -> t - val remove_prim : t -> t - val remove_prims : t -> int -> t - val remove_branch : t -> t - val direct_call_of_indirect : t -> t - val requested_inline : t -> size_of:Flambda.t -> t - - val remove_code : Flambda.t -> t -> t - val remove_code_named : Flambda.named -> t -> t - val remove_projection : Projection.t -> t -> t - - val add_code : Flambda.t -> t -> t - val add_code_named : Flambda.named -> t -> t - val add_projection : Projection.t -> t -> t - - val print : Format.formatter -> t -> unit -end - -module Whether_sufficient_benefit : sig - (* Evaluation of the benefit of removing certain operations against an - inlining threshold. *) - - type t - - val create - : original:Flambda.t - -> toplevel:bool - -> branch_depth:int - -> Flambda.t - -> benefit:Benefit.t - -> lifting:bool - -> round:int - -> t - - val create_estimate - : original_size:int - -> toplevel:bool - -> branch_depth: int - -> new_size:int - -> benefit:Benefit.t - -> lifting:bool - -> round:int - -> t - - val evaluate : t -> bool - - val to_string : t -> string - - val print_description : subfunctions:bool -> Format.formatter -> t -> unit -end - -val scale_inline_threshold_by : int - -val default_toplevel_multiplier : int - -val direct_call_size : int - -(** If a function body exceeds this size, we can make a fast decision not - to inline it (see [Inlining_decision]). *) -val maximum_interesting_size_of_function_body : int -> int - -(** Measure the given expression to determine whether its size is at or - below the given threshold. [None] is returned if it is too big; otherwise - [Some] is returned with the measured size. *) -val lambda_smaller' : Flambda.expr -> than:int -> int option - -val lambda_size : Flambda.expr -> int diff --git a/middle_end/inlining_decision.ml b/middle_end/inlining_decision.ml deleted file mode 100644 index ca462a5613..0000000000 --- a/middle_end/inlining_decision.ml +++ /dev/null @@ -1,741 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -module A = Simple_value_approx -module E = Inline_and_simplify_aux.Env -module R = Inline_and_simplify_aux.Result -module W = Inlining_cost.Whether_sufficient_benefit -module T = Inlining_cost.Threshold -module S = Inlining_stats_types -module D = S.Decision - -let get_function_body (function_decl : A.function_declaration) = - match function_decl.function_body with - | None -> assert false - | Some function_body -> function_body - -type ('a, 'b) inlining_result = - | Changed of (Flambda.t * R.t) * 'a - | Original of 'b - -type 'b good_idea = - | Try_it - | Don't_try_it of 'b - -let inline env r ~lhs_of_application - ~closure_id_being_applied - ~(function_decl : A.function_declaration) - ~(function_body : A.function_body) - ~value_set_of_closures ~only_use_of_function ~original ~recursive - ~(args : Variable.t list) ~size_from_approximation ~dbg ~simplify - ~(inline_requested : Lambda.inline_attribute) - ~(specialise_requested : Lambda.specialise_attribute) - ~fun_vars ~set_of_closures_origin - ~self_call ~fun_cost ~inlining_threshold = - let toplevel = E.at_toplevel env in - let branch_depth = E.branch_depth env in - let unrolling, always_inline, never_inline, env = - let unrolling = E.actively_unrolling env set_of_closures_origin in - match unrolling with - | Some count -> - if count > 0 then - let env = E.continue_actively_unrolling env set_of_closures_origin in - true, true, false, env - else false, false, true, env - | None -> begin - let inline_annotation = - (* Merge call site annotation and function annotation. - The call site annotation takes precedence *) - match (inline_requested : Lambda.inline_attribute) with - | Always_inline | Never_inline | Unroll _ -> inline_requested - | Default_inline -> function_body.inline - in - match inline_annotation with - | Always_inline -> false, true, false, env - | Never_inline -> false, false, true, env - | Default_inline -> false, false, false, env - | Unroll count -> - if count > 0 then - let env = - E.start_actively_unrolling - env set_of_closures_origin (count - 1) - in - true, true, false, env - else false, false, true, env - end - in - let remaining_inlining_threshold : Inlining_cost.Threshold.t = - if always_inline then inlining_threshold - else Lazy.force fun_cost - in - let try_inlining = - if unrolling then - Try_it - else if self_call then - Don't_try_it S.Not_inlined.Self_call - else if not (E.inlining_allowed env function_decl.closure_origin) then - Don't_try_it S.Not_inlined.Unrolling_depth_exceeded - else if only_use_of_function || always_inline then - Try_it - else if never_inline then - Don't_try_it S.Not_inlined.Annotation - else if not (E.unrolling_allowed env set_of_closures_origin) - && (Lazy.force recursive) then - Don't_try_it S.Not_inlined.Unrolling_depth_exceeded - else if T.equal remaining_inlining_threshold T.Never_inline then - let threshold = - match inlining_threshold with - | T.Never_inline -> assert false - | T.Can_inline_if_no_larger_than threshold -> threshold - in - Don't_try_it (S.Not_inlined.Above_threshold threshold) - else if not (toplevel && branch_depth = 0) - && A.all_not_useful (E.find_list_exn env args) then - (* When all of the arguments to the function being inlined are unknown, - then we cannot materially simplify the function. As such, we know - what the benefit of inlining it would be: just removing the call. - In this case we may be able to prove the function cannot be inlined - without traversing its body. - Note that if the function is sufficiently small, we still have to call - [simplify], because the body needs freshening before substitution. - *) - (* CR-someday mshinwell: (from GPR#8): pchambart writes: - - We may need to think a bit about that. I can't see a lot of - meaningful examples right now, but there are some cases where some - optimization can happen even if we don't know anything about the - shape of the arguments. - - For instance - - let f x y = x - - let g x = - let y = (x,x) in - f x y - let f x y = - if x = y then ... else ... - - let g x = f x x - *) - match size_from_approximation with - | Some body_size -> - let wsb = - let benefit = Inlining_cost.Benefit.zero in - let benefit = Inlining_cost.Benefit.remove_call benefit in - let benefit = - Variable.Set.fold (fun v acc -> - try - let t = - Var_within_closure.Map.find (Var_within_closure.wrap v) - value_set_of_closures.A.bound_vars - in - match t.A.var with - | Some v -> - if (E.mem env v) then Inlining_cost.Benefit.remove_prim acc - else acc - | None -> acc - with Not_found -> acc) - function_body.free_variables benefit - in - W.create_estimate - ~original_size:Inlining_cost.direct_call_size - ~new_size:body_size - ~toplevel:(E.at_toplevel env) - ~branch_depth:(E.branch_depth env) - ~lifting:function_body.A.is_a_functor - ~round:(E.round env) - ~benefit - in - if (not (W.evaluate wsb)) then begin - Don't_try_it - (S.Not_inlined.Without_subfunctions wsb) - end else Try_it - | None -> - (* The function is definitely too large to inline given that we don't - have any approximations for its arguments. Further, the body - should already have been simplified (inside its declaration), so - we also expect no gain from the code below that permits inlining - inside the body. *) - Don't_try_it S.Not_inlined.No_useful_approximations - else begin - (* There are useful approximations, so we should simplify. *) - Try_it - end - in - match try_inlining with - | Don't_try_it decision -> Original decision - | Try_it -> - let r = - R.set_inlining_threshold r (Some remaining_inlining_threshold) - in - let body, r_inlined = - (* First we construct the code that would result from copying the body of - the function, without doing any further inlining upon it, to the call - site. *) - Inlining_transforms.inline_by_copying_function_body ~env - ~r:(R.reset_benefit r) ~lhs_of_application - ~closure_id_being_applied ~specialise_requested ~inline_requested - ~function_decl ~function_body ~fun_vars ~args ~dbg ~simplify - in - let num_direct_applications_seen = - (R.num_direct_applications r_inlined) - (R.num_direct_applications r) - in - assert (num_direct_applications_seen >= 0); - let keep_inlined_version decision = - (* Inlining the body of the function was sufficiently beneficial that we - will keep it, replacing the call site. We continue by allowing - further inlining within the inlined copy of the body. *) - let r_inlined = - (* The meaning of requesting inlining is that the user ensure - that the function has a benefit of at least its size. It is not - added to the benefit exposed by the inlining because the user should - have taken that into account before annotating the function. *) - if always_inline then - R.map_benefit r_inlined - (Inlining_cost.Benefit.max ~round:(E.round env) - Inlining_cost.Benefit.(requested_inline ~size_of:body zero)) - else r_inlined - in - let r = - R.map_benefit r_inlined (Inlining_cost.Benefit.(+) (R.benefit r)) - in - let env = E.note_entering_inlined env in - let env = - (* We decrement the unrolling count even if the function is not - recursive to avoid having to check whether or not it is recursive *) - E.inside_unrolled_function env set_of_closures_origin - in - let env = E.inside_inlined_function env function_decl.closure_origin in - let env = - if E.inlining_level env = 0 - (* If the function was considered for inlining without considering - its sub-functions, and it is not below another inlining choice, - then we are certain that this code will be kept. *) - then env - else E.inlining_level_up env - in - Changed ((simplify env r body), decision) - in - if always_inline then - keep_inlined_version S.Inlined.Annotation - else if only_use_of_function then - keep_inlined_version S.Inlined.Decl_local_to_application - else begin - let wsb = - W.create ~original body - ~toplevel:(E.at_toplevel env) - ~branch_depth:(E.branch_depth env) - ~lifting:function_body.is_a_functor - ~round:(E.round env) - ~benefit:(R.benefit r_inlined) - in - if W.evaluate wsb then - keep_inlined_version (S.Inlined.Without_subfunctions wsb) - else if num_direct_applications_seen < 1 then begin - (* Inlining the body of the function did not appear sufficiently - beneficial; however, it may become so if we inline within the body - first. We try that next, unless it is known that there were - no direct applications in the simplified body computed above, meaning - no opportunities for inlining. *) - Original (S.Not_inlined.Without_subfunctions wsb) - end else begin - let env = E.inlining_level_up env in - let env = E.note_entering_inlined env in - let env = - (* We decrement the unrolling count even if the function is recursive - to avoid having to check whether or not it is recursive *) - E.inside_unrolled_function env set_of_closures_origin - in - let body, r_inlined = simplify env r_inlined body in - let wsb_with_subfunctions = - W.create ~original body - ~toplevel:(E.at_toplevel env) - ~branch_depth:(E.branch_depth env) - ~lifting:function_body.is_a_functor - ~round:(E.round env) - ~benefit:(R.benefit r_inlined) - in - if W.evaluate wsb_with_subfunctions then begin - let res = - (body, R.map_benefit r_inlined - (Inlining_cost.Benefit.(+) (R.benefit r))) - in - let decision = - S.Inlined.With_subfunctions (wsb, wsb_with_subfunctions) - in - Changed (res, decision) - end - else begin - (* r_inlined contains an approximation that may be invalid for the - untransformed expression: it may reference functions that only - exists if the body of the function is in fact inlined. - If the function approximation contained an approximation that - does not depend on the actual values of its arguments, it - could be returned instead of [A.value_unknown]. *) - let decision = - S.Not_inlined.With_subfunctions (wsb, wsb_with_subfunctions) - in - Original decision - end - end - end - -let specialise env r ~lhs_of_application - ~(function_decls : A.function_declarations) - ~(function_decl : A.function_declaration) - ~closure_id_being_applied - ~(value_set_of_closures : A.value_set_of_closures) - ~args ~args_approxs ~dbg ~simplify ~original ~recursive ~self_call - ~inlining_threshold ~fun_cost - ~inline_requested ~specialise_requested = - let invariant_params = value_set_of_closures.invariant_params in - let free_vars = value_set_of_closures.free_vars in - let has_no_useful_approxes = - lazy - (List.for_all2 - (fun id approx -> - not ((A.useful approx) - && Variable.Map.mem id (Lazy.force invariant_params))) - (Parameter.List.vars function_decl.params) args_approxs) - in - let always_specialise, never_specialise = - (* Merge call site annotation and function annotation. - The call site annotation takes precedence *) - match (specialise_requested : Lambda.specialise_attribute) with - | Always_specialise -> true, false - | Never_specialise -> false, true - | Default_specialise -> begin - match function_decl.function_body with - | None -> false, true - | Some { specialise } -> - match (specialise : Lambda.specialise_attribute) with - | Always_specialise -> true, false - | Never_specialise -> false, true - | Default_specialise -> false, false - end - in - let remaining_inlining_threshold : Inlining_cost.Threshold.t = - if always_specialise then inlining_threshold - else Lazy.force fun_cost - in - let try_specialising = - (* Try specialising if the function: - - is recursive; and - - is closed (it and all other members of the set of closures on which - it depends); and - - has useful approximations for some invariant parameters. *) - if function_decls.is_classic_mode then - Don't_try_it S.Not_specialised.Classic_mode - else if self_call then - Don't_try_it S.Not_specialised.Self_call - else if always_specialise && not (Lazy.force has_no_useful_approxes) then - Try_it - else if never_specialise then - Don't_try_it S.Not_specialised.Annotation - else if T.equal remaining_inlining_threshold T.Never_inline then - let threshold = - match inlining_threshold with - | T.Never_inline -> assert false - | T.Can_inline_if_no_larger_than threshold -> threshold - in - Don't_try_it (S.Not_specialised.Above_threshold threshold) - else if not (Variable.Map.is_empty free_vars) then - Don't_try_it S.Not_specialised.Not_closed - else if not (Lazy.force recursive) then - Don't_try_it S.Not_specialised.Not_recursive - else if Variable.Map.is_empty (Lazy.force invariant_params) then - Don't_try_it S.Not_specialised.No_invariant_parameters - else if Lazy.force has_no_useful_approxes then - Don't_try_it S.Not_specialised.No_useful_approximations - else Try_it - in - match try_specialising with - | Don't_try_it decision -> Original decision - | Try_it -> begin - let r = - R.set_inlining_threshold r (Some remaining_inlining_threshold) - in - let copied_function_declaration = - Inlining_transforms.inline_by_copying_function_declaration ~env - ~r:(R.reset_benefit r) ~lhs_of_application - ~function_decls ~closure_id_being_applied ~function_decl - ~args ~args_approxs - ~invariant_params:invariant_params - ~specialised_args:value_set_of_closures.specialised_args - ~free_vars:value_set_of_closures.free_vars - ~direct_call_surrogates:value_set_of_closures.direct_call_surrogates - ~dbg ~simplify ~inline_requested - in - match copied_function_declaration with - | Some (expr, r_inlined) -> - let wsb = - W.create ~original expr - ~toplevel:false - ~branch_depth:(E.branch_depth env) - ~lifting:false - ~round:(E.round env) - ~benefit:(R.benefit r_inlined) - in - let env = - (* CR-someday lwhite: could avoid calculating this if stats is turned - off *) - let closure_ids = - Closure_id.Set.of_list ( - List.map Closure_id.wrap - (Variable.Set.elements (Variable.Map.keys function_decls.funs))) - in - E.note_entering_specialised env ~closure_ids - in - if always_specialise || W.evaluate wsb then begin - let r_inlined = - if always_specialise then - R.map_benefit r_inlined - (Inlining_cost.Benefit.max ~round:(E.round env) - Inlining_cost.Benefit.(requested_inline ~size_of:expr zero)) - else r_inlined - in - let r = - R.map_benefit r_inlined (Inlining_cost.Benefit.(+) (R.benefit r)) - in - let closure_env = - let env = - if E.inlining_level env = 0 - (* If the function was considered for specialising without - considering its sub-functions, and it is not below another - inlining choice, then we are certain that this code will - be kept. *) - then env - else E.inlining_level_up env - in - E.set_never_inline_outside_closures env - in - let application_env = E.set_never_inline_inside_closures env in - let expr, r = simplify closure_env r expr in - let res = simplify application_env r expr in - let decision = - if always_specialise then S.Specialised.Annotation - else S.Specialised.Without_subfunctions wsb - in - Changed (res, decision) - end else begin - let closure_env = - let env = E.inlining_level_up env in - E.set_never_inline_outside_closures env - in - let expr, r_inlined = simplify closure_env r_inlined expr in - let wsb_with_subfunctions = - W.create ~original expr - ~toplevel:false - ~branch_depth:(E.branch_depth env) - ~lifting:false - ~round:(E.round env) - ~benefit:(R.benefit r_inlined) - in - if W.evaluate wsb_with_subfunctions then begin - let r = - R.map_benefit r_inlined - (Inlining_cost.Benefit.(+) (R.benefit r)) - in - let application_env = E.set_never_inline_inside_closures env in - let res = simplify application_env r expr in - let decision = - S.Specialised.With_subfunctions (wsb, wsb_with_subfunctions) - in - Changed (res, decision) - end else begin - let decision = - S.Not_specialised.Not_beneficial (wsb, wsb_with_subfunctions) - in - Original decision - end - end - | None -> - let decision = S.Not_specialised.No_useful_approximations in - Original decision - end - -let for_call_site ~env ~r ~(function_decls : A.function_declarations) - ~lhs_of_application ~closure_id_being_applied - ~(function_decl : A.function_declaration) - ~(value_set_of_closures : A.value_set_of_closures) - ~args ~args_approxs ~dbg ~simplify ~inline_requested - ~specialise_requested = - if List.length args <> List.length args_approxs then begin - Misc.fatal_error "Inlining_decision.for_call_site: inconsistent lengths \ - of [args] and [args_approxs]" - end; - (* Remove unroll attributes from functions we are already actively - unrolling, otherwise they'll be unrolled again next round. *) - let inline_requested : Lambda.inline_attribute = - match (inline_requested : Lambda.inline_attribute) with - | Unroll _ -> begin - let unrolling = - E.actively_unrolling env function_decls.set_of_closures_origin - in - match unrolling with - | Some _ -> Default_inline - | None -> inline_requested - end - | Always_inline | Default_inline | Never_inline -> - inline_requested - in - let original = - Flambda.Apply { - func = lhs_of_application; - args; - kind = Direct closure_id_being_applied; - dbg; - inline = inline_requested; - specialise = specialise_requested; - } - in - let original_r = - R.set_approx (R.seen_direct_application r) (A.value_unknown Other) - in - match function_decl.function_body with - | None -> original, original_r - | Some { stub; _ } -> - if stub then begin - let fun_vars = Variable.Map.keys function_decls.funs in - let function_body = get_function_body function_decl in - let body, r = - Inlining_transforms.inline_by_copying_function_body ~env - ~r ~fun_vars ~lhs_of_application - ~closure_id_being_applied ~specialise_requested ~inline_requested - ~function_decl ~function_body ~args ~dbg ~simplify - in - simplify env r body - end else if E.never_inline env then - (* This case only occurs when examining the body of a stub function - but not in the context of inlining said function. As such, there - is nothing to do here (and no decision to report). *) - original, original_r - else if function_decls.is_classic_mode then begin - let env = - E.note_entering_call env - ~closure_id:closure_id_being_applied ~dbg:dbg - in - let simpl = - match function_decl.function_body with - | None -> Original S.Not_inlined.Classic_mode - | Some function_body -> - let self_call = - E.inside_set_of_closures_declaration - function_decls.set_of_closures_origin env - in - let try_inlining = - if self_call then - Don't_try_it S.Not_inlined.Self_call - else - if not (E.inlining_allowed env function_decl.closure_origin) then - Don't_try_it S.Not_inlined.Unrolling_depth_exceeded - else - Try_it - in - match try_inlining with - | Don't_try_it decision -> Original decision - | Try_it -> - let fun_vars = Variable.Map.keys function_decls.funs in - let body, r = - Inlining_transforms.inline_by_copying_function_body ~env - ~r ~function_body ~lhs_of_application - ~closure_id_being_applied ~specialise_requested - ~inline_requested ~function_decl ~fun_vars ~args ~dbg ~simplify - in - let env = E.note_entering_inlined env in - let env = - (* We decrement the unrolling count even if the function is not - recursive to avoid having to check whether or not it is - recursive *) - E.inside_unrolled_function env - function_decls.set_of_closures_origin - in - let env = - E.inside_inlined_function env function_decl.closure_origin - in - Changed ((simplify env r body), S.Inlined.Classic_mode) - in - let res, decision = - match simpl with - | Original decision -> - let decision = - S.Decision.Unchanged (S.Not_specialised.Classic_mode, decision) - in - (original, original_r), decision - | Changed ((expr, r), decision) -> - let max_inlining_threshold = - if E.at_toplevel env then - Inline_and_simplify_aux.initial_inlining_toplevel_threshold - ~round:(E.round env) - else - Inline_and_simplify_aux.initial_inlining_threshold - ~round:(E.round env) - in - let raw_inlining_threshold = R.inlining_threshold r in - let unthrottled_inlining_threshold = - match raw_inlining_threshold with - | None -> max_inlining_threshold - | Some inlining_threshold -> inlining_threshold - in - let inlining_threshold = - T.min unthrottled_inlining_threshold max_inlining_threshold - in - let inlining_threshold_diff = - T.sub unthrottled_inlining_threshold inlining_threshold - in - let res = - if E.inlining_level env = 0 - then expr, R.set_inlining_threshold r raw_inlining_threshold - else expr, R.add_inlining_threshold r inlining_threshold_diff - in - res, S.Decision.Inlined (S.Not_specialised.Classic_mode, decision) - in - E.record_decision env decision; - res - end else begin - let function_body = get_function_body function_decl in - let env = E.unset_never_inline_inside_closures env in - let env = - E.note_entering_call env - ~closure_id:closure_id_being_applied ~dbg:dbg - in - let max_level = - Clflags.Int_arg_helper.get ~key:(E.round env) !Clflags.inline_max_depth - in - let raw_inlining_threshold = R.inlining_threshold r in - let max_inlining_threshold = - if E.at_toplevel env then - Inline_and_simplify_aux.initial_inlining_toplevel_threshold - ~round:(E.round env) - else - Inline_and_simplify_aux.initial_inlining_threshold - ~round:(E.round env) - in - let unthrottled_inlining_threshold = - match raw_inlining_threshold with - | None -> max_inlining_threshold - | Some inlining_threshold -> inlining_threshold - in - let inlining_threshold = - T.min unthrottled_inlining_threshold max_inlining_threshold - in - let inlining_threshold_diff = - T.sub unthrottled_inlining_threshold inlining_threshold - in - let inlining_prevented = - match inlining_threshold with - | Never_inline -> true - | Can_inline_if_no_larger_than _ -> false - in - let simpl = - if inlining_prevented then - Original (D.Prevented Function_prevented_from_inlining) - else if E.inlining_level env >= max_level then - Original (D.Prevented Level_exceeded) - else begin - let self_call = - E.inside_set_of_closures_declaration - function_decls.set_of_closures_origin env - in - let fun_cost = - lazy - (Inlining_cost.can_try_inlining function_body.body - inlining_threshold - ~number_of_arguments:(List.length function_decl.params) - (* CR-someday mshinwell: for the moment, this is None, since - the Inlining_cost code isn't checking sizes up to the max - inlining threshold---this seems to take too long. *) - ~size_from_approximation:None) - in - let recursive = - lazy - (let fun_var = Closure_id.unwrap closure_id_being_applied in - Variable.Set.mem fun_var - (Lazy.force value_set_of_closures.recursive)) - in - let specialise_result = - specialise env r - ~function_decls ~function_decl - ~lhs_of_application ~recursive ~closure_id_being_applied - ~value_set_of_closures ~args ~args_approxs ~dbg ~simplify - ~original ~inline_requested ~specialise_requested ~fun_cost - ~self_call ~inlining_threshold - in - match specialise_result with - | Changed (res, spec_reason) -> - Changed (res, D.Specialised spec_reason) - | Original spec_reason -> - let only_use_of_function = false in - (* If we didn't specialise then try inlining *) - let size_from_approximation = - let fun_var = Closure_id.unwrap closure_id_being_applied in - match - Variable.Map.find fun_var - (Lazy.force value_set_of_closures.size) - with - | size -> size - | exception Not_found -> - Misc.fatal_errorf "Approximation does not give a size for the \ - function having fun_var %a. \ - value_set_of_closures: %a" - Variable.print fun_var - A.print_value_set_of_closures value_set_of_closures - in - let fun_vars = Variable.Map.keys function_decls.funs in - let set_of_closures_origin = - function_decls.set_of_closures_origin - in - let inline_result = - inline env r ~lhs_of_application - ~closure_id_being_applied ~function_decl ~value_set_of_closures - ~only_use_of_function ~original ~recursive - ~inline_requested ~specialise_requested - ~fun_vars ~set_of_closures_origin ~args - ~size_from_approximation ~dbg ~simplify ~fun_cost ~self_call - ~inlining_threshold ~function_body - in - match inline_result with - | Changed (res, inl_reason) -> - Changed (res, D.Inlined (spec_reason, inl_reason)) - | Original inl_reason -> - Original (D.Unchanged (spec_reason, inl_reason)) - end - in - let res, decision = - match simpl with - | Original decision -> (original, original_r), decision - | Changed ((expr, r), decision) -> - let res = - if E.inlining_level env = 0 - then expr, R.set_inlining_threshold r raw_inlining_threshold - else expr, R.add_inlining_threshold r inlining_threshold_diff - in - res, decision - in - E.record_decision env decision; - res - end - -(* We do not inline inside stubs, which are always inlined at their call site. - Inlining inside the declaration of a stub could result in more code than - expected being inlined (e.g. the body of a function that was transformed - by adding the stub). *) -let should_inline_inside_declaration (decl : Flambda.function_declaration) = - not decl.stub diff --git a/middle_end/inlining_decision.mli b/middle_end/inlining_decision.mli deleted file mode 100644 index 3694e30366..0000000000 --- a/middle_end/inlining_decision.mli +++ /dev/null @@ -1,43 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -(** See the Flambda manual chapter for an explanation in prose of the - inlining decision procedure. *) - -(** Try to inline a full application of a known function, guided by various - heuristics. *) -val for_call_site - : env:Inline_and_simplify_aux.Env.t - -> r:Inline_and_simplify_aux.Result.t - -> function_decls:Simple_value_approx.function_declarations - -> lhs_of_application:Variable.t - -> closure_id_being_applied:Closure_id.t - -> function_decl:Simple_value_approx.function_declaration - -> value_set_of_closures:Simple_value_approx.value_set_of_closures - -> args:Variable.t list - -> args_approxs:Simple_value_approx.t list - -> dbg:Debuginfo.t - -> simplify:Inlining_decision_intf.simplify - -> inline_requested:Lambda.inline_attribute - -> specialise_requested:Lambda.specialise_attribute - -> Flambda.t * Inline_and_simplify_aux.Result.t - -(** When a function declaration is encountered by [for_call_site], the body - may be subject to inlining immediately, thus changing the declaration. - This function must return [true] for that to be able to happen. *) -val should_inline_inside_declaration : Flambda.function_declaration -> bool diff --git a/middle_end/inlining_decision_intf.mli b/middle_end/inlining_decision_intf.mli deleted file mode 100644 index 15a080316c..0000000000 --- a/middle_end/inlining_decision_intf.mli +++ /dev/null @@ -1,49 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -(* CR-someday mshinwell: name of this source file could now be improved *) - -type 'a by_copying_function_body = - env:Inline_and_simplify_aux.Env.t - -> r:Inline_and_simplify_aux.Result.t - -> clos:Flambda.function_declarations - -> lfunc:Flambda.t - -> fun_id:Closure_id.t - -> func:Flambda.function_declaration - -> args:Flambda.t list - -> Flambda.t * Inline_and_simplify_aux.Result.t - -type 'a by_copying_function_declaration = - env:Inline_and_simplify_aux.Env.t - -> r:Inline_and_simplify_aux.Result.t - -> funct:Flambda.t - -> clos:Flambda.function_declarations - -> fun_id:Closure_id.t - -> func:Flambda.function_declaration - -> args_with_approxs: - (Flambda.t list) * (Simple_value_approx.t list) - -> invariant_params:Variable.Set.t - -> specialised_args:Variable.Set.t - -> dbg:Debuginfo.t - -> (Flambda.t * Inline_and_simplify_aux.Result.t) option - -type simplify = - Inline_and_simplify_aux.Env.t - -> Inline_and_simplify_aux.Result.t - -> Flambda.t - -> Flambda.t * Inline_and_simplify_aux.Result.t diff --git a/middle_end/inlining_stats.ml b/middle_end/inlining_stats.ml deleted file mode 100644 index 6809d4cbb4..0000000000 --- a/middle_end/inlining_stats.ml +++ /dev/null @@ -1,252 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -module Closure_stack = struct - type t = node list - - and node = - | Closure of Closure_id.t * Debuginfo.t - | Call of Closure_id.t * Debuginfo.t - | Inlined - | Specialised of Closure_id.Set.t - - let create () = [] - - let note_entering_closure t ~closure_id ~dbg = - if not !Clflags.inlining_report then t - else - match t with - | [] | (Closure _ | Inlined | Specialised _) :: _-> - (Closure (closure_id, dbg)) :: t - | (Call _) :: _ -> - Misc.fatal_errorf "note_entering_closure: unexpected Call node" - - (* CR-someday lwhite: since calls do not have a unique id it is possible - some calls will end up sharing nodes. *) - let note_entering_call t ~closure_id ~dbg = - if not !Clflags.inlining_report then t - else - match t with - | [] | (Closure _ | Inlined | Specialised _) :: _ -> - (Call (closure_id, dbg)) :: t - | (Call _) :: _ -> - Misc.fatal_errorf "note_entering_call: unexpected Call node" - - let note_entering_inlined t = - if not !Clflags.inlining_report then t - else - match t with - | [] | (Closure _ | Inlined | Specialised _) :: _-> - Misc.fatal_errorf "note_entering_inlined: missing Call node" - | (Call _) :: _ -> Inlined :: t - - let note_entering_specialised t ~closure_ids = - if not !Clflags.inlining_report then t - else - match t with - | [] | (Closure _ | Inlined | Specialised _) :: _ -> - Misc.fatal_errorf "note_entering_specialised: missing Call node" - | (Call _) :: _ -> Specialised closure_ids :: t - -end - -let log - : (Closure_stack.t * Inlining_stats_types.Decision.t) list ref - = ref [] - -let record_decision decision ~closure_stack = - if !Clflags.inlining_report then begin - match closure_stack with - | [] - | Closure_stack.Closure _ :: _ - | Closure_stack.Inlined :: _ - | Closure_stack.Specialised _ :: _ -> - Misc.fatal_errorf "record_decision: missing Call node" - | Closure_stack.Call _ :: _ -> - log := (closure_stack, decision) :: !log - end - -module Inlining_report = struct - - module Place = struct - type kind = - | Closure - | Call - - type t = Debuginfo.t * Closure_id.t * kind - - let compare ((d1, cl1, k1) : t) ((d2, cl2, k2) : t) = - let c = Debuginfo.compare d1 d2 in - if c <> 0 then c else - let c = Closure_id.compare cl1 cl2 in - if c <> 0 then c else - match k1, k2 with - | Closure, Closure -> 0 - | Call, Call -> 0 - | Closure, Call -> 1 - | Call, Closure -> -1 - end - - module Place_map = Map.Make(Place) - - type t = node Place_map.t - - and node = - | Closure of t - | Call of call - - and call = - { decision: Inlining_stats_types.Decision.t option; - inlined: t option; - specialised: t option; } - - let empty_call = - { decision = None; - inlined = None; - specialised = None; } - - (* Prevented or unchanged decisions may be overridden by a later look at the - same call. Other decisions may also be "overridden" because calls are not - uniquely identified. *) - let add_call_decision call (decision : Inlining_stats_types.Decision.t) = - match call.decision, decision with - | None, _ -> { call with decision = Some decision } - | Some _, Prevented _ -> call - | Some (Prevented _), _ -> { call with decision = Some decision } - | Some (Specialised _), _ -> call - | Some _, Specialised _ -> { call with decision = Some decision } - | Some (Inlined _), _ -> call - | Some _, Inlined _ -> { call with decision = Some decision } - | Some Unchanged _, Unchanged _ -> call - - let add_decision t (stack, decision) = - let rec loop t : Closure_stack.t -> _ = function - | Closure(cl, dbg) :: rest -> - let key : Place.t = (dbg, cl, Closure) in - let v = - try - match Place_map.find key t with - | Closure v -> v - | Call _ -> assert false - with Not_found -> Place_map.empty - in - let v = loop v rest in - Place_map.add key (Closure v) t - | Call(cl, dbg) :: rest -> - let key : Place.t = (dbg, cl, Call) in - let v = - try - match Place_map.find key t with - | Call v -> v - | Closure _ -> assert false - with Not_found -> empty_call - in - let v = - match rest with - | [] -> add_call_decision v decision - | Inlined :: rest -> - let inlined = - match v.inlined with - | None -> Place_map.empty - | Some inlined -> inlined - in - let inlined = loop inlined rest in - { v with inlined = Some inlined } - | Specialised _ :: rest -> - let specialised = - match v.specialised with - | None -> Place_map.empty - | Some specialised -> specialised - in - let specialised = loop specialised rest in - { v with specialised = Some specialised } - | Call _ :: _ -> assert false - | Closure _ :: _ -> assert false - in - Place_map.add key (Call v) t - | [] -> assert false - | Inlined :: _ -> assert false - | Specialised _ :: _ -> assert false - in - loop t (List.rev stack) - - let build log = - List.fold_left add_decision Place_map.empty log - - let print_stars ppf n = - let s = String.make n '*' in - Format.fprintf ppf "%s" s - - let rec print ~depth ppf t = - Place_map.iter (fun (dbg, cl, _) v -> - match v with - | Closure t -> - Format.fprintf ppf "@[%a Definition of %a%s@]@." - print_stars (depth + 1) - Closure_id.print cl - (Debuginfo.to_string dbg); - print ppf ~depth:(depth + 1) t; - if depth = 0 then Format.pp_print_newline ppf () - | Call c -> - match c.decision with - | None -> - Misc.fatal_error "Inlining_report.print: missing call decision" - | Some decision -> - Format.pp_open_vbox ppf (depth + 2); - Format.fprintf ppf "@[%a Application of %a%s@]@;@;@[%a@]" - print_stars (depth + 1) - Closure_id.print cl - (Debuginfo.to_string dbg) - Inlining_stats_types.Decision.summary decision; - Format.pp_close_box ppf (); - Format.pp_print_newline ppf (); - Format.pp_print_newline ppf (); - Inlining_stats_types.Decision.calculation ~depth:(depth + 1) - ppf decision; - begin - match c.specialised with - | None -> () - | Some specialised -> - print ppf ~depth:(depth + 1) specialised - end; - begin - match c.inlined with - | None -> () - | Some inlined -> - print ppf ~depth:(depth + 1) inlined - end; - if depth = 0 then Format.pp_print_newline ppf ()) - t - - let print ppf t = print ~depth:0 ppf t - -end - -let really_save_then_forget_decisions ~output_prefix = - let report = Inlining_report.build !log in - let out_channel = open_out (output_prefix ^ ".inlining.org") in - let ppf = Format.formatter_of_out_channel out_channel in - Inlining_report.print ppf report; - close_out out_channel; - log := [] - -let save_then_forget_decisions ~output_prefix = - if !Clflags.inlining_report then begin - really_save_then_forget_decisions ~output_prefix - end diff --git a/middle_end/inlining_stats.mli b/middle_end/inlining_stats.mli deleted file mode 100644 index f1e84fdcea..0000000000 --- a/middle_end/inlining_stats.mli +++ /dev/null @@ -1,46 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -module Closure_stack : sig - type t - - val create : unit -> t - - val note_entering_closure - : t - -> closure_id:Closure_id.t - -> dbg:Debuginfo.t - -> t - - val note_entering_call - : t - -> closure_id:Closure_id.t - -> dbg:Debuginfo.t - -> t - - val note_entering_inlined : t -> t - val note_entering_specialised : t -> closure_ids:Closure_id.Set.t -> t - -end - -val record_decision - : Inlining_stats_types.Decision.t - -> closure_stack:Closure_stack.t - -> unit - -val save_then_forget_decisions : output_prefix:string -> unit diff --git a/middle_end/inlining_stats_types.ml b/middle_end/inlining_stats_types.ml deleted file mode 100644 index 7aef0796d9..0000000000 --- a/middle_end/inlining_stats_types.ml +++ /dev/null @@ -1,290 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -module Wsb = Inlining_cost.Whether_sufficient_benefit - -let print_stars ppf n = - let s = String.make n '*' in - Format.fprintf ppf "%s" s - -let print_calculation ~depth ~title ~subfunctions ppf wsb = - Format.pp_open_vbox ppf (depth + 2); - Format.fprintf ppf "@[%a %s@]@;@;@[%a@]" - print_stars (depth + 1) - title - (Wsb.print_description ~subfunctions) wsb; - Format.pp_close_box ppf (); - Format.pp_print_newline ppf (); - Format.pp_print_newline ppf () - -module Inlined = struct - - type t = - | Classic_mode - | Annotation - | Decl_local_to_application - | Without_subfunctions of Wsb.t - | With_subfunctions of Wsb.t * Wsb.t - - let summary ppf = function - | Classic_mode -> - Format.pp_print_text ppf - "This function was inlined because it was small enough \ - to be inlined in `-Oclassic'" - | Annotation -> - Format.pp_print_text ppf - "This function was inlined because of an annotation." - | Decl_local_to_application -> - Format.pp_print_text ppf - "This function was inlined because it was local to this application." - | Without_subfunctions _ -> - Format.pp_print_text ppf - "This function was inlined because \ - the expected benefit outweighed the change in code size." - | With_subfunctions _ -> - Format.pp_print_text ppf - "This function was inlined because \ - the expected benefit outweighed the change in code size." - - let calculation ~depth ppf = function - | Classic_mode -> () - | Annotation -> () - | Decl_local_to_application -> () - | Without_subfunctions wsb -> - print_calculation - ~depth ~title:"Inlining benefit calculation" - ~subfunctions:false ppf wsb - | With_subfunctions(_, wsb) -> - print_calculation - ~depth ~title:"Inlining benefit calculation" - ~subfunctions:true ppf wsb - -end - -module Not_inlined = struct - type t = - | Classic_mode - | Above_threshold of int - | Annotation - | No_useful_approximations - | Unrolling_depth_exceeded - | Self_call - | Without_subfunctions of Wsb.t - | With_subfunctions of Wsb.t * Wsb.t - - - let summary ppf = function - | Classic_mode -> - Format.pp_print_text ppf - "This function was not inlined because it was too \ - large to be inlined in `-Oclassic'." - | Above_threshold size -> - Format.pp_print_text ppf - "This function was not inlined because \ - it was larger than the current size threshold"; - Format.fprintf ppf "(%i)" size - | Annotation -> - Format.pp_print_text ppf - "This function was not inlined because \ - of an annotation." - | No_useful_approximations -> - Format.pp_print_text ppf - "This function was not inlined because \ - there was no useful information about any of its parameters, \ - and it was not particularly small." - | Unrolling_depth_exceeded -> - Format.pp_print_text ppf - "This function was not inlined because \ - its unrolling depth was exceeded." - | Self_call -> - Format.pp_print_text ppf - "This function was not inlined because \ - it was a self call." - | Without_subfunctions _ -> - Format.pp_print_text ppf - "This function was not inlined because \ - the expected benefit did not outweigh the change in code size." - | With_subfunctions _ -> - Format.pp_print_text ppf - "This function was not inlined because \ - the expected benefit did not outweigh the change in code size." - - let calculation ~depth ppf = function - | Classic_mode - | Above_threshold _ - | Annotation - | No_useful_approximations - | Unrolling_depth_exceeded - | Self_call -> () - | Without_subfunctions wsb -> - print_calculation - ~depth ~title:"Inlining benefit calculation" - ~subfunctions:false ppf wsb - | With_subfunctions(_, wsb) -> - print_calculation - ~depth ~title:"Inlining benefit calculation" - ~subfunctions:true ppf wsb - -end - -module Specialised = struct - type t = - | Annotation - | Without_subfunctions of Wsb.t - | With_subfunctions of Wsb.t * Wsb.t - - let summary ppf = function - | Annotation -> - Format.pp_print_text ppf - "This function was specialised because of an annotation." - | Without_subfunctions _ -> - Format.pp_print_text ppf - "This function was specialised because the expected benefit \ - outweighed the change in code size." - | With_subfunctions _ -> - Format.pp_print_text ppf - "This function was specialised because the expected benefit \ - outweighed the change in code size." - - - let calculation ~depth ppf = function - | Annotation -> () - | Without_subfunctions wsb -> - print_calculation - ~depth ~title:"Specialising benefit calculation" - ~subfunctions:false ppf wsb - | With_subfunctions(_, wsb) -> - print_calculation - ~depth ~title:"Specialising benefit calculation" - ~subfunctions:true ppf wsb -end - -module Not_specialised = struct - type t = - | Classic_mode - | Above_threshold of int - | Annotation - | Not_recursive - | Not_closed - | No_invariant_parameters - | No_useful_approximations - | Self_call - | Not_beneficial of Wsb.t * Wsb.t - - let summary ppf = function - | Classic_mode -> - Format.pp_print_text ppf - "This function was not specialised because it was \ - compiled with `-Oclassic'." - | Above_threshold size -> - Format.pp_print_text ppf - "This function was not specialised because \ - it was larger than the current size threshold"; - Format.fprintf ppf "(%i)" size - | Annotation -> - Format.pp_print_text ppf - "This function was not specialised because \ - of an annotation." - | Not_recursive -> - Format.pp_print_text ppf - "This function was not specialised because \ - it is not recursive." - | Not_closed -> - Format.pp_print_text ppf - "This function was not specialised because \ - it is not closed." - | No_invariant_parameters -> - Format.pp_print_text ppf - "This function was not specialised because \ - it has no invariant parameters." - | No_useful_approximations -> - Format.pp_print_text ppf - "This function was not specialised because \ - there was no useful information about any of its invariant \ - parameters." - | Self_call -> - Format.pp_print_text ppf - "This function was not specialised because \ - it was a self call." - | Not_beneficial _ -> - Format.pp_print_text ppf - "This function was not specialised because \ - the expected benefit did not outweigh the change in code size." - - let calculation ~depth ppf = function - | Classic_mode - | Above_threshold _ - | Annotation - | Not_recursive - | Not_closed - | No_invariant_parameters - | No_useful_approximations - | Self_call -> () - | Not_beneficial(_, wsb) -> - print_calculation - ~depth ~title:"Specialising benefit calculation" - ~subfunctions:true ppf wsb - -end - -module Prevented = struct - type t = - | Function_prevented_from_inlining - | Level_exceeded - - let summary ppf = function - | Function_prevented_from_inlining -> - Format.pp_print_text ppf - "This function was prevented from inlining or specialising." - | Level_exceeded -> - Format.pp_print_text ppf - "This function was prevented from inlining or specialising \ - because the inlining depth was exceeded." -end - -module Decision = struct - type t = - | Prevented of Prevented.t - | Specialised of Specialised.t - | Inlined of Not_specialised.t * Inlined.t - | Unchanged of Not_specialised.t * Not_inlined.t - - let summary ppf = function - | Prevented p -> - Prevented.summary ppf p - | Specialised s -> - Specialised.summary ppf s - | Inlined (s, i) -> - Format.fprintf ppf "@[@[%a@]@;@;@[%a@]@]" - Not_specialised.summary s Inlined.summary i - | Unchanged (s, i) -> - Format.fprintf ppf "@[@[%a@]@;@;@[%a@]@]" - Not_specialised.summary s Not_inlined.summary i - - let calculation ~depth ppf = function - | Prevented _ -> () - | Specialised s -> - Specialised.calculation ~depth ppf s - | Inlined (s, i) -> - Not_specialised.calculation ~depth ppf s; - Inlined.calculation ~depth ppf i - | Unchanged (s, i) -> - Not_specialised.calculation ~depth ppf s; - Not_inlined.calculation ~depth ppf i -end diff --git a/middle_end/inlining_stats_types.mli b/middle_end/inlining_stats_types.mli deleted file mode 100644 index 9d476c8981..0000000000 --- a/middle_end/inlining_stats_types.mli +++ /dev/null @@ -1,89 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -(* Types used for producing statistics about inlining. *) - -module Inlined : sig - type t = - | Classic_mode - | Annotation - | Decl_local_to_application - | Without_subfunctions of - Inlining_cost.Whether_sufficient_benefit.t - | With_subfunctions of - Inlining_cost.Whether_sufficient_benefit.t - * Inlining_cost.Whether_sufficient_benefit.t -end - -module Not_inlined : sig - type t = - | Classic_mode - | Above_threshold of int - | Annotation - | No_useful_approximations - | Unrolling_depth_exceeded - | Self_call - | Without_subfunctions of - Inlining_cost.Whether_sufficient_benefit.t - | With_subfunctions of - Inlining_cost.Whether_sufficient_benefit.t - * Inlining_cost.Whether_sufficient_benefit.t -end - -module Specialised : sig - type t = - | Annotation - | Without_subfunctions of - Inlining_cost.Whether_sufficient_benefit.t - | With_subfunctions of - Inlining_cost.Whether_sufficient_benefit.t - * Inlining_cost.Whether_sufficient_benefit.t -end - -module Not_specialised : sig - type t = - | Classic_mode - | Above_threshold of int - | Annotation - | Not_recursive - | Not_closed - | No_invariant_parameters - | No_useful_approximations - | Self_call - | Not_beneficial of - Inlining_cost.Whether_sufficient_benefit.t - * Inlining_cost.Whether_sufficient_benefit.t -end - -module Prevented : sig - type t = - | Function_prevented_from_inlining - | Level_exceeded -end - -module Decision : sig - - type t = - | Prevented of Prevented.t - | Specialised of Specialised.t - | Inlined of Not_specialised.t * Inlined.t - | Unchanged of Not_specialised.t * Not_inlined.t - - val summary : Format.formatter -> t -> unit - val calculation : depth:int -> Format.formatter -> t -> unit -end diff --git a/middle_end/inlining_transforms.ml b/middle_end/inlining_transforms.ml deleted file mode 100644 index b08e62bb0a..0000000000 --- a/middle_end/inlining_transforms.ml +++ /dev/null @@ -1,668 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -module B = Inlining_cost.Benefit -module E = Inline_and_simplify_aux.Env -module R = Inline_and_simplify_aux.Result -module A = Simple_value_approx - -let new_var name = - Variable.create name - ~current_compilation_unit:(Compilation_unit.get_current_exn ()) - -(** Fold over all variables bound by the given closure, which is bound to the - variable [lhs_of_application], and corresponds to the given - [function_decls]. Each variable bound by the closure is passed to the - user-specified function as an [Flambda.named] value that projects the - variable from its closure. *) -let fold_over_projections_of_vars_bound_by_closure ~closure_id_being_applied - ~lhs_of_application ~bound_variables ~init ~f = - Variable.Set.fold (fun var acc -> - let expr : Flambda.named = - Project_var { - closure = lhs_of_application; - closure_id = closure_id_being_applied; - var = Var_within_closure.wrap var; - } - in - f ~acc ~var ~expr) - bound_variables - init - -let set_inline_attribute_on_all_apply body inline specialise = - Flambda_iterators.map_toplevel_expr (function - | Apply apply -> Apply { apply with inline; specialise } - | expr -> expr) - body - -(** Assign fresh names for a function's parameters and rewrite the body to - use these new names. *) -let copy_of_function's_body_with_freshened_params env - ~(function_decl : A.function_declaration) - ~(function_body : A.function_body) = - let params = function_decl.params in - let param_vars = Parameter.List.vars params in - (* We cannot avoid the substitution in the case where we are inlining - inside the function itself. This can happen in two ways: either - (a) we are inlining the function itself directly inside its declaration; - or (b) we are inlining the function into an already-inlined copy. - For (a) we cannot short-cut the substitution by freshening since the - original [params] may still be referenced; for (b) we cannot do it - either since the freshening may already be renaming the parameters for - the first inlining of the function. *) - if E.does_not_bind env param_vars - && E.does_not_freshen env param_vars - then - params, function_body.body - else - let freshened_params = List.map (fun p -> Parameter.rename p) params in - let subst = - Variable.Map.of_list - (List.combine param_vars (Parameter.List.vars freshened_params)) - in - let body = Flambda_utils.toplevel_substitution subst function_body.body in - freshened_params, body - -(* CR-soon mshinwell: Add a note somewhere to explain why "bound by the closure" - does not include the function identifiers for other functions in the same - set of closures. - mshinwell: The terminology may be used inconsistently. *) - -(** Inline a function by copying its body into a context where it becomes - closed. That is to say, we bind the free variables of the body - (= "variables bound by the closure"), and any function identifiers - introduced by the corresponding set of closures. *) -let inline_by_copying_function_body ~env ~r - ~lhs_of_application - ~(inline_requested : Lambda.inline_attribute) - ~(specialise_requested : Lambda.specialise_attribute) - ~closure_id_being_applied - ~(function_decl : A.function_declaration) - ~(function_body : A.function_body) - ~fun_vars - ~args ~dbg ~simplify = - assert (E.mem env lhs_of_application); - assert (List.for_all (E.mem env) args); - let r = - if function_body.stub then r - else R.map_benefit r B.remove_call - in - let freshened_params, body = - copy_of_function's_body_with_freshened_params env - ~function_decl ~function_body - in - let body = - let default_inline = - Lambda.equal_inline_attribute inline_requested Default_inline - in - let default_specialise = - Lambda.equal_specialise_attribute specialise_requested Default_specialise - in - if function_body.stub - && ((not default_inline) || (not default_specialise)) then - (* When the function inlined function is a stub, the annotation - is reported to the function applications inside the stub. - This allows to report the annotation to the application the - original programmer really intended: the stub is not visible - in the source. *) - set_inline_attribute_on_all_apply body - inline_requested specialise_requested - else - body - in - let bindings_for_params_to_args = - (* Bind the function's parameters to the arguments from the call site. *) - let args = List.map (fun arg -> Flambda.Expr (Var arg)) args in - Flambda_utils.bind ~body - ~bindings:(List.combine (Parameter.List.vars freshened_params) args) - in - (* Add bindings for the variables bound by the closure. *) - let bindings_for_vars_bound_by_closure_and_params_to_args = - let bound_variables = - let params = Parameter.Set.vars function_decl.params in - Variable.Set.diff - (Variable.Set.diff function_body.free_variables params) - fun_vars - in - fold_over_projections_of_vars_bound_by_closure ~closure_id_being_applied - ~lhs_of_application ~bound_variables ~init:bindings_for_params_to_args - ~f:(fun ~acc:body ~var ~expr -> Flambda.create_let var expr body) - in - (* Add bindings for variables corresponding to the functions introduced by - the whole set of closures. Each such variable will be bound to a closure; - each such closure is in turn produced by moving from the closure being - applied to another closure in the same set. - *) - let expr = - Variable.Set.fold (fun another_closure_in_the_same_set expr -> - let used = - Variable.Set.mem another_closure_in_the_same_set - function_body.free_variables - in - if used then - Flambda.create_let another_closure_in_the_same_set - (Move_within_set_of_closures { - closure = lhs_of_application; - start_from = closure_id_being_applied; - move_to = Closure_id.wrap another_closure_in_the_same_set; - }) - expr - else expr) - fun_vars - bindings_for_vars_bound_by_closure_and_params_to_args - in - let env = E.set_never_inline env in - let env = E.activate_freshening env in - let env = E.set_inline_debuginfo ~dbg env in - simplify env r expr - -type state = { - old_inside_to_new_inside : Variable.t Variable.Map.t; - (* Map from old inner vars to new inner vars *) - old_outside_to_new_outside : Variable.t Variable.Map.t; - (* Map from old outer vars to new outer vars *) - old_params_to_new_outside : Variable.t Variable.Map.t; - (* Map from old parameters to new outer vars. These are params - that should be specialised if they are copied to the new set of - closures. *) - old_fun_var_to_new_fun_var : Variable.t Variable.Map.t; - (* Map from old fun vars to new fun vars. These are the functions - that will be copied into the new set of closures *) - let_bindings : (Variable.t * Flambda.named) list; - (* Let bindings that will surround the definition of the new set - of closures *) - to_copy : Variable.t list; - (* List of functions that still need to be copied to the new set - of closures *) - new_funs : Flambda.function_declaration Variable.Map.t; - (* The function declarations for the new set of closures *) - new_free_vars_with_old_projections : Flambda.specialised_to Variable.Map.t; - (* The free variables for the new set of closures, but the projection - fields still point to old free variables. *) - new_specialised_args_with_old_projections : - Flambda.specialised_to Variable.Map.t; - (* The specialised parameters for the new set of closures, but the - projection fields still point to old specialised parameters. *) -} - -let empty_state = - { to_copy = []; - old_inside_to_new_inside = Variable.Map.empty; - old_outside_to_new_outside = Variable.Map.empty; - old_params_to_new_outside = Variable.Map.empty; - old_fun_var_to_new_fun_var = Variable.Map.empty; - let_bindings = []; - new_funs = Variable.Map.empty; - new_free_vars_with_old_projections = Variable.Map.empty; - new_specialised_args_with_old_projections = Variable.Map.empty; } - -(* Add let bindings for the free vars in the set_of_closures and - add them to [old_outside_to_new_outside] *) -let bind_free_vars ~lhs_of_application ~closure_id_being_applied - ~state ~free_vars = - Variable.Map.fold - (fun free_var (spec : Flambda.specialised_to) state -> - let var_clos = new_var Internal_variable_names.from_closure in - let expr : Flambda.named = - Project_var { - closure = lhs_of_application; - closure_id = closure_id_being_applied; - var = Var_within_closure.wrap free_var; - } - in - let let_bindings = (var_clos, expr) :: state.let_bindings in - let old_outside_to_new_outside = - Variable.Map.add spec.var var_clos state.old_outside_to_new_outside - in - { state with let_bindings; old_outside_to_new_outside }) - free_vars state - -(* For arguments of specialised parameters: - - Add them to [old_outside_to_new_outside] - - Add them and their invariant aliases to [old_params_to_new_outside] - For other arguments that are also worth specialising: - - Add them and their invariant aliases to [old_params_to_new_outside] *) -let register_arguments ~specialised_args ~invariant_params - ~state ~params ~args ~args_approxs = - let rec loop ~state ~params ~args ~args_approxs = - match params, args, args_approxs with - | [], [], [] -> state - | param :: params, arg :: args, arg_approx :: args_approxs -> begin - let param = Parameter.var param in - let worth_specialising, old_outside_to_new_outside = - match Variable.Map.find_opt param specialised_args with - | Some (spec : Flambda.specialised_to) -> - let old_outside_to_new_outside = - Variable.Map.add spec.var arg state.old_outside_to_new_outside - in - true, old_outside_to_new_outside - | None -> - let worth_specialising = - A.useful arg_approx - && Variable.Map.mem param (Lazy.force invariant_params) - in - worth_specialising, state.old_outside_to_new_outside - in - let old_params_to_new_outside = - if worth_specialising then begin - let old_params_to_new_outside = - Variable.Map.add param arg state.old_params_to_new_outside - in - match Variable.Map.find_opt param (Lazy.force invariant_params) with - | Some set -> - Variable.Set.fold - (fun elem acc -> Variable.Map.add elem arg acc) - set old_params_to_new_outside - | None -> - old_params_to_new_outside - end else begin - state.old_params_to_new_outside - end - in - let state = - { state with old_outside_to_new_outside; old_params_to_new_outside } - in - loop ~state ~params ~args ~args_approxs - end - | _, _, _ -> assert false - in - loop ~state ~params ~args ~args_approxs - -(* Add an old parameter to [old_inside_to_new_inside]. If it appears in - [old_params_to_new_outside] then also add it to the new specialised args. *) -let add_param ~specialised_args ~state ~param = - let param = Parameter.var param in - let new_param = Variable.rename param in - let old_inside_to_new_inside = - Variable.Map.add param new_param state.old_inside_to_new_inside - in - let new_specialised_args_with_old_projections = - match Variable.Map.find_opt param specialised_args with - | Some (spec : Flambda.specialised_to) -> - let new_outside_var = - Variable.Map.find spec.var state.old_outside_to_new_outside - in - let new_spec : Flambda.specialised_to = - { spec with var = new_outside_var } - in - Variable.Map.add new_param new_spec - state.new_specialised_args_with_old_projections - | None -> begin - match Variable.Map.find_opt param state.old_params_to_new_outside with - | None -> state.new_specialised_args_with_old_projections - | Some new_outside_var -> - let new_spec : Flambda.specialised_to = - { var = new_outside_var; projection = None } - in - Variable.Map.add new_param new_spec - state.new_specialised_args_with_old_projections - end - in - let state = - { state with old_inside_to_new_inside; - new_specialised_args_with_old_projections } - in - state, Parameter.wrap new_param - -(* Add a let binding for an old fun_var, add it to the new free variables, and - add it to [old_inside_to_new_inside] *) -let add_fun_var ~lhs_of_application ~closure_id_being_applied ~state ~fun_var = - if Variable.Map.mem fun_var state.old_inside_to_new_inside then state - else begin - let inside_var = Variable.rename fun_var in - let outside_var = Variable.create Internal_variable_names.closure in - let expr = - Flambda.Move_within_set_of_closures - { closure = lhs_of_application; - start_from = closure_id_being_applied; - move_to = Closure_id.wrap fun_var; } - in - let let_bindings = (outside_var, expr) :: state.let_bindings in - let spec : Flambda.specialised_to = - { var = outside_var; projection = None; } - in - let new_free_vars_with_old_projections = - Variable.Map.add inside_var spec state.new_free_vars_with_old_projections - in - let old_inside_to_new_inside = - Variable.Map.add fun_var inside_var state.old_inside_to_new_inside - in - { state with - old_inside_to_new_inside; let_bindings; - new_free_vars_with_old_projections } - end - -(* Add an old free_var to the new free variables and add it to - [old_inside_to_new_inside]. *) -let add_free_var ~free_vars ~state ~free_var = - if Variable.Map.mem free_var state.old_inside_to_new_inside then state - else begin - let spec : Flambda.specialised_to = Variable.Map.find free_var free_vars in - let outside_var = spec.var in - let new_outside_var = - Variable.Map.find outside_var state.old_outside_to_new_outside - in - let new_spec : Flambda.specialised_to = - { spec with var = new_outside_var } - in - let new_inside_var = Variable.rename free_var in - let new_free_vars_with_old_projections = - Variable.Map.add new_inside_var new_spec - state.new_free_vars_with_old_projections - in - let old_inside_to_new_inside = - Variable.Map.add free_var new_inside_var state.old_inside_to_new_inside - in - { state with old_inside_to_new_inside; new_free_vars_with_old_projections } - end - -(* Add a function to the new set of closures iff: - 1) All it's specialised parameters are available in - [old_outside_to_new_outside] - 2) At least one more parameter will become specialised *) -let add_function ~specialised_args ~state ~fun_var ~function_decl = - match function_decl.A.function_body with - | None -> None - | Some _ -> begin - let rec loop worth_specialising = function - | [] -> worth_specialising - | param :: params -> begin - let param = Parameter.var param in - match Variable.Map.find_opt param specialised_args with - | Some (spec : Flambda.specialised_to) -> - Variable.Map.mem spec.var state.old_outside_to_new_outside - && loop worth_specialising params - | None -> - let worth_specialising = - worth_specialising - || Variable.Map.mem param state.old_params_to_new_outside - in - loop worth_specialising params - end - in - let worth_specialising = loop false function_decl.A.params in - if not worth_specialising then None - else begin - let new_fun_var = Variable.rename fun_var in - let old_fun_var_to_new_fun_var = - Variable.Map.add fun_var new_fun_var state.old_fun_var_to_new_fun_var - in - let to_copy = fun_var :: state.to_copy in - let state = { state with old_fun_var_to_new_fun_var; to_copy } in - Some (state, new_fun_var) - end - end - -(* Lookup a function in the new set of closures, trying to add it if - necessary. *) -let lookup_function ~specialised_args ~state ~fun_var ~function_decl = - match Variable.Map.find_opt fun_var state.old_fun_var_to_new_fun_var with - | Some new_fun_var -> Some (state, new_fun_var) - | None -> add_function ~specialised_args ~state ~fun_var ~function_decl - -(* A direct call to a function in the new set of closures can be specialised - if all the function's newly specialised parameters are passed arguments - that are specialised to the same outside variable *) -let specialisable_call ~specialised_args ~state ~args ~params = - List.for_all2 - (fun arg param -> - let param = Parameter.var param in - if Variable.Map.mem param specialised_args then true - else begin - let old_params_to_new_outside = state.old_params_to_new_outside in - match Variable.Map.find_opt param old_params_to_new_outside with - | None -> true - | Some outside_var -> begin - match Variable.Map.find_opt arg old_params_to_new_outside with - | Some outside_var' -> - Variable.equal outside_var outside_var' - | None -> false - end - end) - args params - -(* Rewrite a call iff: - 1) It is to a function in the old set of closures that can be specialised - 2) All the newly specialised parameters of that function are passed values - known to be equal to their new specialisation. *) -let rec rewrite_direct_call ~specialised_args ~funs ~direct_call_surrogates - ~state ~closure_id ~(apply : Flambda.apply) = - match Closure_id.Map.find_opt closure_id direct_call_surrogates with - | Some closure_id -> - rewrite_direct_call ~specialised_args ~funs ~direct_call_surrogates - ~state ~closure_id ~apply - | None -> begin - let fun_var = Closure_id.unwrap closure_id in - match Variable.Map.find_opt fun_var funs with - | None -> None - | Some function_decl -> begin - match - lookup_function ~specialised_args ~state ~fun_var ~function_decl - with - | None -> None - | Some (state, new_fun_var) -> begin - let args = apply.args in - let params = function_decl.A.params in - let specialisable = - specialisable_call ~specialised_args ~state ~args ~params - in - if not specialisable then None - else begin - let kind = Flambda.Direct (Closure_id.wrap new_fun_var) in - let apply = { apply with func = new_fun_var; kind } in - Some (state, Flambda.Apply apply) - end - end - end - end - -(* Rewrite the body a function declaration for use in the new set of - closures. *) -let rewrite_function ~lhs_of_application ~closure_id_being_applied - ~direct_call_surrogates ~specialised_args ~free_vars ~funs - ~state fun_var = - let function_decl : A.function_declaration = - Variable.Map.find fun_var funs - in - let function_body = - match function_decl.function_body with - | None -> assert false - | Some function_body -> function_body - in - let new_fun_var = - Variable.Map.find fun_var state.old_fun_var_to_new_fun_var - in - let state, params = - List.fold_right - (fun param (state, params) -> - let state, param = add_param ~specialised_args ~state ~param in - (state, param :: params)) - function_decl.params (state, []) - in - let state = - Variable.Set.fold - (fun var state -> - if Variable.Map.mem var funs then - add_fun_var ~lhs_of_application ~closure_id_being_applied - ~state ~fun_var:var - else if Variable.Map.mem var free_vars then - add_free_var ~free_vars ~state ~free_var:var - else - state) - function_body.free_variables state - in - let state_ref = ref state in - let body = - Flambda_iterators.map_toplevel_expr - (fun (expr : Flambda.t) -> - match expr with - | Apply ({ kind = Direct closure_id } as apply) -> begin - match - rewrite_direct_call ~specialised_args ~funs - ~direct_call_surrogates ~state:!state_ref ~closure_id ~apply - with - | None -> expr - | Some (state, expr) -> - state_ref := state; - expr - end - | _ -> expr) - function_body.body - in - let body = - Flambda_utils.toplevel_substitution state.old_inside_to_new_inside body - in - let new_function_decl = - Flambda.create_function_declaration - ~params ~body - ~stub:function_body.stub - ~dbg:function_body.dbg - ~inline:function_body.inline - ~specialise:function_body.specialise - ~is_a_functor:function_body.is_a_functor - ~closure_origin:(Closure_origin.create (Closure_id.wrap new_fun_var)) - in - let new_funs = - Variable.Map.add new_fun_var new_function_decl state.new_funs - in - let state = { !state_ref with new_funs } in - state - -let update_projections ~state projections = - let old_to_new = state.old_inside_to_new_inside in - Variable.Map.map - (fun (spec_to : Flambda.specialised_to) -> - let projection : Projection.t option = - match spec_to.projection with - | None -> None - | Some (Project_var proj) -> begin - match Variable.Map.find_opt proj.closure old_to_new with - | None -> None - | Some closure -> - let proj = { proj with closure } in - Some (Projection.Project_var proj) - end - | Some (Project_closure proj) -> begin - match Variable.Map.find_opt proj.set_of_closures old_to_new with - | None -> None - | Some set_of_closures -> - let proj = { proj with set_of_closures } in - Some (Projection.Project_closure proj) - end - | Some (Move_within_set_of_closures proj) -> begin - match Variable.Map.find_opt proj.closure old_to_new with - | None -> None - | Some closure -> - let proj = { proj with closure } in - Some (Projection.Move_within_set_of_closures proj) - end - | Some (Field (index, var)) -> begin - match Variable.Map.find_opt var old_to_new with - | None -> None - | Some var -> Some (Projection.Field(index, var)) - end - in - { spec_to with projection }) - projections - -let inline_by_copying_function_declaration - ~(env : Inline_and_simplify_aux.Env.t) - ~(r : Inline_and_simplify_aux.Result.t) - ~(function_decls : A.function_declarations) - ~(lhs_of_application : Variable.t) - ~(inline_requested : Lambda.inline_attribute) - ~(closure_id_being_applied : Closure_id.t) - ~(function_decl : A.function_declaration) - ~(args : Variable.t list) - ~(args_approxs : A.t list) - ~(invariant_params : Variable.Set.t Variable.Map.t lazy_t) - ~(specialised_args : Flambda.specialised_to Variable.Map.t) - ~(free_vars : Flambda.specialised_to Variable.Map.t) - ~(direct_call_surrogates : Closure_id.t Closure_id.Map.t) - ~(dbg : Debuginfo.t) - ~(simplify : Inlining_decision_intf.simplify) = - let state = empty_state in - let state = - bind_free_vars ~lhs_of_application ~closure_id_being_applied - ~state ~free_vars - in - let params = function_decl.params in - let state = - register_arguments ~specialised_args ~invariant_params - ~state ~params ~args ~args_approxs - in - let fun_var = Closure_id.unwrap closure_id_being_applied in - match add_function ~specialised_args ~state ~fun_var ~function_decl with - | None -> None - | Some (state, new_fun_var) -> begin - let funs = function_decls.funs in - let rec loop state = - match state.to_copy with - | [] -> state - | next :: rest -> - let state = { state with to_copy = rest } in - let state = - rewrite_function ~lhs_of_application ~closure_id_being_applied - ~direct_call_surrogates ~specialised_args ~free_vars ~funs - ~state next - in - loop state - in - let state = loop state in - let closure_id = Closure_id.wrap new_fun_var in - let function_decls = - Flambda.create_function_declarations_with_origin - ~funs:state.new_funs - ~set_of_closures_origin:function_decls.set_of_closures_origin - ~is_classic_mode:function_decls.is_classic_mode - in - let free_vars = - update_projections ~state - state.new_free_vars_with_old_projections - in - let specialised_args = - update_projections ~state - state.new_specialised_args_with_old_projections - in - let direct_call_surrogates = Variable.Map.empty in - let set_of_closures = - Flambda.create_set_of_closures ~function_decls - ~free_vars ~specialised_args ~direct_call_surrogates - in - let closure_var = new_var Internal_variable_names.dup_func in - let set_of_closures_var = - new_var Internal_variable_names.dup_set_of_closures - in - let project : Flambda.project_closure = - {set_of_closures = set_of_closures_var; closure_id} - in - let apply : Flambda.apply = - { func = closure_var; args; kind = Direct closure_id; dbg; - inline = inline_requested; specialise = Default_specialise; } - in - let body = - Flambda.create_let - set_of_closures_var (Set_of_closures set_of_closures) - (Flambda.create_let closure_var (Project_closure project) - (Apply apply)) - in - let expr = Flambda_utils.bind ~body ~bindings:state.let_bindings in - let env = E.activate_freshening (E.set_never_inline env) in - Some (simplify env r expr) - end diff --git a/middle_end/inlining_transforms.mli b/middle_end/inlining_transforms.mli deleted file mode 100644 index e31d1b0849..0000000000 --- a/middle_end/inlining_transforms.mli +++ /dev/null @@ -1,105 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -(** Source code transformations used during inlining. *) - -(** Inline a function by substituting its body (which may be subject to - further transformation) at a call site. The function's declaration is - not copied. - - This transformation is used when: - - inlining a call to a non-recursive function; - - inlining a call, within a recursive or mutually-recursive function, to - the same or another function being defined simultaneously ("unrolling"). - The maximum depth of unrolling is bounded (see [E.unrolling_allowed]). - - In both cases, the body of the function is copied, within a sequence of - [let]s that bind the function parameters, the variables "bound by the - closure" (see flambda.mli), and any function identifiers introduced by the - set of closures. These stages are delimited below by comments. - - As an example, suppose we are inlining the following function: - - let f x = x + y - ... - let p = f, f in - (fst p) 42 - - The call site [ (fst p) 42] will be transformed to: - - let clos_id = fst p in (* must eventually yield a closure *) - let y = in - let x' = 42 in - let x = x' in - x + y - - When unrolling a recursive function we rename the arguments to the - recursive call in order to avoid clashes with existing bindings. For - example, suppose we are inlining the following call to [f], which lies - within its own declaration: - - let rec f x y = - f (fst x) (y + snd x) - - This will be transformed to: - - let rec f x y = - let clos_id = f in (* not used this time, since [f] has no free vars *) - let x' = fst x in - let y' = y + snd x in - f (fst x') (y' + snd x') (* body of [f] with parameters freshened *) -*) -val inline_by_copying_function_body - : env:Inline_and_simplify_aux.Env.t - -> r:Inline_and_simplify_aux.Result.t - -> lhs_of_application:Variable.t - -> inline_requested:Lambda.inline_attribute - -> specialise_requested:Lambda.specialise_attribute - -> closure_id_being_applied:Closure_id.t - -> function_decl:Simple_value_approx.function_declaration - -> function_body:Simple_value_approx.function_body - -> fun_vars:Variable.Set.t - -> args:Variable.t list - -> dbg:Debuginfo.t - -> simplify:Inlining_decision_intf.simplify - -> Flambda.t * Inline_and_simplify_aux.Result.t - -(** Inlining of recursive function(s) yields a copy of the functions' - definitions (not just their bodies, unlike the non-recursive case) and - a direct application of the new body. - Note: the function really does need to be recursive (but possibly only via - some mutual recursion) to end up in here; a simultaneous binding [that is - non-recursive] is not sufficient. -*) -val inline_by_copying_function_declaration - : env:Inline_and_simplify_aux.Env.t - -> r:Inline_and_simplify_aux.Result.t - -> function_decls:Simple_value_approx.function_declarations - -> lhs_of_application:Variable.t - -> inline_requested:Lambda.inline_attribute - -> closure_id_being_applied:Closure_id.t - -> function_decl:Simple_value_approx.function_declaration - -> args:Variable.t list - -> args_approxs:Simple_value_approx.t list - -> invariant_params:Variable.Set.t Variable.Map.t lazy_t - -> specialised_args:Flambda.specialised_to Variable.Map.t - -> free_vars:Flambda.specialised_to Variable.Map.t - -> direct_call_surrogates:Closure_id.t Closure_id.Map.t - -> dbg:Debuginfo.t - -> simplify:Inlining_decision_intf.simplify - -> (Flambda.t * Inline_and_simplify_aux.Result.t) option diff --git a/middle_end/int_replace_polymorphic_compare.ml b/middle_end/int_replace_polymorphic_compare.ml deleted file mode 100644 index 7cd6bf1099..0000000000 --- a/middle_end/int_replace_polymorphic_compare.ml +++ /dev/null @@ -1,8 +0,0 @@ -let ( = ) : int -> int -> bool = Stdlib.( = ) -let ( <> ) : int -> int -> bool = Stdlib.( <> ) -let ( < ) : int -> int -> bool = Stdlib.( < ) -let ( > ) : int -> int -> bool = Stdlib.( > ) -let ( <= ) : int -> int -> bool = Stdlib.( <= ) -let ( >= ) : int -> int -> bool = Stdlib.( >= ) - -let compare : int -> int -> int = Stdlib.compare diff --git a/middle_end/int_replace_polymorphic_compare.mli b/middle_end/int_replace_polymorphic_compare.mli deleted file mode 100644 index 689e741b66..0000000000 --- a/middle_end/int_replace_polymorphic_compare.mli +++ /dev/null @@ -1,8 +0,0 @@ -val ( = ) : int -> int -> bool -val ( <> ) : int -> int -> bool -val ( < ) : int -> int -> bool -val ( > ) : int -> int -> bool -val ( <= ) : int -> int -> bool -val ( >= ) : int -> int -> bool - -val compare : int -> int -> int diff --git a/middle_end/invariant_params.ml b/middle_end/invariant_params.ml deleted file mode 100644 index a43cfdace1..0000000000 --- a/middle_end/invariant_params.ml +++ /dev/null @@ -1,420 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -(* CR-someday pchambart to pchambart: in fact partial application doesn't - work because there are no 'known' partial application left: they are - converted to applications new partial function declaration. - That can be improved (and many other cases) by keeping track of aliases in - closure of functions. *) - -(* These analyses are computed in two steps: - * accumulate the atomic <- relations - * compute the least-fixed point - - The <- relation is represented by the type - - t Variable.Pair.Map.t - - if [Variable.Pair.Map.find (f, x) relation = Top] then (f, x) <- Top - is in the relation. - - if [Variable.Pair.Map.find (f, x) relation = Implication s] and - [Variable.Pair.Set.mem (g, y) s] then (f, x) <- (g, y) is in the - relation. -*) - -type t = - | Top - | Implication of Variable.Pair.Set.t - -let _print ppf = function - | Top -> Format.fprintf ppf "Top" - | Implication args -> - Format.fprintf ppf "Implication: @[%a@]" - Variable.Pair.Set.print args - -let top relation p = - Variable.Pair.Map.add p Top relation - -let implies relation from to_ = - match Variable.Pair.Map.find to_ relation with - | Top -> relation - | Implication set -> - Variable.Pair.Map.add to_ - (Implication (Variable.Pair.Set.add from set)) - relation - | exception Not_found -> - Variable.Pair.Map.add to_ - (Implication (Variable.Pair.Set.singleton from)) - relation - -let transitive_closure state = - let union s1 s2 = - match s1, s2 with - | Top, _ | _, Top -> Top - | Implication s1, Implication s2 -> - Implication (Variable.Pair.Set.union s1 s2) - in - let equal s1 s2 = - match s1, s2 with - | Top, Implication _ | Implication _, Top -> false - | Top, Top -> true - | Implication s1, Implication s2 -> Variable.Pair.Set.equal s1 s2 - in - let update arg state = - let original_set = - try Variable.Pair.Map.find arg state with - | Not_found -> Implication Variable.Pair.Set.empty - in - match original_set with - | Top -> state - | Implication arguments -> - let set = - Variable.Pair.Set.fold - (fun orig acc-> - let set = - try Variable.Pair.Map.find orig state with - | Not_found -> Implication Variable.Pair.Set.empty in - union set acc) - arguments original_set - in - Variable.Pair.Map.add arg set state - in - let once state = - Variable.Pair.Map.fold (fun arg _ state -> update arg state) state state - in - let rec fp state = - let state' = once state in - if Variable.Pair.Map.equal equal state state' - then state - else fp state' - in - fp state - -(* CR-soon pchambart: to move to Flambda_utils and document - mshinwell: I think this calculation is basically the same as - [Flambda_utils.fun_vars_referenced_in_decls], so we should try - to share code. However let's defer until after 4.03. (And note CR - below.) -*) -(* Finds variables that represent the functions. - In a construction like: - let f x = - let g = Symbol f_closure in - .. - the variable g is bound to the symbol f_closure which - is the current closure. - The result of [function_variable_alias] will contain - the association [g -> f] -*) -let function_variable_alias - (function_decls : Flambda.function_declarations) - ~backend = - let fun_vars = Variable.Map.keys function_decls.funs in - let symbols_to_fun_vars = - let module Backend = (val backend : Backend_intf.S) in - Variable.Set.fold (fun fun_var symbols_to_fun_vars -> - let closure_id = Closure_id.wrap fun_var in - let symbol = Backend.closure_symbol closure_id in - Symbol.Map.add symbol fun_var symbols_to_fun_vars) - fun_vars - Symbol.Map.empty - in - let fun_var_bindings = ref Variable.Map.empty in - Variable.Map.iter (fun _ ( function_decl : Flambda.function_declaration ) -> - Flambda_iterators.iter_all_toplevel_immutable_let_and_let_rec_bindings - ~f:(fun var named -> - (* CR-soon mshinwell: consider having the body passed to this - function and using fv calculation instead of used_variables. - Need to be careful of "let rec" *) - match named with - | Symbol sym -> - begin match Symbol.Map.find sym symbols_to_fun_vars with - | exception Not_found -> () - | fun_var -> - fun_var_bindings := - Variable.Map.add var fun_var !fun_var_bindings - end - | _ -> ()) - function_decl.body) - function_decls.funs; - !fun_var_bindings - -let analyse_functions ~backend ~param_to_param - ~anything_to_param ~param_to_anywhere - (decls : Flambda.function_declarations) = - let function_variable_alias = function_variable_alias ~backend decls in - let param_indexes_by_fun_vars = - Variable.Map.map (fun (decl : Flambda.function_declaration) -> - Array.of_list (Parameter.List.vars decl.params)) - decls.funs - in - let find_callee_arg ~callee ~callee_pos = - match Variable.Map.find callee param_indexes_by_fun_vars with - | exception Not_found -> None (* not a recursive call *) - | arr -> - (* Ignore overapplied parameters: they are applied to a different - function. *) - if callee_pos < Array.length arr then Some arr.(callee_pos) - else None - in - let escaping_functions = Variable.Tbl.create 13 in - let escaping_function fun_var = - let fun_var = - match Variable.Map.find fun_var function_variable_alias with - | exception Not_found -> fun_var - | fun_var -> fun_var - in - if Variable.Map.mem fun_var decls.funs - then Variable.Tbl.add escaping_functions fun_var (); - in - let used_variables = Variable.Tbl.create 42 in - let used_variable var = Variable.Tbl.add used_variables var () in - let relation = ref Variable.Pair.Map.empty in - (* If the called closure is in the current set of closures, record the - relation (callee, callee_arg) <- (caller, caller_arg) *) - let check_argument ~caller ~callee ~callee_pos ~caller_arg = - escaping_function caller_arg; - match find_callee_arg ~callee ~callee_pos with - | None -> used_variable caller_arg (* not a recursive call *) - | Some callee_arg -> - match Variable.Map.find caller decls.funs with - | exception Not_found -> - assert false - | { params } -> - let new_relation = - (* We only track dataflow for parameters of functions, not - arbitrary variables. *) - if List.exists - (fun param -> Variable.equal (Parameter.var param) caller_arg) - params - then - param_to_param ~caller ~caller_arg ~callee ~callee_arg !relation - else begin - used_variable caller_arg; - anything_to_param ~callee ~callee_arg !relation - end - in - relation := new_relation - in - let arity ~callee = - match Variable.Map.find callee decls.funs with - | exception Not_found -> 0 - | func -> Flambda_utils.function_arity func - in - let check_expr ~caller (expr : Flambda.t) = - match expr with - | Apply { func; args } -> - used_variable func; - let callee = - match Variable.Map.find func function_variable_alias with - | exception Not_found -> func - | callee -> callee - in - let num_args = List.length args in - for callee_pos = num_args to (arity ~callee) - 1 do - (* If a function is partially applied, consider all missing - arguments as "anything". *) - match find_callee_arg ~callee ~callee_pos with - | None -> () - | Some callee_arg -> - relation := anything_to_param ~callee ~callee_arg !relation - done; - List.iteri (fun callee_pos caller_arg -> - check_argument ~caller ~callee ~callee_pos ~caller_arg) - args - | _ -> () - in - Variable.Map.iter (fun caller (decl : Flambda.function_declaration) -> - Flambda_iterators.iter (check_expr ~caller) - (fun (_ : Flambda.named) -> ()) - decl.body; - Variable.Set.iter - (fun var -> escaping_function var; used_variable var) - (* CR-soon mshinwell: we should avoid recomputing this, cache in - [function_declaration]. See also comment on - [only_via_symbols] in [Flambda_utils]. *) - (Flambda.free_variables ~ignore_uses_as_callee:() - ~ignore_uses_as_argument:() decl.body)) - decls.funs; - Variable.Map.iter - (fun func_var ({ params } : Flambda.function_declaration) -> - List.iter - (fun (param : Parameter.t) -> - if Variable.Tbl.mem used_variables (Parameter.var param) then - relation := - param_to_anywhere ~caller:func_var - ~caller_arg:(Parameter.var param) !relation; - if Variable.Tbl.mem escaping_functions func_var then - relation := - anything_to_param ~callee:func_var - ~callee_arg:(Parameter.var param) !relation) - params) - decls.funs; - transitive_closure !relation - - -(* A parameter [x] of the function [f] is considered as unchanging if - during an 'external' (call from outside the set of closures) call of - [f], every recursive call of [f] all the instances of [x] are aliased - to the original one. This function computes an underapproximation of - that set by computing the flow of parameters between the different - functions of the set of closures. - - We record [(f, x) <- (g, y)] when the function g calls f and - the y parameter of g is used as argument for the x parameter of f. For - instance in - - let rec f x = ... - and g y = f x - - We record [(f, x) <- Top] when some unknown values can flow to the - [y] parameter. - - let rec f x = f 1 - - We record also [(f, x) <- Top] if [f] could escape. This is over - approximated by considering that a function escape when its variable is used - for something else than an application: - - let rec f x = (f, f) - - [x] is not unchanging if either - (f, x) <- Top - or (f, x) <- (f, y) with x != y - - Notice that having (f, x) <- (g, a) and (f, x) <- (g, b) does not make - x not unchanging. This is because (g, a) and (g, b) represent necessarily - different values only if g is the externaly called function. If some - value where created during the execution of the function that could - flow to (g, a), then (g, a) <- Top, so (f, x) <- Top. - - *) - -let invariant_params_in_recursion (decls : Flambda.function_declarations) - ~backend = - let param_to_param ~caller ~caller_arg ~callee ~callee_arg relation = - implies relation (caller, caller_arg) (callee, callee_arg) - in - let anything_to_param ~callee ~callee_arg relation = - top relation (callee, callee_arg) - in - let param_to_anywhere ~caller:_ ~caller_arg:_ relation = relation in - let relation = - analyse_functions ~backend ~param_to_param - ~anything_to_param ~param_to_anywhere - decls - in - let not_unchanging = - Variable.Pair.Map.fold (fun (func, var) set not_unchanging -> - match set with - | Top -> Variable.Set.add var not_unchanging - | Implication set -> - if Variable.Pair.Set.exists (fun (func', var') -> - Variable.equal func func' && not (Variable.equal var var')) - set - then Variable.Set.add var not_unchanging - else not_unchanging) - relation Variable.Set.empty - in - let params = Variable.Map.fold (fun _ - ({ params } : Flambda.function_declaration) set -> - Variable.Set.union (Parameter.Set.vars params) set) - decls.funs Variable.Set.empty - in - let unchanging = Variable.Set.diff params not_unchanging in - let aliased_to = - Variable.Pair.Map.fold (fun (_, var) set aliases -> - match set with - | Implication set - when Variable.Set.mem var unchanging -> - Variable.Pair.Set.fold (fun (_, caller_args) aliases -> - if Variable.Set.mem caller_args unchanging then - let alias_set = - match Variable.Map.find caller_args aliases with - | exception Not_found -> - Variable.Set.singleton var - | alias_set -> - Variable.Set.add var alias_set - in - Variable.Map.add caller_args alias_set aliases - else - aliases) - set aliases - | Top | Implication _ -> aliases) - relation Variable.Map.empty - in - (* We complete the set of aliases such that there does not miss any - unchanging param *) - Variable.Map.of_set (fun var -> - match Variable.Map.find var aliased_to with - | exception Not_found -> Variable.Set.empty - | set -> set) - unchanging - -let invariant_param_sources decls ~backend = - let param_to_param ~caller ~caller_arg ~callee ~callee_arg relation = - implies relation (caller, caller_arg) (callee, callee_arg) - in - let anything_to_param ~callee:_ ~callee_arg:_ relation = relation in - let param_to_anywhere ~caller:_ ~caller_arg:_ relation = relation in - let relation = - analyse_functions ~backend ~param_to_param - ~anything_to_param ~param_to_anywhere - decls - in - Variable.Pair.Map.fold (fun (_, var) set relation -> - match set with - | Top -> relation - | Implication set -> Variable.Map.add var set relation) - relation Variable.Map.empty - -let pass_name = "unused-arguments" -let () = Clflags.all_passes := pass_name :: !Clflags.all_passes - -let unused_arguments (decls : Flambda.function_declarations) ~backend = - let dump = Clflags.dumped_pass pass_name in - let param_to_param ~caller ~caller_arg ~callee ~callee_arg relation = - implies relation (callee, callee_arg) (caller, caller_arg) - in - let anything_to_param ~callee:_ ~callee_arg:_ relation = relation in - let param_to_anywhere ~caller ~caller_arg relation = - top relation (caller, caller_arg) - in - let relation = - analyse_functions ~backend ~param_to_param - ~anything_to_param ~param_to_anywhere - decls - in - let arguments = - Variable.Map.fold - (fun fun_var decl acc -> - List.fold_left - (fun acc param -> - match Variable.Pair.Map.find (fun_var, param) relation with - | exception Not_found -> Variable.Set.add param acc - | Implication _ -> Variable.Set.add param acc - | Top -> acc) - acc (Parameter.List.vars decl.Flambda.params)) - decls.funs Variable.Set.empty - in - if dump then begin - Format.printf "Unused arguments: %a@." Variable.Set.print arguments - end; - arguments diff --git a/middle_end/invariant_params.mli b/middle_end/invariant_params.mli deleted file mode 100644 index c68514203c..0000000000 --- a/middle_end/invariant_params.mli +++ /dev/null @@ -1,57 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -(* [invariant_params_in_recursion] calculates the set of parameters whose - values are known not to change during the execution of a recursive - function. As such, occurrences of the parameters may always be replaced - by the corresponding values. - - For example, [x] would be in [invariant_params] for both of the following - functions: - - let rec f x y = (f x y) + (f x (y+1)) - - let rec f x l = List.iter (f x) l - - For invariant parameters it also computes the set of parameters of functions - in the set of closures that are always aliased to it. For example in the set - of closures: - - let rec f x y = (f x y) + (f x (y+1)) + g x - and g z = z + 1 - - The map of aliases is - - x -> { x; z } -*) -val invariant_params_in_recursion - : Flambda.function_declarations - -> backend:(module Backend_intf.S) - -> Variable.Set.t Variable.Map.t - -val invariant_param_sources - : Flambda.function_declarations - -> backend:(module Backend_intf.S) - -> Variable.Pair.Set.t Variable.Map.t - -(* CR-soon mshinwell: think about whether this function should - be in this file. Should it be called "unused_parameters"? *) -val unused_arguments - : Flambda.function_declarations - -> backend:(module Backend_intf.S) - -> Variable.Set.t diff --git a/middle_end/lift_code.ml b/middle_end/lift_code.ml deleted file mode 100644 index 02292c46e1..0000000000 --- a/middle_end/lift_code.ml +++ /dev/null @@ -1,163 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -type lifter = Flambda.program -> Flambda.program - -let rebuild_let - (defs : (Variable.t * Flambda.named Flambda.With_free_variables.t) list) - (body : Flambda.t) = - let module W = Flambda.With_free_variables in - List.fold_left (fun body (var, def) -> - W.create_let_reusing_defining_expr var def body) - body defs - -let rec extract_lets - (acc:(Variable.t * Flambda.named Flambda.With_free_variables.t) list) - (let_expr:Flambda.let_expr) : - (Variable.t * Flambda.named Flambda.With_free_variables.t) list * - Flambda.t Flambda.With_free_variables.t = - let module W = Flambda.With_free_variables in - match let_expr with - | { var = v1; defining_expr = Expr (Let let2); _ } -> - let acc, body2 = extract_lets acc let2 in - let acc = (v1, W.expr body2) :: acc in - let body = W.of_body_of_let let_expr in - extract acc body - | { var = v; _ } -> - let acc = (v, W.of_defining_expr_of_let let_expr) :: acc in - let body = W.of_body_of_let let_expr in - extract acc body - -and extract acc (expr : Flambda.t Flambda.With_free_variables.t) = - let module W = Flambda.With_free_variables in - match W.contents expr with - | Let let_expr -> - extract_lets acc let_expr - | _ -> - acc, expr - -let rec lift_lets_expr (expr:Flambda.t) ~toplevel : Flambda.t = - let module W = Flambda.With_free_variables in - match expr with - | Let let_expr -> - let defs, body = extract_lets [] let_expr in - let rev_defs = - List.rev_map (lift_lets_named_with_free_variables ~toplevel) defs - in - let body = lift_lets_expr (W.contents body) ~toplevel in - rebuild_let (List.rev rev_defs) body - | e -> - Flambda_iterators.map_subexpressions - (lift_lets_expr ~toplevel) - (lift_lets_named ~toplevel) - e - -and lift_lets_named_with_free_variables - ((var, named):Variable.t * Flambda.named Flambda.With_free_variables.t) - ~toplevel : Variable.t * Flambda.named Flambda.With_free_variables.t = - let module W = Flambda.With_free_variables in - match W.contents named with - | Expr e -> - var, W.expr (W.of_expr (lift_lets_expr e ~toplevel)) - | Set_of_closures set when not toplevel -> - var, - W.of_named - (Set_of_closures - (Flambda_iterators.map_function_bodies - ~f:(lift_lets_expr ~toplevel) set)) - | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ - | Read_symbol_field (_, _) | Project_closure _ | Move_within_set_of_closures _ - | Project_var _ | Prim _ | Set_of_closures _ -> - var, named - -and lift_lets_named _var (named:Flambda.named) ~toplevel : Flambda.named = - let module W = Flambda.With_free_variables in - match named with - | Expr e -> - Expr (lift_lets_expr e ~toplevel) - | Set_of_closures set when not toplevel -> - Set_of_closures - (Flambda_iterators.map_function_bodies ~f:(lift_lets_expr ~toplevel) set) - | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ - | Read_symbol_field (_, _) | Project_closure _ | Move_within_set_of_closures _ - | Project_var _ | Prim _ | Set_of_closures _ -> - named - -module Sort_lets = Strongly_connected_components.Make (Variable) - -let rebuild_let_rec (defs:(Variable.t * Flambda.named) list) body = - let map = Variable.Map.of_list defs in - let graph = - Variable.Map.map - (fun named -> - Variable.Set.filter (fun v -> Variable.Map.mem v map) - (Flambda.free_variables_named named)) - map - in - let components = - Sort_lets.connected_components_sorted_from_roots_to_leaf graph - in - Array.fold_left (fun body (component:Sort_lets.component) -> - match component with - | No_loop v -> - let def = Variable.Map.find v map in - Flambda.create_let v def body - | Has_loop l -> - Flambda.Let_rec - (List.map (fun v -> v, Variable.Map.find v map) l, - body)) - body components - -let lift_let_rec program = - Flambda_iterators.map_exprs_at_toplevel_of_program program - ~f:(Flambda_iterators.map_expr - (fun expr -> match expr with - | Let_rec (defs, body) -> - rebuild_let_rec defs body - | expr -> expr)) - -let lift_lets program = - let program = lift_let_rec program in - Flambda_iterators.map_exprs_at_toplevel_of_program program - ~f:(lift_lets_expr ~toplevel:false) - -let lifting_helper exprs ~evaluation_order ~create_body ~name = - let vars, lets = - (* [vars] corresponds elementwise to [exprs]; the order is unchanged. *) - List.fold_right (fun (flam : Flambda.t) (vars, lets) -> - match flam with - | Var v -> - (* Note that [v] is (statically) always an immutable variable. *) - v::vars, lets - | expr -> - let v = - Variable.create name ~current_compilation_unit: - (Compilation_unit.get_current_exn ()) - in - v::vars, (v, expr)::lets) - exprs ([], []) - in - let lets = - match evaluation_order with - | `Right_to_left -> lets - | `Left_to_right -> List.rev lets - in - List.fold_left (fun body (v, expr) -> - Flambda.create_let v (Expr expr) body) - (create_body vars) lets diff --git a/middle_end/lift_code.mli b/middle_end/lift_code.mli deleted file mode 100644 index 92ecda0154..0000000000 --- a/middle_end/lift_code.mli +++ /dev/null @@ -1,43 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -type lifter = Flambda.program -> Flambda.program - -(** Lift [let] bindings to attempt to increase the length of scopes, as an - aid to further optimizations. For example: - let c = let b = in b, b in fst c - would be transformed to: - let b = in let c = b, b in fst c - which is then clearly just: - -*) -val lift_lets : lifter - -val lift_lets_expr : Flambda.t -> toplevel:bool -> Flambda.t - -(* CR-someday mshinwell: Rename to [bind]? Also see Flambda_utils.bind. *) -(* [create_body] always receives the variables corresponding to [evaluate] - in the same order. However [evaluation_order] specifies in which order - the (possibly complex) expressions bound to those variables are - evaluated. *) -val lifting_helper - : Flambda.t list - -> evaluation_order:[ `Left_to_right | `Right_to_left ] - -> create_body:(Variable.t list -> Flambda.t) - -> name:Internal_variable_names.t - -> Flambda.t diff --git a/middle_end/lift_constants.ml b/middle_end/lift_constants.ml deleted file mode 100644 index dd60de9ce2..0000000000 --- a/middle_end/lift_constants.ml +++ /dev/null @@ -1,1019 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -(* CR-someday mshinwell: move to Flambda_utils *) -let rec tail_variable : Flambda.t -> Variable.t option = function - | Var v -> Some v - | Let_rec (_, e) - | Let_mutable { body = e } - | Let { body = e; _ } -> tail_variable e - | _ -> None - -let closure_symbol ~(backend : (module Backend_intf.S)) closure_id = - let module Backend = (val backend) in - Backend.closure_symbol closure_id - -(** Traverse the given expression assigning symbols to [let]- and [let rec]- - bound constant variables. At the same time collect the definitions of - such variables. *) -let assign_symbols_and_collect_constant_definitions - ~(backend : (module Backend_intf.S)) - ~(program : Flambda.program) - ~(inconstants : Inconstant_idents.result) = - let var_to_symbol_tbl = Variable.Tbl.create 42 in - let var_to_definition_tbl = Variable.Tbl.create 42 in - let module AA = Alias_analysis in - let assign_symbol var (named : Flambda.named) = - if not (Inconstant_idents.variable var inconstants) then begin - let assign_symbol () = - let symbol = Symbol.of_variable (Variable.rename var) in - Variable.Tbl.add var_to_symbol_tbl var symbol - in - let assign_existing_symbol = Variable.Tbl.add var_to_symbol_tbl var in - let record_definition = Variable.Tbl.add var_to_definition_tbl var in - match named with - | Symbol symbol -> - assign_existing_symbol symbol; - record_definition (AA.Symbol symbol) - | Const const -> record_definition (AA.Const const) - | Allocated_const const -> - assign_symbol (); - record_definition (AA.Allocated_const (Normal const)) - | Read_mutable _ -> - (* [Inconstant_idents] always marks these expressions as - inconstant, so we should never get here. *) - assert false - | Prim (Pmakeblock (tag, _, _value_kind), fields, _) -> - assign_symbol (); - record_definition (AA.Block (Tag.create_exn tag, fields)) - | Read_symbol_field (symbol, field) -> - record_definition (AA.Symbol_field (symbol, field)) - | Set_of_closures ( - { function_decls = { funs; set_of_closures_id; _ }; - _ } as set) -> - assert (not (Inconstant_idents.closure set_of_closures_id - inconstants)); - assign_symbol (); - record_definition (AA.Set_of_closures set); - Variable.Map.iter (fun fun_var _ -> - let closure_id = Closure_id.wrap fun_var in - let closure_symbol = closure_symbol ~backend closure_id in - Variable.Tbl.add var_to_symbol_tbl fun_var closure_symbol; - let project_closure = - Alias_analysis.Project_closure - { set_of_closures = var; closure_id } - in - Variable.Tbl.add var_to_definition_tbl fun_var - project_closure) - funs - | Move_within_set_of_closures ({ closure = _; start_from = _; move_to; } - as move) -> - assign_existing_symbol (closure_symbol ~backend move_to); - record_definition (AA.Move_within_set_of_closures move) - | Project_closure ({ closure_id } as project_closure) -> - assign_existing_symbol (closure_symbol ~backend closure_id); - record_definition (AA.Project_closure project_closure) - | Prim (Pfield index, [block], _) -> - record_definition (AA.Field (block, index)) - | Prim (Pfield _, _, _) -> - Misc.fatal_errorf "[Pfield] with the wrong number of arguments" - Flambda.print_named named - | Prim (Pmakearray (Pfloatarray as kind, mutability), args, _) -> - assign_symbol (); - record_definition (AA.Allocated_const (Array (kind, mutability, args))) - | Prim (Pduparray (kind, mutability), [arg], _) -> - assign_symbol (); - record_definition (AA.Allocated_const ( - Duplicate_array (kind, mutability, arg))) - | Prim _ -> - Misc.fatal_errorf "Primitive not expected to be constant: @.%a@." - Flambda.print_named named - | Project_var project_var -> - record_definition (AA.Project_var project_var) - | Expr e -> - match tail_variable e with - | None -> assert false (* See [Inconstant_idents]. *) - | Some v -> record_definition (AA.Variable v) - end - in - let assign_symbol_program expr = - Flambda_iterators.iter_all_immutable_let_and_let_rec_bindings expr - ~f:assign_symbol - in - Flambda_iterators.iter_exprs_at_toplevel_of_program program - ~f:assign_symbol_program; - let let_symbol_to_definition_tbl = Symbol.Tbl.create 42 in - let initialize_symbol_to_definition_tbl = Symbol.Tbl.create 42 in - let rec collect_let_and_initialize_symbols (program : Flambda.program_body) = - match program with - | Let_symbol (symbol, decl, program) -> - Symbol.Tbl.add let_symbol_to_definition_tbl symbol decl; - collect_let_and_initialize_symbols program - | Let_rec_symbol (decls, program) -> - List.iter (fun (symbol, decl) -> - Symbol.Tbl.add let_symbol_to_definition_tbl symbol decl) - decls; - collect_let_and_initialize_symbols program - | Effect (_, program) -> collect_let_and_initialize_symbols program - | Initialize_symbol (symbol,_tag,fields,program) -> - collect_let_and_initialize_symbols program; - let fields = List.map tail_variable fields in - Symbol.Tbl.add initialize_symbol_to_definition_tbl symbol fields - | End _ -> () - in - collect_let_and_initialize_symbols program.program_body; - let record_set_of_closure_equalities - (set_of_closures : Flambda.set_of_closures) = - Variable.Map.iter (fun arg (var : Flambda.specialised_to) -> - if not (Inconstant_idents.variable arg inconstants) then - Variable.Tbl.add var_to_definition_tbl arg (AA.Variable var.var)) - set_of_closures.free_vars; - Variable.Map.iter (fun arg (spec_to : Flambda.specialised_to) -> - if not (Inconstant_idents.variable arg inconstants) then - Variable.Tbl.add var_to_definition_tbl arg - (AA.Variable spec_to.var)) - set_of_closures.specialised_args - in - Flambda_iterators.iter_on_set_of_closures_of_program program - ~f:(fun ~constant set_of_closures -> - record_set_of_closure_equalities set_of_closures; - if constant then begin - Variable.Map.iter (fun fun_var _ -> - let closure_id = Closure_id.wrap fun_var in - let closure_symbol = closure_symbol ~backend closure_id in - Variable.Tbl.add var_to_definition_tbl fun_var - (AA.Symbol closure_symbol); - Variable.Tbl.add var_to_symbol_tbl fun_var closure_symbol) - set_of_closures.Flambda.function_decls.funs - end); - var_to_symbol_tbl, var_to_definition_tbl, - let_symbol_to_definition_tbl, initialize_symbol_to_definition_tbl - -let variable_field_definition - (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) - (var_to_definition_tbl : - Alias_analysis.constant_defining_value Variable.Tbl.t) - (var : Variable.t) : Flambda.constant_defining_value_block_field = - try - Symbol (Variable.Tbl.find var_to_symbol_tbl var) - with Not_found -> - match Variable.Tbl.find var_to_definition_tbl var with - | Const c -> Const c - | const_defining_value -> - Misc.fatal_errorf "Unexpected pattern for a constant: %a: %a" - Variable.print var - Alias_analysis.print_constant_defining_value const_defining_value - | exception Not_found -> - Misc.fatal_errorf "No associated symbol for the constant %a" - Variable.print var - -let resolve_variable - (aliases : Alias_analysis.allocation_point Variable.Map.t) - (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) - (var_to_definition_tbl : - Alias_analysis.constant_defining_value Variable.Tbl.t) - (var : Variable.t) : Flambda.constant_defining_value_block_field = - match Variable.Map.find var aliases with - | exception Not_found -> - variable_field_definition var_to_symbol_tbl var_to_definition_tbl var - | Symbol s -> Symbol s - | Variable aliased_variable -> - variable_field_definition var_to_symbol_tbl var_to_definition_tbl - aliased_variable - -let translate_set_of_closures - (inconstants : Inconstant_idents.result) - (aliases : Alias_analysis.allocation_point Variable.Map.t) - (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) - (var_to_definition_tbl: - Alias_analysis.constant_defining_value Variable.Tbl.t) - (set_of_closures : Flambda.set_of_closures) = - let f var (named : Flambda.named) : Flambda.named = - if Inconstant_idents.variable var inconstants then - named - else - let resolved = - resolve_variable - aliases - var_to_symbol_tbl - var_to_definition_tbl - var - in - match resolved with - | Symbol s -> Symbol s - | Const c -> Const c - in - Flambda_iterators.map_function_bodies set_of_closures - ~f:(Flambda_iterators.map_all_immutable_let_and_let_rec_bindings ~f) - -let translate_constant_set_of_closures - (inconstants : Inconstant_idents.result) - (aliases : Alias_analysis.allocation_point Variable.Map.t) - (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) - (var_to_definition_tbl: - Alias_analysis.constant_defining_value Variable.Tbl.t) - (constant_defining_values : Flambda.constant_defining_value Symbol.Map.t) = - Symbol.Map.map (fun (const : Flambda.constant_defining_value) -> - match const with - | Flambda.Allocated_const _ - | Flambda.Block _ - | Flambda.Project_closure _ -> - const - | Flambda.Set_of_closures set_of_closures -> - let set_of_closures = - translate_set_of_closures - (inconstants : Inconstant_idents.result) - (aliases : Alias_analysis.allocation_point Variable.Map.t) - (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) - (var_to_definition_tbl: - Alias_analysis.constant_defining_value Variable.Tbl.t) - (set_of_closures : Flambda.set_of_closures) - in - Flambda.Set_of_closures set_of_closures) - constant_defining_values - -let find_original_set_of_closure - (aliases : Alias_analysis.allocation_point Variable.Map.t) - (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) - (var_to_definition_tbl: - Alias_analysis.constant_defining_value Variable.Tbl.t) - project_closure_map - var = - let rec loop var = - match Variable.Map.find var aliases with - | Variable var -> - begin match Variable.Tbl.find var_to_definition_tbl var with - | Project_closure { set_of_closures = var } - | Move_within_set_of_closures { closure = var } -> - loop var - | Set_of_closures _ -> begin - match Variable.Tbl.find var_to_symbol_tbl var with - | s -> - s - | exception Not_found -> - Format.eprintf "var: %a@." Variable.print var; - assert false - end - | _ -> assert false - end - | Symbol s -> - match Symbol.Map.find s project_closure_map with - | exception Not_found -> - Misc.fatal_errorf "find_original_set_of_closure: cannot find \ - symbol %a in the project-closure map" - Symbol.print s - | s -> s - in - loop var - -let translate_definition_and_resolve_alias inconstants - (aliases : Alias_analysis.allocation_point Variable.Map.t) - (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) - (var_to_definition_tbl : - Alias_analysis.constant_defining_value Variable.Tbl.t) - (symbol_definition_map : Flambda.constant_defining_value Symbol.Map.t) - (project_closure_map : Symbol.t Symbol.Map.t) - (definition : Alias_analysis.constant_defining_value) - ~(backend : (module Backend_intf.S)) - : Flambda.constant_defining_value option = - let resolve_float_array_involving_variables - ~(mutability : Asttypes.mutable_flag) ~vars = - (* Resolve an [Allocated_const] of the form: - [Array (Pfloatarray, _, _)] - (which references its contents via variables; it does not contain - manifest floats). *) - let find_float_var_definition var = - match Variable.Tbl.find var_to_definition_tbl var with - | Allocated_const (Normal (Float f)) -> f - | const_defining_value -> - Misc.fatal_errorf "Bad definition for float array member %a: %a" - Variable.print var - Alias_analysis.print_constant_defining_value - const_defining_value - in - let find_float_symbol_definition sym = - match Symbol.Map.find sym symbol_definition_map with - | Allocated_const (Float f) -> f - | const_defining_value -> - Misc.fatal_errorf "Bad definition for float array member %a: %a" - Symbol.print sym - Flambda.print_constant_defining_value - const_defining_value - in - let floats = - List.map (fun var -> - match Variable.Map.find var aliases with - | exception Not_found -> find_float_var_definition var - | Variable var -> find_float_var_definition var - | Symbol sym -> find_float_symbol_definition sym) - vars - in - let const : Allocated_const.t = - match mutability with - | Immutable -> Immutable_float_array floats - | Mutable -> Float_array floats - in - Some (Flambda.Allocated_const const) - in - match definition with - | Block (tag, fields) -> - Some (Flambda.Block (tag, - List.map (resolve_variable aliases var_to_symbol_tbl - var_to_definition_tbl) - fields)) - | Allocated_const (Normal const) -> Some (Flambda.Allocated_const const) - | Allocated_const (Duplicate_array (Pfloatarray, mutability, var)) -> - (* CR-someday mshinwell: This next section could do with cleanup. - What happens is: - - Duplicate contains a variable, which is resolved to - a float array thing full of variables; - - We send that value back through this function again so the - individual members of that array are resolved from variables to - floats. - - Then we can build the Flambda.name term containing the - Allocated_const (full of floats). - We should maybe factor out the code from the - Allocated_const (Array (...)) case below so this function doesn't have - to be recursive. *) - let (constant_defining_value : Alias_analysis.constant_defining_value) = - match Variable.Map.find var aliases with - | exception Not_found -> - Variable.Tbl.find var_to_definition_tbl var - | Variable var -> - Variable.Tbl.find var_to_definition_tbl var - | Symbol sym -> - match Symbol.Map.find sym symbol_definition_map with - | Allocated_const ((Immutable_float_array _) as const) -> - Alias_analysis.Allocated_const (Normal const) - | (Allocated_const _ | Block _ | Set_of_closures _ - | Project_closure _) as wrong -> - Misc.fatal_errorf - "Lift_constants.translate_definition_and_resolve_alias: \ - Duplicate Pfloatarray %a with symbol %a mapping to \ - wrong constant defining value %a" - Variable.print var - Alias_analysis.print_constant_defining_value definition - Flambda.print_constant_defining_value wrong - | exception Not_found -> - let module Backend = (val backend) in - match (Backend.import_symbol sym).descr with - | Value_unresolved _ -> - Misc.fatal_errorf - "Lift_constants.translate_definition_and_resolve_alias: \ - Duplicate Pfloatarray %a with unknown symbol: %a" - Variable.print var - Alias_analysis.print_constant_defining_value definition - | Value_float_array value_float_array -> - let contents = - Simple_value_approx.float_array_as_constant value_float_array - in - begin match contents with - | None -> - Misc.fatal_errorf - "Lift_constants.translate_definition_and_resolve_alias: \ - Duplicate Pfloatarray %a with not completely known float \ - array from symbol: %a" - Variable.print var - Alias_analysis.print_constant_defining_value definition - | Some l -> - Alias_analysis.Allocated_const (Normal (Immutable_float_array l)) - end - | wrong -> - (* CR-someday mshinwell: we might hit this if we ever duplicate - a mutable array across compilation units (e.g. "snapshotting" - an array). We do not currently generate such code. *) - Misc.fatal_errorf - "Lift_constants.translate_definition_and_resolve_alias: \ - Duplicate Pfloatarray %a with symbol %a that does not \ - have an export description of an immutable array" - Variable.print var - Alias_analysis.print_constant_defining_value definition - Simple_value_approx.print_descr wrong - in - begin match constant_defining_value with - | Allocated_const (Normal (Float_array _)) -> - (* This example from pchambart illustrates why we do not allow - the duplication of mutable arrays: - - {| - let_symbol a = Allocated_const (Immutable_float_array [|0.|]) - initialize_symbol b = Duparray(Mutable, a) - effect b.(0) <- 1. - initialize_symbol c = Duparray(Mutable, b) - |} - - This will be converted to: - {| - let_symbol a = Allocated_const (Immutable_float_array [|0.|]) - let_symbol b = Allocated_const (Float_array [|0.|]) - effect b.(0) <- 1. - let_symbol c = Allocated_const (Float_array [|0.|]) - |} - - We can't encounter that currently, but it's scary. - *) - Misc.fatal_error "Pduparray is not allowed on mutable arrays" - | Allocated_const (Normal (Immutable_float_array floats)) -> - let const : Allocated_const.t = - match mutability with - | Immutable -> Immutable_float_array floats - | Mutable -> Float_array floats - in - Some (Flambda.Allocated_const const) - | Allocated_const (Array (Pfloatarray, _, vars)) -> - (* Important: [mutability] is from the [Duplicate_array] - construction above. *) - resolve_float_array_involving_variables ~mutability ~vars - | const -> - Misc.fatal_errorf - "Lift_constants.translate_definition_and_resolve_alias: \ - Duplicate Pfloatarray %a with wrong argument: %a" - Variable.print var - Alias_analysis.print_constant_defining_value const - end - | Allocated_const (Duplicate_array (_, _, _)) -> - Misc.fatal_errorf "Lift_constants.translate_definition_and_resolve_alias: \ - Duplicate_array with non-Pfloatarray kind: %a" - Alias_analysis.print_constant_defining_value definition - | Allocated_const (Array (Pfloatarray, mutability, vars)) -> - resolve_float_array_involving_variables ~mutability ~vars - | Allocated_const (Array (_, _, _)) -> - Misc.fatal_errorf "Lift_constants.translate_definition_and_resolve_alias: \ - Array with non-Pfloatarray kind: %a" - Alias_analysis.print_constant_defining_value definition - | Project_closure { set_of_closures; closure_id } -> - begin match Variable.Map.find set_of_closures aliases with - | Symbol s -> - Some (Flambda.Project_closure (s, closure_id)) - (* If a closure projection is a constant, the set of closures must - be assigned to a symbol. *) - | exception Not_found -> - assert false - | Variable v -> - match Variable.Tbl.find var_to_symbol_tbl v with - | s -> - Some (Flambda.Project_closure (s, closure_id)) - | exception Not_found -> - Format.eprintf "var: %a@." Variable.print v; - assert false - end - | Move_within_set_of_closures { closure; move_to } -> - let set_of_closure_symbol = - find_original_set_of_closure - aliases - var_to_symbol_tbl - var_to_definition_tbl - project_closure_map - closure - in - Some (Flambda.Project_closure (set_of_closure_symbol, move_to)) - | Set_of_closures set_of_closures -> - let set_of_closures = - translate_set_of_closures - inconstants - aliases - var_to_symbol_tbl - var_to_definition_tbl - set_of_closures - in - Some (Flambda.Set_of_closures set_of_closures) - | Project_var _ -> None - | Field (_,_) | Symbol_field _ -> None - | Const _ -> None - | Symbol _ -> None - | Variable _ -> None - -let translate_definitions_and_resolve_alias - inconstants - (aliases : Alias_analysis.allocation_point Variable.Map.t) - (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) - (var_to_definition_tbl: - Alias_analysis.constant_defining_value Variable.Tbl.t) - symbol_definition_map - project_closure_map - ~backend = - Variable.Tbl.fold (fun var def map -> - match - translate_definition_and_resolve_alias inconstants aliases ~backend - var_to_symbol_tbl var_to_definition_tbl symbol_definition_map - project_closure_map def - with - | None -> map - | Some def -> - let symbol = Variable.Tbl.find var_to_symbol_tbl var in - Symbol.Map.add symbol def map) - var_to_definition_tbl Symbol.Map.empty - -(* Resorting of graph including Initialize_symbol *) -let constant_dependencies ~backend:_ - (const : Flambda.constant_defining_value) = - match const with - | Allocated_const _ -> Symbol.Set.empty - | Block (_, fields) -> - let symbol_fields = - List.filter_map - (function - | (Symbol s : Flambda.constant_defining_value_block_field) -> Some s - | Flambda.Const _ -> None) - fields - in - Symbol.Set.of_list symbol_fields - | Set_of_closures set_of_closures -> - Flambda.free_symbols_named (Set_of_closures set_of_closures) - | Project_closure (s, _) -> - Symbol.Set.singleton s - -module Symbol_SCC = Strongly_connected_components.Make (Symbol) - -let program_graph ~backend imported_symbols symbol_to_constant - (initialize_symbol_tbl : - (Tag.t * Flambda.t list * Symbol.t option) Symbol.Tbl.t) - (effect_tbl : (Flambda.t * Symbol.t option) Symbol.Tbl.t) = - let expression_symbol_dependencies expr = Flambda.free_symbols expr in - let graph_with_only_constant_parts = - Symbol.Map.map (fun const -> - Symbol.Set.diff (constant_dependencies ~backend const) - imported_symbols) - symbol_to_constant - in - let graph_with_initialisation = - Symbol.Tbl.fold (fun sym (_tag, fields, previous) -> - let order_dep = - match previous with - | None -> Symbol.Set.empty - | Some previous -> Symbol.Set.singleton previous - in - let deps = List.fold_left (fun set field -> - Symbol.Set.union (expression_symbol_dependencies field) set) - order_dep fields - in - let deps = Symbol.Set.diff deps imported_symbols in - Symbol.Map.add sym deps) - initialize_symbol_tbl graph_with_only_constant_parts - in - let graph = - Symbol.Tbl.fold (fun sym (expr, previous) -> - let order_dep = - match previous with - | None -> Symbol.Set.empty - | Some previous -> Symbol.Set.singleton previous - in - let deps = - Symbol.Set.union (expression_symbol_dependencies expr) order_dep - in - let deps = Symbol.Set.diff deps imported_symbols in - Symbol.Map.add sym deps - ) - effect_tbl graph_with_initialisation - in - let components = - Symbol_SCC.connected_components_sorted_from_roots_to_leaf - graph - in - components - -(* rebuilding the program *) -let add_definition_of_symbol constant_definitions - (initialize_symbol_tbl : - (Tag.t * Flambda.t list * Symbol.t option) Symbol.Tbl.t) - (effect_tbl : (Flambda.t * Symbol.t option) Symbol.Tbl.t) - (program : Flambda.program_body) component : Flambda.program_body = - let symbol_declaration sym = - (* A symbol declared through an Initialize_symbol construct - cannot be recursive, this is not allowed in the construction. - This also couldn't have been introduced by this pass, so we can - safely assert that this is not possible here *) - assert(not (Symbol.Tbl.mem initialize_symbol_tbl sym)); - (sym, Symbol.Map.find sym constant_definitions) - in - match component with - | Symbol_SCC.Has_loop l -> - let l = List.map symbol_declaration l in - Let_rec_symbol (l, program) - | Symbol_SCC.No_loop sym -> - match Symbol.Tbl.find initialize_symbol_tbl sym with - | (tag, fields, _previous) -> - Initialize_symbol (sym, tag, fields, program) - | exception Not_found -> - match Symbol.Tbl.find effect_tbl sym with - | (expr, _previous) -> - Effect (expr, program) - | exception Not_found -> - let decl = Symbol.Map.find sym constant_definitions in - Let_symbol (sym, decl, program) - -let add_definitions_of_symbols constant_definitions initialize_symbol_tbl - effect_tbl program components = - Array.fold_left - (add_definition_of_symbol constant_definitions initialize_symbol_tbl - effect_tbl) - program components - -let introduce_free_variables_in_set_of_closures - (var_to_block_field_tbl : - Flambda.constant_defining_value_block_field Variable.Tbl.t) - ({ Flambda.function_decls; free_vars; specialised_args; - direct_call_surrogates; } - as set_of_closures) = - let add_definition_and_make_substitution var (expr, subst) = - let searched_var = - match Variable.Map.find var specialised_args with - | exception Not_found -> var - | external_var -> - (* specialised arguments bound to constant can be rewritten *) - external_var.var - in - match Variable.Tbl.find var_to_block_field_tbl searched_var with - | def -> - let fresh = Variable.rename var in - let named : Flambda.named = match def with - | Symbol sym -> Symbol sym - | Const c -> Const c - in - (Flambda.create_let fresh named expr), Variable.Map.add var fresh subst - | exception Not_found -> - (* The variable is bound by the closure or the arguments or not - constant. In either case it does not need to be bound *) - expr, subst - in - let done_something = ref false in - let function_decls : Flambda.function_declarations = - Flambda.update_function_declarations function_decls - ~funs:(Variable.Map.map - (fun (func_decl : Flambda.function_declaration) -> - let variables_to_bind = - (* Closures from the same set must not be bound. *) - Variable.Set.diff func_decl.free_variables - (Variable.Map.keys function_decls.funs) - in - let body, subst = - Variable.Set.fold add_definition_and_make_substitution - variables_to_bind - (func_decl.body, Variable.Map.empty) - in - if Variable.Map.is_empty subst then begin - func_decl - end else begin - done_something := true; - let body = Flambda_utils.toplevel_substitution subst body in - Flambda.update_body_of_function_declaration func_decl ~body - end) - function_decls.funs) - in - let free_vars = - (* Keep only those that are not rewritten to constants. *) - Variable.Map.filter (fun v _ -> - let keep = not (Variable.Tbl.mem var_to_block_field_tbl v) in - if not keep then done_something := true; - keep) - free_vars - in - let free_vars = - Flambda_utils.clean_projections ~which_variables:free_vars - in - let specialised_args = - (* Keep only those that are not rewritten to constants. *) - Variable.Map.filter (fun _ (spec_to : Flambda.specialised_to) -> - let keep = - not (Variable.Tbl.mem var_to_block_field_tbl spec_to.var) - in - if not keep then begin - done_something := true - end; - keep) - specialised_args - in - let specialised_args = - Flambda_utils.clean_projections ~which_variables:specialised_args - in - if not !done_something then - set_of_closures - else - Flambda.create_set_of_closures ~function_decls ~free_vars - ~specialised_args ~direct_call_surrogates - -let rewrite_project_var - (var_to_block_field_tbl - : Flambda.constant_defining_value_block_field Variable.Tbl.t) - (project_var : Flambda.project_var) ~original : Flambda.named = - let var = Var_within_closure.unwrap project_var.var in - match Variable.Tbl.find var_to_block_field_tbl var with - | exception Not_found -> original - | Symbol sym -> Symbol sym - | Const const -> Const const - -let introduce_free_variables_in_sets_of_closures - (var_to_block_field_tbl: - Flambda.constant_defining_value_block_field Variable.Tbl.t) - (translate_definition : Flambda.constant_defining_value Symbol.Map.t) = - Symbol.Map.map (fun (def : Flambda.constant_defining_value) -> - match def with - | Allocated_const _ - | Block _ - | Project_closure _ -> def - | Set_of_closures set_of_closures -> - Flambda.Set_of_closures - (introduce_free_variables_in_set_of_closures - var_to_block_field_tbl - set_of_closures)) - translate_definition - -let var_to_block_field - (aliases : Alias_analysis.allocation_point Variable.Map.t) - (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) - (var_to_definition_tbl : - Alias_analysis.constant_defining_value Variable.Tbl.t) = - let var_to_block_field_tbl = Variable.Tbl.create 42 in - Variable.Tbl.iter (fun var _ -> - let def = - resolve_variable aliases var_to_symbol_tbl var_to_definition_tbl var - in - Variable.Tbl.add var_to_block_field_tbl var def) - var_to_definition_tbl; - var_to_block_field_tbl - -let program_symbols ~backend (program : Flambda.program) = - let new_fake_symbol () = - let var = Variable.create Internal_variable_names.fake_effect_symbol in - Symbol.of_variable var - in - let initialize_symbol_tbl = Symbol.Tbl.create 42 in - let effect_tbl = Symbol.Tbl.create 42 in - let symbol_definition_tbl = Symbol.Tbl.create 42 in - let add_project_closure_definitions def_symbol - (const : Flambda.constant_defining_value) = - match const with - | Set_of_closures { function_decls = { funs } } -> - Variable.Map.iter (fun fun_var _ -> - let closure_id = Closure_id.wrap fun_var in - let closure_symbol = closure_symbol ~backend closure_id in - let project_closure = - Flambda.Project_closure (def_symbol, closure_id) - in - Symbol.Tbl.add symbol_definition_tbl closure_symbol - project_closure) - funs - | Project_closure _ - | Allocated_const _ - | Block _ -> () - in - let rec loop (program : Flambda.program_body) previous_effect = - match program with - | Flambda.Let_symbol (symbol, def, program) -> - add_project_closure_definitions symbol def; - Symbol.Tbl.add symbol_definition_tbl symbol def; - loop program previous_effect - | Flambda.Let_rec_symbol (defs, program) -> - List.iter (fun (symbol, def) -> - add_project_closure_definitions symbol def; - Symbol.Tbl.add symbol_definition_tbl symbol def) - defs; - loop program previous_effect - | Flambda.Initialize_symbol (symbol, tag, fields, program) -> - (* previous_effect is used to keep the order of initialize and effect - values. Their effects order must be kept ordered. - it is used as an extra dependency when sorting the symbols. *) - (* CR-someday pchambart: if the fields expressions are pure, we could - drop this dependency - mshinwell: deferred CR *) - Symbol.Tbl.add initialize_symbol_tbl symbol - (tag, fields, previous_effect); - loop program (Some symbol) - | Flambda.Effect (expr, program) -> - (* Used to ensure that effects are correctly ordered *) - let fake_effect_symbol = new_fake_symbol () in - Symbol.Tbl.add effect_tbl fake_effect_symbol (expr, previous_effect); - loop program (Some fake_effect_symbol) - | Flambda.End _ -> () - in - loop program.program_body None; - initialize_symbol_tbl, symbol_definition_tbl, effect_tbl - -let replace_definitions_in_initialize_symbol_and_effects - (inconstants : Inconstant_idents.result) - (aliases : Alias_analysis.allocation_point Variable.Map.t) - (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) - (var_to_definition_tbl : - Alias_analysis.constant_defining_value Variable.Tbl.t) - (initialize_symbol_tbl : - (Tag.t * Flambda.t list * Symbol.t option) Symbol.Tbl.t) - (effect_tbl : (Flambda.t * Symbol.t option) Symbol.Tbl.t) = - let rewrite_expr expr = - Flambda_iterators.map_all_immutable_let_and_let_rec_bindings expr - ~f:(fun var (named : Flambda.named) : Flambda.named -> - if Inconstant_idents.variable var inconstants then - named - else - let resolved = - resolve_variable - aliases - var_to_symbol_tbl - var_to_definition_tbl - var - in - match named, resolved with - | Symbol s1, Symbol s2 -> - assert (s1 == s2); (* physical equality for speed *) - named; - | Const c1, Const c2 -> - assert (c1 == c2); - named - | _, Symbol s -> Symbol s - | _, Const c -> Const c) - in - (* This is safe because we only [replace] the current key during - iteration (cf. https://github.com/ocaml/ocaml/pull/337) *) - Symbol.Tbl.iter - (fun symbol (tag, fields, previous) -> - let fields = List.map rewrite_expr fields in - Symbol.Tbl.replace initialize_symbol_tbl symbol (tag, fields, previous)) - initialize_symbol_tbl; - Symbol.Tbl.iter - (fun symbol (expr, previous) -> - Symbol.Tbl.replace effect_tbl symbol (rewrite_expr expr, previous)) - effect_tbl - -(* CR-soon mshinwell: Update the name of [project_closure_map]. *) -let project_closure_map symbol_definition_map = - Symbol.Map.fold (fun sym (const : Flambda.constant_defining_value) acc -> - match const with - | Project_closure (set_of_closures, _) -> - Symbol.Map.add sym set_of_closures acc - | Set_of_closures _ -> - Symbol.Map.add sym sym acc - | Allocated_const _ - | Block _ -> acc) - symbol_definition_map - Symbol.Map.empty - -let lift_constants (program : Flambda.program) ~backend = - let the_dead_constant = - let var = Variable.create Internal_variable_names.the_dead_constant in - Symbol.of_variable var - in - let program_body : Flambda.program_body = - Let_symbol (the_dead_constant, Allocated_const (Nativeint 0n), - program.program_body) - in - let program : Flambda.program = - { program with program_body; } - in - let inconstants = - Inconstant_idents.inconstants_on_program program ~backend - ~compilation_unit:(Compilation_unit.get_current_exn ()) - in - let initialize_symbol_tbl, symbol_definition_tbl, effect_tbl = - program_symbols ~backend program - in - let var_to_symbol_tbl, var_to_definition_tbl, let_symbol_to_definition_tbl, - initialize_symbol_to_definition_tbl = - assign_symbols_and_collect_constant_definitions ~backend ~program - ~inconstants - in - let aliases = - Alias_analysis.run var_to_definition_tbl - initialize_symbol_to_definition_tbl - let_symbol_to_definition_tbl - ~the_dead_constant - in - replace_definitions_in_initialize_symbol_and_effects - (inconstants : Inconstant_idents.result) - (aliases : Alias_analysis.allocation_point Variable.Map.t) - (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) - (var_to_definition_tbl - : Alias_analysis.constant_defining_value Variable.Tbl.t) - initialize_symbol_tbl - effect_tbl; - let symbol_definition_map = - translate_constant_set_of_closures - (inconstants : Inconstant_idents.result) - (aliases : Alias_analysis.allocation_point Variable.Map.t) - (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) - (var_to_definition_tbl - : Alias_analysis.constant_defining_value Variable.Tbl.t) - (Symbol.Tbl.to_map symbol_definition_tbl) - in - let project_closure_map = project_closure_map symbol_definition_map in - let translated_definitions = - translate_definitions_and_resolve_alias - inconstants - (aliases : Alias_analysis.allocation_point Variable.Map.t) - (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) - (var_to_definition_tbl - : Alias_analysis.constant_defining_value Variable.Tbl.t) - symbol_definition_map - project_closure_map - ~backend - in - let var_to_block_field_tbl = - var_to_block_field - (aliases : Alias_analysis.allocation_point Variable.Map.t) - (var_to_symbol_tbl : Symbol.t Variable.Tbl.t) - (var_to_definition_tbl - : Alias_analysis.constant_defining_value Variable.Tbl.t) - in - let translated_definitions = - introduce_free_variables_in_sets_of_closures var_to_block_field_tbl - translated_definitions - in - let constant_definitions = - (* Add previous Let_symbol to the newly discovered ones *) - Symbol.Map.union - (fun _sym - (c1:Flambda.constant_defining_value) - (c2:Flambda.constant_defining_value) -> - match c1, c2 with - | Project_closure (s1, closure_id1), - Project_closure (s2, closure_id2) when - Symbol.equal s1 s2 && - Closure_id.equal closure_id1 closure_id2 -> - Some c1 - | Project_closure (s1, closure_id1), - Project_closure (s2, closure_id2) -> - Format.eprintf "not equal project closure@. s %a %a@. cid %a %a@." - Symbol.print s1 Symbol.print s2 - Closure_id.print closure_id1 Closure_id.print closure_id2; - assert false - | _ -> - assert false - ) - symbol_definition_map - translated_definitions - in - (* Upon the [Initialize_symbol]s, the [Effect]s and the constant definitions, - do the following: - 1. Introduce [Let]s to bind variables that are going to be replaced - by constants. - 2. If a variable bound by a closure gets replaced by a symbol and - thus eliminated from the [free_vars] set of the closure, we need to - rewrite any subsequent [Project_var] expressions that project that - variable. *) - let rewrite_expr expr = - Flambda_iterators.map_named (function - | (Set_of_closures set_of_closures) as named -> - let new_set_of_closures = - introduce_free_variables_in_set_of_closures - var_to_block_field_tbl set_of_closures - in - if new_set_of_closures == set_of_closures then - named - else - Set_of_closures new_set_of_closures - | (Project_var project_var) as original -> - rewrite_project_var var_to_block_field_tbl project_var ~original - | (Symbol _ | Const _ | Allocated_const _ | Project_closure _ - | Move_within_set_of_closures _ | Prim _ | Expr _ - | Read_mutable _ | Read_symbol_field _) as named -> named) - expr - in - let constant_definitions = - Symbol.Map.map (fun (const : Flambda.constant_defining_value) -> - match const with - | Allocated_const _ | Block _ | Project_closure _ -> const - | Set_of_closures set_of_closures -> - let set_of_closures = - Flambda_iterators.map_function_bodies set_of_closures - ~f:rewrite_expr - in - Flambda.Set_of_closures - (introduce_free_variables_in_set_of_closures - var_to_block_field_tbl set_of_closures)) - constant_definitions - in - let effect_tbl = - Symbol.Tbl.map effect_tbl (fun (effect, dep) -> rewrite_expr effect, dep) - in - let initialize_symbol_tbl = - Symbol.Tbl.map initialize_symbol_tbl (fun (tag, fields, dep) -> - let fields = List.map rewrite_expr fields in - tag, fields, dep) - in - let imported_symbols = Flambda_utils.imported_symbols program in - let components = - program_graph ~backend imported_symbols constant_definitions - initialize_symbol_tbl effect_tbl - in - let program_body = - add_definitions_of_symbols constant_definitions - initialize_symbol_tbl - effect_tbl - (End (Flambda_utils.root_symbol program)) - components - in - Flambda_utils.introduce_needed_import_symbols { program with program_body; } diff --git a/middle_end/lift_constants.mli b/middle_end/lift_constants.mli deleted file mode 100644 index 969c365e33..0000000000 --- a/middle_end/lift_constants.mli +++ /dev/null @@ -1,65 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -(** The aim of this pass is to assign symbols to values known to be - constant (in other words, whose values we know at compile time), with - appropriate sharing of constants, and replace the occurrences of the - constants with their corresponding symbols. - - This pass uses the results of two other passes, [Inconstant_idents] and - [Alias_analysis]. The relationship between these two deserves some - attention. - - [Inconstant_idents] is a "backwards" analysis that propagates implications - about inconstantness of variables and set of closures IDs. - - [Alias_analysis] is a "forwards" analysis that is analogous to the - propagation of [Simple_value_approx.t] values during [Inline_and_simplify]. - It gives us information about relationships between values but not actually - about their constantness. - - Combining these two into a single pass has been attempted previously, - but was not thought to be successful; this experiment could be repeated in - the future. (If "constant" is considered as "top" and "inconstant" is - considered as "bottom", then [Alias_analysis] corresponds to a least fixed - point and [Inconstant_idents] corresponds to a greatest fixed point.) - - At a high level, this pass operates as follows. Symbols are assigned to - variables known to be constant and their defining expressions examined. - Based on the results of [Alias_analysis], we simplify the destructive - elements within the defining expressions (specifically, projection of - fields from blocks), to eventually yield [Flambda.constant_defining_value]s - that are entirely constructive. These will be bound to symbols in the - resulting program. - - Another approach to this pass could be to only use the results of - [Inconstant_idents] and then repeatedly lift constants and run - [Inline_and_simplify] until a fixpoint. It was thought more robust to - instead use [Alias_analysis], where the fixpointing involves a less - complicated function. - - We still run [Inline_and_simplify] once after this pass since the lifting - of constants may enable more functions to become closed; the simplification - pass provides an easy way of cleaning up (e.g. making sure [free_vars] - maps in sets of closures are correct). -*) - -val lift_constants - : Flambda.program - -> backend:(module Backend_intf.S) - -> Flambda.program diff --git a/middle_end/lift_let_to_initialize_symbol.ml b/middle_end/lift_let_to_initialize_symbol.ml deleted file mode 100644 index ccef0d8a1f..0000000000 --- a/middle_end/lift_let_to_initialize_symbol.ml +++ /dev/null @@ -1,298 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -type ('a, 'b) kind = - | Initialisation of (Symbol.t * Tag.t * Flambda.t list) - | Effect of 'b - -let should_copy (named:Flambda.named) = - match named with - | Symbol _ | Read_symbol_field _ | Const _ -> true - | _ -> false - -type extracted = - | Expr of Variable.t * Flambda.t - | Exprs of Variable.t list * Flambda.t - | Block of Variable.t * Tag.t * Variable.t list - -type accumulated = { - copied_lets : (Variable.t * Flambda.named) list; - extracted_lets : extracted list; - terminator : Flambda.expr; -} - -let rec accumulate ~substitution ~copied_lets ~extracted_lets - (expr : Flambda.t) = - match expr with - | Let { var; body = Var var'; _ } | Let_rec ([var, _], Var var') - when Variable.equal var var' -> - { copied_lets; extracted_lets; - terminator = Flambda_utils.toplevel_substitution substitution expr; - } - (* If the pattern is what lifting let_rec generates, prevent it from being - lifted again. *) - | Let_rec (defs, - Let { var; body = Var var'; - defining_expr = Prim (Pmakeblock _, fields, _); }) - when - Variable.equal var var' - && List.for_all (fun field -> - List.exists (fun (def_var, _) -> Variable.equal def_var field) defs) - fields -> - { copied_lets; extracted_lets; - terminator = Flambda_utils.toplevel_substitution substitution expr; - } - | Let { var; defining_expr = Expr (Var alias); body; _ } - | Let_rec ([var, Expr (Var alias)], body) -> - let alias = - match Variable.Map.find alias substitution with - | exception Not_found -> alias - | original_alias -> original_alias - in - accumulate - ~substitution:(Variable.Map.add var alias substitution) - ~copied_lets - ~extracted_lets - body - | Let { var; defining_expr = named; body; _ } - | Let_rec ([var, named], body) - when should_copy named -> - accumulate body - ~substitution - ~copied_lets:((var, named)::copied_lets) - ~extracted_lets - | Let { var; defining_expr = named; body; _ } -> - let extracted = - let renamed = Variable.rename var in - match named with - | Prim (Pmakeblock (tag, Asttypes.Immutable, _value_kind), args, _dbg) -> - let tag = Tag.create_exn tag in - let args = - List.map (fun v -> - try Variable.Map.find v substitution - with Not_found -> v) - args - in - Block (var, tag, args) - | named -> - let expr = - Flambda_utils.toplevel_substitution substitution - (Flambda.create_let renamed named (Var renamed)) - in - Expr (var, expr) - in - accumulate body - ~substitution - ~copied_lets - ~extracted_lets:(extracted::extracted_lets) - | Let_rec ([var, named], body) -> - let renamed = Variable.rename var in - let def_substitution = Variable.Map.add var renamed substitution in - let expr = - Flambda_utils.toplevel_substitution def_substitution - (Let_rec ([renamed, named], Var renamed)) - in - let extracted = Expr (var, expr) in - accumulate body - ~substitution - ~copied_lets - ~extracted_lets:(extracted::extracted_lets) - | Let_rec (defs, body) -> - let renamed_defs, def_substitution = - List.fold_right (fun (var, def) (acc, substitution) -> - let new_var = Variable.rename var in - (new_var, def) :: acc, - Variable.Map.add var new_var substitution) - defs ([], substitution) - in - let extracted = - let expr = - let name = Internal_variable_names.lifted_let_rec_block in - Flambda_utils.toplevel_substitution def_substitution - (Let_rec (renamed_defs, - Flambda_utils.name_expr ~name - (Prim (Pmakeblock (0, Immutable, None), - List.map fst renamed_defs, - Debuginfo.none)))) - in - Exprs (List.map fst defs, expr) - in - accumulate body - ~substitution - ~copied_lets - ~extracted_lets:(extracted::extracted_lets) - | _ -> - { copied_lets; - extracted_lets; - terminator = Flambda_utils.toplevel_substitution substitution expr; - } - -let rebuild_expr - ~(extracted_definitions : (Symbol.t * int list) Variable.Map.t) - ~(copied_definitions : Flambda.named Variable.Map.t) - ~(substitute : bool) - (expr : Flambda.t) = - let expr_with_read_symbols = - Flambda_utils.substitute_read_symbol_field_for_variables - extracted_definitions expr - in - let free_variables = Flambda.free_variables expr_with_read_symbols in - let substitution = - if substitute then - Variable.Map.of_set (fun x -> Variable.rename x) free_variables - else - Variable.Map.of_set (fun x -> x) free_variables - in - let expr_with_read_symbols = - Flambda_utils.toplevel_substitution substitution - expr_with_read_symbols - in - Variable.Map.fold (fun var declaration body -> - let definition = Variable.Map.find var copied_definitions in - Flambda.create_let declaration definition body) - substitution expr_with_read_symbols - -let rebuild (used_variables:Variable.Set.t) (accumulated:accumulated) = - let copied_definitions = Variable.Map.of_list accumulated.copied_lets in - let accumulated_extracted_lets = - List.map (fun decl -> - match decl with - | Block (var, _, _) | Expr (var, _) -> - Symbol.of_variable (Variable.rename var), decl - | Exprs _ -> - let name = Internal_variable_names.lifted_let_rec_block in - let var = Variable.create name in - Symbol.of_variable var, decl) - accumulated.extracted_lets - in - let extracted_definitions = - (* Blocks are lifted to direct top-level Initialize_block: - accessing the value be done directly through the symbol. - Other let bound variables are initialized inside a size - one static block: - accessing the value is done directly through the field 0 - of the symbol. - let rec of size more than one is represented as a block of - all the bound variables allocated inside a size one static - block: - accessing the value is done directly through the right - field of the field 0 of the symbol. *) - List.fold_left (fun map (symbol, decl) -> - match decl with - | Block (var, _tag, _fields) -> - Variable.Map.add var (symbol, []) map - | Expr (var, _expr) -> - Variable.Map.add var (symbol, [0]) map - | Exprs (vars, _expr) -> - let map, _ = - List.fold_left (fun (map, field) var -> - Variable.Map.add var (symbol, [field; 0]) map, - field + 1) - (map, 0) vars - in - map) - Variable.Map.empty accumulated_extracted_lets - in - let extracted = - List.map (fun (symbol, decl) -> - match decl with - | Expr (var, decl) -> - let expr = - rebuild_expr ~extracted_definitions ~copied_definitions - ~substitute:true decl - in - if Variable.Set.mem var used_variables then - Initialisation - (symbol, - Tag.create_exn 0, - [expr]) - else - Effect expr - | Exprs (_vars, decl) -> - let expr = - rebuild_expr ~extracted_definitions ~copied_definitions - ~substitute:true decl - in - Initialisation (symbol, Tag.create_exn 0, [expr]) - | Block (_var, tag, fields) -> - let fields = - List.map (fun var -> - rebuild_expr ~extracted_definitions ~copied_definitions - ~substitute:true (Var var)) - fields - in - Initialisation (symbol, tag, fields)) - accumulated_extracted_lets - in - let terminator = - (* We don't need to substitute the variables in the terminator, we - suppose that we did for every other occurrence. Avoiding this - substitution allows this transformation to be idempotent. *) - rebuild_expr ~extracted_definitions ~copied_definitions - ~substitute:false accumulated.terminator - in - List.rev extracted, terminator - -let introduce_symbols expr = - let accumulated = - accumulate expr - ~substitution:Variable.Map.empty - ~copied_lets:[] ~extracted_lets:[] - in - let used_variables = Flambda.used_variables expr in - let extracted, terminator = rebuild used_variables accumulated in - extracted, terminator - -let add_extracted introduced program = - List.fold_right (fun extracted program -> - match extracted with - | Initialisation (symbol, tag, def) -> - Flambda.Initialize_symbol (symbol, tag, def, program) - | Effect effect -> - Flambda.Effect (effect, program)) - introduced program - -let rec split_program (program : Flambda.program_body) : Flambda.program_body = - match program with - | End s -> End s - | Let_symbol (s, def, program) -> - Let_symbol (s, def, split_program program) - | Let_rec_symbol (defs, program) -> - Let_rec_symbol (defs, split_program program) - | Effect (expr, program) -> - let program = split_program program in - let introduced, expr = introduce_symbols expr in - add_extracted introduced (Flambda.Effect (expr, program)) - | Initialize_symbol (symbol, tag, ((_::_::_) as fields), program) -> - (* CR-someday pchambart: currently the only initialize_symbol with more - than 1 field is the module block. This could evolve, in that case - this pattern should be handled properly. *) - Initialize_symbol (symbol, tag, fields, split_program program) - | Initialize_symbol (sym, tag, [], program) -> - Let_symbol (sym, Block (tag, []), split_program program) - | Initialize_symbol (symbol, tag, [field], program) -> - let program = split_program program in - let introduced, field = introduce_symbols field in - add_extracted introduced - (Flambda.Initialize_symbol (symbol, tag, [field], program)) - -let lift ~backend:_ (program : Flambda.program) = - { program with - program_body = split_program program.program_body; - } diff --git a/middle_end/lift_let_to_initialize_symbol.mli b/middle_end/lift_let_to_initialize_symbol.mli deleted file mode 100644 index afb1c60f9c..0000000000 --- a/middle_end/lift_let_to_initialize_symbol.mli +++ /dev/null @@ -1,38 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -(** Lift toplevel [Let]-expressions to Flambda [program] constructions such - that the results of evaluation of such expressions may be accessed - directly, through symbols, rather than through closures. The - [Let]-expressions typically come from the compilation of modules (using - the bytecode strategy) in [Translmod]. - - This means of compilation supersedes the old "transl_store_" methodology - for native code. - - An [Initialize_symbol] construction generated by this pass may be - subsequently rewritten to [Let_symbol] if it is discovered that the - initializer is in fact constant. (See [Initialize_symbol_to_let_symbol].) - - The [program] constructions generated by this pass will be joined by - others that arise from the lifting of constants (see [Lift_constants]). -*) -val lift - : backend:(module Backend_intf.S) - -> Flambda.program - -> Flambda.program diff --git a/middle_end/linkage_name.ml b/middle_end/linkage_name.ml new file mode 100644 index 0000000000..46febfba8f --- /dev/null +++ b/middle_end/linkage_name.ml @@ -0,0 +1,30 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +type t = string + +include Identifiable.Make (struct + include String + let hash = Hashtbl.hash + let print ppf t = Format.pp_print_string ppf t + let output chan t = output_string chan t +end) + +let create t = t +let to_string t = t diff --git a/middle_end/linkage_name.mli b/middle_end/linkage_name.mli new file mode 100644 index 0000000000..58731917cd --- /dev/null +++ b/middle_end/linkage_name.mli @@ -0,0 +1,22 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +include Identifiable.S + +val create : string -> t +val to_string : t -> string diff --git a/middle_end/middle_end.ml b/middle_end/middle_end.ml deleted file mode 100644 index e604a3285b..0000000000 --- a/middle_end/middle_end.ml +++ /dev/null @@ -1,200 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -let _dump_function_sizes flam ~backend = - let module Backend = (val backend : Backend_intf.S) in - let than = max_int in - Flambda_iterators.iter_on_set_of_closures_of_program flam - ~f:(fun ~constant:_ (set_of_closures : Flambda.set_of_closures) -> - Variable.Map.iter (fun fun_var - (function_decl : Flambda.function_declaration) -> - let closure_id = Closure_id.wrap fun_var in - let symbol = Backend.closure_symbol closure_id in - match Inlining_cost.lambda_smaller' function_decl.body ~than with - | Some size -> Format.eprintf "%a %d\n" Symbol.print symbol size - | None -> assert false) - set_of_closures.function_decls.funs) - -let middle_end ~ppf_dump ~prefixname ~backend - ~size - ~filename - ~module_ident - ~module_initializer = - Profile.record_call "flambda" (fun () -> - let previous_warning_reporter = !Location.warning_reporter in - let module WarningSet = - Set.Make (struct - type t = Location.t * Warnings.t - let compare = Stdlib.compare - end) - in - let warning_set = ref WarningSet.empty in - let flambda_warning_reporter loc w = - let elt = loc, w in - if not (WarningSet.mem elt !warning_set) then begin - warning_set := WarningSet.add elt !warning_set; - previous_warning_reporter loc w - end else None - in - Misc.protect_refs - [Misc.R (Location.warning_reporter, flambda_warning_reporter)] - (fun () -> - let pass_number = ref 0 in - let round_number = ref 0 in - let check flam = - if !Clflags.flambda_invariant_checks then begin - try Flambda_invariants.check_exn flam - with exn -> - Misc.fatal_errorf "After Flambda pass %d, round %d:@.%s:@.%a" - !pass_number !round_number (Printexc.to_string exn) - Flambda.print_program flam - end - in - let (+-+) flam (name, pass) = - incr pass_number; - if !Clflags.dump_flambda_verbose then begin - Format.fprintf ppf_dump "@.PASS: %s@." name; - Format.fprintf ppf_dump "Before pass %d, round %d:@ %a@." - !pass_number !round_number Flambda.print_program flam; - Format.fprintf ppf_dump "\n@?" - end; - let flam = Profile.record ~accumulate:true name pass flam in - if !Clflags.flambda_invariant_checks then begin - Profile.record ~accumulate:true "check" check flam - end; - flam - in - Profile.record_call ~accumulate:true "middle_end" (fun () -> - let flam = - Profile.record_call ~accumulate:true "closure_conversion" - (fun () -> - module_initializer - |> Closure_conversion.lambda_to_flambda ~backend - ~module_ident ~size ~filename) - in - if !Clflags.dump_rawflambda - then - Format.fprintf ppf_dump "After closure conversion:@ %a@." - Flambda.print_program flam; - check flam; - let fast_mode flam = - pass_number := 0; - let round = 0 in - flam - +-+ ("lift_lets 1", Lift_code.lift_lets) - +-+ ("Lift_constants", Lift_constants.lift_constants ~backend) - +-+ ("Share_constants", Share_constants.share_constants) - +-+ ("Lift_let_to_initialize_symbol", - Lift_let_to_initialize_symbol.lift ~backend) - +-+ ("Inline_and_simplify", - Inline_and_simplify.run ~never_inline:false ~backend - ~prefixname ~round ~ppf_dump) - +-+ ("Remove_unused_closure_vars 2", - Remove_unused_closure_vars.remove_unused_closure_variables - ~remove_direct_call_surrogates:false) - +-+ ("Ref_to_variables", - Ref_to_variables.eliminate_ref) - +-+ ("Initialize_symbol_to_let_symbol", - Initialize_symbol_to_let_symbol.run) - in - let rec loop flam = - pass_number := 0; - let round = !round_number in - incr round_number; - if !round_number > (Clflags.rounds ()) then flam - else - flam - (* Beware: [Lift_constants] must be run before any pass that - might duplicate strings. *) - +-+ ("lift_lets 1", Lift_code.lift_lets) - +-+ ("Lift_constants", Lift_constants.lift_constants ~backend) - +-+ ("Share_constants", Share_constants.share_constants) - +-+ ("Remove_unused_program_constructs", - Remove_unused_program_constructs.remove_unused_program_constructs) - +-+ ("Lift_let_to_initialize_symbol", - Lift_let_to_initialize_symbol.lift ~backend) - +-+ ("lift_lets 2", Lift_code.lift_lets) - +-+ ("Remove_unused_closure_vars 1", - Remove_unused_closure_vars.remove_unused_closure_variables - ~remove_direct_call_surrogates:false) - +-+ ("Inline_and_simplify", - Inline_and_simplify.run ~never_inline:false ~backend - ~prefixname ~round ~ppf_dump) - +-+ ("Remove_unused_closure_vars 2", - Remove_unused_closure_vars.remove_unused_closure_variables - ~remove_direct_call_surrogates:false) - +-+ ("lift_lets 3", Lift_code.lift_lets) - +-+ ("Inline_and_simplify noinline", - Inline_and_simplify.run ~never_inline:true ~backend - ~prefixname ~round ~ppf_dump) - +-+ ("Remove_unused_closure_vars 3", - Remove_unused_closure_vars.remove_unused_closure_variables - ~remove_direct_call_surrogates:false) - +-+ ("Ref_to_variables", - Ref_to_variables.eliminate_ref) - +-+ ("Initialize_symbol_to_let_symbol", - Initialize_symbol_to_let_symbol.run) - |> loop - in - let back_end flam = - flam - +-+ ("Remove_unused_closure_vars", - Remove_unused_closure_vars.remove_unused_closure_variables - ~remove_direct_call_surrogates:true) - +-+ ("Lift_constants", Lift_constants.lift_constants ~backend) - +-+ ("Share_constants", Share_constants.share_constants) - +-+ ("Remove_unused_program_constructs", - Remove_unused_program_constructs.remove_unused_program_constructs) - in - let flam = - if !Clflags.classic_inlining then - fast_mode flam - else - loop flam - in - let flam = back_end flam in - (* Check that there aren't any unused "always inline" attributes. *) - Flambda_iterators.iter_apply_on_program flam ~f:(fun apply -> - match apply.inline with - | Default_inline | Never_inline -> () - | Always_inline -> - (* CR-someday mshinwell: consider a different error message if - this triggers as a result of the propagation of a user's - attribute into the second part of an over application - (inline_and_simplify.ml line 710). *) - Location.prerr_warning (Debuginfo.to_location apply.dbg) - (Warnings.Inlining_impossible - "[@inlined] attribute was not used on this function \ - application (the optimizer did not know what function \ - was being applied)") - | Unroll _ -> - Location.prerr_warning (Debuginfo.to_location apply.dbg) - (Warnings.Inlining_impossible - "[@unroll] attribute was not used on this function \ - application (the optimizer did not know what function \ - was being applied)")); - if !Clflags.dump_flambda - then - Format.fprintf ppf_dump "End of middle end:@ %a@." - Flambda.print_program flam; - check flam; - (* CR-someday mshinwell: add -d... option for this *) - (* dump_function_sizes flam ~backend; *) - flam)) - ) diff --git a/middle_end/middle_end.mli b/middle_end/middle_end.mli deleted file mode 100644 index 584cb45a98..0000000000 --- a/middle_end/middle_end.mli +++ /dev/null @@ -1,29 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -(* Translate Lambda code to Flambda code and then optimize it. *) - -val middle_end - : ppf_dump:Format.formatter - -> prefixname:string - -> backend:(module Backend_intf.S) - -> size:int - -> filename:string - -> module_ident:Ident.t - -> module_initializer:Lambda.lambda - -> Flambda.program diff --git a/middle_end/parameter.ml b/middle_end/parameter.ml deleted file mode 100644 index 0c916dd7ae..0000000000 --- a/middle_end/parameter.ml +++ /dev/null @@ -1,69 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -[@@@ocaml.warning "+9"] -(* Warning 9 is enabled to ensure correct update of each function when - a field is added to type parameter *) - -type parameter = { - var : Variable.t; -} - -let wrap var = { var } - -let var p = p.var - -module M = - Identifiable.Make (struct - type t = parameter - - let compare { var = var1 } { var = var2 } = - Variable.compare var1 var2 - - let equal { var = var1 } { var = var2 } = - Variable.equal var1 var2 - - let hash { var } = - Variable.hash var - - let print ppf { var } = - Variable.print ppf var - - let output o { var } = - Variable.output o var - end) - -module T = M.T -include T - -module Map = M.Map -module Tbl = M.Tbl -module Set = struct - include M.Set - let vars l = Variable.Set.of_list (List.map var l) -end - -let rename ?current_compilation_unit p = - { var = Variable.rename ?current_compilation_unit p.var } - -let map_var f { var } = { var = f var } - -module List = struct - let vars params = List.map (fun { var } -> var) params -end diff --git a/middle_end/parameter.mli b/middle_end/parameter.mli deleted file mode 100644 index ceed16786b..0000000000 --- a/middle_end/parameter.mli +++ /dev/null @@ -1,52 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -(** [Parameter.t] carries a unique [Variable.t] used as function parameter. - It can also carry annotations about the usage of the variable. *) - -type t -type parameter = t - -(** Make a parameter from a variable with default attributes *) -val wrap : Variable.t -> t - -val var : t -> Variable.t - -(** Rename the inner variable of the parameter *) -val rename - : ?current_compilation_unit:Compilation_unit.t - -> t - -> t - -val map_var : (Variable.t -> Variable.t) -> t -> t - -module T : Identifiable.Thing with type t = t - -module Set : sig - include Identifiable.Set with module T := T - val vars : parameter list -> Variable.Set.t -end - -include Identifiable.S with type t := t - and module T := T - and module Set := Set - -module List : sig - (** extract variables from a list of parameters, preserving the order *) - val vars : t list -> Variable.t list -end diff --git a/middle_end/pass_wrapper.ml b/middle_end/pass_wrapper.ml deleted file mode 100644 index a20053326f..0000000000 --- a/middle_end/pass_wrapper.ml +++ /dev/null @@ -1,35 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -let register ~pass_name = - Clflags.all_passes := pass_name :: !Clflags.all_passes - -let with_dump ~ppf_dump ~pass_name ~f ~input ~print_input ~print_output = - let dump = Clflags.dumped_pass pass_name in - let result = f () in - match result with - | None -> - if dump then Format.fprintf ppf_dump "%s: no-op.\n\n%!" pass_name; - None - | Some result -> - if dump then begin - Format.fprintf ppf_dump "Before %s:@ %a@.@." pass_name print_input input; - Format.fprintf ppf_dump "After %s:@ %a@.@." pass_name print_output result; - end; - Some result diff --git a/middle_end/pass_wrapper.mli b/middle_end/pass_wrapper.mli deleted file mode 100644 index 3a30e61d6d..0000000000 --- a/middle_end/pass_wrapper.mli +++ /dev/null @@ -1,26 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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. *) -(* *) -(**************************************************************************) - -val register : pass_name:string -> unit - -val with_dump - : ppf_dump:Format.formatter - -> pass_name:string - -> f:(unit -> 'b option) - -> input:'a - -> print_input:(Format.formatter -> 'a -> unit) - -> print_output:(Format.formatter -> 'b -> unit) - -> 'b option diff --git a/middle_end/printclambda.ml b/middle_end/printclambda.ml new file mode 100644 index 0000000000..fceb34851d --- /dev/null +++ b/middle_end/printclambda.ml @@ -0,0 +1,272 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + + +open Format +open Asttypes +open Clambda + +module V = Backend_var +module VP = Backend_var.With_provenance + +let mutable_flag = function + | Mutable-> "[mut]" + | Immutable -> "" + +let value_kind = + let open Lambda in + function + | Pgenval -> "" + | Pintval -> ":int" + | Pfloatval -> ":float" + | Pboxedintval Pnativeint -> ":nativeint" + | Pboxedintval Pint32 -> ":int32" + | Pboxedintval Pint64 -> ":int64" + +let rec structured_constant ppf = function + | Uconst_float x -> fprintf ppf "%F" x + | Uconst_int32 x -> fprintf ppf "%ldl" x + | Uconst_int64 x -> fprintf ppf "%LdL" x + | Uconst_nativeint x -> fprintf ppf "%ndn" x + | Uconst_block (tag, l) -> + fprintf ppf "block(%i" tag; + List.iter (fun u -> fprintf ppf ",%a" uconstant u) l; + fprintf ppf ")" + | Uconst_float_array [] -> + fprintf ppf "floatarray()" + | Uconst_float_array (f1 :: fl) -> + fprintf ppf "floatarray(%F" f1; + List.iter (fun f -> fprintf ppf ",%F" f) fl; + fprintf ppf ")" + | Uconst_string s -> fprintf ppf "%S" s + | Uconst_closure(clos, sym, fv) -> + let funs ppf = + List.iter (fprintf ppf "@ %a" one_fun) in + let sconsts ppf scl = + List.iter (fun sc -> fprintf ppf "@ %a" uconstant sc) scl in + fprintf ppf "@[<2>(const_closure%a %s@ %a)@]" funs clos sym sconsts fv + +and one_fun ppf f = + let idents ppf = + List.iter + (fun (x, k) -> + fprintf ppf "@ %a%a" + VP.print x + Printlambda.value_kind k + ) + in + fprintf ppf "(fun@ %s%s@ %d@ @[<2>%a@]@ @[<2>%a@])" + f.label (value_kind f.return) f.arity idents f.params lam f.body + +and phantom_defining_expr ppf = function + | Uphantom_const const -> uconstant ppf const + | Uphantom_var var -> Ident.print ppf var + | Uphantom_offset_var { var; offset_in_words; } -> + Format.fprintf ppf "%a+(%d)" Backend_var.print var offset_in_words + | Uphantom_read_field { var; field; } -> + Format.fprintf ppf "%a[%d]" Backend_var.print var field + | Uphantom_read_symbol_field { sym; field; } -> + Format.fprintf ppf "%s[%d]" sym field + | Uphantom_block { tag; fields; } -> + Format.fprintf ppf "[%d: " tag; + List.iter (fun field -> + Format.fprintf ppf "%a; " Backend_var.print field) + fields; + Format.fprintf ppf "]" + +and phantom_defining_expr_opt ppf = function + | None -> Format.fprintf ppf "DEAD" + | Some expr -> phantom_defining_expr ppf expr + +and uconstant ppf = function + | Uconst_ref (s, Some c) -> + fprintf ppf "%S=%a" s structured_constant c + | Uconst_ref (s, None) -> fprintf ppf "%S"s + | Uconst_int i -> fprintf ppf "%i" i + | Uconst_ptr i -> fprintf ppf "%ia" i + +and lam ppf = function + | Uvar id -> + V.print ppf id + | Uconst c -> uconstant ppf c + | Udirect_apply(f, largs, _) -> + let lams ppf largs = + List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in + fprintf ppf "@[<2>(apply*@ %s %a)@]" f lams largs + | Ugeneric_apply(lfun, largs, _) -> + let lams ppf largs = + List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in + fprintf ppf "@[<2>(apply@ %a%a)@]" lam lfun lams largs + | Uclosure(clos, fv) -> + let funs ppf = + List.iter (fprintf ppf "@ @[<2>%a@]" one_fun) in + let lams ppf = + List.iter (fprintf ppf "@ %a" lam) in + fprintf ppf "@[<2>(closure@ %a %a)@]" funs clos lams fv + | Uoffset(l,i) -> fprintf ppf "@[<2>(offset %a %d)@]" lam l i + | Ulet(mut, kind, id, arg, body) -> + let rec letbody ul = match ul with + | Ulet(mut, kind, id, arg, body) -> + fprintf ppf "@ @[<2>%a%s%s@ %a@]" + VP.print id + (mutable_flag mut) (value_kind kind) lam arg; + letbody body + | _ -> ul in + fprintf ppf "@[<2>(let@ @[(@[<2>%a%s%s@ %a@]" + VP.print id (mutable_flag mut) + (value_kind kind) lam arg; + let expr = letbody body in + fprintf ppf ")@]@ %a)@]" lam expr + | Uphantom_let (id, defining_expr, body) -> + let rec letbody ul = match ul with + | Uphantom_let (id, defining_expr, body) -> + fprintf ppf "@ @[<2>%a@ %a@]" + Backend_var.With_provenance.print id + phantom_defining_expr_opt defining_expr; + letbody body + | _ -> ul in + fprintf ppf "@[<2>(phantom_let@ @[(@[<2>%a@ %a@]" + Backend_var.With_provenance.print id + phantom_defining_expr_opt defining_expr; + let expr = letbody body in + fprintf ppf ")@]@ %a)@]" lam expr + | Uletrec(id_arg_list, body) -> + let bindings ppf id_arg_list = + let spc = ref false in + List.iter + (fun (id, l) -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[<2>%a@ %a@]" + VP.print id + lam l) + id_arg_list in + fprintf ppf + "@[<2>(letrec@ (@[%a@])@ %a)@]" bindings id_arg_list lam body + | Uprim(prim, largs, _) -> + let lams ppf largs = + List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in + fprintf ppf "@[<2>(%a%a)@]" + Printclambda_primitives.primitive prim lams largs + | Uswitch(larg, sw, _dbg) -> + let print_case tag index i ppf = + for j = 0 to Array.length index - 1 do + if index.(j) = i then fprintf ppf "case %s %i:" tag j + done in + let print_cases tag index cases ppf = + for i = 0 to Array.length cases - 1 do + fprintf ppf "@ @[<2>%t@ %a@]" + (print_case tag index i) sequence cases.(i) + done in + let switch ppf sw = + print_cases "int" sw.us_index_consts sw.us_actions_consts ppf ; + print_cases "tag" sw.us_index_blocks sw.us_actions_blocks ppf in + fprintf ppf + "@[@[<2>(switch@ %a@ @]%a)@]" + lam larg switch sw + | Ustringswitch(larg,sw,d) -> + let switch ppf sw = + let spc = ref false in + List.iter + (fun (s,l) -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[case \"%s\":@ %a@]" + (String.escaped s) lam l) + sw ; + begin match d with + | Some d -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[default:@ %a@]" lam d + | None -> () + end in + fprintf ppf + "@[<1>(switch %a@ @[%a@])@]" lam larg switch sw + | Ustaticfail (i, ls) -> + let lams ppf largs = + List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in + fprintf ppf "@[<2>(exit@ %d%a)@]" i lams ls; + | Ucatch(i, vars, lbody, lhandler) -> + fprintf ppf "@[<2>(catch@ %a@;<1 -1>with (%d%a)@ %a)@]" + lam lbody i + (fun ppf vars -> + List.iter + (fun (x, k) -> + fprintf ppf " %a%a" + VP.print x + Printlambda.value_kind k + ) + vars + ) + vars + lam lhandler + | Utrywith(lbody, param, lhandler) -> + fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]" + lam lbody VP.print param lam lhandler + | Uifthenelse(lcond, lif, lelse) -> + fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" lam lcond lam lif lam lelse + | Usequence(l1, l2) -> + fprintf ppf "@[<2>(seq@ %a@ %a)@]" lam l1 sequence l2 + | Uwhile(lcond, lbody) -> + fprintf ppf "@[<2>(while@ %a@ %a)@]" lam lcond lam lbody + | Ufor(param, lo, hi, dir, body) -> + fprintf ppf "@[<2>(for %a@ %a@ %s@ %a@ %a)@]" + VP.print param lam lo + (match dir with Upto -> "to" | Downto -> "downto") + lam hi lam body + | Uassign(id, expr) -> + fprintf ppf "@[<2>(assign@ %a@ %a)@]" V.print id lam expr + | Usend (k, met, obj, largs, _) -> + let args ppf largs = + List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in + let kind = + if k = Lambda.Self then "self" + else if k = Lambda.Cached then "cache" + else "" in + fprintf ppf "@[<2>(send%s@ %a@ %a%a)@]" kind lam obj lam met args largs + | Uunreachable -> + fprintf ppf "unreachable" + +and sequence ppf ulam = match ulam with + | Usequence(l1, l2) -> + fprintf ppf "%a@ %a" sequence l1 sequence l2 + | _ -> lam ppf ulam + +let clambda ppf ulam = + fprintf ppf "%a@." lam ulam + + +let rec approx ppf = function + Value_closure(fundesc, a) -> + Format.fprintf ppf "@[<2>function %s@ arity %i" + fundesc.fun_label fundesc.fun_arity; + if fundesc.fun_closed then begin + Format.fprintf ppf "@ (closed)" + end; + if fundesc.fun_inline <> None then begin + Format.fprintf ppf "@ (inline)" + end; + Format.fprintf ppf "@ -> @ %a@]" approx a + | Value_tuple a -> + let tuple ppf a = + for i = 0 to Array.length a - 1 do + if i > 0 then Format.fprintf ppf ";@ "; + Format.fprintf ppf "%i: %a" i approx a.(i) + done in + Format.fprintf ppf "@[(%a)@]" tuple a + | Value_unknown -> + Format.fprintf ppf "_" + | Value_const c -> + fprintf ppf "@[const(%a)@]" uconstant c + | Value_global_field (s, i) -> + fprintf ppf "@[global(%s,%i)@]" s i diff --git a/middle_end/printclambda.mli b/middle_end/printclambda.mli new file mode 100644 index 0000000000..121667e2a4 --- /dev/null +++ b/middle_end/printclambda.mli @@ -0,0 +1,26 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Clambda +open Format + +val clambda: formatter -> ulambda -> unit +val approx: formatter -> value_approximation -> unit +val structured_constant: formatter -> ustructured_constant -> unit + +val phantom_defining_expr_opt + : formatter + -> uphantom_defining_expr option + -> unit diff --git a/middle_end/printclambda_primitives.ml b/middle_end/printclambda_primitives.ml new file mode 100644 index 0000000000..3f627063d4 --- /dev/null +++ b/middle_end/printclambda_primitives.ml @@ -0,0 +1,202 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + + +open Format +open Asttypes + +let boxed_integer_name = function + | Lambda.Pnativeint -> "nativeint" + | Lambda.Pint32 -> "int32" + | Lambda.Pint64 -> "int64" + +let boxed_integer_mark name = function + | Lambda.Pnativeint -> Printf.sprintf "Nativeint.%s" name + | Lambda.Pint32 -> Printf.sprintf "Int32.%s" name + | Lambda.Pint64 -> Printf.sprintf "Int64.%s" name + +let print_boxed_integer name ppf bi = + fprintf ppf "%s" (boxed_integer_mark name bi);; + +let array_kind array_kind = + let open Lambda in + match array_kind with + | Pgenarray -> "gen" + | Paddrarray -> "addr" + | Pintarray -> "int" + | Pfloatarray -> "float" + +let access_size size = + let open Clambda_primitives in + match size with + | Sixteen -> "16" + | Thirty_two -> "32" + | Sixty_four -> "64" + +let access_safety safety = + let open Lambda in + match safety with + | Safe -> "" + | Unsafe -> "unsafe_" + +let primitive ppf (prim:Clambda_primitives.primitive) = + let open Lambda in + let open Clambda_primitives in + match prim with + | Pread_symbol sym -> + fprintf ppf "read_symbol %s" sym + | Pmakeblock(tag, Immutable, shape) -> + fprintf ppf "makeblock %i%a" tag Printlambda.block_shape shape + | Pmakeblock(tag, Mutable, shape) -> + fprintf ppf "makemutable %i%a" tag Printlambda.block_shape shape + | Pfield n -> fprintf ppf "field %i" n + | Pfield_computed -> fprintf ppf "field_computed" + | Psetfield(n, ptr, init) -> + let instr = + match ptr with + | Pointer -> "ptr" + | Immediate -> "imm" + in + let init = + match init with + | Heap_initialization -> "(heap-init)" + | Root_initialization -> "(root-init)" + | Assignment -> "" + in + fprintf ppf "setfield_%s%s %i" instr init n + | Psetfield_computed (ptr, init) -> + let instr = + match ptr with + | Pointer -> "ptr" + | Immediate -> "imm" + in + let init = + match init with + | Heap_initialization -> "(heap-init)" + | Root_initialization -> "(root-init)" + | Assignment -> "" + in + fprintf ppf "setfield_%s%s_computed" instr init + | Pfloatfield n -> fprintf ppf "floatfield %i" n + | Psetfloatfield (n, init) -> + let init = + match init with + | Heap_initialization -> "(heap-init)" + | Root_initialization -> "(root-init)" + | Assignment -> "" + in + fprintf ppf "setfloatfield%s %i" init n + | Pduprecord (rep, size) -> + fprintf ppf "duprecord %a %i" Printlambda.record_rep rep size + | Pccall p -> fprintf ppf "%s" p.Primitive.prim_name + | Praise k -> fprintf ppf "%s" (Lambda.raise_kind k) + | Psequand -> fprintf ppf "&&" + | Psequor -> fprintf ppf "||" + | Pnot -> fprintf ppf "not" + | Pnegint -> fprintf ppf "~" + | Paddint -> fprintf ppf "+" + | Psubint -> fprintf ppf "-" + | Pmulint -> fprintf ppf "*" + | Pdivint Safe -> fprintf ppf "/" + | Pdivint Unsafe -> fprintf ppf "/u" + | Pmodint Safe -> fprintf ppf "mod" + | Pmodint Unsafe -> fprintf ppf "mod_unsafe" + | Pandint -> fprintf ppf "and" + | Porint -> fprintf ppf "or" + | Pxorint -> fprintf ppf "xor" + | Plslint -> fprintf ppf "lsl" + | Plsrint -> fprintf ppf "lsr" + | Pasrint -> fprintf ppf "asr" + | Pintcomp(cmp) -> Printlambda.integer_comparison ppf cmp + | Poffsetint n -> fprintf ppf "%i+" n + | Poffsetref n -> fprintf ppf "+:=%i"n + | Pintoffloat -> fprintf ppf "int_of_float" + | Pfloatofint -> fprintf ppf "float_of_int" + | Pnegfloat -> fprintf ppf "~." + | Pabsfloat -> fprintf ppf "abs." + | Paddfloat -> fprintf ppf "+." + | Psubfloat -> fprintf ppf "-." + | Pmulfloat -> fprintf ppf "*." + | Pdivfloat -> fprintf ppf "/." + | Pfloatcomp(cmp) -> Printlambda.float_comparison ppf cmp + | Pstringlength -> fprintf ppf "string.length" + | Pstringrefu -> fprintf ppf "string.unsafe_get" + | Pstringrefs -> fprintf ppf "string.get" + | Pbyteslength -> fprintf ppf "bytes.length" + | Pbytesrefu -> fprintf ppf "bytes.unsafe_get" + | Pbytessetu -> fprintf ppf "bytes.unsafe_set" + | Pbytesrefs -> fprintf ppf "bytes.get" + | Pbytessets -> fprintf ppf "bytes.set" + + | Parraylength k -> fprintf ppf "array.length[%s]" (array_kind k) + | Pmakearray (k, Mutable) -> fprintf ppf "makearray[%s]" (array_kind k) + | Pmakearray (k, Immutable) -> fprintf ppf "makearray_imm[%s]" (array_kind k) + | Pduparray (k, Mutable) -> fprintf ppf "duparray[%s]" (array_kind k) + | Pduparray (k, Immutable) -> fprintf ppf "duparray_imm[%s]" (array_kind k) + | Parrayrefu k -> fprintf ppf "array.unsafe_get[%s]" (array_kind k) + | Parraysetu k -> fprintf ppf "array.unsafe_set[%s]" (array_kind k) + | Parrayrefs k -> fprintf ppf "array.get[%s]" (array_kind k) + | Parraysets k -> fprintf ppf "array.set[%s]" (array_kind k) + | Pisint -> fprintf ppf "isint" + | Pisout -> fprintf ppf "isout" + | Pbintofint bi -> print_boxed_integer "of_int" ppf bi + | Pintofbint bi -> print_boxed_integer "to_int" ppf bi + | Pcvtbint (bi1, bi2) -> + fprintf ppf "%s_of_%s" (boxed_integer_name bi2) (boxed_integer_name bi1) + | Pnegbint bi -> print_boxed_integer "neg" ppf bi + | Paddbint bi -> print_boxed_integer "add" ppf bi + | Psubbint bi -> print_boxed_integer "sub" ppf bi + | Pmulbint bi -> print_boxed_integer "mul" ppf bi + | Pdivbint { size = bi; is_safe = Safe } -> + print_boxed_integer "div" ppf bi + | Pdivbint { size = bi; is_safe = Unsafe } -> + print_boxed_integer "div_unsafe" ppf bi + | Pmodbint { size = bi; is_safe = Safe } -> + print_boxed_integer "mod" ppf bi + | Pmodbint { size = bi; is_safe = Unsafe } -> + print_boxed_integer "mod_unsafe" ppf bi + | Pandbint bi -> print_boxed_integer "and" ppf bi + | Porbint bi -> print_boxed_integer "or" ppf bi + | Pxorbint bi -> print_boxed_integer "xor" ppf bi + | Plslbint bi -> print_boxed_integer "lsl" ppf bi + | Plsrbint bi -> print_boxed_integer "lsr" ppf bi + | Pasrbint bi -> print_boxed_integer "asr" ppf bi + | Pbintcomp(bi, Ceq) -> print_boxed_integer "==" ppf bi + | Pbintcomp(bi, Cne) -> print_boxed_integer "!=" ppf bi + | Pbintcomp(bi, Clt) -> print_boxed_integer "<" ppf bi + | Pbintcomp(bi, Cgt) -> print_boxed_integer ">" ppf bi + | Pbintcomp(bi, Cle) -> print_boxed_integer "<=" ppf bi + | Pbintcomp(bi, Cge) -> print_boxed_integer ">=" ppf bi + | Pbigarrayref(unsafe, _n, kind, layout) -> + Printlambda.print_bigarray "get" unsafe kind ppf layout + | Pbigarrayset(unsafe, _n, kind, layout) -> + Printlambda.print_bigarray "set" unsafe kind ppf layout + | Pbigarraydim(n) -> fprintf ppf "Bigarray.dim_%i" n + | Pstring_load(size, safety) -> + fprintf ppf "string.%sget%s" (access_safety safety) (access_size size) + | Pbytes_load(size, safety) -> + fprintf ppf "bytes.%sget%s" (access_safety safety) (access_size size) + | Pbytes_set(size, safety) -> + fprintf ppf "bytes.%sset%s" (access_safety safety) (access_size size) + | Pbigstring_load(size, safety) -> + fprintf ppf "bigarray.array1.%sget%s" + (access_safety safety) (access_size size) + | Pbigstring_set(size, safety) -> + fprintf ppf "bigarray.array1.%sset%s" + (access_safety safety) (access_size size) + | Pbswap16 -> fprintf ppf "bswap16" + | Pbbswap(bi) -> print_boxed_integer "bswap" ppf bi + | Pint_as_pointer -> fprintf ppf "int_as_pointer" + | Popaque -> fprintf ppf "opaque" diff --git a/middle_end/printclambda_primitives.mli b/middle_end/printclambda_primitives.mli new file mode 100644 index 0000000000..07db5a1ce6 --- /dev/null +++ b/middle_end/printclambda_primitives.mli @@ -0,0 +1,18 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Format + +val primitive: formatter -> Clambda_primitives.primitive -> unit diff --git a/middle_end/projection.ml b/middle_end/projection.ml deleted file mode 100644 index 2c660a2a28..0000000000 --- a/middle_end/projection.ml +++ /dev/null @@ -1,170 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -(* CR-someday mshinwell: Move these three types into their own modules. *) - -type project_closure = { - set_of_closures : Variable.t; - closure_id : Closure_id.t; -} - -type move_within_set_of_closures = { - closure : Variable.t; - start_from : Closure_id.t; - move_to : Closure_id.t; -} - -type project_var = { - closure : Variable.t; - closure_id : Closure_id.t; - var : Var_within_closure.t; -} - -let compare_project_var - ({ closure = closure1; closure_id = closure_id1; var = var1; } - : project_var) - ({ closure = closure2; closure_id = closure_id2; var = var2; } - : project_var) = - let c = Variable.compare closure1 closure2 in - if c <> 0 then c - else - let c = Closure_id.compare closure_id1 closure_id2 in - if c <> 0 then c - else - Var_within_closure.compare var1 var2 - -let compare_move_within_set_of_closures - ({ closure = closure1; start_from = start_from1; move_to = move_to1; } - : move_within_set_of_closures) - ({ closure = closure2; start_from = start_from2; move_to = move_to2; } - : move_within_set_of_closures) = - let c = Variable.compare closure1 closure2 in - if c <> 0 then c - else - let c = Closure_id.compare start_from1 start_from2 in - if c <> 0 then c - else - Closure_id.compare move_to1 move_to2 - -let compare_project_closure - ({ set_of_closures = set_of_closures1; closure_id = closure_id1; } - : project_closure) - ({ set_of_closures = set_of_closures2; closure_id = closure_id2; } - : project_closure) = - let c = Variable.compare set_of_closures1 set_of_closures2 in - if c <> 0 then c - else - Closure_id.compare closure_id1 closure_id2 - -let print_project_closure ppf (project_closure : project_closure) = - Format.fprintf ppf "@[<2>(project_closure@ %a@ from@ %a)@]" - Closure_id.print project_closure.closure_id - Variable.print project_closure.set_of_closures - -let print_move_within_set_of_closures ppf - (move_within_set_of_closures : move_within_set_of_closures) = - Format.fprintf ppf - "@[<2>(move_within_set_of_closures@ %a <-- %a@ (closure = %a))@]" - Closure_id.print move_within_set_of_closures.move_to - Closure_id.print move_within_set_of_closures.start_from - Variable.print move_within_set_of_closures.closure - -let print_project_var ppf (project_var : project_var) = - Format.fprintf ppf "@[<2>(project_var@ %a@ from %a=%a)@]" - Var_within_closure.print project_var.var - Closure_id.print project_var.closure_id - Variable.print project_var.closure - -type t = - | Project_var of project_var - | Project_closure of project_closure - | Move_within_set_of_closures of move_within_set_of_closures - | Field of int * Variable.t - -include Identifiable.Make (struct - type nonrec t = t - - let compare t1 t2 = - match t1, t2 with - | Project_var project_var1, Project_var project_var2 -> - compare_project_var project_var1 project_var2 - | Project_closure project_closure1, Project_closure project_closure2 -> - compare_project_closure project_closure1 project_closure2 - | Move_within_set_of_closures move1, Move_within_set_of_closures move2 -> - compare_move_within_set_of_closures move1 move2 - | Field (index1, var1), Field (index2, var2) -> - let c = compare index1 index2 in - if c <> 0 then c - else Variable.compare var1 var2 - | Project_var _, _ -> -1 - | _, Project_var _ -> 1 - | Project_closure _, _ -> -1 - | _, Project_closure _ -> 1 - | Move_within_set_of_closures _, _ -> -1 - | _, Move_within_set_of_closures _ -> 1 - - let equal t1 t2 = - (compare t1 t2) = 0 - - let hash = Hashtbl.hash - - let print ppf t = - match t with - | Project_closure (project_closure) -> - print_project_closure ppf project_closure - | Project_var (project_var) -> print_project_var ppf project_var - | Move_within_set_of_closures (move_within_set_of_closures) -> - print_move_within_set_of_closures ppf move_within_set_of_closures - | Field (field_index, var) -> - Format.fprintf ppf "Field %d of %a" field_index Variable.print var - - let output _ _ = failwith "Projection.output: not yet implemented" -end) - -let projecting_from t = - match t with - | Project_var { closure; _ } -> closure - | Project_closure { set_of_closures; _ } -> set_of_closures - | Move_within_set_of_closures { closure; _ } -> closure - | Field (_, var) -> var - -let map_projecting_from t ~f : t = - match t with - | Project_var project_var -> - let project_var : project_var = - { project_var with - closure = f project_var.closure; - } - in - Project_var project_var - | Project_closure project_closure -> - let project_closure : project_closure = - { project_closure with - set_of_closures = f project_closure.set_of_closures; - } - in - Project_closure project_closure - | Move_within_set_of_closures move -> - let move : move_within_set_of_closures = - { move with - closure = f move.closure; - } - in - Move_within_set_of_closures move - | Field (field_index, var) -> Field (field_index, f var) diff --git a/middle_end/projection.mli b/middle_end/projection.mli deleted file mode 100644 index 1b251ca262..0000000000 --- a/middle_end/projection.mli +++ /dev/null @@ -1,80 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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. *) -(* *) -(**************************************************************************) - -(** Representation of projections from closures and blocks. *) - -(** The selection of one closure given a set of closures, required before - a function defined by said set of closures can be applied. See more - detailed documentation below on [set_of_closures]. *) -type project_closure = { - set_of_closures : Variable.t; (** must yield a set of closures *) - closure_id : Closure_id.t; -} - -(** The selection of one closure given another closure in the same set of - closures. See more detailed documentation below on [set_of_closures]. - The [move_to] closure must be part of the free variables of - [start_from]. *) -type move_within_set_of_closures = { - closure : Variable.t; (** must yield a closure *) - start_from : Closure_id.t; - move_to : Closure_id.t; -} - -(** The selection from a closure of a variable bound by said closure. - In other words, access to a function's environment. Also see more - detailed documentation below on [set_of_closures]. *) -type project_var = { - closure : Variable.t; (** must yield a closure *) - closure_id : Closure_id.t; - var : Var_within_closure.t; -} - -val print_project_closure - : Format.formatter - -> project_closure - -> unit - -val print_move_within_set_of_closures - : Format.formatter - -> move_within_set_of_closures - -> unit - -val print_project_var - : Format.formatter - -> project_var - -> unit - -val compare_project_var : project_var -> project_var -> int -val compare_project_closure : project_closure -> project_closure -> int -val compare_move_within_set_of_closures - : move_within_set_of_closures - -> move_within_set_of_closures - -> int - -type t = - | Project_var of project_var - | Project_closure of project_closure - | Move_within_set_of_closures of move_within_set_of_closures - | Field of int * Variable.t - -include Identifiable.S with type t := t - -(** Return which variable the given projection projects from. *) -val projecting_from : t -> Variable.t - -(** Change the variable that the given projection projects from. *) -val map_projecting_from : t -> f:(Variable.t -> Variable.t) -> t diff --git a/middle_end/ref_to_variables.ml b/middle_end/ref_to_variables.ml deleted file mode 100644 index f93948f912..0000000000 --- a/middle_end/ref_to_variables.ml +++ /dev/null @@ -1,199 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -let variables_not_used_as_local_reference (tree:Flambda.t) = - let set = ref Variable.Set.empty in - let rec loop_named (flam : Flambda.named) = - match flam with - (* Directly used block: does not prevent use as a variable *) - | Prim(Pfield _, [_], _) - | Prim(Poffsetref _, [_], _) -> () - | Prim(Psetfield _, [_block; v], _) -> - (* block is not prevented to be used as a local reference, but v is *) - set := Variable.Set.add v !set - | Prim(_, _, _) - | Symbol _ |Const _ | Allocated_const _ | Read_mutable _ - | Read_symbol_field _ | Project_closure _ - | Move_within_set_of_closures _ | Project_var _ -> - set := Variable.Set.union !set (Flambda.free_variables_named flam) - | Set_of_closures set_of_closures -> - set := Variable.Set.union !set (Flambda.free_variables_named flam); - Variable.Map.iter (fun _ (function_decl : Flambda.function_declaration) -> - loop function_decl.body) - set_of_closures.function_decls.funs - | Expr e -> - loop e - and loop (flam : Flambda.t) = - match flam with - | Let { defining_expr; body; _ } -> - loop_named defining_expr; - loop body - | Let_rec (defs, body) -> - List.iter (fun (_var, named) -> loop_named named) defs; - loop body - | Var v -> - set := Variable.Set.add v !set - | Let_mutable { initial_value = v; body } -> - set := Variable.Set.add v !set; - loop body - | If_then_else (cond, ifso, ifnot) -> - set := Variable.Set.add cond !set; - loop ifso; - loop ifnot - | Switch (cond, { consts; blocks; failaction }) -> - set := Variable.Set.add cond !set; - List.iter (fun (_, branch) -> loop branch) consts; - List.iter (fun (_, branch) -> loop branch) blocks; - Misc.may loop failaction - | String_switch (cond, branches, default) -> - set := Variable.Set.add cond !set; - List.iter (fun (_, branch) -> loop branch) branches; - Misc.may loop default - | Static_catch (_, _, body, handler) -> - loop body; - loop handler - | Try_with (body, _, handler) -> - loop body; - loop handler - | While (cond, body) -> - loop cond; - loop body - | For { bound_var = _; from_value; to_value; direction = _; body; } -> - set := Variable.Set.add from_value !set; - set := Variable.Set.add to_value !set; - loop body - | Static_raise (_, args) -> - set := Variable.Set.union (Variable.Set.of_list args) !set - | Proved_unreachable | Apply _ | Send _ | Assign _ -> - set := Variable.Set.union !set (Flambda.free_variables flam) - in - loop tree; - !set - -let variables_containing_ref (flam:Flambda.t) = - let map = ref Variable.Map.empty in - let aux (flam : Flambda.t) = - match flam with - | Let { var; - defining_expr = Prim(Pmakeblock(0, Asttypes.Mutable, _), l, _); - } -> - map := Variable.Map.add var (List.length l) !map - | _ -> () - in - Flambda_iterators.iter aux (fun _ -> ()) flam; - !map - -let eliminate_ref_of_expr flam = - let variables_not_used_as_local_reference = - variables_not_used_as_local_reference flam - in - let convertible_variables = - Variable.Map.filter - (fun v _ -> - not (Variable.Set.mem v variables_not_used_as_local_reference)) - (variables_containing_ref flam) - in - if Variable.Map.cardinal convertible_variables = 0 then flam - else - let convertible_variables = - Variable.Map.mapi (fun v size -> - Array.init size (fun _ -> Mutable_variable.create_from_variable v)) - convertible_variables - in - let convertible_variable v = Variable.Map.mem v convertible_variables in - let get_variable v field = - let arr = try Variable.Map.find v convertible_variables - with Not_found -> assert false in - if Array.length arr <= field - then None (* This case could apply when inlining code containing GADTS *) - else Some (arr.(field), Array.length arr) - in - let aux (flam : Flambda.t) : Flambda.t = - match flam with - | Let { var; - defining_expr = Prim(Pmakeblock(0, Asttypes.Mutable, shape), l,_); - body } - when convertible_variable var -> - let shape = match shape with - | None -> List.map (fun _ -> Lambda.Pgenval) l - | Some shape -> shape - in - let _, expr = - List.fold_left2 (fun (field,body) init kind -> - match get_variable var field with - | None -> assert false - | Some (field_var, _) -> - field+1, - (Let_mutable { var = field_var; - initial_value = init; - body; - contents_kind = kind } : Flambda.t)) - (0,body) l shape in - expr - | Let _ | Let_mutable _ - | Assign _ | Var _ | Apply _ - | Let_rec _ | Switch _ | String_switch _ - | Static_raise _ | Static_catch _ - | Try_with _ | If_then_else _ - | While _ | For _ | Send _ | Proved_unreachable -> - flam - and aux_named (named : Flambda.named) : Flambda.named = - match named with - | Prim(Pfield field, [v], _) - when convertible_variable v -> - (match get_variable v field with - | None -> Expr Proved_unreachable - | Some (var,_) -> Read_mutable var) - | Prim(Poffsetref delta, [v], dbg) - when convertible_variable v -> - (match get_variable v 0 with - | None -> Expr Proved_unreachable - | Some (var,size) -> - if size = 1 - then begin - let mut_name = Internal_variable_names.read_mutable in - let mut = Variable.create mut_name in - let new_value_name = Internal_variable_names.offsetted in - let new_value = Variable.create new_value_name in - let expr = - Flambda.create_let mut (Read_mutable var) - (Flambda.create_let new_value - (Prim(Poffsetint delta, [mut], dbg)) - (Assign { being_assigned = var; new_value })) - in - Expr expr - end - else - Expr Proved_unreachable) - | Prim(Psetfield (field, _, _), [v; new_value], _) - when convertible_variable v -> - (match get_variable v field with - | None -> Expr Proved_unreachable - | Some (being_assigned,_) -> - Expr (Assign { being_assigned; new_value })) - | Prim _ | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ - | Read_symbol_field _ | Set_of_closures _ | Project_closure _ - | Move_within_set_of_closures _ | Project_var _ | Expr _ -> - named - in - Flambda_iterators.map aux aux_named flam - -let eliminate_ref (program:Flambda.program) = - Flambda_iterators.map_exprs_at_toplevel_of_program program - ~f:eliminate_ref_of_expr diff --git a/middle_end/ref_to_variables.mli b/middle_end/ref_to_variables.mli deleted file mode 100644 index 38d3688917..0000000000 --- a/middle_end/ref_to_variables.mli +++ /dev/null @@ -1,23 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -(** Transform [let]-bound references into variables. *) - -val eliminate_ref - : Flambda.program - -> Flambda.program diff --git a/middle_end/remove_free_vars_equal_to_args.ml b/middle_end/remove_free_vars_equal_to_args.ml deleted file mode 100644 index 6327d30cda..0000000000 --- a/middle_end/remove_free_vars_equal_to_args.ml +++ /dev/null @@ -1,99 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -let pass_name = "remove-free-vars-equal-to-args" -let () = Pass_wrapper.register ~pass_name - -let rewrite_one_function_decl ~(function_decl : Flambda.function_declaration) - ~back_free_vars ~specialised_args = - let params_for_equal_free_vars = - List.fold_left (fun subst param -> - match Variable.Map.find param specialised_args with - | exception Not_found -> - (* param is not specialised *) - subst - | (spec_to : Flambda.specialised_to) -> - let outside_var = spec_to.var in - match Variable.Map.find outside_var back_free_vars with - | exception Not_found -> - (* No free variables equal to the param *) - subst - | set -> - (* Replace the free variables equal to a parameter *) - Variable.Set.fold (fun free_var subst -> - Variable.Map.add free_var param subst) - set subst) - Variable.Map.empty (Parameter.List.vars function_decl.params) - in - if Variable.Map.is_empty params_for_equal_free_vars then - function_decl - else - let body = - Flambda_utils.toplevel_substitution - params_for_equal_free_vars - function_decl.body - in - Flambda.update_function_declaration function_decl - ~params:function_decl.params ~body:body - -let rewrite_one_set_of_closures (set_of_closures : Flambda.set_of_closures) = - let back_free_vars = - Variable.Map.fold (fun var (outside_var : Flambda.specialised_to) map -> - let set = - match Variable.Map.find outside_var.var map with - | exception Not_found -> Variable.Set.singleton var - | set -> Variable.Set.add var set - in - Variable.Map.add outside_var.var set map) - set_of_closures.free_vars Variable.Map.empty - in - let done_something = ref false in - let funs = - Variable.Map.map (fun function_decl -> - let new_function_decl = - rewrite_one_function_decl ~function_decl ~back_free_vars - ~specialised_args:set_of_closures.specialised_args - in - if not (new_function_decl == function_decl) then begin - done_something := true - end; - new_function_decl) - set_of_closures.function_decls.funs - in - if not !done_something then - None - else - let function_decls = - Flambda.update_function_declarations - set_of_closures.function_decls ~funs - in - let set_of_closures = - Flambda.create_set_of_closures - ~function_decls - ~free_vars:set_of_closures.free_vars - ~specialised_args:set_of_closures.specialised_args - ~direct_call_surrogates:set_of_closures.direct_call_surrogates - in - Some set_of_closures - -let run ~ppf_dump set_of_closures = - Pass_wrapper.with_dump ~ppf_dump ~pass_name ~input:set_of_closures - ~print_input:Flambda.print_set_of_closures - ~print_output:Flambda.print_set_of_closures - ~f:(fun () -> rewrite_one_set_of_closures set_of_closures) diff --git a/middle_end/remove_free_vars_equal_to_args.mli b/middle_end/remove_free_vars_equal_to_args.mli deleted file mode 100644 index 49f25ac106..0000000000 --- a/middle_end/remove_free_vars_equal_to_args.mli +++ /dev/null @@ -1,23 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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. *) -(* *) -(**************************************************************************) - -(** Replace free variables in closures known to be equal to specialised - arguments of such closures with those specialised arguments. *) - -val run - : ppf_dump:Format.formatter - -> Flambda.set_of_closures - -> Flambda.set_of_closures option diff --git a/middle_end/remove_unused_arguments.ml b/middle_end/remove_unused_arguments.ml deleted file mode 100644 index f70da729ae..0000000000 --- a/middle_end/remove_unused_arguments.ml +++ /dev/null @@ -1,242 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -let pass_name = "remove-unused-arguments" -let () = Clflags.all_passes := pass_name :: !Clflags.all_passes - -let rename_var var = - Variable.rename var - ~current_compilation_unit:(Compilation_unit.get_current_exn ()) - -let remove_params unused (fun_decl: Flambda.function_declaration) - ~new_fun_var = - let unused_params, used_params = - List.partition (fun v -> Variable.Set.mem (Parameter.var v) unused) - fun_decl.params - in - let unused_params = List.filter (fun v -> - Variable.Set.mem (Parameter.var v) fun_decl.free_variables) unused_params - in - let body = - List.fold_left (fun body param -> - Flambda.create_let (Parameter.var param) (Const (Const_pointer 0)) body) - fun_decl.body - unused_params - in - Flambda.create_function_declaration ~params:used_params ~body - ~stub:fun_decl.stub ~dbg:fun_decl.dbg ~inline:fun_decl.inline - ~specialise:fun_decl.specialise ~is_a_functor:fun_decl.is_a_functor - ~closure_origin:(Closure_origin.create (Closure_id.wrap new_fun_var)) - -let make_stub unused var (fun_decl : Flambda.function_declaration) - ~specialised_args ~additional_specialised_args = - let renamed = rename_var var in - let args' = - List.map (fun param -> param, Parameter.rename param) fun_decl.params - in - let used_args' = - List.filter (fun (param, _) -> - not (Variable.Set.mem (Parameter.var param) unused)) args' - in - let args'_var = - List.map (fun (p1, p2) -> Parameter.var p1, Parameter.var p2) args' - in - let args_renaming = Variable.Map.of_list args'_var in - let additional_specialised_args = - List.fold_left (fun additional_specialised_args (original_arg,arg) -> - match Variable.Map.find original_arg specialised_args with - | exception Not_found -> additional_specialised_args - | (outer_var : Flambda.specialised_to) -> - (* CR-soon mshinwell: share with Augment_specialised_args *) - let outer_var : Flambda.specialised_to = - match outer_var.projection with - | None -> outer_var - | Some projection -> - let projection = - Projection.map_projecting_from projection ~f:(fun var -> - match Variable.Map.find var args_renaming with - | exception Not_found -> - (* Must always be a parameter of this - [function_decl]. *) - assert false - | wrapper_arg -> wrapper_arg) - in - { outer_var with - projection = Some projection; - } - in - Variable.Map.add arg outer_var additional_specialised_args) - additional_specialised_args args'_var - in - let args = List.map (fun (_, var) -> var) used_args' in - let kind = Flambda.Direct (Closure_id.wrap renamed) in - let body : Flambda.t = - Apply { - func = renamed; - args = Parameter.List.vars args; - kind; - dbg = fun_decl.dbg; - inline = Default_inline; - specialise = Default_specialise; - } - in - let function_decl = - Flambda.create_function_declaration ~params:(List.map snd args') ~body - ~stub:true ~dbg:fun_decl.dbg ~inline:Default_inline - ~specialise:Default_specialise ~is_a_functor:fun_decl.is_a_functor - ~closure_origin:fun_decl.closure_origin - in - function_decl, renamed, additional_specialised_args - -let separate_unused_arguments ~only_specialised - ~backend ~(set_of_closures : Flambda.set_of_closures) = - let function_decls = set_of_closures.function_decls in - let unused = Invariant_params.unused_arguments ~backend function_decls in - let non_stub_arguments = - Variable.Map.fold (fun _ (decl : Flambda.function_declaration) acc -> - if decl.stub then - acc - else - Variable.Set.union acc (Parameter.Set.vars decl.Flambda.params)) - function_decls.funs Variable.Set.empty - in - let unused = Variable.Set.inter non_stub_arguments unused in - let specialised_args = Variable.Map.keys set_of_closures.specialised_args in - let unused = - if only_specialised then Variable.Set.inter specialised_args unused - else unused - in - if Variable.Set.is_empty unused - then None - else begin - let funs, additional_specialised_args = - Variable.Map.fold (fun fun_id (fun_decl : Flambda.function_declaration) - (funs, additional_specialised_args) -> - if List.exists (fun v -> Variable.Set.mem (Parameter.var v) unused) - fun_decl.params - then begin - let stub, renamed_fun_id, additional_specialised_args = - make_stub unused fun_id fun_decl - ~specialised_args:set_of_closures.specialised_args - ~additional_specialised_args - in - let cleaned = - remove_params unused fun_decl ~new_fun_var:renamed_fun_id - in - Variable.Map.add fun_id stub - (Variable.Map.add renamed_fun_id cleaned funs), - additional_specialised_args - end - else - Variable.Map.add fun_id fun_decl funs, - additional_specialised_args - ) - function_decls.funs (Variable.Map.empty, Variable.Map.empty) - in - let specialised_args = - Variable.Map.disjoint_union additional_specialised_args - (Variable.Map.filter (fun param _ -> - not (Variable.Set.mem param unused)) - set_of_closures.specialised_args) - in - let specialised_args = - Flambda_utils.clean_projections ~which_variables:specialised_args - in - let function_decls = - Flambda.update_function_declarations function_decls ~funs - in - let set_of_closures = - Flambda.create_set_of_closures ~function_decls - ~free_vars:set_of_closures.free_vars ~specialised_args - (* CR-soon mshinwell: Use direct_call_surrogates for this - transformation. *) - ~direct_call_surrogates:set_of_closures.direct_call_surrogates - in - Some set_of_closures - end - -(* Splitting is not always beneficial. For instance when a function - is only indirectly called, suppressing unused arguments does not - benefit, and introduce an useless intermediate call. Specialised - args should always be beneficial since they should not be used in - indirect calls. *) -let should_split_only_specialised_args - (fun_decls : Flambda.function_declarations) - ~backend = - if not !Clflags.remove_unused_arguments then begin - true - end else begin - let no_recursive_functions = - Variable.Set.is_empty - (Find_recursive_functions.in_function_declarations fun_decls ~backend) - in - let number_of_non_stub_functions = - Variable.Map.cardinal - (Variable.Map.filter (fun _ { Flambda.stub } -> not stub) - fun_decls.funs) - in - (* CR-soon lwhite: this criteria could use some justification. - mshinwell: pchambart cannot remember how these criteria arose, - but we're going to leave this as-is for 4.03. *) - no_recursive_functions && (number_of_non_stub_functions <= 1) - end - -let separate_unused_arguments_in_set_of_closures set_of_closures ~backend = - let dump = Clflags.dumped_pass pass_name in - let only_specialised = - should_split_only_specialised_args - set_of_closures.Flambda.function_decls - ~backend - in - match separate_unused_arguments - ~only_specialised ~backend ~set_of_closures with - | None -> - if dump then - Format.eprintf "No change for Remove_unused_arguments:@ %a@.@." - Flambda.print_set_of_closures set_of_closures; - None - | Some result -> - if dump then - Format.eprintf "Before Remove_unused_arguments:@ %a@.@.\ - After Remove_unused_arguments:@ %a@.@." - Flambda.print_set_of_closures set_of_closures - Flambda.print_set_of_closures result; - Some result - -let separate_unused_arguments_in_closures_expr tree ~backend = - let aux_named (named : Flambda.named) : Flambda.named = - match named with - | Set_of_closures set_of_closures -> begin - let only_specialised = - should_split_only_specialised_args - set_of_closures.function_decls - ~backend - in - match separate_unused_arguments - ~only_specialised ~backend ~set_of_closures with - | None -> named - | Some set_of_closures -> Set_of_closures set_of_closures - end - | e -> e - in - Flambda_iterators.map_named aux_named tree - -let separate_unused_arguments_in_closures program ~backend = - Flambda_iterators.map_exprs_at_toplevel_of_program program ~f:(fun expr -> - separate_unused_arguments_in_closures_expr expr ~backend) diff --git a/middle_end/remove_unused_arguments.mli b/middle_end/remove_unused_arguments.mli deleted file mode 100644 index 759b32f2d2..0000000000 --- a/middle_end/remove_unused_arguments.mli +++ /dev/null @@ -1,39 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -(** Introduce a stub function to avoid depending on unused arguments. - - For instance, it turns - [let rec fact n unused = - if n = 0 then 1 - else n * fact (n-1) unused] - into - [let rec fact' n = - if n = 0 then 1 - else n * fact' (n-1) - and fact n unused = fact' n] -*) -val separate_unused_arguments_in_closures - : Flambda.program - -> backend:(module Backend_intf.S) - -> Flambda.program - -val separate_unused_arguments_in_set_of_closures - : Flambda.set_of_closures - -> backend:(module Backend_intf.S) - -> Flambda.set_of_closures option diff --git a/middle_end/remove_unused_closure_vars.ml b/middle_end/remove_unused_closure_vars.ml deleted file mode 100644 index 0d4ad621dd..0000000000 --- a/middle_end/remove_unused_closure_vars.ml +++ /dev/null @@ -1,125 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -(** A variable in a closure can either be used by the closure itself - or by an inlined version of the function. *) -let remove_unused_closure_variables ~remove_direct_call_surrogates program = - let used_vars_within_closure, used_closure_ids = - let used = Var_within_closure.Tbl.create 13 in - let used_fun = Closure_id.Tbl.create 13 in - let aux_named (named : Flambda.named) = - match named with - | Project_closure { set_of_closures = _; closure_id } -> - Closure_id.Tbl.add used_fun closure_id () - | Project_var { closure_id; var } -> - Var_within_closure.Tbl.add used var (); - Closure_id.Tbl.add used_fun closure_id () - | Move_within_set_of_closures { closure = _; start_from; move_to } -> - Closure_id.Tbl.add used_fun start_from (); - Closure_id.Tbl.add used_fun move_to () - | Symbol _ | Const _ | Set_of_closures _ | Prim _ | Expr _ - | Allocated_const _ | Read_mutable _ | Read_symbol_field _ -> () - in - Flambda_iterators.iter_named_of_program ~f:aux_named program; - used, used_fun - in - let aux_named _ (named : Flambda.named) : Flambda.named = - match named with - | Set_of_closures ({ function_decls; free_vars; _ } as set_of_closures) -> - let direct_call_surrogates = - if remove_direct_call_surrogates then Variable.Set.empty - else - Variable.Set.of_list - (Variable.Map.data set_of_closures.direct_call_surrogates) - in - let rec add_needed needed_funs remaining_funs free_vars_of_kept_funs = - let new_needed_funs, remaining_funs = - (* Keep a function if it is used either by the rest of the code, - (in used_closure_ids), or by any other kept function - (in free_vars_of_kept_funs) *) - Variable.Map.partition (fun fun_id _ -> - Variable.Set.mem fun_id free_vars_of_kept_funs - || Closure_id.Tbl.mem used_closure_ids - (Closure_id.wrap fun_id) - || Variable.Set.mem fun_id direct_call_surrogates) - remaining_funs - in - if Variable.Map.is_empty new_needed_funs then - (* If no new function is needed, we reached fixpoint *) - needed_funs, free_vars_of_kept_funs - else begin - let needed_funs = - Variable.Map.disjoint_union needed_funs new_needed_funs - in - let free_vars_of_kept_funs = - Variable.Map.fold (fun _ { Flambda. free_variables } acc -> - Variable.Set.union free_variables acc) - new_needed_funs - free_vars_of_kept_funs - in - add_needed needed_funs remaining_funs free_vars_of_kept_funs - end - in - let funs, free_vars_of_kept_funs = - add_needed Variable.Map.empty function_decls.funs Variable.Set.empty - in - let free_vars = - Variable.Map.filter (fun id _var -> - Variable.Set.mem id free_vars_of_kept_funs - || Var_within_closure.Tbl.mem - used_vars_within_closure - (Var_within_closure.wrap id)) - free_vars - in - let function_decls = - Flambda.update_function_declarations function_decls ~funs - in - let specialised_args = - (* Remove specialised args that are used by removed functions *) - let all_remaining_arguments = - Variable.Map.fold (fun _ { Flambda.params } set -> - Variable.Set.union set (Parameter.Set.vars params)) - funs Variable.Set.empty - in - Variable.Map.filter (fun arg _ -> - Variable.Set.mem arg all_remaining_arguments) - set_of_closures.specialised_args - in - let free_vars = - Flambda_utils.clean_projections ~which_variables:free_vars - in - let direct_call_surrogates = - (* Remove direct call surrogates where either the existing function - or the surrogate has been eliminated. *) - Variable.Map.fold (fun existing surrogate surrogates -> - if not (Variable.Map.mem existing funs) - || not (Variable.Map.mem surrogate funs) - then surrogates - else Variable.Map.add existing surrogate surrogates) - set_of_closures.direct_call_surrogates - Variable.Map.empty - in - let set_of_closures = - Flambda.create_set_of_closures ~function_decls - ~free_vars ~specialised_args ~direct_call_surrogates - in - Set_of_closures set_of_closures - | e -> e - in - Flambda_iterators.map_named_of_program ~f:aux_named program diff --git a/middle_end/remove_unused_closure_vars.mli b/middle_end/remove_unused_closure_vars.mli deleted file mode 100644 index 225697a814..0000000000 --- a/middle_end/remove_unused_closure_vars.mli +++ /dev/null @@ -1,26 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -(* CR-soon mshinwell: Rename this module. *) - -(** Eliminate variables bound by sets of closures that are not required. - Also eliminate functions within sets of closures that are not required. *) -val remove_unused_closure_variables - : remove_direct_call_surrogates:bool - -> Flambda.program - -> Flambda.program diff --git a/middle_end/remove_unused_program_constructs.ml b/middle_end/remove_unused_program_constructs.ml deleted file mode 100644 index 059d68bcba..0000000000 --- a/middle_end/remove_unused_program_constructs.ml +++ /dev/null @@ -1,111 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -let dependency (expr:Flambda.t) = Flambda.free_symbols expr - -(* CR-soon pchambart: copied from lift_constant. Needs remerging *) -let constant_dependencies (const:Flambda.constant_defining_value) = - let closure_dependencies (set_of_closures:Flambda.set_of_closures) = - Flambda.free_symbols_named (Set_of_closures set_of_closures) - in - match const with - | Allocated_const _ -> Symbol.Set.empty - | Block (_, fields) -> - let symbol_fields = - List.filter_map (function - | (Symbol s : Flambda.constant_defining_value_block_field) -> - Some s - | Flambda.Const _ -> None) - fields - in - Symbol.Set.of_list symbol_fields - | Set_of_closures set_of_closures -> closure_dependencies set_of_closures - | Project_closure (s, _) -> Symbol.Set.singleton s - -let let_rec_dep defs dep = - let add_deps l dep = - List.fold_left (fun dep (sym, sym_dep) -> - if Symbol.Set.mem sym dep then Symbol.Set.union dep sym_dep - else dep) - dep l - in - let defs_deps = - List.map (fun (sym, def) -> sym, constant_dependencies def) defs - in - let rec fixpoint dep = - let new_dep = add_deps defs_deps dep in - if Symbol.Set.equal dep new_dep then dep - else fixpoint new_dep - in - fixpoint dep - -let rec loop (program : Flambda.program_body) - : Flambda.program_body * Symbol.Set.t = - match program with - | Let_symbol (sym, def, program) -> - let program, dep = loop program in - if Symbol.Set.mem sym dep then - Let_symbol (sym, def, program), - Symbol.Set.union dep (constant_dependencies def) - else - program, dep - | Let_rec_symbol (defs, program) -> - let program, dep = loop program in - let dep = let_rec_dep defs dep in - let defs = - List.filter (fun (sym, _) -> Symbol.Set.mem sym dep) defs - in begin match defs with - | [] -> program, dep - | _ -> Let_rec_symbol (defs, program), dep - end - | Initialize_symbol (sym, tag, fields, program) -> - let program, dep = loop program in - if Symbol.Set.mem sym dep then - let dep = - List.fold_left (fun dep field -> - Symbol.Set.union dep (dependency field)) - dep fields - in - Initialize_symbol (sym, tag, fields, program), dep - else begin - List.fold_left - (fun (program, dep) field -> - if Effect_analysis.no_effects field then - program, dep - else - let new_dep = dependency field in - let dep = Symbol.Set.union new_dep dep in - Flambda.Effect (field, program), dep) - (program, dep) fields - end - | Effect (effect, program) -> - let program, dep = loop program in - if Effect_analysis.no_effects effect then begin - program, dep - end else begin - let new_dep = dependency effect in - let dep = Symbol.Set.union new_dep dep in - Effect (effect, program), dep - end - | End symbol -> program, Symbol.Set.singleton symbol - -let remove_unused_program_constructs (program : Flambda.program) = - { program with - program_body = fst (loop program.program_body); - } diff --git a/middle_end/remove_unused_program_constructs.mli b/middle_end/remove_unused_program_constructs.mli deleted file mode 100644 index 3a722011bb..0000000000 --- a/middle_end/remove_unused_program_constructs.mli +++ /dev/null @@ -1,24 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -(* Remove unused [Flambda.program] constructs from the given program. - - Symbols (whose defining expressions have no effects) are eliminated - if unused. - - [Effect] constructs that turn out to have no effects are eliminated. -*) -val remove_unused_program_constructs : Flambda.program -> Flambda.program diff --git a/middle_end/semantics_of_primitives.ml b/middle_end/semantics_of_primitives.ml new file mode 100644 index 0000000000..2daf167ecd --- /dev/null +++ b/middle_end/semantics_of_primitives.ml @@ -0,0 +1,153 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +type effects = No_effects | Only_generative_effects | Arbitrary_effects +type coeffects = No_coeffects | Has_coeffects + +let for_primitive (prim : Clambda_primitives.primitive) = + match prim with + | Pmakeblock _ + | Pmakearray (_, Mutable) -> Only_generative_effects, No_coeffects + | Pmakearray (_, Immutable) -> No_effects, No_coeffects + | Pduparray (_, Immutable) -> + No_effects, No_coeffects (* Pduparray (_, Immutable) is allowed only on + immutable arrays. *) + | Pduparray (_, Mutable) | Pduprecord _ -> + Only_generative_effects, Has_coeffects + | Pccall { prim_name = + ( "caml_format_float" | "caml_format_int" | "caml_int32_format" + | "caml_nativeint_format" | "caml_int64_format" ) } -> + No_effects, No_coeffects + | Pccall _ -> Arbitrary_effects, Has_coeffects + | Praise _ -> Arbitrary_effects, No_coeffects + | Pnot + | Pnegint + | Paddint + | Psubint + | Pmulint + | Pandint + | Porint + | Pxorint + | Plslint + | Plsrint + | Pasrint + | Pintcomp _ -> No_effects, No_coeffects + | Pdivbint { is_safe = Unsafe } + | Pmodbint { is_safe = Unsafe } + | Pdivint Unsafe + | Pmodint Unsafe -> + No_effects, No_coeffects (* Will not raise [Division_by_zero]. *) + | Pdivbint { is_safe = Safe } + | Pmodbint { is_safe = Safe } + | Pdivint Safe + | Pmodint Safe -> + Arbitrary_effects, No_coeffects + | Poffsetint _ -> No_effects, No_coeffects + | Poffsetref _ -> Arbitrary_effects, Has_coeffects + | Pintoffloat + | Pfloatofint + | Pnegfloat + | Pabsfloat + | Paddfloat + | Psubfloat + | Pmulfloat + | Pdivfloat + | Pfloatcomp _ -> No_effects, No_coeffects + | Pstringlength | Pbyteslength + | Parraylength _ -> + No_effects, Has_coeffects (* That old chestnut: [Obj.truncate]. *) + | Pisint + | Pisout + | Pbintofint _ + | Pintofbint _ + | Pcvtbint _ + | Pnegbint _ + | Paddbint _ + | Psubbint _ + | Pmulbint _ + | Pandbint _ + | Porbint _ + | Pxorbint _ + | Plslbint _ + | Plsrbint _ + | Pasrbint _ + | Pbintcomp _ -> No_effects, No_coeffects + | Pbigarraydim _ -> + No_effects, Has_coeffects (* Some people resize bigarrays in place. *) + | Pread_symbol _ + | Pfield _ + | Pfield_computed + | Pfloatfield _ + | Parrayrefu _ + | Pstringrefu + | Pbytesrefu + | Pstring_load (_, Unsafe) + | Pbytes_load (_, Unsafe) + | Pbigarrayref (true, _, _, _) + | Pbigstring_load (_, Unsafe) -> + No_effects, Has_coeffects + | Parrayrefs _ + | Pstringrefs + | Pbytesrefs + | Pstring_load (_, Safe) + | Pbytes_load (_, Safe) + | Pbigarrayref (false, _, _, _) + | Pbigstring_load (_, Safe) -> + (* May trigger a bounds check exception. *) + Arbitrary_effects, Has_coeffects + | Psetfield _ + | Psetfield_computed _ + | Psetfloatfield _ + | Parraysetu _ + | Parraysets _ + | Pbytessetu + | Pbytessets + | Pbytes_set _ + | Pbigarrayset _ + | Pbigstring_set _ -> + (* Whether or not some of these are "unsafe" is irrelevant; they always + have an effect. *) + Arbitrary_effects, No_coeffects + | Pbswap16 + | Pbbswap _ -> No_effects, No_coeffects + | Pint_as_pointer -> No_effects, No_coeffects + | Popaque -> Arbitrary_effects, Has_coeffects + | Psequand + | Psequor -> + (* Removed by [Closure_conversion] in the flambda pipeline. *) + No_effects, No_coeffects + +type return_type = + | Float + | Other + +let return_type_of_primitive (prim:Clambda_primitives.primitive) = + match prim with + | Pfloatofint + | Pnegfloat + | Pabsfloat + | Paddfloat + | Psubfloat + | Pmulfloat + | Pdivfloat + | Pfloatfield _ + | Parrayrefu Pfloatarray + | Parrayrefs Pfloatarray -> + Float + | _ -> + Other diff --git a/middle_end/semantics_of_primitives.mli b/middle_end/semantics_of_primitives.mli new file mode 100644 index 0000000000..78407df71d --- /dev/null +++ b/middle_end/semantics_of_primitives.mli @@ -0,0 +1,69 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(** Description of the semantics of primitives, to be used for optimization + purposes. + + "No effects" means that the primitive does not change the observable state + of the world. For example, it must not write to any mutable storage, + call arbitrary external functions or change control flow (e.g. by raising + an exception). Note that allocation is not "No effects" (see below). + + It is assumed in the compiler that applications of primitives with no + effects, whose results are not used, may be eliminated. It is further + assumed that applications of primitives with no effects may be + duplicated (and thus possibly executed more than once). + + (Exceptions arising from allocation points, for example "out of memory" or + exceptions propagated from finalizers or signal handlers, are treated as + "effects out of the ether" and thus ignored for our determination here + of effectfulness. The same goes for floating point operations that may + cause hardware traps on some platforms.) + + "Only generative effects" means that a primitive does not change the + observable state of the world save for possibly affecting the state of + the garbage collector by performing an allocation. Applications of + primitives that only have generative effects and whose results are unused + may be eliminated by the compiler. However, unlike "No effects" + primitives, such applications will never be eligible for duplication. + + "Arbitrary effects" covers all other primitives. + + "No coeffects" means that the primitive does not observe the effects (in + the sense described above) of other expressions. For example, it must not + read from any mutable storage or call arbitrary external functions. + + It is assumed in the compiler that, subject to data dependencies, + expressions with neither effects nor coeffects may be reordered with + respect to other expressions. +*) + +type effects = No_effects | Only_generative_effects | Arbitrary_effects +type coeffects = No_coeffects | Has_coeffects + +(** Describe the semantics of a primitive. This does not take into account of + the (non-)(co)effectfulness of the arguments in a primitive application. + To determine whether such an application is (co)effectful, the arguments + must also be analysed. *) +val for_primitive: Clambda_primitives.primitive -> effects * coeffects + +type return_type = + | Float + | Other + +val return_type_of_primitive: Clambda_primitives.primitive -> return_type diff --git a/middle_end/share_constants.ml b/middle_end/share_constants.ml deleted file mode 100644 index 2bbd7134b8..0000000000 --- a/middle_end/share_constants.ml +++ /dev/null @@ -1,130 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -module Constant_defining_value = Flambda.Constant_defining_value - -let update_constant_for_sharing sharing_symbol_tbl const - : Flambda.constant_defining_value = - let substitute_symbol sym = - match Symbol.Tbl.find sharing_symbol_tbl sym with - | exception Not_found -> sym - | symbol -> symbol - in - match (const:Flambda.constant_defining_value) with - | Allocated_const _ -> const - | Block (tag, fields) -> - let subst_field (field:Flambda.constant_defining_value_block_field) : - Flambda.constant_defining_value_block_field = - match field with - | Const _ -> field - | Symbol sym -> - Symbol (substitute_symbol sym) - in - let fields = List.map subst_field fields in - Block (tag, fields) - | Set_of_closures set_of_closures -> - Set_of_closures ( - Flambda_iterators.map_symbols_on_set_of_closures - ~f:substitute_symbol set_of_closures - ) - | Project_closure (sym, closure_id) -> - Project_closure (substitute_symbol sym, closure_id) - -let cannot_share (const : Flambda.constant_defining_value) = - match const with - (* Strings and float arrays are mutable; we never share them. *) - | Allocated_const ((String _) | (Float_array _)) -> true - | Allocated_const _ | Set_of_closures _ | Project_closure _ | Block _ -> - false - -let share_definition constant_to_symbol_tbl sharing_symbol_tbl - symbol def end_symbol = - let def = update_constant_for_sharing sharing_symbol_tbl def in - if cannot_share def || Symbol.equal symbol end_symbol then - (* The symbol exported by the unit (end_symbol), cannot be removed - from the module. We prevent it from being shared to avoid that. *) - Some def - else - begin match Constant_defining_value.Tbl.find constant_to_symbol_tbl def with - | exception Not_found -> - Constant_defining_value.Tbl.add constant_to_symbol_tbl def symbol; - Some def - | equal_symbol -> - Symbol.Tbl.add sharing_symbol_tbl symbol equal_symbol; - None - end - -let rec end_symbol (program : Flambda.program_body) = - match program with - | End symbol -> symbol - | Let_symbol (_, _, program) - | Let_rec_symbol (_, program) - | Initialize_symbol (_, _, _, program) - | Effect (_, program) -> - end_symbol program - -let share_constants (program : Flambda.program) = - let end_symbol = end_symbol program.program_body in - let sharing_symbol_tbl = Symbol.Tbl.create 42 in - let constant_to_symbol_tbl = Constant_defining_value.Tbl.create 42 in - let rec loop (program : Flambda.program_body) : Flambda.program_body = - match program with - | Let_symbol (symbol,def,program) -> - begin match - share_definition constant_to_symbol_tbl sharing_symbol_tbl symbol - def end_symbol - with - | None -> - loop program - | Some def' -> - Let_symbol (symbol,def',loop program) - end - | Let_rec_symbol (defs,program) -> - let defs = - List.map (fun (symbol, def) -> - let def = update_constant_for_sharing sharing_symbol_tbl def in - symbol, def) - defs - in - Let_rec_symbol (defs, loop program) - | Initialize_symbol (symbol,tag,fields,program) -> - let fields = - List.map (fun field -> - Flambda_iterators.map_symbols - ~f:(fun symbol -> - try Symbol.Tbl.find sharing_symbol_tbl symbol with - | Not_found -> symbol) - field) - fields - in - Initialize_symbol (symbol,tag,fields,loop program) - | Effect (expr,program) -> - let expr = - Flambda_iterators.map_symbols - ~f:(fun symbol -> - try Symbol.Tbl.find sharing_symbol_tbl symbol with - | Not_found -> symbol) - expr - in - Effect (expr, loop program) - | End root -> End root - in - { program with - program_body = loop program.program_body; - } diff --git a/middle_end/share_constants.mli b/middle_end/share_constants.mli deleted file mode 100644 index 7fec22bc44..0000000000 --- a/middle_end/share_constants.mli +++ /dev/null @@ -1,22 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -(** Share lifted constants that are eligible for sharing (e.g. not strings) - and have equal definitions. *) - -val share_constants : Flambda.program -> Flambda.program diff --git a/middle_end/simple_value_approx.ml b/middle_end/simple_value_approx.ml deleted file mode 100644 index 34fc5ce056..0000000000 --- a/middle_end/simple_value_approx.ml +++ /dev/null @@ -1,1043 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -module U = Flambda_utils - -type 'a boxed_int = - | Int32 : int32 boxed_int - | Int64 : int64 boxed_int - | Nativeint : nativeint boxed_int - -type value_string = { - (* CR-soon mshinwell: use variant *) - contents : string option; (* None if unknown or mutable *) - size : int; -} - -type unresolved_value = - | Set_of_closures_id of Set_of_closures_id.t - | Symbol of Symbol.t - -type unknown_because_of = - | Unresolved_value of unresolved_value - | Other - -type t = { - descr : descr; - var : Variable.t option; - symbol : (Symbol.t * int option) option; -} - -and descr = - | Value_block of Tag.t * t array - | Value_int of int - | Value_char of char - | Value_constptr of int - | Value_float of float option - | Value_boxed_int : 'a boxed_int * 'a -> descr - | Value_set_of_closures of value_set_of_closures - | Value_closure of value_closure - | Value_string of value_string - | Value_float_array of value_float_array - | Value_unknown of unknown_because_of - | Value_bottom - | Value_extern of Export_id.t - | Value_symbol of Symbol.t - | Value_unresolved of unresolved_value - (* No description was found for this value *) - -and value_closure = { - set_of_closures : t; - closure_id : Closure_id.t; -} - -and function_declarations = { - is_classic_mode : bool; - set_of_closures_id : Set_of_closures_id.t; - set_of_closures_origin : Set_of_closures_origin.t; - funs : function_declaration Variable.Map.t; -} - -and function_body = { - free_variables : Variable.Set.t; - free_symbols : Symbol.Set.t; - stub : bool; - dbg : Debuginfo.t; - inline : Lambda.inline_attribute; - specialise : Lambda.specialise_attribute; - is_a_functor : bool; - body : Flambda.t; -} - -and function_declaration = { - closure_origin : Closure_origin.t; - params : Parameter.t list; - function_body : function_body option; -} - -and value_set_of_closures = { - function_decls : function_declarations; - bound_vars : t Var_within_closure.Map.t; - free_vars : Flambda.specialised_to Variable.Map.t; - invariant_params : Variable.Set.t Variable.Map.t Lazy.t; - recursive : Variable.Set.t Lazy.t; - size : int option Variable.Map.t Lazy.t; - specialised_args : Flambda.specialised_to Variable.Map.t; - freshening : Freshening.Project_var.t; - direct_call_surrogates : Closure_id.t Closure_id.Map.t; -} - -and value_float_array_contents = - | Contents of t array - | Unknown_or_mutable - -and value_float_array = { - contents : value_float_array_contents; - size : int; -} - -let descr t = t.descr - -let print_value_set_of_closures ppf - { function_decls = { funs }; invariant_params; freshening; size; _ } = - Format.fprintf ppf - "(set_of_closures:@ %a invariant_params=%a freshening=%a size=%a)" - (fun ppf -> Variable.Map.iter (fun id _ -> Variable.print ppf id)) funs - (Variable.Map.print Variable.Set.print) (Lazy.force invariant_params) - Freshening.Project_var.print freshening - (Variable.Map.print (fun ppf some_size -> - match some_size with - | None -> Format.fprintf ppf "None" - | Some size -> Format.fprintf ppf "Some %d" size)) - (Lazy.force size) - -let print_unresolved_value ppf = function - | Set_of_closures_id set -> - Format.fprintf ppf "Set_of_closures_id %a" Set_of_closures_id.print set - | Symbol symbol -> - Format.fprintf ppf "Symbol %a" Symbol.print symbol - -let print_function_declaration ppf var (f : function_declaration) = - let param ppf p = Variable.print ppf (Parameter.var p) in - let params ppf = List.iter (Format.fprintf ppf "@ %a" param) in - match f.function_body with - | None -> - Format.fprintf ppf "@[<2>(%a@ =@ fun@[<2>%a@])@]@ " - Variable.print var params f.params - | Some (b : function_body) -> - let stub = if b.stub then " *stub*" else "" in - let is_a_functor = if b.is_a_functor then " *functor*" else "" in - let inline = - match b.inline with - | Always_inline -> " *inline*" - | Never_inline -> " *never_inline*" - | Unroll _ -> " *unroll*" - | Default_inline -> "" - in - let specialise = - match b.specialise with - | Always_specialise -> " *specialise*" - | Never_specialise -> " *never_specialise*" - | Default_specialise -> "" - in - let print_body ppf _ = - Format.fprintf ppf "" - in - Format.fprintf ppf "@[<2>(%a%s%s%s%s@ =@ fun@[<2>%a@] ->@ @[<2><%a>@])@]@ " - Variable.print var stub is_a_functor inline specialise - params f.params - print_body b - -let print_function_declarations ppf (fd : function_declarations) = - let funs ppf = Variable.Map.iter (print_function_declaration ppf) in - Format.fprintf ppf "@[<2>(%a)@]" funs fd.funs - -let rec print_descr ppf = function - | Value_int i -> Format.pp_print_int ppf i - | Value_char c -> Format.fprintf ppf "%c" c - | Value_constptr i -> Format.fprintf ppf "%ia" i - | Value_block (tag,fields) -> - let p ppf fields = - Array.iter (fun v -> Format.fprintf ppf "%a@ " print v) fields in - Format.fprintf ppf "[%i:@ @[<1>%a@]]" (Tag.to_int tag) p fields - | Value_unknown reason -> - begin match reason with - | Unresolved_value value -> - Format.fprintf ppf "?(due to unresolved %a)" print_unresolved_value value - | Other -> Format.fprintf ppf "?" - end; - | Value_bottom -> Format.fprintf ppf "bottom" - | Value_extern id -> Format.fprintf ppf "_%a_" Export_id.print id - | Value_symbol sym -> Format.fprintf ppf "%a" Symbol.print sym - | Value_closure { set_of_closures; closure_id; } -> - Format.fprintf ppf "(closure:@ %a from@ %a)" Closure_id.print closure_id - print set_of_closures - | Value_set_of_closures set_of_closures -> - print_value_set_of_closures ppf set_of_closures - | Value_unresolved value -> - Format.fprintf ppf "(unresolved %a)" print_unresolved_value value - | Value_float (Some f) -> Format.pp_print_float ppf f - | Value_float None -> Format.pp_print_string ppf "float" - | Value_string { contents; size } -> begin - match contents with - | None -> - Format.fprintf ppf "string %i" size - | Some s -> - let s = - if size > 10 - then String.sub s 0 8 ^ "..." - else s - in - Format.fprintf ppf "string %i %S" size s - end - | Value_float_array float_array -> - begin match float_array.contents with - | Unknown_or_mutable -> - Format.fprintf ppf "float_array %i" float_array.size - | Contents _ -> - Format.fprintf ppf "float_array_imm %i" float_array.size - end - | Value_boxed_int (t, i) -> - match t with - | Int32 -> Format.fprintf ppf "%li" i - | Int64 -> Format.fprintf ppf "%Li" i - | Nativeint -> Format.fprintf ppf "%ni" i - -and print ppf { descr; var; symbol; } = - let print ppf = function - | None -> Symbol.print_opt ppf None - | Some (sym, None) -> Symbol.print ppf sym - | Some (sym, Some field) -> - Format.fprintf ppf "%a.(%i)" Symbol.print sym field - in - Format.fprintf ppf "{ descr=%a var=%a symbol=%a }" - print_descr descr - Variable.print_opt var - print symbol - -let approx descr = { descr; var = None; symbol = None } - -let augment_with_variable t var = { t with var = Some var } -let augment_with_symbol t symbol = { t with symbol = Some (symbol, None) } -let augment_with_symbol_field t symbol field = - match t.symbol with - | None -> { t with symbol = Some (symbol, Some field) } - | Some _ -> t -let replace_description t descr = { t with descr } - -let augment_with_kind t (kind:Lambda.value_kind) = - match kind with - | Pgenval -> t - | Pfloatval -> - begin match t.descr with - | Value_float _ -> - t - | Value_unknown _ | Value_unresolved _ -> - { t with descr = Value_float None } - | Value_block _ - | Value_int _ - | Value_char _ - | Value_constptr _ - | Value_boxed_int _ - | Value_set_of_closures _ - | Value_closure _ - | Value_string _ - | Value_float_array _ - | Value_bottom -> - (* Unreachable *) - { t with descr = Value_bottom } - | Value_extern _ | Value_symbol _ -> - (* We don't know yet *) - t - end - | _ -> t - -let augment_kind_with_approx t (kind:Lambda.value_kind) : Lambda.value_kind = - match t.descr with - | Value_float _ -> Pfloatval - | Value_int _ -> Pintval - | Value_boxed_int (Int32, _) -> Pboxedintval Pint32 - | Value_boxed_int (Int64, _) -> Pboxedintval Pint64 - | Value_boxed_int (Nativeint, _) -> Pboxedintval Pnativeint - | _ -> kind - -let value_unknown reason = approx (Value_unknown reason) -let value_int i = approx (Value_int i) -let value_char i = approx (Value_char i) -let value_constptr i = approx (Value_constptr i) -let value_float f = approx (Value_float (Some f)) -let value_any_float = approx (Value_float None) -let value_boxed_int bi i = approx (Value_boxed_int (bi,i)) - -let value_closure ?closure_var ?set_of_closures_var ?set_of_closures_symbol - value_set_of_closures closure_id = - let approx_set_of_closures = - { descr = Value_set_of_closures value_set_of_closures; - var = set_of_closures_var; - symbol = Misc.may_map (fun s -> s, None) set_of_closures_symbol; - } - in - let value_closure = - { set_of_closures = approx_set_of_closures; - closure_id; - } - in - { descr = Value_closure value_closure; - var = closure_var; - symbol = None; - } - -let create_value_set_of_closures - ~(function_decls : function_declarations) ~bound_vars ~free_vars - ~invariant_params ~recursive ~specialised_args ~freshening - ~direct_call_surrogates = - let size = - lazy ( - let functions = Variable.Map.keys function_decls.funs in - Variable.Map.fold - (fun fun_var function_decl sizes -> - match function_decl.function_body with - | None -> sizes - | Some function_body -> - let params = Parameter.Set.vars function_decl.params in - let free_vars = - Variable.Set.diff - (Variable.Set.diff function_body.free_variables params) - functions - in - let num_free_vars = Variable.Set.cardinal free_vars in - let max_size = - Inlining_cost.maximum_interesting_size_of_function_body - num_free_vars - in - let size = - Inlining_cost.lambda_smaller' function_body.body ~than:max_size - in - Variable.Map.add fun_var size sizes) - function_decls.funs Variable.Map.empty) - in - { function_decls; - bound_vars; - free_vars; - invariant_params; - recursive; - size; - specialised_args; - freshening; - direct_call_surrogates; - } - -let update_freshening_of_value_set_of_closures value_set_of_closures - ~freshening = - (* CR-someday mshinwell: We could maybe check that [freshening] is - reasonable. *) - { value_set_of_closures with freshening; } - -let value_set_of_closures ?set_of_closures_var value_set_of_closures = - { descr = Value_set_of_closures value_set_of_closures; - var = set_of_closures_var; - symbol = None; - } - -let value_block t b = approx (Value_block (t, b)) -let value_extern ex = approx (Value_extern ex) -let value_symbol sym = - { (approx (Value_symbol sym)) with symbol = Some (sym, None) } -let value_bottom = approx Value_bottom -let value_unresolved value = approx (Value_unresolved value) - -let value_string size contents = approx (Value_string {size; contents }) -let value_mutable_float_array ~size = - approx (Value_float_array { contents = Unknown_or_mutable; size; } ) -let value_immutable_float_array (contents:t array) = - let size = Array.length contents in - let contents = - Array.map (fun t -> augment_with_kind t Pfloatval) contents - in - approx (Value_float_array { contents = Contents contents; size; } ) - -let name_expr_fst (named, thing) ~name = - (Flambda_utils.name_expr named ~name), thing - -let make_const_int_named n : Flambda.named * t = - Const (Int n), value_int n -let make_const_int (n : int) = - let name = - match n with - | 0 -> Internal_variable_names.const_zero - | 1 -> Internal_variable_names.const_one - | _ -> Internal_variable_names.const_int - in - name_expr_fst (make_const_int_named n) ~name - -let make_const_char_named n : Flambda.named * t = - Const (Char n), value_char n -let make_const_char n = - let name = Internal_variable_names.const_char in - name_expr_fst (make_const_char_named n) ~name - -let make_const_ptr_named n : Flambda.named * t = - Const (Const_pointer n), value_constptr n -let make_const_ptr (n : int) = - let name = - match n with - | 0 -> Internal_variable_names.const_ptr_zero - | 1 -> Internal_variable_names.const_ptr_one - | _ -> Internal_variable_names.const_ptr - in - name_expr_fst (make_const_ptr_named n) ~name - -let make_const_bool_named b : Flambda.named * t = - make_const_ptr_named (if b then 1 else 0) -let make_const_bool b = - name_expr_fst (make_const_bool_named b) - ~name:Internal_variable_names.const_bool - -let make_const_float_named f : Flambda.named * t = - Allocated_const (Float f), value_float f -let make_const_float f = - name_expr_fst (make_const_float_named f) - ~name:Internal_variable_names.const_float - -let make_const_boxed_int_named (type bi) (t:bi boxed_int) (i:bi) - : Flambda.named * t = - let c : Allocated_const.t = - match t with - | Int32 -> Int32 i - | Int64 -> Int64 i - | Nativeint -> Nativeint i - in - Allocated_const c, value_boxed_int t i -let make_const_boxed_int t i = - name_expr_fst (make_const_boxed_int_named t i) - ~name:Internal_variable_names.const_boxed_int - -type simplification_summary = - | Nothing_done - | Replaced_term - -type simplification_result = Flambda.t * simplification_summary * t -type simplification_result_named = Flambda.named * simplification_summary * t - -let simplify t (lam : Flambda.t) : simplification_result = - if Effect_analysis.no_effects lam then - match t.descr with - | Value_int n -> - let const, approx = make_const_int n in - const, Replaced_term, approx - | Value_char n -> - let const, approx = make_const_char n in - const, Replaced_term, approx - | Value_constptr n -> - let const, approx = make_const_ptr n in - const, Replaced_term, approx - | Value_float (Some f) -> - let const, approx = make_const_float f in - const, Replaced_term, approx - | Value_boxed_int (t, i) -> - let const, approx = make_const_boxed_int t i in - const, Replaced_term, approx - | Value_symbol sym -> - let name = Internal_variable_names.symbol in - U.name_expr (Symbol sym) ~name, Replaced_term, t - | Value_string _ | Value_float_array _ | Value_float None - | Value_block _ | Value_set_of_closures _ | Value_closure _ - | Value_unknown _ | Value_bottom | Value_extern _ | Value_unresolved _ -> - lam, Nothing_done, t - else - lam, Nothing_done, t - -let simplify_named t (named : Flambda.named) : simplification_result_named = - if Effect_analysis.no_effects_named named then - match t.descr with - | Value_int n -> - let const, approx = make_const_int_named n in - const, Replaced_term, approx - | Value_char n -> - let const, approx = make_const_char_named n in - const, Replaced_term, approx - | Value_constptr n -> - let const, approx = make_const_ptr_named n in - const, Replaced_term, approx - | Value_float (Some f) -> - let const, approx = make_const_float_named f in - const, Replaced_term, approx - | Value_boxed_int (t, i) -> - let const, approx = make_const_boxed_int_named t i in - const, Replaced_term, approx - | Value_symbol sym -> - Symbol sym, Replaced_term, t - | Value_string _ | Value_float_array _ | Value_float None - | Value_block _ | Value_set_of_closures _ | Value_closure _ - | Value_unknown _ | Value_bottom | Value_extern _ | Value_unresolved _ -> - named, Nothing_done, t - else - named, Nothing_done, t - -(* CR-soon mshinwell: bad name. This function and its call site in - [Inline_and_simplify] is also messy. *) -let simplify_var t : (Flambda.named * t) option = - match t.descr with - | Value_int n -> Some (make_const_int_named n) - | Value_char n -> Some (make_const_char_named n) - | Value_constptr n -> Some (make_const_ptr_named n) - | Value_float (Some f) -> Some (make_const_float_named f) - | Value_boxed_int (t, i) -> Some (make_const_boxed_int_named t i) - | Value_symbol sym -> Some (Symbol sym, t) - | Value_string _ | Value_float_array _ | Value_float None - | Value_block _ | Value_set_of_closures _ | Value_closure _ - | Value_unknown _ | Value_bottom | Value_extern _ - | Value_unresolved _ -> - match t.symbol with - | Some (sym, None) -> Some (Symbol sym, t) - | Some (sym, Some field) -> Some (Read_symbol_field (sym, field), t) - | None -> None - -let join_summaries summary ~replaced_by_var_or_symbol = - match replaced_by_var_or_symbol, summary with - | true, Nothing_done - | true, Replaced_term - | false, Replaced_term -> Replaced_term - | false, Nothing_done -> Nothing_done - -let simplify_using_env t ~is_present_in_env flam = - let replaced_by_var_or_symbol, flam = - match t.var with - | Some var when is_present_in_env var -> true, Flambda.Var var - | _ -> - match t.symbol with - | Some (sym, None) -> - let name = Internal_variable_names.symbol in - (true, U.name_expr (Symbol sym) ~name) - | Some (sym, Some field) -> - let name = Internal_variable_names.symbol_field in - (true, U.name_expr (Read_symbol_field (sym, field)) ~name) - | None -> false, flam - in - let const, summary, approx = simplify t flam in - const, join_summaries summary ~replaced_by_var_or_symbol, approx - -let simplify_named_using_env t ~is_present_in_env named = - let replaced_by_var_or_symbol, named = - match t.var with - | Some var when is_present_in_env var -> - true, Flambda.Expr (Var var) - | _ -> - match t.symbol with - | Some (sym, None) -> true, (Flambda.Symbol sym:Flambda.named) - | Some (sym, Some field) -> - true, Flambda.Read_symbol_field (sym, field) - | None -> false, named - in - let const, summary, approx = simplify_named t named in - const, join_summaries summary ~replaced_by_var_or_symbol, approx - -let simplify_var_to_var_using_env t ~is_present_in_env = - match t.var with - | Some var when is_present_in_env var -> Some var - | _ -> None - -let known t = - match t.descr with - | Value_unresolved _ - | Value_unknown _ -> false - | Value_string _ | Value_float_array _ - | Value_bottom | Value_block _ | Value_int _ | Value_char _ - | Value_constptr _ | Value_set_of_closures _ | Value_closure _ - | Value_extern _ | Value_float _ | Value_boxed_int _ | Value_symbol _ -> true - -let useful t = - match t.descr with - | Value_unresolved _ | Value_unknown _ | Value_bottom -> false - | Value_string _ | Value_float_array _ | Value_block _ | Value_int _ - | Value_char _ | Value_constptr _ | Value_set_of_closures _ - | Value_float _ | Value_boxed_int _ | Value_closure _ | Value_extern _ - | Value_symbol _ -> true - -let all_not_useful ts = List.for_all (fun t -> not (useful t)) ts - -let warn_on_mutation t = - match t.descr with - | Value_block(_, fields) -> Array.length fields > 0 - | Value_string { contents = Some _ } - | Value_int _ | Value_char _ | Value_constptr _ - | Value_set_of_closures _ | Value_float _ | Value_boxed_int _ - | Value_closure _ -> true - | Value_string { contents = None } | Value_float_array _ - | Value_unresolved _ | Value_unknown _ | Value_bottom -> false - | Value_extern _ | Value_symbol _ -> assert false - -type get_field_result = - | Ok of t - | Unreachable - -let get_field t ~field_index:i : get_field_result = - match t.descr with - | Value_block (_tag, fields) -> - if i >= 0 && i < Array.length fields then begin - Ok fields.(i) - end else begin - (* This (unfortunately) cannot be a fatal error; it can happen if a - .cmx file is missing. However for debugging the compiler this can - be a useful point to put a [Misc.fatal_errorf]. *) - Unreachable - end - (* CR-someday mshinwell: This should probably return Unreachable in more - cases. I added a couple more. *) - | Value_bottom - | Value_int _ | Value_char _ | Value_constptr _ -> - (* Something seriously wrong is happening: either the user is doing - something exceptionally unsafe, or it is an unreachable branch. - We consider this as unreachable and mark the result accordingly. *) - Ok value_bottom - | Value_float_array _ -> - (* For the moment we return "unknown" even for immutable arrays, since - it isn't possible for user code to project from an immutable array. *) - (* CR-someday mshinwell: If Leo's array's patch lands, then we can - change this, although it's probably not Pfield that is used to - do the projection. *) - Ok (value_unknown Other) - | Value_string _ | Value_float _ | Value_boxed_int _ -> - (* The user is doing something unsafe. *) - Unreachable - | Value_set_of_closures _ | Value_closure _ - (* This is used by [CamlinternalMod]. *) - | Value_symbol _ | Value_extern _ -> - (* These should have been resolved. *) - Ok (value_unknown Other) - | Value_unknown reason -> - Ok (value_unknown reason) - | Value_unresolved value -> - (* We don't know anything, but we must remember that it comes - from another compilation unit in case it contains a closure. *) - Ok (value_unknown (Unresolved_value value)) - -type checked_approx_for_block = - | Wrong - | Ok of Tag.t * t array - -let check_approx_for_block t = - match t.descr with - | Value_block (tag, fields) -> - Ok (tag, fields) - | Value_bottom - | Value_int _ | Value_char _ | Value_constptr _ - | Value_float_array _ - | Value_string _ | Value_float _ | Value_boxed_int _ - | Value_set_of_closures _ | Value_closure _ - | Value_symbol _ | Value_extern _ - | Value_unknown _ - | Value_unresolved _ -> - Wrong - -let descrs approxs = List.map (fun v -> v.descr) approxs - -let equal_boxed_int (type t1) (type t2) - (bi1:t1 boxed_int) (i1:t1) - (bi2:t2 boxed_int) (i2:t2) = - match bi1, bi2 with - | Int32, Int32 -> Int32.equal i1 i2 - | Int64, Int64 -> Int64.equal i1 i2 - | Nativeint, Nativeint -> Nativeint.equal i1 i2 - | _ -> false - -let equal_floats f1 f2 = - match f1, f2 with - | None, None -> true - | None, Some _ | Some _, None -> false - | Some f1, Some f2 -> Allocated_const.compare_floats f1 f2 = 0 - -(* Closures and set of closures descriptions cannot be merged. - - let f x = - let g y -> x + y in - g - in - let v = - if ... - then f 1 - else f 2 - in - v 3 - - The approximation for [f 1] and [f 2] could both contain the - description of [g]. But if [f] where inlined, a new [g] would - be created in each branch, leading to incompatible description. - And we must never make the description for a function less - precise that it used to be: its information are needed for - rewriting [Project_var] and [Project_closure] constructions - in [Flambdainline.loop] -*) -let rec meet_descr ~really_import_approx d1 d2 = match d1, d2 with - | Value_int i, Value_int j when i = j -> - d1 - | Value_constptr i, Value_constptr j when i = j -> - d1 - | Value_symbol s1, Value_symbol s2 when Symbol.equal s1 s2 -> - d1 - | Value_extern e1, Value_extern e2 when Export_id.equal e1 e2 -> - d1 - | Value_float i, Value_float j when equal_floats i j -> - d1 - | Value_boxed_int (bi1, i1), Value_boxed_int (bi2, i2) when - equal_boxed_int bi1 i1 bi2 i2 -> - d1 - | Value_block (tag1, a1), Value_block (tag2, a2) - when Tag.compare tag1 tag2 = 0 && Array.length a1 = Array.length a2 -> - let fields = - Array.mapi (fun i v -> meet ~really_import_approx v a2.(i)) a1 - in - Value_block (tag1, fields) - | _ -> Value_unknown Other - -and meet ~really_import_approx a1 a2 = - match a1, a2 with - | { descr = Value_bottom }, a - | a, { descr = Value_bottom } -> a - | { descr = (Value_symbol _ | Value_extern _) }, _ - | _, { descr = (Value_symbol _ | Value_extern _) } -> - meet ~really_import_approx - (really_import_approx a1) (really_import_approx a2) - | _ -> - let var = - match a1.var, a2.var with - | None, _ | _, None -> None - | Some v1, Some v2 -> - if Variable.equal v1 v2 - then Some v1 - else None - in - let symbol = - match a1.symbol, a2.symbol with - | None, _ | _, None -> None - | Some (v1, field1), Some (v2, field2) -> - if Symbol.equal v1 v2 - then match field1, field2 with - | None, None -> a1.symbol - | Some f1, Some f2 when f1 = f2 -> - a1.symbol - | _ -> None - else None - in - { descr = meet_descr ~really_import_approx a1.descr a2.descr; - var; - symbol } - -(* Given a set-of-closures approximation and a closure ID, apply any - freshening specified in the approximation to the closure ID, and return - that new closure ID. A fatal error is produced if the new closure ID - does not correspond to a function declaration in the given approximation. *) -let freshen_and_check_closure_id - (value_set_of_closures : value_set_of_closures) closure_id = - let closure_id = - Freshening.Project_var.apply_closure_id - value_set_of_closures.freshening closure_id - in - try - ignore ( - Variable.Map.find (Closure_id.unwrap closure_id) - value_set_of_closures.function_decls.funs - ); - closure_id - with Not_found -> - Misc.fatal_error (Format.asprintf - "Function %a not found in the set of closures@ %a@.%a@." - Closure_id.print closure_id - print_value_set_of_closures value_set_of_closures - print_function_declarations value_set_of_closures.function_decls) - -type checked_approx_for_set_of_closures = - | Wrong - | Unresolved of unresolved_value - | Unknown - | Unknown_because_of_unresolved_value of unresolved_value - | Ok of Variable.t option * value_set_of_closures - -let check_approx_for_set_of_closures t : checked_approx_for_set_of_closures = - match t.descr with - | Value_unresolved value -> Unresolved value - | Value_unknown (Unresolved_value value) -> - Unknown_because_of_unresolved_value value - | Value_set_of_closures value_set_of_closures -> - (* Note that [var] might be [None]; we might be reaching the set of - closures via approximations only, with the variable originally bound - to the set now out of scope. *) - Ok (t.var, value_set_of_closures) - | Value_closure _ | Value_block _ | Value_int _ | Value_char _ - | Value_constptr _ | Value_float _ | Value_boxed_int _ | Value_unknown _ - | Value_bottom | Value_extern _ | Value_string _ | Value_float_array _ - | Value_symbol _ -> - Wrong - -type strict_checked_approx_for_set_of_closures = - | Wrong - | Ok of Variable.t option * value_set_of_closures - -let strict_check_approx_for_set_of_closures t - : strict_checked_approx_for_set_of_closures = - match check_approx_for_set_of_closures t with - | Ok (var, value_set_of_closures) -> Ok (var, value_set_of_closures) - | Wrong | Unresolved _ - | Unknown | Unknown_because_of_unresolved_value _ -> Wrong - -type checked_approx_for_closure_allowing_unresolved = - | Wrong - | Unresolved of unresolved_value - | Unknown - | Unknown_because_of_unresolved_value of unresolved_value - | Ok of value_closure * Variable.t option - * Symbol.t option * value_set_of_closures - -let check_approx_for_closure_allowing_unresolved t - : checked_approx_for_closure_allowing_unresolved = - match t.descr with - | Value_closure value_closure -> - begin match value_closure.set_of_closures.descr with - | Value_set_of_closures value_set_of_closures -> - let symbol = match value_closure.set_of_closures.symbol with - | Some (symbol, None) -> Some symbol - | None | Some (_, Some _) -> None - in - Ok (value_closure, value_closure.set_of_closures.var, - symbol, value_set_of_closures) - | Value_unresolved _ - | Value_closure _ | Value_block _ | Value_int _ | Value_char _ - | Value_constptr _ | Value_float _ | Value_boxed_int _ | Value_unknown _ - | Value_bottom | Value_extern _ | Value_string _ | Value_float_array _ - | Value_symbol _ -> - Wrong - end - | Value_unknown (Unresolved_value value) -> - Unknown_because_of_unresolved_value value - | Value_unresolved symbol -> Unresolved symbol - | Value_set_of_closures _ | Value_block _ | Value_int _ | Value_char _ - | Value_constptr _ | Value_float _ | Value_boxed_int _ - | Value_bottom | Value_extern _ | Value_string _ | Value_float_array _ - | Value_symbol _ -> - Wrong - (* CR-soon mshinwell: This should be unwound once the reason for a value - being unknown can be correctly propagated through the export info. *) - | Value_unknown Other -> Unknown - -type checked_approx_for_closure = - | Wrong - | Ok of value_closure * Variable.t option - * Symbol.t option * value_set_of_closures - -let check_approx_for_closure t : checked_approx_for_closure = - match check_approx_for_closure_allowing_unresolved t with - | Ok (value_closure, set_of_closures_var, set_of_closures_symbol, - value_set_of_closures) -> - Ok (value_closure, set_of_closures_var, set_of_closures_symbol, - value_set_of_closures) - | Wrong | Unknown | Unresolved _ | Unknown_because_of_unresolved_value _ -> - Wrong - -let approx_for_bound_var value_set_of_closures var = - try - Var_within_closure.Map.find var value_set_of_closures.bound_vars - with - | Not_found -> - Misc.fatal_errorf "The set-of-closures approximation %a@ does not \ - bind the variable %a@.%s@." - print_value_set_of_closures value_set_of_closures - Var_within_closure.print var - (Printexc.raw_backtrace_to_string (Printexc.get_callstack max_int)) - -let check_approx_for_float t : float option = - match t.descr with - | Value_float f -> f - | Value_unresolved _ - | Value_unknown _ | Value_string _ | Value_float_array _ - | Value_bottom | Value_block _ | Value_int _ | Value_char _ - | Value_constptr _ | Value_set_of_closures _ | Value_closure _ - | Value_extern _ | Value_boxed_int _ | Value_symbol _ -> - None - -let float_array_as_constant (t:value_float_array) : float list option = - match t.contents with - | Unknown_or_mutable -> None - | Contents contents -> - Array.fold_right (fun elt acc -> - match acc, elt.descr with - | Some acc, Value_float (Some f) -> - Some (f :: acc) - | None, _ - | Some _, - (Value_float None | Value_unresolved _ - | Value_unknown _ | Value_string _ | Value_float_array _ - | Value_bottom | Value_block _ | Value_int _ | Value_char _ - | Value_constptr _ | Value_set_of_closures _ | Value_closure _ - | Value_extern _ | Value_boxed_int _ | Value_symbol _) - -> None) - contents (Some []) - -let check_approx_for_string t : string option = - match t.descr with - | Value_string { contents } -> contents - | Value_float _ - | Value_unresolved _ - | Value_unknown _ | Value_float_array _ - | Value_bottom | Value_block _ | Value_int _ | Value_char _ - | Value_constptr _ | Value_set_of_closures _ | Value_closure _ - | Value_extern _ | Value_boxed_int _ | Value_symbol _ -> - None - -type switch_branch_selection = - | Cannot_be_taken - | Can_be_taken - | Must_be_taken - -let potentially_taken_const_switch_branch t branch = - match t.descr with - | Value_unresolved _ - | Value_unknown _ - | Value_extern _ - | Value_symbol _ -> - (* In theory symbol cannot contain integers but this shouldn't - matter as this will always be an imported approximation *) - Can_be_taken - | Value_constptr i | Value_int i when i = branch -> - Must_be_taken - | Value_char c when Char.code c = branch -> - Must_be_taken - | Value_constptr _ | Value_int _ | Value_char _ -> - Cannot_be_taken - | Value_block _ | Value_float _ | Value_float_array _ - | Value_string _ | Value_closure _ | Value_set_of_closures _ - | Value_boxed_int _ | Value_bottom -> - Cannot_be_taken - -let potentially_taken_block_switch_branch t tag = - match t.descr with - | (Value_unresolved _ - | Value_unknown _ - | Value_extern _ - | Value_symbol _) -> - Can_be_taken - | (Value_constptr _ | Value_int _| Value_char _) -> - Cannot_be_taken - | Value_block (block_tag, _) when Tag.to_int block_tag = tag -> - Must_be_taken - | Value_float _ when tag = Obj.double_tag -> - Must_be_taken - | Value_float_array _ when tag = Obj.double_array_tag -> - Must_be_taken - | Value_string _ when tag = Obj.string_tag -> - Must_be_taken - | (Value_closure _ | Value_set_of_closures _) - when tag = Obj.closure_tag || tag = Obj.infix_tag -> - Can_be_taken - | Value_boxed_int _ when tag = Obj.custom_tag -> - Must_be_taken - | Value_block _ | Value_float _ | Value_set_of_closures _ | Value_closure _ - | Value_string _ | Value_float_array _ | Value_boxed_int _ -> - Cannot_be_taken - | Value_bottom -> - Cannot_be_taken - -let function_arity (fun_decl : function_declaration) = - List.length fun_decl.params - -let function_declaration_approx ~keep_body fun_var - (fun_decl : Flambda.function_declaration) = - let function_body = - if not (keep_body fun_var fun_decl) then None - else begin - Some { body = fun_decl.body; - stub = fun_decl.stub; - inline = fun_decl.inline; - dbg = fun_decl.dbg; - specialise = fun_decl.specialise; - is_a_functor = fun_decl.is_a_functor; - free_variables = fun_decl.free_variables; - free_symbols = fun_decl.free_symbols; } - end - in - { function_body; - params = fun_decl.params; - closure_origin = fun_decl.closure_origin; } - -let function_declarations_approx ~keep_body - (fun_decls : Flambda.function_declarations) = - let funs = - Variable.Map.mapi (function_declaration_approx ~keep_body) fun_decls.funs - in - { funs; - is_classic_mode = fun_decls.is_classic_mode; - set_of_closures_id = fun_decls.set_of_closures_id; - set_of_closures_origin = fun_decls.set_of_closures_origin; } - -let import_function_declarations_for_pack function_decls - import_set_of_closures_id import_set_of_closures_origin = - { set_of_closures_id = - import_set_of_closures_id function_decls.set_of_closures_id; - set_of_closures_origin = - import_set_of_closures_origin function_decls.set_of_closures_origin; - funs = function_decls.funs; - is_classic_mode = function_decls.is_classic_mode; - } - -let update_function_declarations function_decls ~funs = - let compilation_unit = Compilation_unit.get_current_exn () in - let is_classic_mode = function_decls.is_classic_mode in - let set_of_closures_id = Set_of_closures_id.create compilation_unit in - let set_of_closures_origin = function_decls.set_of_closures_origin in - { is_classic_mode; - set_of_closures_id; - set_of_closures_origin; - funs; - } - -let clear_function_bodies (function_decls : function_declarations) = - let funs = - Variable.Map.map (fun (fun_decl : function_declaration) -> - match fun_decl.function_body with - | None | Some { stub = true; _ } -> - fun_decl - | Some _ -> - { fun_decl with function_body = None }) - function_decls.funs - in - { function_decls with funs } - -let update_function_declaration_body - (function_decl : function_declaration) - (f : Flambda.t -> Flambda.t) = - match function_decl.function_body with - | None -> function_decl - | Some function_body -> - let new_function_body = - let body = f function_body.body in - let free_variables = Flambda.free_variables body in - let free_symbols = Flambda.free_symbols body in - { function_body with free_variables; free_symbols; body; } - in - { function_decl with function_body = Some new_function_body } - -let make_closure_map input = - let map = ref Closure_id.Map.empty in - let add_set_of_closures _ (function_decls : function_declarations) = - Variable.Map.iter (fun var _ -> - let closure_id = Closure_id.wrap var in - map := Closure_id.Map.add closure_id function_decls !map) - function_decls.funs - in - Set_of_closures_id.Map.iter add_set_of_closures input; - !map diff --git a/middle_end/simple_value_approx.mli b/middle_end/simple_value_approx.mli deleted file mode 100644 index dd38652f5b..0000000000 --- a/middle_end/simple_value_approx.mli +++ /dev/null @@ -1,501 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -(** Simple approximations to the runtime results of computations. - This pass is designed for speed rather than accuracy; the performance - is important since it is used heavily during inlining. *) - -type 'a boxed_int = - | Int32 : int32 boxed_int - | Int64 : int64 boxed_int - | Nativeint : nativeint boxed_int - -type value_string = { - contents : string option; (* [None] if unknown or mutable *) - size : int; -} - -type unresolved_value = - | Set_of_closures_id of Set_of_closures_id.t - | Symbol of Symbol.t - -type unknown_because_of = - | Unresolved_value of unresolved_value - | Other - -(** A value of type [t] corresponds to an "approximation" of the result of - a computation in the program being compiled. That is to say, it - represents what knowledge we have about such a result at compile time. - The simplification pass exploits this information to partially evaluate - computations. - - At a high level, an approximation for a value [v] has three parts: - - the "description" (for example, "the constant integer 42"); - - an optional variable; - - an optional symbol or symbol field. - If the variable (resp. symbol) is present then that variable (resp. - symbol) may be used to obtain the value [v]. - - The exact semantics of the variable and symbol fields follows. - - Approximations are deduced at particular points in an expression tree, - but may subsequently be propagated to other locations. - - At the point at which an approximation is built for some value [v], we can - construct a set of variables (call the set [S]) that are known to alias the - same value [v]. Each member of [S] will have the same or a more precise - [descr] field in its approximation relative to the approximation for [v]. - (An increase in precision may currently be introduced for pattern - matches.) If [S] is non-empty then it is guaranteed that there is a - unique member of [S] that was declared in a scope further out ("earlier") - than all other members of [S]. If such a member exists then it is - recorded in the [var] field. Otherwise [var] is [None]. - - Analogous to the construction of the set [S], we can construct a set [T] - consisting of all symbols that are known to alias the value whose - approximation is being constructed. If [T] is non-empty then the - [symbol] field is set to some member of [T]; it does not matter which - one. (There is no notion of scope for symbols.) - - Note about mutable blocks: - - Mutable blocks are always represented by [Value_unknown] or - [Value_bottom]. Any other approximation could leave the door open to - a miscompilation. Such bad scenarios are most likely a user using - [Obj.magic] or [Obj.set_field] in an inappropriate situation. - Such a situation might be: - [let x = (1, 1) in - Obj.set_field (Obj.repr x) 0 (Obj.repr 2); - assert(fst x = 2)] - The user would probably expect the assertion to be true, but the - compiler could in fact propagate the value of [x] across the - [Obj.set_field]. - - Insisting that mutable blocks have [Value_unknown] or [Value_bottom] - approximations certainly won't always prevent this kind of error, but - should help catch many of them. - - It is possible that there may be some false positives, with correct - but unreachable code causing this check to fail. However the likelihood - of this seems sufficiently low, especially compared to the advantages - gained by performing the check, that we include it. - - An example of a pattern that might trigger a false positive is: - [type a = { a : int } - type b = { mutable b : int } - type _ t = - | A : a t - | B : b t - let f (type x) (v:x t) (r:x) = - match v with - | A -> r.a - | B -> r.b <- 2; 3 - - let v = - let r = - ref A in - r := A; (* Some pattern that the compiler can't understand *) - f !r { a = 1 }] - When inlining [f], the B branch is unreachable, yet the compiler - cannot prove it and must therefore keep it. -*) -type t = private { - descr : descr; - var : Variable.t option; - symbol : (Symbol.t * int option) option; -} - -and descr = private - | Value_block of Tag.t * t array - | Value_int of int - | Value_char of char - | Value_constptr of int - | Value_float of float option - | Value_boxed_int : 'a boxed_int * 'a -> descr - | Value_set_of_closures of value_set_of_closures - | Value_closure of value_closure - | Value_string of value_string - | Value_float_array of value_float_array - | Value_unknown of unknown_because_of - | Value_bottom - | Value_extern of Export_id.t - | Value_symbol of Symbol.t - | Value_unresolved of unresolved_value - (* No description was found for this value *) - -and value_closure = { - set_of_closures : t; - closure_id : Closure_id.t; -} - -and function_declarations = private { - is_classic_mode: bool; - set_of_closures_id : Set_of_closures_id.t; - set_of_closures_origin : Set_of_closures_origin.t; - funs : function_declaration Variable.Map.t; -} - -and function_body = private { - free_variables : Variable.Set.t; - free_symbols : Symbol.Set.t; - stub : bool; - dbg : Debuginfo.t; - inline : Lambda.inline_attribute; - specialise : Lambda.specialise_attribute; - is_a_functor : bool; - body : Flambda.t; -} - -and function_declaration = private { - closure_origin : Closure_origin.t; - params : Parameter.t list; - function_body : function_body option; -} - - -(* CR-soon mshinwell: add support for the approximations of the results, so we - can do all of the tricky higher-order cases. *) -(* when [is_classic_mode] is [false], functions in [function_declarations] - are guaranteed to have function bodies (ie: - [function_declaration.function_body] will be of the [Some] variant). - - When it [is_classic_mode] is [true], however, no guarantees about the - function_bodies are given. -*) -and value_set_of_closures = private { - function_decls : function_declarations; - bound_vars : t Var_within_closure.Map.t; - free_vars : Flambda.specialised_to Variable.Map.t; - invariant_params : Variable.Set.t Variable.Map.t Lazy.t; - recursive : Variable.Set.t Lazy.t; - size : int option Variable.Map.t Lazy.t; - (** For functions that are very likely to be inlined, the size of the - function's body. *) - specialised_args : Flambda.specialised_to Variable.Map.t; - (* Any freshening that has been applied to [function_decls]. *) - freshening : Freshening.Project_var.t; - direct_call_surrogates : Closure_id.t Closure_id.Map.t; -} - -and value_float_array_contents = - | Contents of t array - | Unknown_or_mutable - -and value_float_array = { - contents : value_float_array_contents; - size : int; -} - -(** Extraction of the description of approximation(s). *) -val descr : t -> descr -val descrs : t list -> descr list - -(** Pretty-printing of approximations to a formatter. *) -val print : Format.formatter -> t -> unit -val print_descr : Format.formatter -> descr -> unit -val print_value_set_of_closures - : Format.formatter - -> value_set_of_closures - -> unit -val print_function_declarations - : Format.formatter - -> function_declarations - -> unit - -val function_declarations_approx - : keep_body:(Variable.t -> Flambda.function_declaration -> bool) - -> Flambda.function_declarations - -> function_declarations - -val create_value_set_of_closures - : function_decls:function_declarations - -> bound_vars:t Var_within_closure.Map.t - -> free_vars:Flambda.specialised_to Variable.Map.t - -> invariant_params:Variable.Set.t Variable.Map.t lazy_t - -> recursive:Variable.Set.t Lazy.t - -> specialised_args:Flambda.specialised_to Variable.Map.t - -> freshening:Freshening.Project_var.t - -> direct_call_surrogates:Closure_id.t Closure_id.Map.t - -> value_set_of_closures - -val update_freshening_of_value_set_of_closures - : value_set_of_closures - -> freshening:Freshening.Project_var.t - -> value_set_of_closures - -(** Basic construction of approximations. *) -val value_unknown : unknown_because_of -> t -val value_int : int -> t -val value_char : char -> t -val value_float : float -> t -val value_any_float : t -val value_mutable_float_array : size:int -> t -val value_immutable_float_array : t array -> t -val value_string : int -> string option -> t -val value_boxed_int : 'i boxed_int -> 'i -> t -val value_constptr : int -> t -val value_block : Tag.t -> t array -> t -val value_extern : Export_id.t -> t -val value_symbol : Symbol.t -> t -val value_bottom : t -val value_unresolved : unresolved_value -> t - -(** Construct a closure approximation given the approximation of the - corresponding set of closures and the closure ID of the closure to - be projected from such set. [closure_var] and/or [set_of_closures_var] - may be specified to augment the approximation with variables that may - be used to access the closure value itself, so long as they are in - scope at the proposed point of use. *) -val value_closure - : ?closure_var:Variable.t - -> ?set_of_closures_var:Variable.t - -> ?set_of_closures_symbol:Symbol.t - -> value_set_of_closures - -> Closure_id.t - -> t - -(** Construct a set of closures approximation. [set_of_closures_var] is as for - the parameter of the same name in [value_closure], above. *) -val value_set_of_closures - : ?set_of_closures_var:Variable.t - -> value_set_of_closures - -> t - -(** Take the given constant and produce an appropriate approximation for it - together with an Flambda expression representing it. *) -val make_const_int : int -> Flambda.t * t -val make_const_char : char -> Flambda.t * t -val make_const_ptr : int -> Flambda.t * t -val make_const_bool : bool -> Flambda.t * t -val make_const_float : float -> Flambda.t * t -val make_const_boxed_int : 'i boxed_int -> 'i -> Flambda.t * t - -val make_const_int_named : int -> Flambda.named * t -val make_const_char_named : char -> Flambda.named * t -val make_const_ptr_named : int -> Flambda.named * t -val make_const_bool_named : bool -> Flambda.named * t -val make_const_float_named : float -> Flambda.named * t -val make_const_boxed_int_named : 'i boxed_int -> 'i -> Flambda.named * t - -(** Augment an approximation with a given variable (see comment above). - If the approximation was already augmented with a variable, the one - passed to this function replaces it within the approximation. *) -val augment_with_variable : t -> Variable.t -> t - -(** Like [augment_with_variable], but for symbol information. *) -val augment_with_symbol : t -> Symbol.t -> t - -(** Like [augment_with_symbol], but for symbol field information. *) -val augment_with_symbol_field : t -> Symbol.t -> int -> t - -(** Replace the description within an approximation. *) -val replace_description : t -> descr -> t - -(** Improve the description by taking the kind into account *) -val augment_with_kind : t -> Lambda.value_kind -> t - -(** Improve the kind by taking the description into account *) -val augment_kind_with_approx : t -> Lambda.value_kind -> Lambda.value_kind - -val equal_boxed_int : 'a boxed_int -> 'a -> 'b boxed_int -> 'b -> bool - -(* CR-soon mshinwell for pchambart: Add comment describing semantics. (Maybe - we should move the comment from the .ml file into here.) *) -val meet : really_import_approx:(t -> t) -> t -> t -> t - -(** An approximation is "known" iff it is not [Value_unknown]. *) -val known : t -> bool - -(** An approximation is "useful" iff it is neither unknown nor bottom. *) -val useful : t -> bool - -(** Whether all approximations in the given list do *not* satisfy [useful]. *) -val all_not_useful : t list -> bool - -(** Whether to warn on attempts to mutate a value. - It must have been resolved (it cannot be [Value_extern] or - [Value_symbol]). (See comment above for further explanation.) *) -val warn_on_mutation : t -> bool - -type simplification_summary = - | Nothing_done - | Replaced_term - -type simplification_result = Flambda.t * simplification_summary * t -type simplification_result_named = Flambda.named * simplification_summary * t - -(** Given an expression and its approximation, attempt to simplify the - expression to a constant (with associated approximation), taking into - account whether the expression has any side effects. *) -val simplify : t -> Flambda.t -> simplification_result - -(** As for [simplify], but also enables us to simplify based on equalities - between variables. The caller must provide a function that tells us - whether, if we simplify to a given variable, the value of that variable - will be accessible in the current environment. *) -val simplify_using_env - : t - -> is_present_in_env:(Variable.t -> bool) - -> Flambda.t - -> simplification_result - -val simplify_named : t -> Flambda.named -> simplification_result_named - -val simplify_named_using_env - : t - -> is_present_in_env:(Variable.t -> bool) - -> Flambda.named - -> simplification_result_named - -(** If the given approximation identifies another variable and - [is_present_in_env] deems it to be in scope, return that variable (wrapped - in a [Some]), otherwise return [None]. *) -val simplify_var_to_var_using_env - : t - -> is_present_in_env:(Variable.t -> bool) - -> Variable.t option - -val simplify_var : t -> (Flambda.named * t) option - -type get_field_result = - | Ok of t - | Unreachable - -(** Given the approximation [t] of a value, expected to correspond to a block - (in the [Pmakeblock] sense of the word), and a field index then return - an appropriate approximation for that field of the block (or - [Unreachable] if the code with the approximation [t] is unreachable). - N.B. Not all cases of unreachable code are returned as [Unreachable]. -*) -val get_field : t -> field_index:int -> get_field_result - -type checked_approx_for_block = - | Wrong - | Ok of Tag.t * t array - -(** Try to prove that a value with the given approximation may be used - as a block. *) -val check_approx_for_block : t -> checked_approx_for_block - -(** Find the approximation for a bound variable in a set-of-closures - approximation. A fatal error is produced if the variable is not bound in - the given approximation. *) -val approx_for_bound_var : value_set_of_closures -> Var_within_closure.t -> t - -(** Given a set-of-closures approximation and a closure ID, apply any - freshening specified by the approximation to the closure ID, and return - the resulting ID. Causes a fatal error if the resulting closure ID does - not correspond to any function declaration in the approximation. *) -val freshen_and_check_closure_id - : value_set_of_closures - -> Closure_id.t - -> Closure_id.t - -type strict_checked_approx_for_set_of_closures = - | Wrong - | Ok of Variable.t option * value_set_of_closures - -val strict_check_approx_for_set_of_closures - : t - -> strict_checked_approx_for_set_of_closures - -type checked_approx_for_set_of_closures = - | Wrong - | Unresolved of unresolved_value - | Unknown - | Unknown_because_of_unresolved_value of unresolved_value - (* In the [Ok] case, there may not be a variable associated with the set of - closures; it might be out of scope. *) - | Ok of Variable.t option * value_set_of_closures - -(** Try to prove that a value with the given approximation may be used as a - set of closures. Values coming from external compilation units with - unresolved approximations are permitted. *) -val check_approx_for_set_of_closures : t -> checked_approx_for_set_of_closures - -type checked_approx_for_closure = - | Wrong - | Ok of value_closure * Variable.t option - * Symbol.t option * value_set_of_closures - -(** Try to prove that a value with the given approximation may be used as a - closure. Values coming from external compilation units with unresolved - approximations are not permitted. *) -(* CR-someday mshinwell: naming is inconsistent: this is as "strict" - as "strict_check_approx_for_set_of_closures" *) -val check_approx_for_closure : t -> checked_approx_for_closure - -type checked_approx_for_closure_allowing_unresolved = - | Wrong - | Unresolved of unresolved_value - | Unknown - | Unknown_because_of_unresolved_value of unresolved_value - | Ok of value_closure * Variable.t option - * Symbol.t option * value_set_of_closures - -(** As for [check_approx_for_closure], but values coming from external - compilation units with unresolved approximations are permitted. *) -val check_approx_for_closure_allowing_unresolved - : t - -> checked_approx_for_closure_allowing_unresolved - -(** Returns the value if it can be proved to be a constant float *) -val check_approx_for_float : t -> float option - -(** Returns the value if it can be proved to be a constant float array *) -val float_array_as_constant : value_float_array -> float list option - -(** Returns the value if it can be proved to be a constant string *) -val check_approx_for_string : t -> string option - -type switch_branch_selection = - | Cannot_be_taken - | Can_be_taken - | Must_be_taken - -(** Check that the branch is compatible with the approximation *) -val potentially_taken_const_switch_branch : t -> int -> switch_branch_selection -val potentially_taken_block_switch_branch : t -> int -> switch_branch_selection - -val function_arity : function_declaration -> int - -(** Create a set of function declarations based on another set of function - declarations. *) -val update_function_declarations - : function_declarations - -> funs:function_declaration Variable.Map.t - -> function_declarations - -val import_function_declarations_for_pack - : function_declarations - -> (Set_of_closures_id.t -> Set_of_closures_id.t) - -> (Set_of_closures_origin.t -> Set_of_closures_origin.t) - -> function_declarations - -val update_function_declaration_body - : function_declaration - -> (Flambda.t -> Flambda.t) - -> function_declaration - -(** Creates a map from closure IDs to function declarations by iterating over - all sets of closures in the given map. *) -val make_closure_map - : function_declarations Set_of_closures_id.Map.t - -> function_declarations Closure_id.Map.t - -val clear_function_bodies : function_declarations -> function_declarations diff --git a/middle_end/simplify_boxed_integer_ops.ml b/middle_end/simplify_boxed_integer_ops.ml deleted file mode 100644 index 1f95a1ec2d..0000000000 --- a/middle_end/simplify_boxed_integer_ops.ml +++ /dev/null @@ -1,116 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -module S = Simplify_common - -(* Simplification of operations on boxed integers (nativeint, Int32, Int64). *) -module Simplify_boxed_integer_operator (I : sig - type t - val kind : Lambda.boxed_integer - val zero : t - val add : t -> t -> t - val sub : t -> t -> t - val mul : t -> t -> t - val div : t -> t -> t - val rem : t -> t -> t - val logand : t -> t -> t - val logor : t -> t -> t - val logxor : t -> t -> t - val shift_left : t -> int -> t - val shift_right : t -> int -> t - val shift_right_logical : t -> int -> t - val to_int : t -> int - val to_int32 : t -> Int32.t - val to_int64 : t -> Int64.t - val neg : t -> t - val swap : t -> t - val compare : t -> t -> int -end) : Simplify_boxed_integer_ops_intf.S with type t := I.t = struct - module A = Simple_value_approx - module C = Inlining_cost - - let equal_kind = Lambda.equal_boxed_integer - - let simplify_unop (p : Clambda_primitives.primitive) - (kind : I.t A.boxed_int) expr (n : I.t) = - let eval op = S.const_boxed_int_expr expr kind (op n) in - let eval_conv kind op = S.const_boxed_int_expr expr kind (op n) in - let eval_unboxed op = S.const_int_expr expr (op n) in - match p with - | Pintofbint kind when equal_kind kind I.kind -> eval_unboxed I.to_int - | Pcvtbint (kind, Pint32) when equal_kind kind I.kind -> - eval_conv A.Int32 I.to_int32 - | Pcvtbint (kind, Pint64) when equal_kind kind I.kind -> - eval_conv A.Int64 I.to_int64 - | Pnegbint kind when equal_kind kind I.kind -> eval I.neg - | Pbbswap kind when equal_kind kind I.kind -> eval I.swap - | _ -> expr, A.value_unknown Other, C.Benefit.zero - - let simplify_binop (p : Clambda_primitives.primitive) - (kind : I.t A.boxed_int) expr (n1 : I.t) (n2 : I.t) = - let eval op = S.const_boxed_int_expr expr kind (op n1 n2) in - let non_zero n = (I.compare I.zero n) <> 0 in - match p with - | Paddbint kind when equal_kind kind I.kind -> eval I.add - | Psubbint kind when equal_kind kind I.kind -> eval I.sub - | Pmulbint kind when equal_kind kind I.kind -> eval I.mul - | Pdivbint {size=kind} when equal_kind kind I.kind && non_zero n2 -> - eval I.div - | Pmodbint {size=kind} when equal_kind kind I.kind && non_zero n2 -> - eval I.rem - | Pandbint kind when equal_kind kind I.kind -> eval I.logand - | Porbint kind when equal_kind kind I.kind -> eval I.logor - | Pxorbint kind when equal_kind kind I.kind -> eval I.logxor - | Pbintcomp (kind, c) when equal_kind kind I.kind -> - S.const_integer_comparison_expr expr c n1 n2 - | _ -> expr, A.value_unknown Other, C.Benefit.zero - - let simplify_binop_int (p : Clambda_primitives.primitive) - (kind : I.t A.boxed_int) expr (n1 : I.t) (n2 : int) ~size_int = - let eval op = S.const_boxed_int_expr expr kind (op n1 n2) in - let precond = 0 <= n2 && n2 < 8 * size_int in - match p with - | Plslbint kind when equal_kind kind I.kind && precond -> eval I.shift_left - | Plsrbint kind when equal_kind kind I.kind && precond -> - eval I.shift_right_logical - | Pasrbint kind when equal_kind kind I.kind && precond -> eval I.shift_right - | _ -> expr, A.value_unknown Other, C.Benefit.zero -end - -module Simplify_boxed_nativeint = Simplify_boxed_integer_operator (struct - include Nativeint - let to_int64 = Int64.of_nativeint - let swap = S.swapnative - let kind = Lambda.Pnativeint -end) - -module Simplify_boxed_int32 = Simplify_boxed_integer_operator (struct - include Int32 - let to_int32 i = i - let to_int64 = Int64.of_int32 - let swap = S.swap32 - let kind = Lambda.Pint32 -end) - -module Simplify_boxed_int64 = Simplify_boxed_integer_operator (struct - include Int64 - let to_int64 i = i - let swap = S.swap64 - let kind = Lambda.Pint64 -end) diff --git a/middle_end/simplify_boxed_integer_ops.mli b/middle_end/simplify_boxed_integer_ops.mli deleted file mode 100644 index f3461043a1..0000000000 --- a/middle_end/simplify_boxed_integer_ops.mli +++ /dev/null @@ -1,28 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -(* Simplification of operations on boxed integers (nativeint, Int32, Int64). *) - -module Simplify_boxed_nativeint : Simplify_boxed_integer_ops_intf.S - with type t := Nativeint.t - -module Simplify_boxed_int32 : Simplify_boxed_integer_ops_intf.S - with type t := Int32.t - -module Simplify_boxed_int64 : Simplify_boxed_integer_ops_intf.S - with type t := Int64.t diff --git a/middle_end/simplify_boxed_integer_ops_intf.mli b/middle_end/simplify_boxed_integer_ops_intf.mli deleted file mode 100644 index f30987ae11..0000000000 --- a/middle_end/simplify_boxed_integer_ops_intf.mli +++ /dev/null @@ -1,45 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -module type S = sig - type t - - val simplify_unop - : Clambda_primitives.primitive - -> t Simple_value_approx.boxed_int - -> Flambda.named - -> t - -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t - - val simplify_binop - : Clambda_primitives.primitive - -> t Simple_value_approx.boxed_int - -> Flambda.named - -> t - -> t - -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t - - val simplify_binop_int - : Clambda_primitives.primitive - -> t Simple_value_approx.boxed_int - -> Flambda.named - -> t - -> int - -> size_int:int - -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t -end diff --git a/middle_end/simplify_common.ml b/middle_end/simplify_common.ml deleted file mode 100644 index fcbbcfbcba..0000000000 --- a/middle_end/simplify_common.ml +++ /dev/null @@ -1,86 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -module A = Simple_value_approx -module C = Inlining_cost - -external swap16 : int -> int = "%bswap16" -external swap32 : int32 -> int32 = "%bswap_int32" -external swap64 : int64 -> int64 = "%bswap_int64" -external swapnative : nativeint -> nativeint = "%bswap_native" - -let const_int_expr expr n = - if Effect_analysis.no_effects_named expr then - let (new_expr, approx) = A.make_const_int_named n in - new_expr, approx, C.Benefit.remove_code_named expr C.Benefit.zero - else expr, A.value_int n, C.Benefit.zero -let const_char_expr expr c = - if Effect_analysis.no_effects_named expr then - let (new_expr, approx) = A.make_const_char_named c in - new_expr, approx, C.Benefit.remove_code_named expr C.Benefit.zero - else expr, A.value_char c, C.Benefit.zero -let const_ptr_expr expr n = - if Effect_analysis.no_effects_named expr then - let (new_expr, approx) = A.make_const_ptr_named n in - new_expr, approx, C.Benefit.remove_code_named expr C.Benefit.zero - else expr, A.value_constptr n, C.Benefit.zero -let const_bool_expr expr b = - const_int_expr expr (if b then 1 else 0) -let const_float_expr expr f = - if Effect_analysis.no_effects_named expr then - let (new_expr, approx) = A.make_const_float_named f in - new_expr, approx, C.Benefit.remove_code_named expr C.Benefit.zero - else expr, A.value_float f, C.Benefit.zero -let const_boxed_int_expr expr t i = - if Effect_analysis.no_effects_named expr then - let (new_expr, approx) = A.make_const_boxed_int_named t i in - new_expr, approx, C.Benefit.remove_code_named expr C.Benefit.zero - else expr, A.value_boxed_int t i, C.Benefit.zero - -let const_integer_comparison_expr expr (cmp : Lambda.integer_comparison) x y = - (* Using the [Stdlib] comparison functions here in the compiler - coincides with the definitions of such functions in the code - compiled by the user, and is thus correct. *) - let open! Stdlib in - const_bool_expr expr - (match cmp with - | Ceq -> x = y - | Cne -> x <> y - | Clt -> x < y - | Cgt -> x > y - | Cle -> x <= y - | Cge -> x >= y) - -let const_float_comparison_expr expr (cmp : Lambda.float_comparison) x y = - (* Using the [Stdlib] comparison functions here in the compiler - coincides with the definitions of such functions in the code - compiled by the user, and is thus correct. *) - let open! Stdlib in - const_bool_expr expr - (match cmp with - | CFeq -> x = y - | CFneq -> not (x = y) - | CFlt -> x < y - | CFnlt -> not (x < y) - | CFgt -> x > y - | CFngt -> not (x > y) - | CFle -> x <= y - | CFnle -> not (x <= y) - | CFge -> x >= y - | CFnge -> not (x >= y)) diff --git a/middle_end/simplify_common.mli b/middle_end/simplify_common.mli deleted file mode 100644 index c667bfffe5..0000000000 --- a/middle_end/simplify_common.mli +++ /dev/null @@ -1,80 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -(** [const_*_expr expr v annot], where the expression [expr] is known to - evaluate to the value [v], attempt to produce a more simple expression - together with its approximation and the benefit gained by replacing [expr] - with this new expression. This simplification is only performed if [expr] - is known to have no side effects. Otherwise, [expr] itself is returned, - with an appropriate approximation but zero benefit. - - [const_boxed_int_expr] takes an additional argument specifying the kind of - boxed integer to which the given expression evaluates. -*) - -val const_int_expr - : Flambda.named - -> int - -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t - -val const_char_expr - : Flambda.named - -> char - -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t - -val const_bool_expr - : Flambda.named - -> bool - -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t - -val const_ptr_expr - : Flambda.named - -> int - -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t - -val const_float_expr - : Flambda.named - -> float - -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t - -val const_boxed_int_expr - : Flambda.named - -> 'a Simple_value_approx.boxed_int - -> 'a - -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t - -val const_integer_comparison_expr - : Flambda.named - -> Lambda.integer_comparison - -> 'a - -> 'a - -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t - -val const_float_comparison_expr - : Flambda.named - -> Lambda.float_comparison - -> float - -> float - -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t - -(** Functions for transposing the order of bytes within words of various - sizes. *) -val swap16 : int -> int -val swap32 : int32 -> int32 -val swap64 : int64 -> int64 -val swapnative : nativeint -> nativeint diff --git a/middle_end/simplify_primitives.ml b/middle_end/simplify_primitives.ml deleted file mode 100644 index 349d2f40ba..0000000000 --- a/middle_end/simplify_primitives.ml +++ /dev/null @@ -1,302 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -module A = Simple_value_approx -module C = Inlining_cost -module I = Simplify_boxed_integer_ops -module S = Simplify_common - -let phys_equal (approxs:A.t list) = - match approxs with - | [] | [_] | _ :: _ :: _ :: _ -> - Misc.fatal_error "wrong number of arguments for equality" - | [a1; a2] -> - (* N.B. The following would be incorrect if the variables are not - bound in the environment: - match a1.var, a2.var with - | Some v1, Some v2 when Variable.equal v1 v2 -> true - | _ -> ... - *) - match a1.symbol, a2.symbol with - | Some (s1, None), Some (s2, None) -> Symbol.equal s1 s2 - | Some (s1, Some f1), Some (s2, Some f2) -> Symbol.equal s1 s2 && f1 = f2 - | _ -> false - -let is_known_to_be_some_kind_of_int (arg:A.descr) = - match arg with - | Value_int _ | Value_char _ | Value_constptr _ -> true - | Value_block (_, _) | Value_float _ | Value_set_of_closures _ - | Value_closure _ | Value_string _ | Value_float_array _ - | A.Value_boxed_int _ | Value_unknown _ | Value_extern _ - | Value_symbol _ | Value_unresolved _ | Value_bottom -> false - -let is_known_to_be_some_kind_of_block (arg:A.descr) = - match arg with - | Value_block _ | Value_float _ | Value_float_array _ | A.Value_boxed_int _ - | Value_closure _ | Value_string _ -> true - | Value_set_of_closures _ | Value_int _ | Value_char _ | Value_constptr _ - | Value_unknown _ | Value_extern _ | Value_symbol _ - | Value_unresolved _ | Value_bottom -> false - -let rec structurally_different (arg1:A.t) (arg2:A.t) = - match arg1.descr, arg2.descr with - | (Value_int n1 | Value_constptr n1), (Value_int n2 | Value_constptr n2) - when n1 <> n2 -> - true - | Value_block (tag1, fields1), Value_block (tag2, fields2) -> - not (Tag.equal tag1 tag2) - || (Array.length fields1 <> Array.length fields2) - || Misc.Stdlib.Array.exists2 structurally_different fields1 fields2 - | descr1, descr2 -> - (* This is not very precise as this won't allow to distinguish - blocks from strings for instance. This can be improved if it - is deemed valuable. *) - (is_known_to_be_some_kind_of_int descr1 - && is_known_to_be_some_kind_of_block descr2) - || (is_known_to_be_some_kind_of_block descr1 - && is_known_to_be_some_kind_of_int descr2) - -let phys_different (approxs:A.t list) = - match approxs with - | [] | [_] | _ :: _ :: _ :: _ -> - Misc.fatal_error "wrong number of arguments for equality" - | [a1; a2] -> - structurally_different a1 a2 - -let is_empty = function - | [] -> true - | _ :: _ -> false - -let is_pisint = function - | Clambda_primitives.Pisint -> true - | _ -> false - -let is_pstring_length = function - | Clambda_primitives.Pstringlength -> true - | _ -> false - -let is_pbytes_length = function - | Clambda_primitives.Pbyteslength -> true - | _ -> false - -let is_pstringrefs = function - | Clambda_primitives.Pstringrefs -> true - | _ -> false - -let is_pbytesrefs = function - | Clambda_primitives.Pbytesrefs -> true - | _ -> false - -let primitive (p : Clambda_primitives.primitive) (args, approxs) - expr dbg ~size_int - : Flambda.named * A.t * Inlining_cost.Benefit.t = - let fpc = !Clflags.float_const_prop in - match p with - | Pmakeblock(tag_int, Asttypes.Immutable, shape) -> - let tag = Tag.create_exn tag_int in - let shape = match shape with - | None -> List.map (fun _ -> Lambda.Pgenval) args - | Some shape -> shape - in - let approxs = List.map2 A.augment_with_kind approxs shape in - let shape = List.map2 A.augment_kind_with_approx approxs shape in - Prim (Pmakeblock(tag_int, Asttypes.Immutable, Some shape), args, dbg), - A.value_block tag (Array.of_list approxs), C.Benefit.zero - | Praise _ -> - expr, A.value_bottom, C.Benefit.zero - | Pmakearray(_, _) when is_empty approxs -> - Prim (Pmakeblock(0, Asttypes.Immutable, Some []), [], dbg), - A.value_block (Tag.create_exn 0) [||], C.Benefit.zero - | Pmakearray (Pfloatarray, Mutable) -> - let approx = - A.value_mutable_float_array ~size:(List.length args) - in - expr, approx, C.Benefit.zero - | Pmakearray (Pfloatarray, Immutable) -> - let approx = - A.value_immutable_float_array (Array.of_list approxs) - in - expr, approx, C.Benefit.zero - | Pintcomp Ceq when phys_equal approxs -> - S.const_bool_expr expr true - | Pintcomp Cne when phys_equal approxs -> - S.const_bool_expr expr false - (* N.B. Having [not (phys_equal approxs)] would not on its own tell us - anything about whether the two values concerned are unequal. To judge - that, it would be necessary to prove that the approximations are - different, which would in turn entail them being completely known. - - It may seem that in the case where we have two approximations each - annotated with a symbol that we should be able to judge inequality - even if part of the approximation description(s) are unknown. This is - unfortunately not the case. Here is an example: - - let a = f 1 - let b = f 1 - let c = a, a - let d = a, a - - If [Share_constants] is run before [f] is completely inlined (assuming - [f] always generates the same result; effects of [f] aren't in fact - relevant) then [c] and [d] will not be shared. However if [f] is - inlined later, [a] and [b] could be shared and thus [c] and [d] could - be too. As such, any intermediate non-aliasing judgement would be - invalid. *) - | Pintcomp Ceq when phys_different approxs -> - S.const_bool_expr expr false - | Pintcomp Cne when phys_different approxs -> - S.const_bool_expr expr true - (* If two values are structurally different we are certain they can never - be shared*) - | _ -> - match A.descrs approxs with - | [Value_int x] -> - begin match p with - | Pnot -> S.const_bool_expr expr (x = 0) - | Pnegint -> S.const_int_expr expr (-x) - | Pbswap16 -> S.const_int_expr expr (S.swap16 x) - | Poffsetint y -> S.const_int_expr expr (x + y) - | Pfloatofint when fpc -> S.const_float_expr expr (float_of_int x) - | Pbintofint Pnativeint -> - S.const_boxed_int_expr expr Nativeint (Nativeint.of_int x) - | Pbintofint Pint32 -> S.const_boxed_int_expr expr Int32 (Int32.of_int x) - | Pbintofint Pint64 -> S.const_boxed_int_expr expr Int64 (Int64.of_int x) - | _ -> expr, A.value_unknown Other, C.Benefit.zero - end - | [(Value_int x | Value_constptr x); (Value_int y | Value_constptr y)] -> - let shift_precond = 0 <= y && y < 8 * size_int in - begin match p with - | Paddint -> S.const_int_expr expr (x + y) - | Psubint -> S.const_int_expr expr (x - y) - | Pmulint -> S.const_int_expr expr (x * y) - | Pdivint _ when y <> 0 -> S.const_int_expr expr (x / y) - | Pmodint _ when y <> 0 -> S.const_int_expr expr (x mod y) - | Pandint -> S.const_int_expr expr (x land y) - | Porint -> S.const_int_expr expr (x lor y) - | Pxorint -> S.const_int_expr expr (x lxor y) - | Plslint when shift_precond -> S.const_int_expr expr (x lsl y) - | Plsrint when shift_precond -> S.const_int_expr expr (x lsr y) - | Pasrint when shift_precond -> S.const_int_expr expr (x asr y) - | Pintcomp cmp -> S.const_integer_comparison_expr expr cmp x y - | Pisout -> S.const_bool_expr expr (y > x || y < 0) - | _ -> expr, A.value_unknown Other, C.Benefit.zero - end - | [Value_char x; Value_char y] -> - begin match p with - | Pintcomp cmp -> S.const_integer_comparison_expr expr cmp x y - | _ -> expr, A.value_unknown Other, C.Benefit.zero - end - | [Value_constptr x] -> - begin match p with - (* [Pidentity] should probably never appear, but is here for - completeness. *) - | Pnot -> S.const_bool_expr expr (x = 0) - | Pisint -> S.const_bool_expr expr true - | Poffsetint y -> S.const_ptr_expr expr (x + y) - | _ -> expr, A.value_unknown Other, C.Benefit.zero - end - | [Value_float (Some x)] when fpc -> - begin match p with - | Pintoffloat -> S.const_int_expr expr (int_of_float x) - | Pnegfloat -> S.const_float_expr expr (-. x) - | Pabsfloat -> S.const_float_expr expr (abs_float x) - | _ -> expr, A.value_unknown Other, C.Benefit.zero - end - | [Value_float (Some n1); Value_float (Some n2)] when fpc -> - begin match p with - | Paddfloat -> S.const_float_expr expr (n1 +. n2) - | Psubfloat -> S.const_float_expr expr (n1 -. n2) - | Pmulfloat -> S.const_float_expr expr (n1 *. n2) - | Pdivfloat -> S.const_float_expr expr (n1 /. n2) - | Pfloatcomp c -> S.const_float_comparison_expr expr c n1 n2 - | _ -> expr, A.value_unknown Other, C.Benefit.zero - end - | [A.Value_boxed_int(A.Nativeint, n)] -> - I.Simplify_boxed_nativeint.simplify_unop p Nativeint expr n - | [A.Value_boxed_int(A.Int32, n)] -> - I.Simplify_boxed_int32.simplify_unop p Int32 expr n - | [A.Value_boxed_int(A.Int64, n)] -> - I.Simplify_boxed_int64.simplify_unop p Int64 expr n - | [A.Value_boxed_int(A.Nativeint, n1); - A.Value_boxed_int(A.Nativeint, n2)] -> - I.Simplify_boxed_nativeint.simplify_binop p Nativeint expr n1 n2 - | [A.Value_boxed_int(A.Int32, n1); A.Value_boxed_int(A.Int32, n2)] -> - I.Simplify_boxed_int32.simplify_binop p Int32 expr n1 n2 - | [A.Value_boxed_int(A.Int64, n1); A.Value_boxed_int(A.Int64, n2)] -> - I.Simplify_boxed_int64.simplify_binop p Int64 expr n1 n2 - | [A.Value_boxed_int(A.Nativeint, n1); Value_int n2] -> - I.Simplify_boxed_nativeint.simplify_binop_int p Nativeint expr n1 n2 - ~size_int - | [A.Value_boxed_int(A.Int32, n1); Value_int n2] -> - I.Simplify_boxed_int32.simplify_binop_int p Int32 expr n1 n2 - ~size_int - | [A.Value_boxed_int(A.Int64, n1); Value_int n2] -> - I.Simplify_boxed_int64.simplify_binop_int p Int64 expr n1 n2 - ~size_int - | [Value_block _] when is_pisint p -> - S.const_bool_expr expr false - | [Value_string { size }] - when (is_pstring_length p || is_pbytes_length p) -> - S.const_int_expr expr size - | [Value_string { size; contents = Some s }; - (Value_int x | Value_constptr x)] when x >= 0 && x < size -> - begin match p with - | Pstringrefu - | Pstringrefs - | Pbytesrefu - | Pbytesrefs -> - S.const_char_expr (Prim(Pstringrefu, args, dbg)) s.[x] - | _ -> expr, A.value_unknown Other, C.Benefit.zero - end - | [Value_string { size; contents = None }; - (Value_int x | Value_constptr x)] - when x >= 0 && x < size && is_pstringrefs p -> - Flambda.Prim (Pstringrefu, args, dbg), - A.value_unknown Other, - (* we improved it, but there is no way to account for that: *) - C.Benefit.zero - | [Value_string { size; contents = None }; - (Value_int x | Value_constptr x)] - when x >= 0 && x < size && is_pbytesrefs p -> - Flambda.Prim (Pbytesrefu, args, dbg), - A.value_unknown Other, - (* we improved it, but there is no way to account for that: *) - C.Benefit.zero - - | [Value_float_array { size; contents }] -> - begin match p with - | Parraylength _ -> S.const_int_expr expr size - | Pfloatfield i -> - begin match contents with - | A.Contents a when i >= 0 && i < size -> - begin match A.check_approx_for_float a.(i) with - | None -> expr, a.(i), C.Benefit.zero - | Some v -> S.const_float_expr expr v - end - | Contents _ | Unknown_or_mutable -> - expr, A.value_unknown Other, C.Benefit.zero - end - | _ -> expr, A.value_unknown Other, C.Benefit.zero - end - | _ -> - match Semantics_of_primitives.return_type_of_primitive p with - | Float -> - expr, A.value_any_float, C.Benefit.zero - | Other -> - expr, A.value_unknown Other, C.Benefit.zero diff --git a/middle_end/simplify_primitives.mli b/middle_end/simplify_primitives.mli deleted file mode 100644 index a6b6330c03..0000000000 --- a/middle_end/simplify_primitives.mli +++ /dev/null @@ -1,27 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -(** Simplifies an application of a primitive based on approximation - information. *) -val primitive - : Clambda_primitives.primitive - -> (Variable.t list * (Simple_value_approx.t list)) - -> Flambda.named - -> Debuginfo.t - -> size_int:int - -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t diff --git a/middle_end/symbol.ml b/middle_end/symbol.ml new file mode 100644 index 0000000000..22a2e0a70e --- /dev/null +++ b/middle_end/symbol.ml @@ -0,0 +1,105 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + + +type t = + | Linkage of + { compilation_unit : Compilation_unit.t; + label : Linkage_name.t; + hash : int; } + | Variable of + { compilation_unit : Compilation_unit.t; + variable : Variable.t; } + +let label t = + match t with + | Linkage { label; _ } -> label + | Variable { variable; _ } -> + (* Use the variable's compilation unit for the label, since the + symbol's compilation unit might be a pack *) + let compilation_unit = Variable.get_compilation_unit variable in + let unit_linkage_name = + Linkage_name.to_string + (Compilation_unit.get_linkage_name compilation_unit) + in + let label = unit_linkage_name ^ "__" ^ Variable.unique_name variable in + Linkage_name.create label + +include Identifiable.Make (struct + + type nonrec t = t + + let compare t1 t2 = + if t1 == t2 then 0 + else begin + match t1, t2 with + | Linkage _, Variable _ -> 1 + | Variable _, Linkage _ -> -1 + | Linkage l1, Linkage l2 -> + let c = compare l1.hash l2.hash in + if c <> 0 then c else begin + (* Linkage names are unique across a whole project, so just comparing + those is sufficient. *) + Linkage_name.compare l1.label l2.label + end + | Variable v1, Variable v2 -> + Variable.compare v1.variable v2.variable + end + + let equal x y = + if x == y then true + else compare x y = 0 + + let output chan t = + Linkage_name.output chan (label t) + + let hash t = + match t with + | Linkage { hash; _ } -> hash + | Variable { variable } -> Variable.hash variable + + let print ppf t = + Linkage_name.print ppf (label t) + +end) + +let of_global_linkage compilation_unit label = + let hash = Linkage_name.hash label in + Linkage { compilation_unit; hash; label } + +let of_variable variable = + let compilation_unit = Variable.get_compilation_unit variable in + Variable { variable; compilation_unit } + +let import_for_pack ~pack:compilation_unit symbol = + match symbol with + | Linkage l -> Linkage { l with compilation_unit } + | Variable v -> Variable { v with compilation_unit } + +let compilation_unit t = + match t with + | Linkage { compilation_unit; _ } -> compilation_unit + | Variable { compilation_unit; _ } -> compilation_unit + +let print_opt ppf = function + | None -> Format.fprintf ppf "" + | Some t -> print ppf t + +let compare_lists l1 l2 = + Misc.Stdlib.List.compare compare l1 l2 diff --git a/middle_end/symbol.mli b/middle_end/symbol.mli new file mode 100644 index 0000000000..d2771af244 --- /dev/null +++ b/middle_end/symbol.mli @@ -0,0 +1,44 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(** A symbol identifies a constant provided by either: + - another compilation unit; or + - a top-level module. + + * [sym_unit] is the compilation unit containing the value. + * [sym_label] is the linkage name of the variable. + + The label must be globally unique: two compilation units linked in the + same program must not share labels. *) + +include Identifiable.S + +val of_variable : Variable.t -> t + +(* Create the symbol without prefixing with the compilation unit. + Used for global symbols like predefined exceptions *) +val of_global_linkage : Compilation_unit.t -> Linkage_name.t -> t + +val import_for_pack : pack:Compilation_unit.t -> t -> t + +val compilation_unit : t -> Compilation_unit.t +val label : t -> Linkage_name.t + +val print_opt : Format.formatter -> t option -> unit + +val compare_lists : t list -> t list -> int diff --git a/middle_end/unbox_closures.ml b/middle_end/unbox_closures.ml deleted file mode 100644 index 5c86bed3da..0000000000 --- a/middle_end/unbox_closures.ml +++ /dev/null @@ -1,87 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -module ASA = Augment_specialised_args -module W = ASA.What_to_specialise -module E = Inline_and_simplify_aux.Env - -module Transform = struct - let pass_name = "unbox-closures" - - let precondition ~env ~(set_of_closures : Flambda.set_of_closures) = - !Clflags.unbox_closures - && not (E.at_toplevel env) - && not (Variable.Map.is_empty set_of_closures.free_vars) - - let what_to_specialise ~env ~(set_of_closures : Flambda.set_of_closures) = - let what_to_specialise = W.create ~set_of_closures in - if not (precondition ~env ~set_of_closures) then - what_to_specialise - else begin - let round = E.round env in - let num_closure_vars = Variable.Map.cardinal set_of_closures.free_vars in - let module B = Inlining_cost.Benefit in - let saved_by_not_building_closure = - (* For the moment assume that we're going to cause all functions in the - set to become closed. *) - B.remove_prims (B.remove_call B.zero) num_closure_vars - in - Flambda_iterators.fold_function_decls_ignoring_stubs set_of_closures - ~init:what_to_specialise - ~f:(fun ~fun_var ~(function_decl : Flambda.function_declaration) - what_to_specialise -> - let body_size = Inlining_cost.lambda_size function_decl.body in - (* If the function is small enough, make a direct call surrogate - for it, so that indirect calls are not penalised by having to - bounce through the stub. (Making such a surrogate involves - duplicating the function.) *) - let small_enough_to_duplicate = - let module W = Inlining_cost.Whether_sufficient_benefit in - let wsb = - W.create_estimate ~original_size:0 - ~toplevel:false - ~branch_depth:0 - ~new_size:((body_size / !Clflags.unbox_closures_factor) + 1) - ~benefit:saved_by_not_building_closure - ~lifting:false - ~round - in - W.evaluate wsb - in - let what_to_specialise = - if small_enough_to_duplicate then - W.make_direct_call_surrogate_for what_to_specialise ~fun_var - else - what_to_specialise - in - let bound_by_the_closure = - Flambda_utils.variables_bound_by_the_closure - (Closure_id.wrap fun_var) - set_of_closures.function_decls - in - Variable.Set.fold (fun inner_free_var what_to_specialise -> - W.new_specialised_arg what_to_specialise - ~fun_var ~group:inner_free_var - ~definition:(Existing_inner_free_var inner_free_var)) - bound_by_the_closure - what_to_specialise) - end -end - -include ASA.Make (Transform) diff --git a/middle_end/unbox_closures.mli b/middle_end/unbox_closures.mli deleted file mode 100644 index fb935a622b..0000000000 --- a/middle_end/unbox_closures.mli +++ /dev/null @@ -1,33 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42"] - -(** Turn free variables of closures into specialised arguments. - The aim is to cause the closure to become closed. *) - -val rewrite_set_of_closures - : env:Inline_and_simplify_aux.Env.t - (* CR-soon mshinwell: eliminate superfluous parameter *) - -> duplicate_function:( - env:Inline_and_simplify_aux.Env.t - -> set_of_closures:Flambda.set_of_closures - -> fun_var:Variable.t - -> new_fun_var:Variable.t - -> Flambda.function_declaration - * Flambda.specialised_to Variable.Map.t) - -> set_of_closures:Flambda.set_of_closures - -> (Flambda.expr * Inlining_cost.Benefit.t) option diff --git a/middle_end/unbox_free_vars_of_closures.ml b/middle_end/unbox_free_vars_of_closures.ml deleted file mode 100644 index 7a4e48ed44..0000000000 --- a/middle_end/unbox_free_vars_of_closures.ml +++ /dev/null @@ -1,170 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -module B = Inlining_cost.Benefit - -let pass_name = "unbox-free-vars-of-closures" -let () = Pass_wrapper.register ~pass_name - -(* CR-someday mshinwell: Nearly but not quite the same as something that - Augment_specialised_args uses. *) -let add_lifted_projections_around_set_of_closures - ~set_of_closures ~existing_inner_to_outer_vars ~benefit - ~definitions_indexed_by_new_inner_vars = - let body = - Flambda_utils.name_expr (Set_of_closures set_of_closures) - ~name:Internal_variable_names.unbox_free_vars_of_closures - in - Variable.Map.fold (fun new_inner_var (projection : Projection.t) - (expr, benefit) -> - let find_outer_var inner_var = - match - Variable.Map.find inner_var existing_inner_to_outer_vars - with - | (outer_var : Flambda.specialised_to) -> outer_var.var - | exception Not_found -> - Misc.fatal_errorf "(UFV) find_outer_var: expected %a \ - to be in [existing_inner_to_outer_vars], but it is \ - not. (The projection was: %a)" - Variable.print inner_var - Projection.print projection - in - let benefit = B.add_projection projection benefit in - let named : Flambda.named = - (* The lifted projection must be in terms of outer variables, - not inner variables. *) - let projection = - Projection.map_projecting_from projection ~f:find_outer_var - in - Flambda_utils.projection_to_named projection - in - let expr = - Flambda.create_let (find_outer_var new_inner_var) named expr - in - (expr, benefit)) - definitions_indexed_by_new_inner_vars - (body, benefit) - -let run ~env ~(set_of_closures : Flambda.set_of_closures) = - if not !Clflags.unbox_free_vars_of_closures then - None - else - let definitions_indexed_by_new_inner_vars, _, free_vars, done_something = - let all_existing_definitions = - Variable.Map.fold (fun _inner_var (outer_var : Flambda.specialised_to) - all_existing_definitions -> - match outer_var.projection with - | None -> all_existing_definitions - | Some projection -> - Projection.Set.add projection all_existing_definitions) - set_of_closures.free_vars - Projection.Set.empty - in - Flambda_iterators.fold_function_decls_ignoring_stubs set_of_closures - ~init:(Variable.Map.empty, all_existing_definitions, - set_of_closures.free_vars, false) - ~f:(fun ~fun_var:_ ~function_decl result -> - let extracted = - Extract_projections.from_function_decl ~env ~function_decl - ~which_variables:set_of_closures.free_vars - in - Projection.Set.fold (fun projection - ((definitions_indexed_by_new_inner_vars, - all_existing_definitions_including_added_ones, - additional_free_vars, _done_something) as result) -> - (* Don't add a new free variable if there already exists a - free variable with the desired projection. We need to - dedup not only across the existing free variables but - also across newly-added ones (unlike in - [Augment_specialised_args]), since free variables are - not local to a function declaration but rather to a - set of closures. *) - if Projection.Set.mem projection - all_existing_definitions_including_added_ones - then begin - result - end else begin - (* Add a new free variable. This needs both a fresh - "new inner" and a fresh "new outer" var, since we know - the definition is not a duplicate. *) - let projecting_from = Projection.projecting_from projection in - let new_inner_var = Variable.rename projecting_from in - let new_outer_var = Variable.rename projecting_from in - let definitions_indexed_by_new_inner_vars = - Variable.Map.add new_inner_var projection - definitions_indexed_by_new_inner_vars - in - let all_existing_definitions_including_added_ones = - Projection.Set.add projection - all_existing_definitions_including_added_ones - in - let new_outer_var : Flambda.specialised_to = - { var = new_outer_var; - projection = Some projection; - } - in - let additional_free_vars = - Variable.Map.add new_inner_var new_outer_var - additional_free_vars - in - definitions_indexed_by_new_inner_vars, - all_existing_definitions_including_added_ones, - additional_free_vars, - true - end) - extracted - result) - in - if not done_something then - None - else - (* CR-someday mshinwell: could consider doing the grouping thing - similar to Augment_specialised_args *) - let num_free_vars_before = - Variable.Map.cardinal set_of_closures.free_vars - in - let num_free_vars_after = - Variable.Map.cardinal free_vars - in - assert (num_free_vars_after > num_free_vars_before); - (* Don't let the closure grow too large. *) - if num_free_vars_after > 2 * num_free_vars_before then - None - else - let set_of_closures = - Flambda.create_set_of_closures - ~function_decls:set_of_closures.function_decls - ~free_vars - ~specialised_args:set_of_closures.specialised_args - ~direct_call_surrogates:set_of_closures.direct_call_surrogates - in - let expr, benefit = - add_lifted_projections_around_set_of_closures ~set_of_closures - ~benefit:B.zero - ~existing_inner_to_outer_vars:set_of_closures.free_vars - ~definitions_indexed_by_new_inner_vars - in - Some (expr, benefit) - -let run ~env ~set_of_closures = - Pass_wrapper.with_dump ~ppf_dump:(Inline_and_simplify_aux.Env.ppf_dump env) - ~pass_name ~input:set_of_closures - ~print_input:Flambda.print_set_of_closures - ~print_output:(fun ppf (expr, _) -> Flambda.print ppf expr) - ~f:(fun () -> run ~env ~set_of_closures) diff --git a/middle_end/unbox_free_vars_of_closures.mli b/middle_end/unbox_free_vars_of_closures.mli deleted file mode 100644 index 3ee181ee3c..0000000000 --- a/middle_end/unbox_free_vars_of_closures.mli +++ /dev/null @@ -1,26 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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. *) -(* *) -(**************************************************************************) - -(** When approximations of free variables of closures indicate that they - are closures or blocks, rewrite projections from such blocks to new - variables (which become free in the closures), with the defining - expressions of the projections lifted out of the corresponding sets - of closures. *) - -val run - : env:Inline_and_simplify_aux.Env.t - -> set_of_closures:Flambda.set_of_closures - -> (Flambda.expr * Inlining_cost.Benefit.t) option diff --git a/middle_end/unbox_specialised_args.ml b/middle_end/unbox_specialised_args.ml deleted file mode 100644 index 70eb87601a..0000000000 --- a/middle_end/unbox_specialised_args.ml +++ /dev/null @@ -1,103 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] -open! Int_replace_polymorphic_compare - -module ASA = Augment_specialised_args -module W = ASA.What_to_specialise - -module Transform = struct - let pass_name = "unbox-specialised-args" - - let precondition ~env:_ ~(set_of_closures : Flambda.set_of_closures) = - !Clflags.unbox_specialised_args - && not (Variable.Map.is_empty set_of_closures.specialised_args) - - let what_to_specialise ~env ~(set_of_closures : Flambda.set_of_closures) = - let what_to_specialise = W.create ~set_of_closures in - if not (precondition ~env ~set_of_closures) then - what_to_specialise - else - let projections_by_function = - Variable.Map.filter_map set_of_closures.function_decls.funs - ~f:(fun _fun_var (function_decl : Flambda.function_declaration) -> - if function_decl.stub then None - else - Some (Extract_projections.from_function_decl ~env - ~function_decl - ~which_variables:set_of_closures.specialised_args)) - in - (* CR-soon mshinwell: consider caching the Invariant_params *relation* - as well as the "_in_recursion" map *) - let invariant_params_flow = - Invariant_params.invariant_param_sources set_of_closures.function_decls - ~backend:(Inline_and_simplify_aux.Env.backend env) - in - Variable.Map.fold (fun fun_var extractions what_to_specialise -> - Projection.Set.fold (fun (projection : Projection.t) - what_to_specialise -> - let group = Projection.projecting_from projection in - assert (Variable.Map.mem group set_of_closures.specialised_args); - let what_to_specialise = - W.new_specialised_arg what_to_specialise ~fun_var ~group - ~definition:(Projection_from_existing_specialised_arg - projection) - in - match Variable.Map.find group invariant_params_flow with - | exception Not_found -> what_to_specialise - | flow -> - (* If for function [f] we would extract a projection expression - [e] from some specialised argument [x] of [f], and we know - from [Invariant_params] that a specialised argument [y] of - another function [g] flows to [x], we will add [e] with - [y] substituted for [x] throughout as a newly-specialised - argument for [g]. This should help reduce the number of - simplification rounds required for mutually-recursive - functions. *) - Variable.Pair.Set.fold (fun (target_fun_var, target_spec_arg) - what_to_specialise -> - if Variable.equal fun_var target_fun_var - || not (Variable.Map.mem target_spec_arg - set_of_closures.specialised_args) - then begin - what_to_specialise - end else begin - (* Rewrite the projection (that was in terms of an inner - specialised arg of [fun_var]) to be in terms of the - corresponding inner specialised arg of - [target_fun_var]. (The outer vars referenced in the - projection remain unchanged.) *) - let projection = - Projection.map_projecting_from projection - ~f:(fun var -> - assert (Variable.equal var group); - target_spec_arg) - in - W.new_specialised_arg what_to_specialise - ~fun_var:target_fun_var ~group - ~definition: - (Projection_from_existing_specialised_arg projection) - end) - flow - what_to_specialise) - extractions - what_to_specialise) - projections_by_function - what_to_specialise -end - -include ASA.Make (Transform) diff --git a/middle_end/unbox_specialised_args.mli b/middle_end/unbox_specialised_args.mli deleted file mode 100644 index f019176482..0000000000 --- a/middle_end/unbox_specialised_args.mli +++ /dev/null @@ -1,50 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 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. *) -(* *) -(**************************************************************************) - -(** When approximations of specialised arguments indicate that they are - closures or blocks, add more specialised arguments corresponding to - the projections from such blocks (with definitions of such projections - lifted out), such that the original specialised arguments may later be - eliminated. - - This in particular enables elimination of closure allocations in - examples such as: - - let rec map f = function - | [] -> [] - | a::l -> let r = f a in r :: map f l - - let g x = - map (fun y -> x + y) [1; 2; 3; 4] - - Here, the specialised version of [map] initially has a specialised - argument [f]; and upon inlining there will be a projection of [x] from - the closure of [f]. This pass adds a new specialised argument to carry - that projection, at which point the closure of [f] is redundant. -*) - -val rewrite_set_of_closures - : env:Inline_and_simplify_aux.Env.t - (* CR-soon mshinwell: eliminate superfluous parameter *) - -> duplicate_function:( - env:Inline_and_simplify_aux.Env.t - -> set_of_closures:Flambda.set_of_closures - -> fun_var:Variable.t - -> new_fun_var:Variable.t - -> Flambda.function_declaration - * Flambda.specialised_to Variable.Map.t) - -> set_of_closures:Flambda.set_of_closures - -> (Flambda.expr * Inlining_cost.Benefit.t) option diff --git a/middle_end/variable.ml b/middle_end/variable.ml new file mode 100644 index 0000000000..64099a73b6 --- /dev/null +++ b/middle_end/variable.ml @@ -0,0 +1,119 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42-66"] +open! Int_replace_polymorphic_compare + +type t = { + compilation_unit : Compilation_unit.t; + name : string; + name_stamp : int; + (** [name_stamp]s are unique within any given compilation unit. *) +} + +include Identifiable.Make (struct + type nonrec t = t + + let compare t1 t2 = + if t1 == t2 then 0 + else + let c = t1.name_stamp - t2.name_stamp in + if c <> 0 then c + else Compilation_unit.compare t1.compilation_unit t2.compilation_unit + + let equal t1 t2 = + if t1 == t2 then true + else + t1.name_stamp = t2.name_stamp + && Compilation_unit.equal t1.compilation_unit t2.compilation_unit + + let output chan t = + output_string chan t.name; + output_string chan "_"; + output_string chan (Int.to_string t.name_stamp) + + let hash t = t.name_stamp lxor (Compilation_unit.hash t.compilation_unit) + + let print ppf t = + if Compilation_unit.equal t.compilation_unit + (Compilation_unit.get_current_exn ()) + then begin + Format.fprintf ppf "%s/%d" + t.name t.name_stamp + end else begin + Format.fprintf ppf "%a.%s/%d" + Compilation_unit.print t.compilation_unit + t.name t.name_stamp + end +end) + +let previous_name_stamp = ref (-1) + +let create_with_name_string ?current_compilation_unit name = + let compilation_unit = + match current_compilation_unit with + | Some compilation_unit -> compilation_unit + | None -> Compilation_unit.get_current_exn () + in + let name_stamp = + incr previous_name_stamp; + !previous_name_stamp + in + { compilation_unit; + name; + name_stamp; + } + +let create ?current_compilation_unit name = + let name = (name : Internal_variable_names.t :> string) in + create_with_name_string ?current_compilation_unit name + +let create_with_same_name_as_ident ident = + create_with_name_string (Ident.name ident) + +let rename ?current_compilation_unit t = + create_with_name_string ?current_compilation_unit t.name + +let in_compilation_unit t cu = + Compilation_unit.equal cu t.compilation_unit + +let get_compilation_unit t = t.compilation_unit + +let name t = t.name + +let unique_name t = + t.name ^ "_" ^ (Int.to_string t.name_stamp) + +let print_list ppf ts = + List.iter (fun t -> Format.fprintf ppf "@ %a" print t) ts + +let debug_when_stamp_matches t ~stamp ~f = + if t.name_stamp = stamp then f () + +let print_opt ppf = function + | None -> Format.fprintf ppf "" + | Some t -> print ppf t + +type pair = t * t +module Pair = Identifiable.Make (Identifiable.Pair (T) (T)) + +let compare_lists l1 l2 = + Misc.Stdlib.List.compare compare l1 l2 + +let output_full chan t = + Compilation_unit.output chan t.compilation_unit; + output_string chan "."; + output chan t diff --git a/middle_end/variable.mli b/middle_end/variable.mli new file mode 100644 index 0000000000..b5d3f136ae --- /dev/null +++ b/middle_end/variable.mli @@ -0,0 +1,63 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2016 OCamlPro SAS *) +(* Copyright 2014--2016 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-4-9-30-40-41-42"] + +(** [Variable.t] is the equivalent of a non-persistent [Ident.t] in + the [Flambda] tree. It wraps an [Ident.t] together with its source + [compilation_unit]. As such, it is unique within a whole program, + not just one compilation unit. + + Introducing a new type helps in tracing the source of identifiers + when debugging the inliner. It also avoids Ident renaming when + importing cmx files. +*) + +include Identifiable.S + +val create + : ?current_compilation_unit:Compilation_unit.t + -> Internal_variable_names.t + -> t +val create_with_same_name_as_ident : Ident.t -> t + +val rename + : ?current_compilation_unit:Compilation_unit.t + -> t + -> t + +val in_compilation_unit : t -> Compilation_unit.t -> bool + +val name : t -> string + +val unique_name : t -> string + +val get_compilation_unit : t -> Compilation_unit.t + +val print_list : Format.formatter -> t list -> unit +val print_opt : Format.formatter -> t option -> unit + +(** If the given variable has the given stamp, call the user-supplied + function. For debugging purposes only. *) +val debug_when_stamp_matches : t -> stamp:int -> f:(unit -> unit) -> unit + +type pair = t * t +module Pair : Identifiable.S with type t := pair + +val compare_lists : t list -> t list -> int + +val output_full : out_channel -> t -> unit +(** Unlike [output], [output_full] includes the compilation unit. *) -- cgit v1.2.1