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. --- .depend | 5519 ++++++++++---------- Changes | 3 + Makefile | 268 +- asmcomp/amd64/emit.mlp | 1 + asmcomp/asmgen.ml | 10 +- asmcomp/asmgen.mli | 1 + asmcomp/asmpackager.ml | 4 +- asmcomp/backend_var.ml | 87 - asmcomp/backend_var.mli | 54 - asmcomp/build_export_info.ml | 711 --- asmcomp/build_export_info.mli | 25 - asmcomp/clambda.ml | 203 - asmcomp/clambda.mli | 153 - asmcomp/clambda_primitives.ml | 155 - asmcomp/clambda_primitives.mli | 158 - asmcomp/closure.ml | 1453 ------ asmcomp/closure.mli | 19 - asmcomp/closure_offsets.ml | 89 - asmcomp/closure_offsets.mli | 27 - asmcomp/cmx_format.mli | 56 - asmcomp/cmxs_format.mli | 35 - asmcomp/compilenv.ml | 452 -- asmcomp/compilenv.mli | 153 - asmcomp/convert_primitives.ml | 153 - asmcomp/convert_primitives.mli | 17 - asmcomp/export_info.ml | 555 -- asmcomp/export_info.mli | 195 - asmcomp/export_info_for_pack.ml | 231 - asmcomp/export_info_for_pack.mli | 34 - asmcomp/flambda_to_clambda.ml | 749 --- asmcomp/flambda_to_clambda.mli | 38 - asmcomp/import_approx.ml | 222 - asmcomp/import_approx.mli | 34 - asmcomp/printclambda.ml | 272 - asmcomp/printclambda.mli | 26 - asmcomp/printclambda_primitives.ml | 202 - asmcomp/printclambda_primitives.mli | 18 - asmcomp/semantics_of_primitives.ml | 153 - asmcomp/semantics_of_primitives.mli | 69 - asmcomp/traverse_for_exported_symbols.ml | 267 - asmcomp/traverse_for_exported_symbols.mli | 41 - asmcomp/un_anf.ml | 817 --- asmcomp/un_anf.mli | 23 - bytecomp/cmo_format.mli | 66 - bytecomp/dune | 8 - bytecomp/generate_runtimedef.sh | 25 - bytecomp/lambda.ml | 886 ---- bytecomp/lambda.mli | 426 -- bytecomp/matching.ml | 3240 ------------ bytecomp/matching.mli | 46 - bytecomp/printlambda.ml | 648 --- bytecomp/printlambda.mli | 32 - bytecomp/runtimedef.mli | 19 - bytecomp/simplif.ml | 854 --- bytecomp/simplif.mli | 44 - bytecomp/switch.ml | 877 ---- bytecomp/switch.mli | 129 - bytecomp/translattribute.ml | 332 -- bytecomp/translattribute.mli | 76 - bytecomp/translclass.ml | 946 ---- bytecomp/translclass.mli | 29 - bytecomp/translcore.ml | 1048 ---- bytecomp/translcore.mli | 50 - bytecomp/translmod.ml | 1556 ------ bytecomp/translmod.mli | 61 - bytecomp/translobj.ml | 199 - bytecomp/translobj.mli | 33 - bytecomp/translprim.ml | 811 --- bytecomp/translprim.mli | 51 - debugger/.depend | 8 +- debugger/Makefile | 17 +- debugger/dune | 22 +- driver/optcompile.ml | 8 +- driver/optcompile.mli | 1 + dune | 142 +- file_formats/cmi_format.ml | 111 + file_formats/cmi_format.mli | 51 + file_formats/cmo_format.mli | 66 + file_formats/cmt_format.ml | 194 + file_formats/cmt_format.mli | 123 + file_formats/cmx_format.mli | 56 + file_formats/cmxs_format.mli | 35 + lambda/debuginfo.ml | 145 + lambda/debuginfo.mli | 46 + lambda/dune | 21 + lambda/generate_runtimedef.sh | 25 + lambda/lambda.ml | 886 ++++ lambda/lambda.mli | 426 ++ lambda/matching.ml | 3240 ++++++++++++ lambda/matching.mli | 46 + lambda/printlambda.ml | 648 +++ lambda/printlambda.mli | 32 + lambda/runtimedef.mli | 19 + lambda/simplif.ml | 854 +++ lambda/simplif.mli | 44 + lambda/switch.ml | 877 ++++ lambda/switch.mli | 129 + lambda/translattribute.ml | 332 ++ lambda/translattribute.mli | 76 + lambda/translclass.ml | 946 ++++ lambda/translclass.mli | 29 + lambda/translcore.ml | 1048 ++++ lambda/translcore.mli | 50 + lambda/translmod.ml | 1556 ++++++ lambda/translmod.mli | 61 + lambda/translobj.ml | 199 + lambda/translobj.mli | 33 + lambda/translprim.ml | 811 +++ lambda/translprim.mli | 51 + 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 + ocamldoc/Makefile.docfiles | 2 +- ocamltest/Makefile | 2 +- ocamltest/ocaml_modifiers.ml | 1 + otherlibs/dynlink/.depend | 3 +- otherlibs/dynlink/Makefile | 10 +- otherlibs/dynlink/dune | 31 +- testsuite/tools/Makefile | 1 + tools/.depend | 60 +- tools/Makefile | 12 +- toplevel/opttoploop.ml | 4 +- typing/cmi_format.ml | 111 - typing/cmi_format.mli | 51 - typing/cmt_format.ml | 194 - typing/cmt_format.mli | 123 - utils/int_replace_polymorphic_compare.ml | 8 + utils/int_replace_polymorphic_compare.mli | 8 + 399 files changed, 46816 insertions(+), 46691 deletions(-) delete mode 100644 asmcomp/backend_var.ml delete mode 100644 asmcomp/backend_var.mli delete mode 100644 asmcomp/build_export_info.ml delete mode 100644 asmcomp/build_export_info.mli delete mode 100644 asmcomp/clambda.ml delete mode 100644 asmcomp/clambda.mli delete mode 100644 asmcomp/clambda_primitives.ml delete mode 100644 asmcomp/clambda_primitives.mli delete mode 100644 asmcomp/closure.ml delete mode 100644 asmcomp/closure.mli delete mode 100644 asmcomp/closure_offsets.ml delete mode 100644 asmcomp/closure_offsets.mli delete mode 100644 asmcomp/cmx_format.mli delete mode 100644 asmcomp/cmxs_format.mli delete mode 100644 asmcomp/compilenv.ml delete mode 100644 asmcomp/compilenv.mli delete mode 100644 asmcomp/convert_primitives.ml delete mode 100644 asmcomp/convert_primitives.mli delete mode 100644 asmcomp/export_info.ml delete mode 100644 asmcomp/export_info.mli delete mode 100644 asmcomp/export_info_for_pack.ml delete mode 100644 asmcomp/export_info_for_pack.mli delete mode 100644 asmcomp/flambda_to_clambda.ml delete mode 100644 asmcomp/flambda_to_clambda.mli delete mode 100644 asmcomp/import_approx.ml delete mode 100644 asmcomp/import_approx.mli delete mode 100644 asmcomp/printclambda.ml delete mode 100644 asmcomp/printclambda.mli delete mode 100644 asmcomp/printclambda_primitives.ml delete mode 100644 asmcomp/printclambda_primitives.mli delete mode 100644 asmcomp/semantics_of_primitives.ml delete mode 100644 asmcomp/semantics_of_primitives.mli delete mode 100644 asmcomp/traverse_for_exported_symbols.ml delete mode 100644 asmcomp/traverse_for_exported_symbols.mli delete mode 100644 asmcomp/un_anf.ml delete mode 100644 asmcomp/un_anf.mli delete mode 100644 bytecomp/cmo_format.mli delete mode 100755 bytecomp/generate_runtimedef.sh delete mode 100644 bytecomp/lambda.ml delete mode 100644 bytecomp/lambda.mli delete mode 100644 bytecomp/matching.ml delete mode 100644 bytecomp/matching.mli delete mode 100644 bytecomp/printlambda.ml delete mode 100644 bytecomp/printlambda.mli delete mode 100644 bytecomp/runtimedef.mli delete mode 100644 bytecomp/simplif.ml delete mode 100644 bytecomp/simplif.mli delete mode 100644 bytecomp/switch.ml delete mode 100644 bytecomp/switch.mli delete mode 100644 bytecomp/translattribute.ml delete mode 100644 bytecomp/translattribute.mli delete mode 100644 bytecomp/translclass.ml delete mode 100644 bytecomp/translclass.mli delete mode 100644 bytecomp/translcore.ml delete mode 100644 bytecomp/translcore.mli delete mode 100644 bytecomp/translmod.ml delete mode 100644 bytecomp/translmod.mli delete mode 100644 bytecomp/translobj.ml delete mode 100644 bytecomp/translobj.mli delete mode 100644 bytecomp/translprim.ml delete mode 100644 bytecomp/translprim.mli create mode 100644 file_formats/cmi_format.ml create mode 100644 file_formats/cmi_format.mli create mode 100644 file_formats/cmo_format.mli create mode 100644 file_formats/cmt_format.ml create mode 100644 file_formats/cmt_format.mli create mode 100644 file_formats/cmx_format.mli create mode 100644 file_formats/cmxs_format.mli create mode 100644 lambda/debuginfo.ml create mode 100644 lambda/debuginfo.mli create mode 100644 lambda/dune create mode 100755 lambda/generate_runtimedef.sh create mode 100644 lambda/lambda.ml create mode 100644 lambda/lambda.mli create mode 100644 lambda/matching.ml create mode 100644 lambda/matching.mli create mode 100644 lambda/printlambda.ml create mode 100644 lambda/printlambda.mli create mode 100644 lambda/runtimedef.mli create mode 100644 lambda/simplif.ml create mode 100644 lambda/simplif.mli create mode 100644 lambda/switch.ml create mode 100644 lambda/switch.mli create mode 100644 lambda/translattribute.ml create mode 100644 lambda/translattribute.mli create mode 100644 lambda/translclass.ml create mode 100644 lambda/translclass.mli create mode 100644 lambda/translcore.ml create mode 100644 lambda/translcore.mli create mode 100644 lambda/translmod.ml create mode 100644 lambda/translmod.mli create mode 100644 lambda/translobj.ml create mode 100644 lambda/translobj.mli create mode 100644 lambda/translprim.ml create mode 100644 lambda/translprim.mli 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 delete mode 100644 typing/cmi_format.ml delete mode 100644 typing/cmi_format.mli delete mode 100644 typing/cmt_format.ml delete mode 100644 typing/cmt_format.mli create mode 100644 utils/int_replace_polymorphic_compare.ml create mode 100644 utils/int_replace_polymorphic_compare.mli diff --git a/.depend b/.depend index a430495140..45473a40cd 100644 --- a/.depend +++ b/.depend @@ -58,6 +58,11 @@ utils/identifiable.cmx : \ utils/misc.cmx \ utils/identifiable.cmi utils/identifiable.cmi : +utils/int_replace_polymorphic_compare.cmo : \ + utils/int_replace_polymorphic_compare.cmi +utils/int_replace_polymorphic_compare.cmx : \ + utils/int_replace_polymorphic_compare.cmi +utils/int_replace_polymorphic_compare.cmi : utils/load_path.cmo : \ utils/misc.cmi \ utils/load_path.cmi @@ -431,54 +436,6 @@ typing/btype.cmi : \ typing/types.cmi \ typing/path.cmi \ parsing/asttypes.cmi -typing/cmi_format.cmo : \ - typing/types.cmi \ - utils/misc.cmi \ - parsing/location.cmi \ - utils/config.cmi \ - typing/cmi_format.cmi -typing/cmi_format.cmx : \ - typing/types.cmx \ - utils/misc.cmx \ - parsing/location.cmx \ - utils/config.cmx \ - typing/cmi_format.cmi -typing/cmi_format.cmi : \ - typing/types.cmi \ - utils/misc.cmi -typing/cmt_format.cmo : \ - typing/types.cmi \ - typing/typedtree.cmi \ - typing/tast_mapper.cmi \ - utils/misc.cmi \ - parsing/location.cmi \ - utils/load_path.cmi \ - parsing/lexer.cmi \ - typing/env.cmi \ - utils/config.cmi \ - typing/cmi_format.cmi \ - utils/clflags.cmi \ - typing/cmt_format.cmi -typing/cmt_format.cmx : \ - typing/types.cmx \ - typing/typedtree.cmx \ - typing/tast_mapper.cmx \ - utils/misc.cmx \ - parsing/location.cmx \ - utils/load_path.cmx \ - parsing/lexer.cmx \ - typing/env.cmx \ - utils/config.cmx \ - typing/cmi_format.cmx \ - utils/clflags.cmx \ - typing/cmt_format.cmi -typing/cmt_format.cmi : \ - typing/types.cmi \ - typing/typedtree.cmi \ - utils/misc.cmi \ - parsing/location.cmi \ - typing/env.cmi \ - typing/cmi_format.cmi typing/ctype.cmo : \ typing/types.cmi \ typing/subst.cmi \ @@ -547,7 +504,7 @@ typing/env.cmo : \ utils/load_path.cmi \ typing/ident.cmi \ typing/datarepr.cmi \ - typing/cmi_format.cmi \ + file_formats/cmi_format.cmi \ utils/clflags.cmi \ parsing/builtin_attributes.cmi \ typing/btype.cmi \ @@ -566,7 +523,7 @@ typing/env.cmx : \ utils/load_path.cmx \ typing/ident.cmx \ typing/datarepr.cmx \ - typing/cmi_format.cmx \ + file_formats/cmi_format.cmx \ utils/clflags.cmx \ parsing/builtin_attributes.cmx \ typing/btype.cmx \ @@ -582,7 +539,7 @@ typing/env.cmi : \ parsing/location.cmi \ utils/load_path.cmi \ typing/ident.cmi \ - typing/cmi_format.cmi \ + file_formats/cmi_format.cmi \ parsing/asttypes.cmi typing/envaux.cmo : \ typing/subst.cmi \ @@ -679,7 +636,7 @@ typing/includemod.cmo : \ typing/ident.cmi \ typing/env.cmi \ typing/ctype.cmi \ - typing/cmt_format.cmi \ + file_formats/cmt_format.cmi \ utils/clflags.cmi \ parsing/builtin_attributes.cmi \ typing/btype.cmi \ @@ -700,7 +657,7 @@ typing/includemod.cmx : \ typing/ident.cmx \ typing/env.cmx \ typing/ctype.cmx \ - typing/cmt_format.cmx \ + file_formats/cmt_format.cmx \ utils/clflags.cmx \ parsing/builtin_attributes.cmx \ typing/btype.cmx \ @@ -825,7 +782,7 @@ typing/persistent_env.cmo : \ utils/load_path.cmi \ utils/consistbl.cmi \ utils/config.cmi \ - typing/cmi_format.cmi \ + file_formats/cmi_format.cmi \ utils/clflags.cmi \ typing/persistent_env.cmi typing/persistent_env.cmx : \ @@ -835,7 +792,7 @@ typing/persistent_env.cmx : \ utils/load_path.cmx \ utils/consistbl.cmx \ utils/config.cmx \ - typing/cmi_format.cmx \ + file_formats/cmi_format.cmx \ utils/clflags.cmx \ typing/persistent_env.cmi typing/persistent_env.cmi : \ @@ -843,7 +800,7 @@ typing/persistent_env.cmi : \ utils/misc.cmi \ parsing/location.cmi \ utils/consistbl.cmi \ - typing/cmi_format.cmi + file_formats/cmi_format.cmi typing/predef.cmo : \ typing/types.cmi \ typing/path.cmi \ @@ -983,7 +940,7 @@ typing/rec_check.cmo : \ typing/typedtree.cmi \ typing/primitive.cmi \ typing/path.cmi \ - bytecomp/lambda.cmi \ + lambda/lambda.cmi \ typing/ident.cmi \ parsing/asttypes.cmi \ typing/rec_check.cmi @@ -993,7 +950,7 @@ typing/rec_check.cmx : \ typing/typedtree.cmx \ typing/primitive.cmx \ typing/path.cmx \ - bytecomp/lambda.cmx \ + lambda/lambda.cmx \ typing/ident.cmx \ parsing/asttypes.cmi \ typing/rec_check.cmi @@ -1096,7 +1053,7 @@ typing/typeclass.cmo : \ typing/ident.cmi \ typing/env.cmi \ typing/ctype.cmi \ - typing/cmt_format.cmi \ + file_formats/cmt_format.cmi \ utils/clflags.cmi \ parsing/builtin_attributes.cmi \ typing/btype.cmi \ @@ -1125,7 +1082,7 @@ typing/typeclass.cmx : \ typing/ident.cmx \ typing/env.cmx \ typing/ctype.cmx \ - typing/cmt_format.cmx \ + file_formats/cmt_format.cmx \ utils/clflags.cmx \ parsing/builtin_attributes.cmx \ typing/btype.cmx \ @@ -1167,7 +1124,7 @@ typing/typecore.cmo : \ typing/ident.cmi \ typing/env.cmi \ typing/ctype.cmi \ - typing/cmt_format.cmi \ + file_formats/cmt_format.cmi \ utils/clflags.cmi \ parsing/builtin_attributes.cmi \ typing/btype.cmi \ @@ -1200,7 +1157,7 @@ typing/typecore.cmx : \ typing/ident.cmx \ typing/env.cmx \ typing/ctype.cmx \ - typing/cmt_format.cmx \ + file_formats/cmt_format.cmx \ utils/clflags.cmx \ parsing/builtin_attributes.cmx \ typing/btype.cmx \ @@ -1441,8 +1398,8 @@ typing/typemod.cmo : \ typing/env.cmi \ typing/ctype.cmi \ utils/config.cmi \ - typing/cmt_format.cmi \ - typing/cmi_format.cmi \ + file_formats/cmt_format.cmi \ + file_formats/cmi_format.cmi \ utils/clflags.cmi \ parsing/builtin_attributes.cmi \ typing/btype.cmi \ @@ -1473,8 +1430,8 @@ typing/typemod.cmx : \ typing/env.cmx \ typing/ctype.cmx \ utils/config.cmx \ - typing/cmt_format.cmx \ - typing/cmi_format.cmx \ + file_formats/cmt_format.cmx \ + file_formats/cmi_format.cmx \ utils/clflags.cmx \ parsing/builtin_attributes.cmx \ typing/btype.cmx \ @@ -1493,14 +1450,14 @@ typing/typemod.cmi : \ typing/includemod.cmi \ typing/ident.cmi \ typing/env.cmi \ - typing/cmi_format.cmi + file_formats/cmi_format.cmi typing/typeopt.cmo : \ typing/types.cmi \ typing/typedtree.cmi \ typing/typedecl.cmi \ typing/predef.cmi \ typing/path.cmi \ - bytecomp/lambda.cmi \ + lambda/lambda.cmi \ typing/ident.cmi \ typing/env.cmi \ typing/ctype.cmi \ @@ -1513,7 +1470,7 @@ typing/typeopt.cmx : \ typing/typedecl.cmx \ typing/predef.cmx \ typing/path.cmx \ - bytecomp/lambda.cmx \ + lambda/lambda.cmx \ typing/ident.cmx \ typing/env.cmx \ typing/ctype.cmx \ @@ -1524,7 +1481,7 @@ typing/typeopt.cmi : \ typing/types.cmi \ typing/typedtree.cmi \ typing/path.cmi \ - bytecomp/lambda.cmi \ + lambda/lambda.cmi \ typing/env.cmi typing/types.cmo : \ typing/primitive.cmi \ @@ -1640,12 +1597,12 @@ typing/untypeast.cmi : \ parsing/asttypes.cmi bytecomp/bytegen.cmo : \ typing/types.cmi \ - bytecomp/switch.cmi \ + lambda/switch.cmi \ typing/subst.cmi \ typing/primitive.cmi \ utils/misc.cmi \ - bytecomp/matching.cmi \ - bytecomp/lambda.cmi \ + lambda/matching.cmi \ + lambda/lambda.cmi \ bytecomp/instruct.cmi \ typing/ident.cmi \ typing/env.cmi \ @@ -1654,12 +1611,12 @@ bytecomp/bytegen.cmo : \ bytecomp/bytegen.cmi bytecomp/bytegen.cmx : \ typing/types.cmx \ - bytecomp/switch.cmx \ + lambda/switch.cmx \ typing/subst.cmx \ typing/primitive.cmx \ utils/misc.cmx \ - bytecomp/matching.cmx \ - bytecomp/lambda.cmx \ + lambda/matching.cmx \ + lambda/lambda.cmx \ bytecomp/instruct.cmx \ typing/ident.cmx \ typing/env.cmx \ @@ -1667,7 +1624,7 @@ bytecomp/bytegen.cmx : \ parsing/asttypes.cmi \ bytecomp/bytegen.cmi bytecomp/bytegen.cmi : \ - bytecomp/lambda.cmi \ + lambda/lambda.cmi \ bytecomp/instruct.cmi bytecomp/bytelibrarian.cmo : \ utils/misc.cmi \ @@ -1675,7 +1632,7 @@ bytecomp/bytelibrarian.cmo : \ utils/load_path.cmi \ bytecomp/emitcode.cmi \ utils/config.cmi \ - bytecomp/cmo_format.cmi \ + file_formats/cmo_format.cmi \ utils/clflags.cmi \ bytecomp/bytelink.cmi \ bytecomp/bytelibrarian.cmi @@ -1685,7 +1642,7 @@ bytecomp/bytelibrarian.cmx : \ utils/load_path.cmx \ bytecomp/emitcode.cmx \ utils/config.cmx \ - bytecomp/cmo_format.cmi \ + file_formats/cmo_format.cmi \ utils/clflags.cmx \ bytecomp/bytelink.cmx \ bytecomp/bytelibrarian.cmi @@ -1703,7 +1660,7 @@ bytecomp/bytelink.cmo : \ bytecomp/dll.cmi \ utils/consistbl.cmi \ utils/config.cmi \ - bytecomp/cmo_format.cmi \ + file_formats/cmo_format.cmi \ utils/clflags.cmi \ utils/ccomp.cmi \ bytecomp/bytesections.cmi \ @@ -1721,7 +1678,7 @@ bytecomp/bytelink.cmx : \ bytecomp/dll.cmx \ utils/consistbl.cmx \ utils/config.cmx \ - bytecomp/cmo_format.cmi \ + file_formats/cmo_format.cmi \ utils/clflags.cmx \ utils/ccomp.cmx \ bytecomp/bytesections.cmx \ @@ -1729,12 +1686,12 @@ bytecomp/bytelink.cmx : \ bytecomp/bytelink.cmi : \ bytecomp/symtable.cmi \ utils/misc.cmi \ - bytecomp/cmo_format.cmi + file_formats/cmo_format.cmi bytecomp/bytepackager.cmo : \ typing/typemod.cmi \ - bytecomp/translmod.cmi \ + lambda/translmod.cmi \ typing/subst.cmi \ - bytecomp/printlambda.cmi \ + lambda/printlambda.cmi \ typing/path.cmi \ utils/misc.cmi \ parsing/location.cmi \ @@ -1744,16 +1701,16 @@ bytecomp/bytepackager.cmo : \ typing/env.cmi \ bytecomp/emitcode.cmi \ utils/config.cmi \ - bytecomp/cmo_format.cmi \ + file_formats/cmo_format.cmi \ utils/clflags.cmi \ bytecomp/bytelink.cmi \ bytecomp/bytegen.cmi \ bytecomp/bytepackager.cmi bytecomp/bytepackager.cmx : \ typing/typemod.cmx \ - bytecomp/translmod.cmx \ + lambda/translmod.cmx \ typing/subst.cmx \ - bytecomp/printlambda.cmx \ + lambda/printlambda.cmx \ typing/path.cmx \ utils/misc.cmx \ parsing/location.cmx \ @@ -1763,7 +1720,7 @@ bytecomp/bytepackager.cmx : \ typing/env.cmx \ bytecomp/emitcode.cmx \ utils/config.cmx \ - bytecomp/cmo_format.cmi \ + file_formats/cmo_format.cmi \ utils/clflags.cmx \ bytecomp/bytelink.cmx \ bytecomp/bytegen.cmx \ @@ -1778,10 +1735,6 @@ bytecomp/bytesections.cmx : \ utils/config.cmx \ bytecomp/bytesections.cmi bytecomp/bytesections.cmi : -bytecomp/cmo_format.cmi : \ - utils/misc.cmi \ - bytecomp/lambda.cmi \ - typing/ident.cmi bytecomp/dll.cmo : \ utils/misc.cmi \ utils/config.cmi \ @@ -1792,34 +1745,34 @@ bytecomp/dll.cmx : \ bytecomp/dll.cmi bytecomp/dll.cmi : bytecomp/emitcode.cmo : \ - bytecomp/translmod.cmi \ + lambda/translmod.cmi \ typing/primitive.cmi \ bytecomp/opcodes.cmi \ utils/misc.cmi \ parsing/location.cmi \ - bytecomp/lambda.cmi \ + lambda/lambda.cmi \ bytecomp/instruct.cmi \ typing/ident.cmi \ typing/env.cmi \ utils/config.cmi \ - bytecomp/cmo_format.cmi \ + file_formats/cmo_format.cmi \ utils/clflags.cmi \ bytecomp/bytegen.cmi \ typing/btype.cmi \ parsing/asttypes.cmi \ bytecomp/emitcode.cmi bytecomp/emitcode.cmx : \ - bytecomp/translmod.cmx \ + lambda/translmod.cmx \ typing/primitive.cmx \ bytecomp/opcodes.cmx \ utils/misc.cmx \ parsing/location.cmx \ - bytecomp/lambda.cmx \ + lambda/lambda.cmx \ bytecomp/instruct.cmx \ typing/ident.cmx \ typing/env.cmx \ utils/config.cmx \ - bytecomp/cmo_format.cmi \ + file_formats/cmo_format.cmi \ utils/clflags.cmx \ bytecomp/bytegen.cmx \ typing/btype.cmx \ @@ -1829,12 +1782,12 @@ bytecomp/emitcode.cmi : \ utils/misc.cmi \ bytecomp/instruct.cmi \ typing/ident.cmi \ - bytecomp/cmo_format.cmi + file_formats/cmo_format.cmi bytecomp/instruct.cmo : \ typing/types.cmi \ typing/subst.cmi \ parsing/location.cmi \ - bytecomp/lambda.cmi \ + lambda/lambda.cmi \ typing/ident.cmi \ typing/env.cmi \ bytecomp/instruct.cmi @@ -1842,7 +1795,7 @@ bytecomp/instruct.cmx : \ typing/types.cmx \ typing/subst.cmx \ parsing/location.cmx \ - bytecomp/lambda.cmx \ + lambda/lambda.cmx \ typing/ident.cmx \ typing/env.cmx \ bytecomp/instruct.cmi @@ -1850,84 +1803,9 @@ bytecomp/instruct.cmi : \ typing/types.cmi \ typing/subst.cmi \ parsing/location.cmi \ - bytecomp/lambda.cmi \ + lambda/lambda.cmi \ typing/ident.cmi \ typing/env.cmi -bytecomp/lambda.cmo : \ - typing/types.cmi \ - typing/primitive.cmi \ - typing/path.cmi \ - utils/misc.cmi \ - parsing/longident.cmi \ - parsing/location.cmi \ - typing/ident.cmi \ - typing/env.cmi \ - parsing/asttypes.cmi \ - bytecomp/lambda.cmi -bytecomp/lambda.cmx : \ - typing/types.cmx \ - typing/primitive.cmx \ - typing/path.cmx \ - utils/misc.cmx \ - parsing/longident.cmx \ - parsing/location.cmx \ - typing/ident.cmx \ - typing/env.cmx \ - parsing/asttypes.cmi \ - bytecomp/lambda.cmi -bytecomp/lambda.cmi : \ - typing/types.cmi \ - typing/primitive.cmi \ - typing/path.cmi \ - parsing/location.cmi \ - typing/ident.cmi \ - typing/env.cmi \ - parsing/asttypes.cmi -bytecomp/matching.cmo : \ - typing/types.cmi \ - typing/typeopt.cmi \ - typing/typedtree.cmi \ - bytecomp/switch.cmi \ - typing/printpat.cmi \ - bytecomp/printlambda.cmi \ - typing/primitive.cmi \ - typing/predef.cmi \ - typing/parmatch.cmi \ - utils/misc.cmi \ - parsing/longident.cmi \ - parsing/location.cmi \ - bytecomp/lambda.cmi \ - typing/ident.cmi \ - typing/env.cmi \ - utils/clflags.cmi \ - typing/btype.cmi \ - parsing/asttypes.cmi \ - bytecomp/matching.cmi -bytecomp/matching.cmx : \ - typing/types.cmx \ - typing/typeopt.cmx \ - typing/typedtree.cmx \ - bytecomp/switch.cmx \ - typing/printpat.cmx \ - bytecomp/printlambda.cmx \ - typing/primitive.cmx \ - typing/predef.cmx \ - typing/parmatch.cmx \ - utils/misc.cmx \ - parsing/longident.cmx \ - parsing/location.cmx \ - bytecomp/lambda.cmx \ - typing/ident.cmx \ - typing/env.cmx \ - utils/clflags.cmx \ - typing/btype.cmx \ - parsing/asttypes.cmi \ - bytecomp/matching.cmi -bytecomp/matching.cmi : \ - typing/typedtree.cmi \ - parsing/location.cmi \ - bytecomp/lambda.cmi \ - typing/ident.cmi bytecomp/meta.cmo : \ bytecomp/instruct.cmi \ bytecomp/meta.cmi @@ -1942,456 +1820,152 @@ bytecomp/opcodes.cmx : \ bytecomp/opcodes.cmi bytecomp/opcodes.cmi : bytecomp/printinstr.cmo : \ - bytecomp/printlambda.cmi \ + lambda/printlambda.cmi \ parsing/location.cmi \ - bytecomp/lambda.cmi \ + lambda/lambda.cmi \ bytecomp/instruct.cmi \ typing/ident.cmi \ bytecomp/printinstr.cmi bytecomp/printinstr.cmx : \ - bytecomp/printlambda.cmx \ + lambda/printlambda.cmx \ parsing/location.cmx \ - bytecomp/lambda.cmx \ + lambda/lambda.cmx \ bytecomp/instruct.cmx \ typing/ident.cmx \ bytecomp/printinstr.cmi bytecomp/printinstr.cmi : \ bytecomp/instruct.cmi -bytecomp/printlambda.cmo : \ - typing/types.cmi \ - typing/printtyp.cmi \ - typing/primitive.cmi \ - parsing/location.cmi \ - bytecomp/lambda.cmi \ - typing/ident.cmi \ - parsing/asttypes.cmi \ - bytecomp/printlambda.cmi -bytecomp/printlambda.cmx : \ - typing/types.cmx \ - typing/printtyp.cmx \ - typing/primitive.cmx \ - parsing/location.cmx \ - bytecomp/lambda.cmx \ - typing/ident.cmx \ - parsing/asttypes.cmi \ - bytecomp/printlambda.cmi -bytecomp/printlambda.cmi : \ - typing/types.cmi \ - bytecomp/lambda.cmi -bytecomp/runtimedef.cmo : \ - bytecomp/runtimedef.cmi -bytecomp/runtimedef.cmx : \ - bytecomp/runtimedef.cmi -bytecomp/runtimedef.cmi : -bytecomp/simplif.cmo : \ - utils/warnings.cmi \ - typing/stypes.cmi \ - typing/primitive.cmi \ - utils/misc.cmi \ - parsing/location.cmi \ - bytecomp/lambda.cmi \ - typing/ident.cmi \ - utils/clflags.cmi \ - parsing/asttypes.cmi \ - typing/annot.cmi \ - bytecomp/simplif.cmi -bytecomp/simplif.cmx : \ - utils/warnings.cmx \ - typing/stypes.cmx \ - typing/primitive.cmx \ - utils/misc.cmx \ - parsing/location.cmx \ - bytecomp/lambda.cmx \ - typing/ident.cmx \ - utils/clflags.cmx \ - parsing/asttypes.cmi \ - typing/annot.cmi \ - bytecomp/simplif.cmi -bytecomp/simplif.cmi : \ - parsing/location.cmi \ - bytecomp/lambda.cmi \ - typing/ident.cmi -bytecomp/switch.cmo : \ - parsing/location.cmi \ - bytecomp/switch.cmi -bytecomp/switch.cmx : \ - parsing/location.cmx \ - bytecomp/switch.cmi -bytecomp/switch.cmi : \ - parsing/location.cmi bytecomp/symtable.cmo : \ - bytecomp/runtimedef.cmi \ + lambda/runtimedef.cmi \ typing/predef.cmi \ utils/misc.cmi \ bytecomp/meta.cmi \ parsing/location.cmi \ - bytecomp/lambda.cmi \ + lambda/lambda.cmi \ typing/ident.cmi \ bytecomp/dll.cmi \ utils/config.cmi \ - bytecomp/cmo_format.cmi \ + file_formats/cmo_format.cmi \ utils/clflags.cmi \ bytecomp/bytesections.cmi \ parsing/asttypes.cmi \ bytecomp/symtable.cmi bytecomp/symtable.cmx : \ - bytecomp/runtimedef.cmx \ + lambda/runtimedef.cmx \ typing/predef.cmx \ utils/misc.cmx \ bytecomp/meta.cmx \ parsing/location.cmx \ - bytecomp/lambda.cmx \ + lambda/lambda.cmx \ typing/ident.cmx \ bytecomp/dll.cmx \ utils/config.cmx \ - bytecomp/cmo_format.cmi \ + file_formats/cmo_format.cmi \ utils/clflags.cmx \ bytecomp/bytesections.cmx \ parsing/asttypes.cmi \ bytecomp/symtable.cmi bytecomp/symtable.cmi : \ utils/misc.cmi \ - bytecomp/lambda.cmi \ - typing/ident.cmi \ - bytecomp/cmo_format.cmi -bytecomp/translattribute.cmo : \ - utils/warnings.cmi \ - typing/typedtree.cmi \ - parsing/parsetree.cmi \ - utils/misc.cmi \ - parsing/longident.cmi \ - parsing/location.cmi \ - bytecomp/lambda.cmi \ - utils/config.cmi \ - bytecomp/translattribute.cmi -bytecomp/translattribute.cmx : \ - utils/warnings.cmx \ - typing/typedtree.cmx \ - parsing/parsetree.cmi \ - utils/misc.cmx \ - parsing/longident.cmx \ - parsing/location.cmx \ - bytecomp/lambda.cmx \ - utils/config.cmx \ - bytecomp/translattribute.cmi -bytecomp/translattribute.cmi : \ - typing/typedtree.cmi \ - parsing/parsetree.cmi \ - parsing/location.cmi \ - bytecomp/lambda.cmi -bytecomp/translclass.cmo : \ - typing/types.cmi \ - typing/typeopt.cmi \ - typing/typedtree.cmi \ - bytecomp/translobj.cmi \ - bytecomp/translcore.cmi \ - typing/path.cmi \ - bytecomp/matching.cmi \ - parsing/location.cmi \ - bytecomp/lambda.cmi \ + lambda/lambda.cmi \ typing/ident.cmi \ - typing/env.cmi \ + file_formats/cmo_format.cmi +asmcomp/CSE.cmo : \ + asmcomp/mach.cmi \ + asmcomp/CSEgen.cmi \ + asmcomp/arch.cmo +asmcomp/CSE.cmx : \ + asmcomp/mach.cmx \ + asmcomp/CSEgen.cmx \ + asmcomp/arch.cmx +asmcomp/CSEgen.cmo : \ + asmcomp/reg.cmi \ + asmcomp/proc.cmi \ + asmcomp/mach.cmi \ + asmcomp/cmm.cmi \ + asmcomp/CSEgen.cmi +asmcomp/CSEgen.cmx : \ + asmcomp/reg.cmx \ + asmcomp/proc.cmx \ + asmcomp/mach.cmx \ + asmcomp/cmm.cmx \ + asmcomp/CSEgen.cmi +asmcomp/CSEgen.cmi : \ + asmcomp/mach.cmi +asmcomp/afl_instrument.cmo : \ + lambda/lambda.cmi \ + asmcomp/cmm.cmi \ utils/clflags.cmi \ - typing/btype.cmi \ + middle_end/backend_var.cmi \ parsing/asttypes.cmi \ - bytecomp/translclass.cmi -bytecomp/translclass.cmx : \ - typing/types.cmx \ - typing/typeopt.cmx \ - typing/typedtree.cmx \ - bytecomp/translobj.cmx \ - bytecomp/translcore.cmx \ - typing/path.cmx \ - bytecomp/matching.cmx \ - parsing/location.cmx \ - bytecomp/lambda.cmx \ - typing/ident.cmx \ - typing/env.cmx \ + asmcomp/afl_instrument.cmi +asmcomp/afl_instrument.cmx : \ + lambda/lambda.cmx \ + asmcomp/cmm.cmx \ utils/clflags.cmx \ - typing/btype.cmx \ + middle_end/backend_var.cmx \ parsing/asttypes.cmi \ - bytecomp/translclass.cmi -bytecomp/translclass.cmi : \ - typing/typedtree.cmi \ - parsing/location.cmi \ - bytecomp/lambda.cmi \ - typing/ident.cmi \ - parsing/asttypes.cmi -bytecomp/translcore.cmo : \ - typing/types.cmi \ - typing/typeopt.cmi \ - typing/typedtree.cmi \ - typing/typecore.cmi \ - bytecomp/translprim.cmi \ - bytecomp/translobj.cmi \ - bytecomp/translattribute.cmi \ - typing/printtyp.cmi \ + asmcomp/afl_instrument.cmi +asmcomp/afl_instrument.cmi : \ + lambda/debuginfo.cmi \ + asmcomp/cmm.cmi +asmcomp/arch.cmo : \ + utils/config.cmi \ + utils/clflags.cmi +asmcomp/arch.cmx : \ + utils/config.cmx \ + utils/clflags.cmx +asmcomp/asmgen.cmo : \ + middle_end/flambda/un_anf.cmi \ + lambda/translmod.cmi \ + middle_end/symbol.cmi \ + asmcomp/split.cmi \ + asmcomp/spill.cmi \ + asmcomp/selection.cmi \ + asmcomp/scheduling.cmi \ + asmcomp/reload.cmi \ + asmcomp/reg.cmi \ + utils/profile.cmi \ + asmcomp/proc.cmi \ + asmcomp/printmach.cmi \ + asmcomp/printlinear.cmi \ + asmcomp/printcmm.cmi \ + middle_end/printclambda.cmi \ typing/primitive.cmi \ - typing/predef.cmi \ typing/path.cmi \ - parsing/parsetree.cmi \ - typing/parmatch.cmi \ utils/misc.cmi \ - bytecomp/matching.cmi \ - parsing/longident.cmi \ + asmcomp/mach.cmi \ parsing/location.cmi \ - bytecomp/lambda.cmi \ + asmcomp/liveness.cmi \ + asmcomp/linscan.cmi \ + middle_end/linkage_name.cmi \ + asmcomp/linearize.cmi \ + lambda/lambda.cmi \ + asmcomp/interval.cmi \ + asmcomp/interf.cmi \ typing/ident.cmi \ - typing/env.cmi \ + middle_end/flambda/flambda_to_clambda.cmi \ + middle_end/flambda/flambda.cmi \ + asmcomp/emitaux.cmi \ + asmcomp/emit.cmi \ + asmcomp/deadcode.cmi \ utils/config.cmi \ + middle_end/compilenv.cmi \ + asmcomp/comballoc.cmi \ + asmcomp/coloring.cmi \ + asmcomp/cmmgen.cmi \ + asmcomp/cmm.cmi \ + middle_end/closure/closure.cmi \ utils/clflags.cmi \ - typing/btype.cmi \ - parsing/asttypes.cmi \ - bytecomp/translcore.cmi -bytecomp/translcore.cmx : \ - typing/types.cmx \ - typing/typeopt.cmx \ - typing/typedtree.cmx \ - typing/typecore.cmx \ - bytecomp/translprim.cmx \ - bytecomp/translobj.cmx \ - bytecomp/translattribute.cmx \ - typing/printtyp.cmx \ - typing/primitive.cmx \ - typing/predef.cmx \ - typing/path.cmx \ - parsing/parsetree.cmi \ - typing/parmatch.cmx \ - utils/misc.cmx \ - bytecomp/matching.cmx \ - parsing/longident.cmx \ - parsing/location.cmx \ - bytecomp/lambda.cmx \ - typing/ident.cmx \ - typing/env.cmx \ - utils/config.cmx \ - utils/clflags.cmx \ - typing/btype.cmx \ - parsing/asttypes.cmi \ - bytecomp/translcore.cmi -bytecomp/translcore.cmi : \ - typing/typedtree.cmi \ - typing/path.cmi \ - parsing/location.cmi \ - bytecomp/lambda.cmi \ - typing/ident.cmi \ - typing/env.cmi \ - parsing/asttypes.cmi -bytecomp/translmod.cmo : \ - typing/types.cmi \ - typing/typedtree.cmi \ - bytecomp/translprim.cmi \ - bytecomp/translobj.cmi \ - bytecomp/translcore.cmi \ - bytecomp/translclass.cmi \ - bytecomp/translattribute.cmi \ - typing/primitive.cmi \ - typing/predef.cmi \ - typing/path.cmi \ - typing/mtype.cmi \ - utils/misc.cmi \ - parsing/location.cmi \ - bytecomp/lambda.cmi \ - typing/ident.cmi \ - typing/env.cmi \ - typing/ctype.cmi \ - utils/clflags.cmi \ - parsing/asttypes.cmi \ - bytecomp/translmod.cmi -bytecomp/translmod.cmx : \ - typing/types.cmx \ - typing/typedtree.cmx \ - bytecomp/translprim.cmx \ - bytecomp/translobj.cmx \ - bytecomp/translcore.cmx \ - bytecomp/translclass.cmx \ - bytecomp/translattribute.cmx \ - typing/primitive.cmx \ - typing/predef.cmx \ - typing/path.cmx \ - typing/mtype.cmx \ - utils/misc.cmx \ - parsing/location.cmx \ - bytecomp/lambda.cmx \ - typing/ident.cmx \ - typing/env.cmx \ - typing/ctype.cmx \ - utils/clflags.cmx \ - parsing/asttypes.cmi \ - bytecomp/translmod.cmi -bytecomp/translmod.cmi : \ - typing/typedtree.cmi \ - typing/primitive.cmi \ - parsing/location.cmi \ - bytecomp/lambda.cmi \ - typing/ident.cmi -bytecomp/translobj.cmo : \ - typing/primitive.cmi \ - utils/misc.cmi \ - parsing/location.cmi \ - bytecomp/lambda.cmi \ - typing/ident.cmi \ - typing/env.cmi \ - utils/config.cmi \ - utils/clflags.cmi \ - typing/btype.cmi \ - parsing/asttypes.cmi \ - bytecomp/translobj.cmi -bytecomp/translobj.cmx : \ - typing/primitive.cmx \ - utils/misc.cmx \ - parsing/location.cmx \ - bytecomp/lambda.cmx \ - typing/ident.cmx \ - typing/env.cmx \ - utils/config.cmx \ - utils/clflags.cmx \ - typing/btype.cmx \ - parsing/asttypes.cmi \ - bytecomp/translobj.cmi -bytecomp/translobj.cmi : \ - bytecomp/lambda.cmi \ - typing/ident.cmi \ - typing/env.cmi -bytecomp/translprim.cmo : \ - typing/types.cmi \ - typing/typeopt.cmi \ - typing/typedtree.cmi \ - typing/primitive.cmi \ - typing/predef.cmi \ - typing/path.cmi \ - utils/misc.cmi \ - bytecomp/matching.cmi \ - parsing/location.cmi \ - bytecomp/lambda.cmi \ - typing/ident.cmi \ - typing/env.cmi \ - utils/config.cmi \ - utils/clflags.cmi \ - parsing/asttypes.cmi \ - bytecomp/translprim.cmi -bytecomp/translprim.cmx : \ - typing/types.cmx \ - typing/typeopt.cmx \ - typing/typedtree.cmx \ - typing/primitive.cmx \ - typing/predef.cmx \ - typing/path.cmx \ - utils/misc.cmx \ - bytecomp/matching.cmx \ - parsing/location.cmx \ - bytecomp/lambda.cmx \ - typing/ident.cmx \ - typing/env.cmx \ - utils/config.cmx \ - utils/clflags.cmx \ - parsing/asttypes.cmi \ - bytecomp/translprim.cmi -bytecomp/translprim.cmi : \ - typing/types.cmi \ - typing/typedtree.cmi \ - typing/primitive.cmi \ - typing/path.cmi \ - parsing/location.cmi \ - bytecomp/lambda.cmi \ - typing/ident.cmi \ - typing/env.cmi -asmcomp/CSE.cmo : \ - asmcomp/mach.cmi \ - asmcomp/CSEgen.cmi \ - asmcomp/arch.cmo -asmcomp/CSE.cmx : \ - asmcomp/mach.cmx \ - asmcomp/CSEgen.cmx \ - asmcomp/arch.cmx -asmcomp/CSEgen.cmo : \ - asmcomp/reg.cmi \ - asmcomp/proc.cmi \ - asmcomp/mach.cmi \ - asmcomp/cmm.cmi \ - asmcomp/CSEgen.cmi -asmcomp/CSEgen.cmx : \ - asmcomp/reg.cmx \ - asmcomp/proc.cmx \ - asmcomp/mach.cmx \ - asmcomp/cmm.cmx \ - asmcomp/CSEgen.cmi -asmcomp/CSEgen.cmi : \ - asmcomp/mach.cmi -asmcomp/afl_instrument.cmo : \ - bytecomp/lambda.cmi \ - asmcomp/cmm.cmi \ - utils/clflags.cmi \ - asmcomp/backend_var.cmi \ - parsing/asttypes.cmi \ - asmcomp/afl_instrument.cmi -asmcomp/afl_instrument.cmx : \ - bytecomp/lambda.cmx \ - asmcomp/cmm.cmx \ - utils/clflags.cmx \ - asmcomp/backend_var.cmx \ - parsing/asttypes.cmi \ - asmcomp/afl_instrument.cmi -asmcomp/afl_instrument.cmi : \ - middle_end/debuginfo.cmi \ - asmcomp/cmm.cmi -asmcomp/arch.cmo : \ - utils/config.cmi \ - utils/clflags.cmi -asmcomp/arch.cmx : \ - utils/config.cmx \ - utils/clflags.cmx -asmcomp/asmgen.cmo : \ - asmcomp/un_anf.cmi \ - bytecomp/translmod.cmi \ - middle_end/base_types/symbol.cmi \ - asmcomp/split.cmi \ - asmcomp/spill.cmi \ - asmcomp/selection.cmi \ - asmcomp/scheduling.cmi \ - asmcomp/reload.cmi \ - asmcomp/reg.cmi \ - utils/profile.cmi \ - asmcomp/proc.cmi \ - asmcomp/printmach.cmi \ - asmcomp/printlinear.cmi \ - asmcomp/printcmm.cmi \ - asmcomp/printclambda.cmi \ - typing/primitive.cmi \ - typing/path.cmi \ - utils/misc.cmi \ - asmcomp/mach.cmi \ - parsing/location.cmi \ - asmcomp/liveness.cmi \ - asmcomp/linscan.cmi \ - middle_end/base_types/linkage_name.cmi \ - asmcomp/linearize.cmi \ - bytecomp/lambda.cmi \ - asmcomp/interval.cmi \ - asmcomp/interf.cmi \ - typing/ident.cmi \ - asmcomp/flambda_to_clambda.cmi \ - middle_end/flambda.cmi \ - asmcomp/emitaux.cmi \ - asmcomp/emit.cmi \ - asmcomp/deadcode.cmi \ - utils/config.cmi \ - asmcomp/compilenv.cmi \ - asmcomp/comballoc.cmi \ - asmcomp/coloring.cmi \ - asmcomp/cmmgen.cmi \ - asmcomp/cmm.cmi \ - asmcomp/closure.cmi \ - utils/clflags.cmi \ - asmcomp/clambda.cmi \ + middle_end/clambda.cmi \ asmcomp/CSE.cmo \ - asmcomp/build_export_info.cmi \ + middle_end/flambda/build_export_info.cmi \ asmcomp/debug/available_regs.cmi \ asmcomp/asmgen.cmi asmcomp/asmgen.cmx : \ - asmcomp/un_anf.cmx \ - bytecomp/translmod.cmx \ - middle_end/base_types/symbol.cmx \ + middle_end/flambda/un_anf.cmx \ + lambda/translmod.cmx \ + middle_end/symbol.cmx \ asmcomp/split.cmx \ asmcomp/spill.cmx \ asmcomp/selection.cmx \ @@ -2403,7 +1977,7 @@ asmcomp/asmgen.cmx : \ asmcomp/printmach.cmx \ asmcomp/printlinear.cmx \ asmcomp/printcmm.cmx \ - asmcomp/printclambda.cmx \ + middle_end/printclambda.cmx \ typing/primitive.cmx \ typing/path.cmx \ utils/misc.cmx \ @@ -2411,46 +1985,46 @@ asmcomp/asmgen.cmx : \ parsing/location.cmx \ asmcomp/liveness.cmx \ asmcomp/linscan.cmx \ - middle_end/base_types/linkage_name.cmx \ + middle_end/linkage_name.cmx \ asmcomp/linearize.cmx \ - bytecomp/lambda.cmx \ + lambda/lambda.cmx \ asmcomp/interval.cmx \ asmcomp/interf.cmx \ typing/ident.cmx \ - asmcomp/flambda_to_clambda.cmx \ - middle_end/flambda.cmx \ + middle_end/flambda/flambda_to_clambda.cmx \ + middle_end/flambda/flambda.cmx \ asmcomp/emitaux.cmx \ asmcomp/emit.cmx \ asmcomp/deadcode.cmx \ utils/config.cmx \ - asmcomp/compilenv.cmx \ + middle_end/compilenv.cmx \ asmcomp/comballoc.cmx \ asmcomp/coloring.cmx \ asmcomp/cmmgen.cmx \ asmcomp/cmm.cmx \ - asmcomp/closure.cmx \ + middle_end/closure/closure.cmx \ utils/clflags.cmx \ - asmcomp/clambda.cmx \ + middle_end/clambda.cmx \ asmcomp/CSE.cmx \ - asmcomp/build_export_info.cmx \ + middle_end/flambda/build_export_info.cmx \ asmcomp/debug/available_regs.cmx \ asmcomp/asmgen.cmi asmcomp/asmgen.cmi : \ - bytecomp/lambda.cmi \ + lambda/lambda.cmi \ typing/ident.cmi \ - middle_end/flambda.cmi \ + middle_end/flambda/flambda.cmi \ asmcomp/cmm.cmi \ middle_end/backend_intf.cmi asmcomp/asmlibrarian.cmo : \ utils/misc.cmi \ parsing/location.cmi \ utils/load_path.cmi \ - asmcomp/export_info.cmi \ + middle_end/flambda/export_info.cmi \ utils/config.cmi \ - asmcomp/compilenv.cmi \ - asmcomp/cmx_format.cmi \ + middle_end/compilenv.cmi \ + file_formats/cmx_format.cmi \ utils/clflags.cmi \ - asmcomp/clambda.cmi \ + middle_end/clambda.cmi \ utils/ccomp.cmi \ asmcomp/asmlink.cmi \ asmcomp/asmlibrarian.cmi @@ -2458,18 +2032,18 @@ asmcomp/asmlibrarian.cmx : \ utils/misc.cmx \ parsing/location.cmx \ utils/load_path.cmx \ - asmcomp/export_info.cmx \ + middle_end/flambda/export_info.cmx \ utils/config.cmx \ - asmcomp/compilenv.cmx \ - asmcomp/cmx_format.cmi \ + middle_end/compilenv.cmx \ + file_formats/cmx_format.cmi \ utils/clflags.cmx \ - asmcomp/clambda.cmx \ + middle_end/clambda.cmx \ utils/ccomp.cmx \ asmcomp/asmlink.cmx \ asmcomp/asmlibrarian.cmi asmcomp/asmlibrarian.cmi : asmcomp/asmlink.cmo : \ - bytecomp/runtimedef.cmi \ + lambda/runtimedef.cmi \ utils/profile.cmi \ utils/misc.cmi \ parsing/location.cmi \ @@ -2478,8 +2052,8 @@ asmcomp/asmlink.cmo : \ asmcomp/emit.cmi \ utils/consistbl.cmi \ utils/config.cmi \ - asmcomp/compilenv.cmi \ - asmcomp/cmx_format.cmi \ + middle_end/compilenv.cmi \ + file_formats/cmx_format.cmi \ asmcomp/cmmgen.cmi \ asmcomp/cmm.cmi \ utils/clflags.cmi \ @@ -2487,7 +2061,7 @@ asmcomp/asmlink.cmo : \ asmcomp/asmgen.cmi \ asmcomp/asmlink.cmi asmcomp/asmlink.cmx : \ - bytecomp/runtimedef.cmx \ + lambda/runtimedef.cmx \ utils/profile.cmx \ utils/misc.cmx \ parsing/location.cmx \ @@ -2496,8 +2070,8 @@ asmcomp/asmlink.cmx : \ asmcomp/emit.cmx \ utils/consistbl.cmx \ utils/config.cmx \ - asmcomp/compilenv.cmx \ - asmcomp/cmx_format.cmi \ + middle_end/compilenv.cmx \ + file_formats/cmx_format.cmi \ asmcomp/cmmgen.cmx \ asmcomp/cmm.cmx \ utils/clflags.cmx \ @@ -2506,24 +2080,24 @@ asmcomp/asmlink.cmx : \ asmcomp/asmlink.cmi asmcomp/asmlink.cmi : \ utils/misc.cmi \ - asmcomp/cmx_format.cmi + file_formats/cmx_format.cmi asmcomp/asmpackager.cmo : \ typing/typemod.cmi \ - bytecomp/translmod.cmi \ + lambda/translmod.cmi \ utils/profile.cmi \ utils/misc.cmi \ - middle_end/middle_end.cmi \ parsing/location.cmi \ utils/load_path.cmi \ - bytecomp/lambda.cmi \ + lambda/lambda.cmi \ typing/ident.cmi \ - asmcomp/export_info_for_pack.cmi \ - asmcomp/export_info.cmi \ + middle_end/flambda/flambda_middle_end.cmi \ + middle_end/flambda/export_info_for_pack.cmi \ + middle_end/flambda/export_info.cmi \ typing/env.cmi \ utils/config.cmi \ - asmcomp/compilenv.cmi \ - middle_end/base_types/compilation_unit.cmi \ - asmcomp/cmx_format.cmi \ + middle_end/compilenv.cmi \ + middle_end/compilation_unit.cmi \ + file_formats/cmx_format.cmi \ utils/clflags.cmi \ utils/ccomp.cmi \ asmcomp/asmlink.cmi \ @@ -2531,21 +2105,21 @@ asmcomp/asmpackager.cmo : \ asmcomp/asmpackager.cmi asmcomp/asmpackager.cmx : \ typing/typemod.cmx \ - bytecomp/translmod.cmx \ + lambda/translmod.cmx \ utils/profile.cmx \ utils/misc.cmx \ - middle_end/middle_end.cmx \ parsing/location.cmx \ utils/load_path.cmx \ - bytecomp/lambda.cmx \ + lambda/lambda.cmx \ typing/ident.cmx \ - asmcomp/export_info_for_pack.cmx \ - asmcomp/export_info.cmx \ + middle_end/flambda/flambda_middle_end.cmx \ + middle_end/flambda/export_info_for_pack.cmx \ + middle_end/flambda/export_info.cmx \ typing/env.cmx \ utils/config.cmx \ - asmcomp/compilenv.cmx \ - middle_end/base_types/compilation_unit.cmx \ - asmcomp/cmx_format.cmi \ + middle_end/compilenv.cmx \ + middle_end/compilation_unit.cmx \ + file_formats/cmx_format.cmi \ utils/clflags.cmx \ utils/ccomp.cmx \ asmcomp/asmlink.cmx \ @@ -2554,20 +2128,6 @@ asmcomp/asmpackager.cmx : \ asmcomp/asmpackager.cmi : \ typing/env.cmi \ middle_end/backend_intf.cmi -asmcomp/backend_var.cmo : \ - typing/path.cmi \ - typing/ident.cmi \ - middle_end/debuginfo.cmi \ - asmcomp/backend_var.cmi -asmcomp/backend_var.cmx : \ - typing/path.cmx \ - typing/ident.cmx \ - middle_end/debuginfo.cmx \ - asmcomp/backend_var.cmi -asmcomp/backend_var.cmi : \ - typing/path.cmi \ - typing/ident.cmi \ - middle_end/debuginfo.cmi asmcomp/branch_relaxation.cmo : \ utils/misc.cmi \ asmcomp/mach.cmi \ @@ -2593,268 +2153,100 @@ asmcomp/branch_relaxation_intf.cmx : \ asmcomp/linearize.cmx \ asmcomp/cmm.cmx \ asmcomp/arch.cmx -asmcomp/build_export_info.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - asmcomp/traverse_for_exported_symbols.cmi \ - middle_end/base_types/tag.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/simple_value_approx.cmi \ - middle_end/base_types/set_of_closures_id.cmi \ - utils/misc.cmi \ - middle_end/invariant_params.cmi \ - middle_end/inline_and_simplify_aux.cmi \ - middle_end/flambda_utils.cmi \ - middle_end/flambda.cmi \ - middle_end/find_recursive_functions.cmi \ - asmcomp/export_info.cmi \ - middle_end/base_types/export_id.cmi \ - asmcomp/compilenv.cmi \ - middle_end/base_types/compilation_unit.cmi \ - middle_end/base_types/closure_id.cmi \ - utils/clflags.cmi \ - middle_end/backend_intf.cmi \ - middle_end/allocated_const.cmi \ - asmcomp/build_export_info.cmi -asmcomp/build_export_info.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/var_within_closure.cmx \ - asmcomp/traverse_for_exported_symbols.cmx \ - middle_end/base_types/tag.cmx \ - middle_end/base_types/symbol.cmx \ - middle_end/simple_value_approx.cmx \ - middle_end/base_types/set_of_closures_id.cmx \ - utils/misc.cmx \ - middle_end/invariant_params.cmx \ - middle_end/inline_and_simplify_aux.cmx \ - middle_end/flambda_utils.cmx \ - middle_end/flambda.cmx \ - middle_end/find_recursive_functions.cmx \ - asmcomp/export_info.cmx \ - middle_end/base_types/export_id.cmx \ - asmcomp/compilenv.cmx \ - middle_end/base_types/compilation_unit.cmx \ - middle_end/base_types/closure_id.cmx \ - utils/clflags.cmx \ - middle_end/backend_intf.cmi \ - middle_end/allocated_const.cmx \ - asmcomp/build_export_info.cmi -asmcomp/build_export_info.cmi : \ - middle_end/flambda.cmi \ - asmcomp/export_info.cmi \ - middle_end/backend_intf.cmi -asmcomp/clambda.cmo : \ - typing/path.cmi \ - bytecomp/lambda.cmi \ - typing/ident.cmi \ - middle_end/debuginfo.cmi \ - asmcomp/clambda_primitives.cmi \ - asmcomp/backend_var.cmi \ - parsing/asttypes.cmi \ - asmcomp/clambda.cmi -asmcomp/clambda.cmx : \ - typing/path.cmx \ - bytecomp/lambda.cmx \ - typing/ident.cmx \ - middle_end/debuginfo.cmx \ - asmcomp/clambda_primitives.cmx \ - asmcomp/backend_var.cmx \ - parsing/asttypes.cmi \ - asmcomp/clambda.cmi -asmcomp/clambda.cmi : \ - typing/path.cmi \ - bytecomp/lambda.cmi \ - typing/ident.cmi \ - middle_end/debuginfo.cmi \ - asmcomp/clambda_primitives.cmi \ - asmcomp/backend_var.cmi \ - parsing/asttypes.cmi -asmcomp/clambda_primitives.cmo : \ - typing/types.cmi \ - typing/primitive.cmi \ - bytecomp/lambda.cmi \ - parsing/asttypes.cmi \ - asmcomp/clambda_primitives.cmi -asmcomp/clambda_primitives.cmx : \ - typing/types.cmx \ - typing/primitive.cmx \ - bytecomp/lambda.cmx \ - parsing/asttypes.cmi \ - asmcomp/clambda_primitives.cmi -asmcomp/clambda_primitives.cmi : \ - typing/types.cmi \ - typing/primitive.cmi \ - bytecomp/lambda.cmi \ - parsing/asttypes.cmi -asmcomp/closure.cmo : \ - utils/warnings.cmi \ - bytecomp/switch.cmi \ - bytecomp/simplif.cmi \ - asmcomp/semantics_of_primitives.cmi \ - typing/primitive.cmi \ - utils/numbers.cmi \ - utils/misc.cmi \ - parsing/location.cmi \ - bytecomp/lambda.cmi \ - typing/ident.cmi \ - typing/env.cmi \ - middle_end/debuginfo.cmi \ - asmcomp/convert_primitives.cmi \ - utils/config.cmi \ - asmcomp/compilenv.cmi \ - utils/clflags.cmi \ - asmcomp/clambda_primitives.cmi \ - asmcomp/clambda.cmi \ - asmcomp/backend_var.cmi \ - parsing/asttypes.cmi \ - asmcomp/arch.cmo \ - asmcomp/closure.cmi -asmcomp/closure.cmx : \ - utils/warnings.cmx \ - bytecomp/switch.cmx \ - bytecomp/simplif.cmx \ - asmcomp/semantics_of_primitives.cmx \ - typing/primitive.cmx \ - utils/numbers.cmx \ - utils/misc.cmx \ - parsing/location.cmx \ - bytecomp/lambda.cmx \ - typing/ident.cmx \ - typing/env.cmx \ - middle_end/debuginfo.cmx \ - asmcomp/convert_primitives.cmx \ - utils/config.cmx \ - asmcomp/compilenv.cmx \ - utils/clflags.cmx \ - asmcomp/clambda_primitives.cmx \ - asmcomp/clambda.cmx \ - asmcomp/backend_var.cmx \ - parsing/asttypes.cmi \ - asmcomp/arch.cmx \ - asmcomp/closure.cmi -asmcomp/closure.cmi : \ - bytecomp/lambda.cmi \ - asmcomp/clambda.cmi -asmcomp/closure_offsets.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - utils/misc.cmi \ - middle_end/flambda_utils.cmi \ - middle_end/flambda.cmi \ - middle_end/base_types/closure_id.cmi \ - asmcomp/closure_offsets.cmi -asmcomp/closure_offsets.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/var_within_closure.cmx \ - utils/misc.cmx \ - middle_end/flambda_utils.cmx \ - middle_end/flambda.cmx \ - middle_end/base_types/closure_id.cmx \ - asmcomp/closure_offsets.cmi -asmcomp/closure_offsets.cmi : \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/flambda.cmi \ - middle_end/base_types/closure_id.cmi asmcomp/cmm.cmo : \ utils/targetint.cmi \ - bytecomp/lambda.cmi \ - middle_end/debuginfo.cmi \ - asmcomp/backend_var.cmi \ + lambda/lambda.cmi \ + lambda/debuginfo.cmi \ + middle_end/backend_var.cmi \ parsing/asttypes.cmi \ asmcomp/arch.cmo \ asmcomp/cmm.cmi asmcomp/cmm.cmx : \ utils/targetint.cmx \ - bytecomp/lambda.cmx \ - middle_end/debuginfo.cmx \ - asmcomp/backend_var.cmx \ + lambda/lambda.cmx \ + lambda/debuginfo.cmx \ + middle_end/backend_var.cmx \ parsing/asttypes.cmi \ asmcomp/arch.cmx \ asmcomp/cmm.cmi asmcomp/cmm.cmi : \ utils/targetint.cmi \ - bytecomp/lambda.cmi \ - middle_end/debuginfo.cmi \ - asmcomp/backend_var.cmi \ + lambda/lambda.cmi \ + lambda/debuginfo.cmi \ + middle_end/backend_var.cmi \ parsing/asttypes.cmi asmcomp/cmmgen.cmo : \ - asmcomp/un_anf.cmi \ + middle_end/flambda/un_anf.cmi \ typing/types.cmi \ utils/targetint.cmi \ - bytecomp/switch.cmi \ + lambda/switch.cmi \ asmcomp/strmatch.cmi \ asmcomp/proc.cmi \ - asmcomp/printclambda_primitives.cmi \ + middle_end/printclambda_primitives.cmi \ typing/primitive.cmi \ utils/numbers.cmi \ utils/misc.cmi \ - bytecomp/lambda.cmi \ - middle_end/debuginfo.cmi \ + lambda/lambda.cmi \ + lambda/debuginfo.cmi \ utils/config.cmi \ - asmcomp/compilenv.cmi \ - asmcomp/cmxs_format.cmi \ - asmcomp/cmx_format.cmi \ + middle_end/compilenv.cmi \ + file_formats/cmxs_format.cmi \ + file_formats/cmx_format.cmi \ asmcomp/cmmgen_state.cmi \ asmcomp/cmm.cmi \ utils/clflags.cmi \ - asmcomp/clambda_primitives.cmi \ - asmcomp/clambda.cmi \ - asmcomp/backend_var.cmi \ + middle_end/clambda_primitives.cmi \ + middle_end/clambda.cmi \ + middle_end/backend_var.cmi \ parsing/asttypes.cmi \ asmcomp/arch.cmo \ asmcomp/afl_instrument.cmi \ asmcomp/cmmgen.cmi asmcomp/cmmgen.cmx : \ - asmcomp/un_anf.cmx \ + middle_end/flambda/un_anf.cmx \ typing/types.cmx \ utils/targetint.cmx \ - bytecomp/switch.cmx \ + lambda/switch.cmx \ asmcomp/strmatch.cmx \ asmcomp/proc.cmx \ - asmcomp/printclambda_primitives.cmx \ + middle_end/printclambda_primitives.cmx \ typing/primitive.cmx \ utils/numbers.cmx \ utils/misc.cmx \ - bytecomp/lambda.cmx \ - middle_end/debuginfo.cmx \ + lambda/lambda.cmx \ + lambda/debuginfo.cmx \ utils/config.cmx \ - asmcomp/compilenv.cmx \ - asmcomp/cmxs_format.cmi \ - asmcomp/cmx_format.cmi \ + middle_end/compilenv.cmx \ + file_formats/cmxs_format.cmi \ + file_formats/cmx_format.cmi \ asmcomp/cmmgen_state.cmx \ asmcomp/cmm.cmx \ utils/clflags.cmx \ - asmcomp/clambda_primitives.cmx \ - asmcomp/clambda.cmx \ - asmcomp/backend_var.cmx \ + middle_end/clambda_primitives.cmx \ + middle_end/clambda.cmx \ + middle_end/backend_var.cmx \ parsing/asttypes.cmi \ asmcomp/arch.cmx \ asmcomp/afl_instrument.cmx \ asmcomp/cmmgen.cmi asmcomp/cmmgen.cmi : \ - asmcomp/cmx_format.cmi \ + file_formats/cmx_format.cmi \ asmcomp/cmm.cmi \ - asmcomp/clambda.cmi + middle_end/clambda.cmi asmcomp/cmmgen_state.cmo : \ utils/misc.cmi \ asmcomp/cmm.cmi \ - asmcomp/clambda.cmi \ + middle_end/clambda.cmi \ asmcomp/cmmgen_state.cmi asmcomp/cmmgen_state.cmx : \ utils/misc.cmx \ asmcomp/cmm.cmx \ - asmcomp/clambda.cmx \ + middle_end/clambda.cmx \ asmcomp/cmmgen_state.cmi asmcomp/cmmgen_state.cmi : \ utils/misc.cmi \ asmcomp/cmm.cmi \ - asmcomp/clambda.cmi -asmcomp/cmx_format.cmi : \ - utils/misc.cmi \ - asmcomp/export_info.cmi \ - asmcomp/clambda.cmi -asmcomp/cmxs_format.cmi : \ - utils/misc.cmi + middle_end/clambda.cmi asmcomp/coloring.cmo : \ asmcomp/reg.cmi \ asmcomp/proc.cmi \ @@ -2878,72 +2270,6 @@ asmcomp/comballoc.cmx : \ asmcomp/comballoc.cmi asmcomp/comballoc.cmi : \ asmcomp/mach.cmi -asmcomp/compilenv.cmo : \ - utils/warnings.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/simple_value_approx.cmi \ - middle_end/base_types/set_of_closures_id.cmi \ - typing/path.cmi \ - utils/misc.cmi \ - parsing/location.cmi \ - utils/load_path.cmi \ - middle_end/base_types/linkage_name.cmi \ - typing/ident.cmi \ - asmcomp/export_info.cmi \ - typing/env.cmi \ - utils/config.cmi \ - middle_end/base_types/compilation_unit.cmi \ - asmcomp/cmx_format.cmi \ - middle_end/base_types/closure_id.cmi \ - utils/clflags.cmi \ - asmcomp/clambda.cmi \ - asmcomp/compilenv.cmi -asmcomp/compilenv.cmx : \ - utils/warnings.cmx \ - middle_end/base_types/symbol.cmx \ - middle_end/simple_value_approx.cmx \ - middle_end/base_types/set_of_closures_id.cmx \ - typing/path.cmx \ - utils/misc.cmx \ - parsing/location.cmx \ - utils/load_path.cmx \ - middle_end/base_types/linkage_name.cmx \ - typing/ident.cmx \ - asmcomp/export_info.cmx \ - typing/env.cmx \ - utils/config.cmx \ - middle_end/base_types/compilation_unit.cmx \ - asmcomp/cmx_format.cmi \ - middle_end/base_types/closure_id.cmx \ - utils/clflags.cmx \ - asmcomp/clambda.cmx \ - asmcomp/compilenv.cmi -asmcomp/compilenv.cmi : \ - middle_end/base_types/symbol.cmi \ - middle_end/simple_value_approx.cmi \ - middle_end/base_types/set_of_closures_id.cmi \ - middle_end/base_types/linkage_name.cmi \ - typing/ident.cmi \ - asmcomp/export_info.cmi \ - middle_end/base_types/compilation_unit.cmi \ - asmcomp/cmx_format.cmi \ - middle_end/base_types/closure_id.cmi \ - asmcomp/clambda.cmi -asmcomp/convert_primitives.cmo : \ - bytecomp/printlambda.cmi \ - utils/misc.cmi \ - bytecomp/lambda.cmi \ - asmcomp/clambda_primitives.cmi \ - asmcomp/convert_primitives.cmi -asmcomp/convert_primitives.cmx : \ - bytecomp/printlambda.cmx \ - utils/misc.cmx \ - bytecomp/lambda.cmx \ - asmcomp/clambda_primitives.cmx \ - asmcomp/convert_primitives.cmi -asmcomp/convert_primitives.cmi : \ - bytecomp/lambda.cmi \ - asmcomp/clambda_primitives.cmi asmcomp/deadcode.cmo : \ asmcomp/reg.cmi \ asmcomp/proc.cmi \ @@ -2970,9 +2296,9 @@ asmcomp/emit.cmo : \ asmcomp/mach.cmi \ asmcomp/linearize.cmi \ asmcomp/emitaux.cmi \ - middle_end/debuginfo.cmi \ + lambda/debuginfo.cmi \ utils/config.cmi \ - asmcomp/compilenv.cmi \ + middle_end/compilenv.cmi \ asmcomp/cmm.cmi \ utils/clflags.cmi \ asmcomp/branch_relaxation.cmi \ @@ -2990,9 +2316,9 @@ asmcomp/emit.cmx : \ asmcomp/mach.cmx \ asmcomp/linearize.cmx \ asmcomp/emitaux.cmx \ - middle_end/debuginfo.cmx \ + lambda/debuginfo.cmx \ utils/config.cmx \ - asmcomp/compilenv.cmx \ + middle_end/compilenv.cmx \ asmcomp/cmm.cmx \ utils/clflags.cmx \ asmcomp/branch_relaxation.cmx \ @@ -3002,185 +2328,21 @@ asmcomp/emit.cmi : \ asmcomp/linearize.cmi \ asmcomp/cmm.cmi asmcomp/emitaux.cmo : \ - middle_end/debuginfo.cmi \ + lambda/debuginfo.cmi \ utils/config.cmi \ asmcomp/cmm.cmi \ utils/clflags.cmi \ asmcomp/arch.cmo \ asmcomp/emitaux.cmi asmcomp/emitaux.cmx : \ - middle_end/debuginfo.cmx \ + lambda/debuginfo.cmx \ utils/config.cmx \ asmcomp/cmm.cmx \ utils/clflags.cmx \ asmcomp/arch.cmx \ asmcomp/emitaux.cmi asmcomp/emitaux.cmi : \ - middle_end/debuginfo.cmi -asmcomp/export_info.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/base_types/tag.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/simple_value_approx.cmi \ - middle_end/base_types/set_of_closures_id.cmi \ - middle_end/flambda.cmi \ - middle_end/base_types/export_id.cmi \ - middle_end/base_types/compilation_unit.cmi \ - middle_end/base_types/closure_id.cmi \ - asmcomp/export_info.cmi -asmcomp/export_info.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/var_within_closure.cmx \ - middle_end/base_types/tag.cmx \ - middle_end/base_types/symbol.cmx \ - middle_end/simple_value_approx.cmx \ - middle_end/base_types/set_of_closures_id.cmx \ - middle_end/flambda.cmx \ - middle_end/base_types/export_id.cmx \ - middle_end/base_types/compilation_unit.cmx \ - middle_end/base_types/closure_id.cmx \ - asmcomp/export_info.cmi -asmcomp/export_info.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/base_types/tag.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/simple_value_approx.cmi \ - middle_end/base_types/set_of_closures_id.cmi \ - middle_end/flambda.cmi \ - middle_end/base_types/export_id.cmi \ - middle_end/base_types/compilation_unit.cmi \ - middle_end/base_types/closure_id.cmi -asmcomp/export_info_for_pack.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/simple_value_approx.cmi \ - middle_end/base_types/set_of_closures_origin.cmi \ - middle_end/base_types/set_of_closures_id.cmi \ - utils/misc.cmi \ - middle_end/flambda_iterators.cmi \ - middle_end/flambda.cmi \ - asmcomp/export_info.cmi \ - middle_end/base_types/export_id.cmi \ - middle_end/base_types/compilation_unit.cmi \ - middle_end/base_types/closure_id.cmi \ - asmcomp/export_info_for_pack.cmi -asmcomp/export_info_for_pack.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/var_within_closure.cmx \ - middle_end/base_types/symbol.cmx \ - middle_end/simple_value_approx.cmx \ - middle_end/base_types/set_of_closures_origin.cmx \ - middle_end/base_types/set_of_closures_id.cmx \ - utils/misc.cmx \ - middle_end/flambda_iterators.cmx \ - middle_end/flambda.cmx \ - asmcomp/export_info.cmx \ - middle_end/base_types/export_id.cmx \ - middle_end/base_types/compilation_unit.cmx \ - middle_end/base_types/closure_id.cmx \ - asmcomp/export_info_for_pack.cmi -asmcomp/export_info_for_pack.cmi : \ - asmcomp/export_info.cmi \ - middle_end/base_types/compilation_unit.cmi -asmcomp/flambda_to_clambda.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/base_types/tag.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/base_types/static_exception.cmi \ - middle_end/simple_value_approx.cmi \ - middle_end/base_types/set_of_closures_id.cmi \ - typing/primitive.cmi \ - middle_end/parameter.cmi \ - utils/numbers.cmi \ - middle_end/base_types/mutable_variable.cmi \ - utils/misc.cmi \ - middle_end/base_types/linkage_name.cmi \ - bytecomp/lambda.cmi \ - middle_end/initialize_symbol_to_let_symbol.cmi \ - middle_end/flambda_utils.cmi \ - middle_end/flambda.cmi \ - asmcomp/export_info.cmi \ - middle_end/debuginfo.cmi \ - asmcomp/compilenv.cmi \ - asmcomp/closure_offsets.cmi \ - middle_end/base_types/closure_id.cmi \ - utils/clflags.cmi \ - asmcomp/clambda.cmi \ - asmcomp/backend_var.cmi \ - middle_end/allocated_const.cmi \ - asmcomp/flambda_to_clambda.cmi -asmcomp/flambda_to_clambda.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/var_within_closure.cmx \ - middle_end/base_types/tag.cmx \ - middle_end/base_types/symbol.cmx \ - middle_end/base_types/static_exception.cmx \ - middle_end/simple_value_approx.cmx \ - middle_end/base_types/set_of_closures_id.cmx \ - typing/primitive.cmx \ - middle_end/parameter.cmx \ - utils/numbers.cmx \ - middle_end/base_types/mutable_variable.cmx \ - utils/misc.cmx \ - middle_end/base_types/linkage_name.cmx \ - bytecomp/lambda.cmx \ - middle_end/initialize_symbol_to_let_symbol.cmx \ - middle_end/flambda_utils.cmx \ - middle_end/flambda.cmx \ - asmcomp/export_info.cmx \ - middle_end/debuginfo.cmx \ - asmcomp/compilenv.cmx \ - asmcomp/closure_offsets.cmx \ - middle_end/base_types/closure_id.cmx \ - utils/clflags.cmx \ - asmcomp/clambda.cmx \ - asmcomp/backend_var.cmx \ - middle_end/allocated_const.cmx \ - asmcomp/flambda_to_clambda.cmi -asmcomp/flambda_to_clambda.cmi : \ - middle_end/base_types/symbol.cmi \ - middle_end/flambda.cmi \ - asmcomp/export_info.cmi \ - asmcomp/clambda.cmi -asmcomp/import_approx.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/simple_value_approx.cmi \ - middle_end/base_types/set_of_closures_id.cmi \ - utils/misc.cmi \ - middle_end/freshening.cmi \ - middle_end/flambda_iterators.cmi \ - middle_end/flambda.cmi \ - asmcomp/export_info.cmi \ - middle_end/base_types/export_id.cmi \ - asmcomp/compilenv.cmi \ - middle_end/base_types/compilation_unit.cmi \ - middle_end/base_types/closure_id.cmi \ - asmcomp/import_approx.cmi -asmcomp/import_approx.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/var_within_closure.cmx \ - middle_end/base_types/symbol.cmx \ - middle_end/simple_value_approx.cmx \ - middle_end/base_types/set_of_closures_id.cmx \ - utils/misc.cmx \ - middle_end/freshening.cmx \ - middle_end/flambda_iterators.cmx \ - middle_end/flambda.cmx \ - asmcomp/export_info.cmx \ - middle_end/base_types/export_id.cmx \ - asmcomp/compilenv.cmx \ - middle_end/base_types/compilation_unit.cmx \ - middle_end/base_types/closure_id.cmx \ - asmcomp/import_approx.cmi -asmcomp/import_approx.cmi : \ - middle_end/base_types/symbol.cmi \ - middle_end/simple_value_approx.cmi + lambda/debuginfo.cmi asmcomp/interf.cmo : \ asmcomp/reg.cmi \ asmcomp/proc.cmi \ @@ -3213,7 +2375,7 @@ asmcomp/linearize.cmo : \ asmcomp/proc.cmi \ utils/misc.cmi \ asmcomp/mach.cmi \ - middle_end/debuginfo.cmi \ + lambda/debuginfo.cmi \ utils/config.cmi \ asmcomp/cmm.cmi \ asmcomp/linearize.cmi @@ -3222,14 +2384,14 @@ asmcomp/linearize.cmx : \ asmcomp/proc.cmx \ utils/misc.cmx \ asmcomp/mach.cmx \ - middle_end/debuginfo.cmx \ + lambda/debuginfo.cmx \ utils/config.cmx \ asmcomp/cmm.cmx \ asmcomp/linearize.cmi asmcomp/linearize.cmi : \ asmcomp/reg.cmi \ asmcomp/mach.cmi \ - middle_end/debuginfo.cmi \ + lambda/debuginfo.cmi \ asmcomp/cmm.cmi asmcomp/linscan.cmo : \ asmcomp/reg.cmi \ @@ -3266,95 +2428,59 @@ asmcomp/mach.cmo : \ asmcomp/debug/reg_with_debug_info.cmi \ asmcomp/debug/reg_availability_set.cmi \ asmcomp/reg.cmi \ - middle_end/debuginfo.cmi \ + lambda/debuginfo.cmi \ asmcomp/cmm.cmi \ - asmcomp/backend_var.cmi \ + middle_end/backend_var.cmi \ asmcomp/arch.cmo \ asmcomp/mach.cmi asmcomp/mach.cmx : \ asmcomp/debug/reg_with_debug_info.cmx \ asmcomp/debug/reg_availability_set.cmx \ asmcomp/reg.cmx \ - middle_end/debuginfo.cmx \ + lambda/debuginfo.cmx \ asmcomp/cmm.cmx \ - asmcomp/backend_var.cmx \ + middle_end/backend_var.cmx \ asmcomp/arch.cmx \ asmcomp/mach.cmi asmcomp/mach.cmi : \ asmcomp/debug/reg_availability_set.cmi \ asmcomp/reg.cmi \ - middle_end/debuginfo.cmi \ + lambda/debuginfo.cmi \ asmcomp/cmm.cmi \ - asmcomp/backend_var.cmi \ + middle_end/backend_var.cmi \ asmcomp/arch.cmo -asmcomp/printclambda.cmo : \ - bytecomp/printlambda.cmi \ - asmcomp/printclambda_primitives.cmi \ - bytecomp/lambda.cmi \ - typing/ident.cmi \ - asmcomp/clambda.cmi \ - asmcomp/backend_var.cmi \ - parsing/asttypes.cmi \ - asmcomp/printclambda.cmi -asmcomp/printclambda.cmx : \ - bytecomp/printlambda.cmx \ - asmcomp/printclambda_primitives.cmx \ - bytecomp/lambda.cmx \ - typing/ident.cmx \ - asmcomp/clambda.cmx \ - asmcomp/backend_var.cmx \ - parsing/asttypes.cmi \ - asmcomp/printclambda.cmi -asmcomp/printclambda.cmi : \ - asmcomp/clambda.cmi -asmcomp/printclambda_primitives.cmo : \ - bytecomp/printlambda.cmi \ - typing/primitive.cmi \ - bytecomp/lambda.cmi \ - asmcomp/clambda_primitives.cmi \ - parsing/asttypes.cmi \ - asmcomp/printclambda_primitives.cmi -asmcomp/printclambda_primitives.cmx : \ - bytecomp/printlambda.cmx \ - typing/primitive.cmx \ - bytecomp/lambda.cmx \ - asmcomp/clambda_primitives.cmx \ - parsing/asttypes.cmi \ - asmcomp/printclambda_primitives.cmi -asmcomp/printclambda_primitives.cmi : \ - asmcomp/clambda_primitives.cmi asmcomp/printcmm.cmo : \ utils/targetint.cmi \ - bytecomp/lambda.cmi \ - middle_end/debuginfo.cmi \ + lambda/lambda.cmi \ + lambda/debuginfo.cmi \ asmcomp/cmm.cmi \ - asmcomp/backend_var.cmi \ + middle_end/backend_var.cmi \ parsing/asttypes.cmi \ asmcomp/printcmm.cmi asmcomp/printcmm.cmx : \ utils/targetint.cmx \ - bytecomp/lambda.cmx \ - middle_end/debuginfo.cmx \ + lambda/lambda.cmx \ + lambda/debuginfo.cmx \ asmcomp/cmm.cmx \ - asmcomp/backend_var.cmx \ + middle_end/backend_var.cmx \ parsing/asttypes.cmi \ asmcomp/printcmm.cmi asmcomp/printcmm.cmi : \ - middle_end/debuginfo.cmi \ + lambda/debuginfo.cmi \ asmcomp/cmm.cmi asmcomp/printlinear.cmo : \ asmcomp/printmach.cmi \ asmcomp/printcmm.cmi \ asmcomp/mach.cmi \ asmcomp/linearize.cmi \ - middle_end/debuginfo.cmi \ + lambda/debuginfo.cmi \ asmcomp/printlinear.cmi asmcomp/printlinear.cmx : \ asmcomp/printmach.cmx \ asmcomp/printcmm.cmx \ asmcomp/mach.cmx \ asmcomp/linearize.cmx \ - middle_end/debuginfo.cmx \ + lambda/debuginfo.cmx \ asmcomp/printlinear.cmi asmcomp/printlinear.cmi : \ asmcomp/linearize.cmi @@ -3365,11 +2491,11 @@ asmcomp/printmach.cmo : \ asmcomp/printcmm.cmi \ asmcomp/mach.cmi \ asmcomp/interval.cmi \ - middle_end/debuginfo.cmi \ + lambda/debuginfo.cmi \ utils/config.cmi \ asmcomp/cmm.cmi \ utils/clflags.cmi \ - asmcomp/backend_var.cmi \ + middle_end/backend_var.cmi \ asmcomp/arch.cmo \ asmcomp/printmach.cmi asmcomp/printmach.cmx : \ @@ -3379,11 +2505,11 @@ asmcomp/printmach.cmx : \ asmcomp/printcmm.cmx \ asmcomp/mach.cmx \ asmcomp/interval.cmx \ - middle_end/debuginfo.cmx \ + lambda/debuginfo.cmx \ utils/config.cmx \ asmcomp/cmm.cmx \ utils/clflags.cmx \ - asmcomp/backend_var.cmx \ + middle_end/backend_var.cmx \ asmcomp/arch.cmx \ asmcomp/printmach.cmi asmcomp/printmach.cmi : \ @@ -3412,15 +2538,15 @@ asmcomp/proc.cmi : \ asmcomp/mach.cmi asmcomp/reg.cmo : \ asmcomp/cmm.cmi \ - asmcomp/backend_var.cmi \ + middle_end/backend_var.cmi \ asmcomp/reg.cmi asmcomp/reg.cmx : \ asmcomp/cmm.cmx \ - asmcomp/backend_var.cmx \ + middle_end/backend_var.cmx \ asmcomp/reg.cmi asmcomp/reg.cmi : \ asmcomp/cmm.cmi \ - asmcomp/backend_var.cmi + middle_end/backend_var.cmi asmcomp/reload.cmo : \ asmcomp/reloadgen.cmi \ asmcomp/reg.cmi \ @@ -3482,41 +2608,41 @@ asmcomp/scheduling.cmx : \ asmcomp/scheduling.cmi : \ asmcomp/linearize.cmi asmcomp/selectgen.cmo : \ - bytecomp/simplif.cmi \ + lambda/simplif.cmi \ asmcomp/reg.cmi \ asmcomp/proc.cmi \ utils/numbers.cmi \ utils/misc.cmi \ asmcomp/mach.cmi \ - bytecomp/lambda.cmi \ - middle_end/debuginfo.cmi \ + lambda/lambda.cmi \ + lambda/debuginfo.cmi \ utils/config.cmi \ asmcomp/cmm.cmi \ - asmcomp/backend_var.cmi \ + middle_end/backend_var.cmi \ parsing/asttypes.cmi \ asmcomp/arch.cmo \ asmcomp/selectgen.cmi asmcomp/selectgen.cmx : \ - bytecomp/simplif.cmx \ + lambda/simplif.cmx \ asmcomp/reg.cmx \ asmcomp/proc.cmx \ utils/numbers.cmx \ utils/misc.cmx \ asmcomp/mach.cmx \ - bytecomp/lambda.cmx \ - middle_end/debuginfo.cmx \ + lambda/lambda.cmx \ + lambda/debuginfo.cmx \ utils/config.cmx \ asmcomp/cmm.cmx \ - asmcomp/backend_var.cmx \ + middle_end/backend_var.cmx \ parsing/asttypes.cmi \ asmcomp/arch.cmx \ asmcomp/selectgen.cmi asmcomp/selectgen.cmi : \ asmcomp/reg.cmi \ asmcomp/mach.cmi \ - middle_end/debuginfo.cmi \ + lambda/debuginfo.cmi \ asmcomp/cmm.cmi \ - asmcomp/backend_var.cmi \ + middle_end/backend_var.cmi \ asmcomp/arch.cmo asmcomp/selection.cmo : \ asmcomp/spacetime_profiling.cmi \ @@ -3541,24 +2667,16 @@ asmcomp/selection.cmx : \ asmcomp/selection.cmi : \ asmcomp/mach.cmi \ asmcomp/cmm.cmi -asmcomp/semantics_of_primitives.cmo : \ - asmcomp/clambda_primitives.cmi \ - asmcomp/semantics_of_primitives.cmi -asmcomp/semantics_of_primitives.cmx : \ - asmcomp/clambda_primitives.cmx \ - asmcomp/semantics_of_primitives.cmi -asmcomp/semantics_of_primitives.cmi : \ - asmcomp/clambda_primitives.cmi asmcomp/spacetime_profiling.cmo : \ asmcomp/selectgen.cmi \ asmcomp/proc.cmi \ utils/misc.cmi \ asmcomp/mach.cmi \ - bytecomp/lambda.cmi \ - middle_end/debuginfo.cmi \ + lambda/lambda.cmi \ + lambda/debuginfo.cmi \ utils/config.cmi \ asmcomp/cmm.cmi \ - asmcomp/backend_var.cmi \ + middle_end/backend_var.cmi \ parsing/asttypes.cmi \ asmcomp/arch.cmo \ asmcomp/spacetime_profiling.cmi @@ -3567,11 +2685,11 @@ asmcomp/spacetime_profiling.cmx : \ asmcomp/proc.cmx \ utils/misc.cmx \ asmcomp/mach.cmx \ - bytecomp/lambda.cmx \ - middle_end/debuginfo.cmx \ + lambda/lambda.cmx \ + lambda/debuginfo.cmx \ utils/config.cmx \ asmcomp/cmm.cmx \ - asmcomp/backend_var.cmx \ + middle_end/backend_var.cmx \ parsing/asttypes.cmi \ asmcomp/arch.cmx \ asmcomp/spacetime_profiling.cmi @@ -3609,89 +2727,26 @@ asmcomp/split.cmi : \ asmcomp/mach.cmi asmcomp/strmatch.cmo : \ parsing/location.cmi \ - bytecomp/lambda.cmi \ - middle_end/debuginfo.cmi \ + lambda/lambda.cmi \ + lambda/debuginfo.cmi \ asmcomp/cmm.cmi \ - asmcomp/backend_var.cmi \ + middle_end/backend_var.cmi \ parsing/asttypes.cmi \ asmcomp/arch.cmo \ asmcomp/strmatch.cmi asmcomp/strmatch.cmx : \ parsing/location.cmx \ - bytecomp/lambda.cmx \ - middle_end/debuginfo.cmx \ + lambda/lambda.cmx \ + lambda/debuginfo.cmx \ asmcomp/cmm.cmx \ - asmcomp/backend_var.cmx \ + middle_end/backend_var.cmx \ parsing/asttypes.cmi \ asmcomp/arch.cmx \ asmcomp/strmatch.cmi asmcomp/strmatch.cmi : \ parsing/location.cmi \ - middle_end/debuginfo.cmi \ + lambda/debuginfo.cmi \ asmcomp/cmm.cmi -asmcomp/traverse_for_exported_symbols.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/simple_value_approx.cmi \ - middle_end/base_types/set_of_closures_id.cmi \ - utils/misc.cmi \ - middle_end/flambda_iterators.cmi \ - middle_end/flambda.cmi \ - asmcomp/export_info.cmi \ - middle_end/base_types/export_id.cmi \ - middle_end/base_types/compilation_unit.cmi \ - middle_end/base_types/closure_id.cmi \ - asmcomp/traverse_for_exported_symbols.cmi -asmcomp/traverse_for_exported_symbols.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/var_within_closure.cmx \ - middle_end/base_types/symbol.cmx \ - middle_end/simple_value_approx.cmx \ - middle_end/base_types/set_of_closures_id.cmx \ - utils/misc.cmx \ - middle_end/flambda_iterators.cmx \ - middle_end/flambda.cmx \ - asmcomp/export_info.cmx \ - middle_end/base_types/export_id.cmx \ - middle_end/base_types/compilation_unit.cmx \ - middle_end/base_types/closure_id.cmx \ - asmcomp/traverse_for_exported_symbols.cmi -asmcomp/traverse_for_exported_symbols.cmi : \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/simple_value_approx.cmi \ - middle_end/base_types/set_of_closures_id.cmi \ - middle_end/flambda.cmi \ - asmcomp/export_info.cmi \ - middle_end/base_types/export_id.cmi \ - middle_end/base_types/closure_id.cmi -asmcomp/un_anf.cmo : \ - asmcomp/semantics_of_primitives.cmi \ - asmcomp/printclambda.cmi \ - utils/misc.cmi \ - bytecomp/lambda.cmi \ - middle_end/debuginfo.cmi \ - utils/clflags.cmi \ - asmcomp/clambda_primitives.cmi \ - asmcomp/clambda.cmi \ - asmcomp/backend_var.cmi \ - parsing/asttypes.cmi \ - asmcomp/un_anf.cmi -asmcomp/un_anf.cmx : \ - asmcomp/semantics_of_primitives.cmx \ - asmcomp/printclambda.cmx \ - utils/misc.cmx \ - bytecomp/lambda.cmx \ - middle_end/debuginfo.cmx \ - utils/clflags.cmx \ - asmcomp/clambda_primitives.cmx \ - asmcomp/clambda.cmx \ - asmcomp/backend_var.cmx \ - parsing/asttypes.cmi \ - asmcomp/un_anf.cmi -asmcomp/un_anf.cmi : \ - asmcomp/clambda.cmi asmcomp/x86_ast.cmi : asmcomp/x86_dsl.cmo : \ asmcomp/x86_proc.cmi \ @@ -3741,1669 +2796,2615 @@ asmcomp/x86_proc.cmx : \ asmcomp/x86_proc.cmi asmcomp/x86_proc.cmi : \ asmcomp/x86_ast.cmi -middle_end/alias_analysis.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/base_types/tag.cmi \ - middle_end/base_types/symbol.cmi \ - utils/misc.cmi \ - bytecomp/lambda.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/flambda.cmi \ - parsing/asttypes.cmi \ - middle_end/allocated_const.cmi \ - middle_end/alias_analysis.cmi -middle_end/alias_analysis.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/var_within_closure.cmx \ - middle_end/base_types/tag.cmx \ - middle_end/base_types/symbol.cmx \ - utils/misc.cmx \ - bytecomp/lambda.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/flambda.cmx \ - parsing/asttypes.cmi \ - middle_end/allocated_const.cmx \ - middle_end/alias_analysis.cmi -middle_end/alias_analysis.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/tag.cmi \ - middle_end/base_types/symbol.cmi \ - bytecomp/lambda.cmi \ - middle_end/flambda.cmi \ - parsing/asttypes.cmi \ - middle_end/allocated_const.cmi -middle_end/allocated_const.cmo : \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/allocated_const.cmi -middle_end/allocated_const.cmx : \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/allocated_const.cmi -middle_end/allocated_const.cmi : -middle_end/augment_specialised_args.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/projection.cmi \ - middle_end/pass_wrapper.cmi \ - middle_end/parameter.cmi \ - utils/misc.cmi \ - middle_end/internal_variable_names.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/inlining_cost.cmi \ - middle_end/inline_and_simplify_aux.cmi \ +middle_end/backend_intf.cmi : \ + middle_end/symbol.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + typing/ident.cmi \ + middle_end/flambda/base_types/closure_id.cmi +middle_end/backend_var.cmo : \ + typing/path.cmi \ + typing/ident.cmi \ + lambda/debuginfo.cmi \ + middle_end/backend_var.cmi +middle_end/backend_var.cmx : \ + typing/path.cmx \ + typing/ident.cmx \ + lambda/debuginfo.cmx \ + middle_end/backend_var.cmi +middle_end/backend_var.cmi : \ + typing/path.cmi \ + typing/ident.cmi \ + lambda/debuginfo.cmi +middle_end/clambda.cmo : \ + typing/path.cmi \ + lambda/lambda.cmi \ + typing/ident.cmi \ + lambda/debuginfo.cmi \ + middle_end/clambda_primitives.cmi \ + middle_end/backend_var.cmi \ + parsing/asttypes.cmi \ + middle_end/clambda.cmi +middle_end/clambda.cmx : \ + typing/path.cmx \ + lambda/lambda.cmx \ + typing/ident.cmx \ + lambda/debuginfo.cmx \ + middle_end/clambda_primitives.cmx \ + middle_end/backend_var.cmx \ + parsing/asttypes.cmi \ + middle_end/clambda.cmi +middle_end/clambda.cmi : \ + typing/path.cmi \ + lambda/lambda.cmi \ + typing/ident.cmi \ + lambda/debuginfo.cmi \ + middle_end/clambda_primitives.cmi \ + middle_end/backend_var.cmi \ + parsing/asttypes.cmi +middle_end/clambda_primitives.cmo : \ + typing/types.cmi \ + typing/primitive.cmi \ + lambda/lambda.cmi \ + parsing/asttypes.cmi \ + middle_end/clambda_primitives.cmi +middle_end/clambda_primitives.cmx : \ + typing/types.cmx \ + typing/primitive.cmx \ + lambda/lambda.cmx \ + parsing/asttypes.cmi \ + middle_end/clambda_primitives.cmi +middle_end/clambda_primitives.cmi : \ + typing/types.cmi \ + typing/primitive.cmi \ + lambda/lambda.cmi \ + parsing/asttypes.cmi +middle_end/compilation_unit.cmo : \ + utils/misc.cmi \ + middle_end/linkage_name.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + utils/identifiable.cmi \ + typing/ident.cmi \ + middle_end/compilation_unit.cmi +middle_end/compilation_unit.cmx : \ + utils/misc.cmx \ + middle_end/linkage_name.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + utils/identifiable.cmx \ + typing/ident.cmx \ + middle_end/compilation_unit.cmi +middle_end/compilation_unit.cmi : \ + middle_end/linkage_name.cmi \ + utils/identifiable.cmi \ + typing/ident.cmi +middle_end/compilenv.cmo : \ + utils/warnings.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + middle_end/flambda/base_types/set_of_closures_id.cmi \ + typing/path.cmi \ + utils/misc.cmi \ + parsing/location.cmi \ + utils/load_path.cmi \ + middle_end/linkage_name.cmi \ + typing/ident.cmi \ + middle_end/flambda/export_info.cmi \ + typing/env.cmi \ + utils/config.cmi \ + middle_end/compilation_unit.cmi \ + file_formats/cmx_format.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ + utils/clflags.cmi \ + middle_end/clambda.cmi \ + middle_end/compilenv.cmi +middle_end/compilenv.cmx : \ + utils/warnings.cmx \ + middle_end/symbol.cmx \ + middle_end/flambda/simple_value_approx.cmx \ + middle_end/flambda/base_types/set_of_closures_id.cmx \ + typing/path.cmx \ + utils/misc.cmx \ + parsing/location.cmx \ + utils/load_path.cmx \ + middle_end/linkage_name.cmx \ + typing/ident.cmx \ + middle_end/flambda/export_info.cmx \ + typing/env.cmx \ + utils/config.cmx \ + middle_end/compilation_unit.cmx \ + file_formats/cmx_format.cmi \ + middle_end/flambda/base_types/closure_id.cmx \ + utils/clflags.cmx \ + middle_end/clambda.cmx \ + middle_end/compilenv.cmi +middle_end/compilenv.cmi : \ + middle_end/symbol.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + middle_end/flambda/base_types/set_of_closures_id.cmi \ + middle_end/linkage_name.cmi \ + typing/ident.cmi \ + middle_end/flambda/export_info.cmi \ + middle_end/compilation_unit.cmi \ + file_formats/cmx_format.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ + middle_end/clambda.cmi +middle_end/convert_primitives.cmo : \ + lambda/printlambda.cmi \ + utils/misc.cmi \ + lambda/lambda.cmi \ + middle_end/clambda_primitives.cmi \ + middle_end/convert_primitives.cmi +middle_end/convert_primitives.cmx : \ + lambda/printlambda.cmx \ + utils/misc.cmx \ + lambda/lambda.cmx \ + middle_end/clambda_primitives.cmx \ + middle_end/convert_primitives.cmi +middle_end/convert_primitives.cmi : \ + lambda/lambda.cmi \ + middle_end/clambda_primitives.cmi +middle_end/internal_variable_names.cmo : \ + parsing/location.cmi \ + lambda/lambda.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/internal_variable_names.cmi +middle_end/internal_variable_names.cmx : \ + parsing/location.cmx \ + lambda/lambda.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/internal_variable_names.cmi +middle_end/internal_variable_names.cmi : \ + parsing/location.cmi \ + lambda/lambda.cmi +middle_end/linkage_name.cmo : \ + utils/int_replace_polymorphic_compare.cmi \ + utils/identifiable.cmi \ + middle_end/linkage_name.cmi +middle_end/linkage_name.cmx : \ + utils/int_replace_polymorphic_compare.cmx \ + utils/identifiable.cmx \ + middle_end/linkage_name.cmi +middle_end/linkage_name.cmi : \ + utils/identifiable.cmi +middle_end/printclambda.cmo : \ + lambda/printlambda.cmi \ + middle_end/printclambda_primitives.cmi \ + lambda/lambda.cmi \ + typing/ident.cmi \ + middle_end/clambda.cmi \ + middle_end/backend_var.cmi \ + parsing/asttypes.cmi \ + middle_end/printclambda.cmi +middle_end/printclambda.cmx : \ + lambda/printlambda.cmx \ + middle_end/printclambda_primitives.cmx \ + lambda/lambda.cmx \ + typing/ident.cmx \ + middle_end/clambda.cmx \ + middle_end/backend_var.cmx \ + parsing/asttypes.cmi \ + middle_end/printclambda.cmi +middle_end/printclambda.cmi : \ + middle_end/clambda.cmi +middle_end/printclambda_primitives.cmo : \ + lambda/printlambda.cmi \ + typing/primitive.cmi \ + lambda/lambda.cmi \ + middle_end/clambda_primitives.cmi \ + parsing/asttypes.cmi \ + middle_end/printclambda_primitives.cmi +middle_end/printclambda_primitives.cmx : \ + lambda/printlambda.cmx \ + typing/primitive.cmx \ + lambda/lambda.cmx \ + middle_end/clambda_primitives.cmx \ + parsing/asttypes.cmi \ + middle_end/printclambda_primitives.cmi +middle_end/printclambda_primitives.cmi : \ + middle_end/clambda_primitives.cmi +middle_end/semantics_of_primitives.cmo : \ + middle_end/clambda_primitives.cmi \ + middle_end/semantics_of_primitives.cmi +middle_end/semantics_of_primitives.cmx : \ + middle_end/clambda_primitives.cmx \ + middle_end/semantics_of_primitives.cmi +middle_end/semantics_of_primitives.cmi : \ + middle_end/clambda_primitives.cmi +middle_end/symbol.cmo : \ + middle_end/variable.cmi \ + utils/misc.cmi \ + middle_end/linkage_name.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + utils/identifiable.cmi \ + middle_end/compilation_unit.cmi \ + middle_end/symbol.cmi +middle_end/symbol.cmx : \ + middle_end/variable.cmx \ + utils/misc.cmx \ + middle_end/linkage_name.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + utils/identifiable.cmx \ + middle_end/compilation_unit.cmx \ + middle_end/symbol.cmi +middle_end/symbol.cmi : \ + middle_end/variable.cmi \ + middle_end/linkage_name.cmi \ + utils/identifiable.cmi \ + middle_end/compilation_unit.cmi +middle_end/variable.cmo : \ + utils/misc.cmi \ + middle_end/internal_variable_names.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + utils/identifiable.cmi \ + typing/ident.cmi \ + middle_end/compilation_unit.cmi \ + middle_end/variable.cmi +middle_end/variable.cmx : \ + utils/misc.cmx \ + middle_end/internal_variable_names.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + utils/identifiable.cmx \ + typing/ident.cmx \ + middle_end/compilation_unit.cmx \ + middle_end/variable.cmi +middle_end/variable.cmi : \ + middle_end/internal_variable_names.cmi \ + utils/identifiable.cmi \ + typing/ident.cmi \ + middle_end/compilation_unit.cmi +lambda/debuginfo.cmo : \ + parsing/location.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + lambda/debuginfo.cmi +lambda/debuginfo.cmx : \ + parsing/location.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + lambda/debuginfo.cmi +lambda/debuginfo.cmi : \ + parsing/location.cmi +lambda/lambda.cmo : \ + typing/types.cmi \ + typing/primitive.cmi \ + typing/path.cmi \ + utils/misc.cmi \ + parsing/longident.cmi \ + parsing/location.cmi \ + typing/ident.cmi \ + typing/env.cmi \ + parsing/asttypes.cmi \ + lambda/lambda.cmi +lambda/lambda.cmx : \ + typing/types.cmx \ + typing/primitive.cmx \ + typing/path.cmx \ + utils/misc.cmx \ + parsing/longident.cmx \ + parsing/location.cmx \ + typing/ident.cmx \ + typing/env.cmx \ + parsing/asttypes.cmi \ + lambda/lambda.cmi +lambda/lambda.cmi : \ + typing/types.cmi \ + typing/primitive.cmi \ + typing/path.cmi \ + parsing/location.cmi \ + typing/ident.cmi \ + typing/env.cmi \ + parsing/asttypes.cmi +lambda/matching.cmo : \ + typing/types.cmi \ + typing/typeopt.cmi \ + typing/typedtree.cmi \ + lambda/switch.cmi \ + typing/printpat.cmi \ + lambda/printlambda.cmi \ + typing/primitive.cmi \ + typing/predef.cmi \ + typing/parmatch.cmi \ + utils/misc.cmi \ + parsing/longident.cmi \ + parsing/location.cmi \ + lambda/lambda.cmi \ + typing/ident.cmi \ + typing/env.cmi \ + utils/clflags.cmi \ + typing/btype.cmi \ + parsing/asttypes.cmi \ + lambda/matching.cmi +lambda/matching.cmx : \ + typing/types.cmx \ + typing/typeopt.cmx \ + typing/typedtree.cmx \ + lambda/switch.cmx \ + typing/printpat.cmx \ + lambda/printlambda.cmx \ + typing/primitive.cmx \ + typing/predef.cmx \ + typing/parmatch.cmx \ + utils/misc.cmx \ + parsing/longident.cmx \ + parsing/location.cmx \ + lambda/lambda.cmx \ + typing/ident.cmx \ + typing/env.cmx \ + utils/clflags.cmx \ + typing/btype.cmx \ + parsing/asttypes.cmi \ + lambda/matching.cmi +lambda/matching.cmi : \ + typing/typedtree.cmi \ + parsing/location.cmi \ + lambda/lambda.cmi \ + typing/ident.cmi +lambda/printlambda.cmo : \ + typing/types.cmi \ + typing/printtyp.cmi \ + typing/primitive.cmi \ + parsing/location.cmi \ + lambda/lambda.cmi \ + typing/ident.cmi \ + parsing/asttypes.cmi \ + lambda/printlambda.cmi +lambda/printlambda.cmx : \ + typing/types.cmx \ + typing/printtyp.cmx \ + typing/primitive.cmx \ + parsing/location.cmx \ + lambda/lambda.cmx \ + typing/ident.cmx \ + parsing/asttypes.cmi \ + lambda/printlambda.cmi +lambda/printlambda.cmi : \ + typing/types.cmi \ + lambda/lambda.cmi +lambda/runtimedef.cmo : \ + lambda/runtimedef.cmi +lambda/runtimedef.cmx : \ + lambda/runtimedef.cmi +lambda/runtimedef.cmi : +lambda/simplif.cmo : \ + utils/warnings.cmi \ + typing/stypes.cmi \ + typing/primitive.cmi \ + utils/misc.cmi \ + parsing/location.cmi \ + lambda/lambda.cmi \ + typing/ident.cmi \ + utils/clflags.cmi \ + parsing/asttypes.cmi \ + typing/annot.cmi \ + lambda/simplif.cmi +lambda/simplif.cmx : \ + utils/warnings.cmx \ + typing/stypes.cmx \ + typing/primitive.cmx \ + utils/misc.cmx \ + parsing/location.cmx \ + lambda/lambda.cmx \ + typing/ident.cmx \ + utils/clflags.cmx \ + parsing/asttypes.cmi \ + typing/annot.cmi \ + lambda/simplif.cmi +lambda/simplif.cmi : \ + parsing/location.cmi \ + lambda/lambda.cmi \ + typing/ident.cmi +lambda/switch.cmo : \ + parsing/location.cmi \ + lambda/switch.cmi +lambda/switch.cmx : \ + parsing/location.cmx \ + lambda/switch.cmi +lambda/switch.cmi : \ + parsing/location.cmi +lambda/translattribute.cmo : \ + utils/warnings.cmi \ + typing/typedtree.cmi \ + parsing/parsetree.cmi \ + utils/misc.cmi \ + parsing/longident.cmi \ + parsing/location.cmi \ + lambda/lambda.cmi \ + utils/config.cmi \ + lambda/translattribute.cmi +lambda/translattribute.cmx : \ + utils/warnings.cmx \ + typing/typedtree.cmx \ + parsing/parsetree.cmi \ + utils/misc.cmx \ + parsing/longident.cmx \ + parsing/location.cmx \ + lambda/lambda.cmx \ + utils/config.cmx \ + lambda/translattribute.cmi +lambda/translattribute.cmi : \ + typing/typedtree.cmi \ + parsing/parsetree.cmi \ + parsing/location.cmi \ + lambda/lambda.cmi +lambda/translclass.cmo : \ + typing/types.cmi \ + typing/typeopt.cmi \ + typing/typedtree.cmi \ + lambda/translobj.cmi \ + lambda/translcore.cmi \ + typing/path.cmi \ + lambda/matching.cmi \ + parsing/location.cmi \ + lambda/lambda.cmi \ + typing/ident.cmi \ + typing/env.cmi \ + utils/clflags.cmi \ + typing/btype.cmi \ + parsing/asttypes.cmi \ + lambda/translclass.cmi +lambda/translclass.cmx : \ + typing/types.cmx \ + typing/typeopt.cmx \ + typing/typedtree.cmx \ + lambda/translobj.cmx \ + lambda/translcore.cmx \ + typing/path.cmx \ + lambda/matching.cmx \ + parsing/location.cmx \ + lambda/lambda.cmx \ + typing/ident.cmx \ + typing/env.cmx \ + utils/clflags.cmx \ + typing/btype.cmx \ + parsing/asttypes.cmi \ + lambda/translclass.cmi +lambda/translclass.cmi : \ + typing/typedtree.cmi \ + parsing/location.cmi \ + lambda/lambda.cmi \ + typing/ident.cmi \ + parsing/asttypes.cmi +lambda/translcore.cmo : \ + typing/types.cmi \ + typing/typeopt.cmi \ + typing/typedtree.cmi \ + typing/typecore.cmi \ + lambda/translprim.cmi \ + lambda/translobj.cmi \ + lambda/translattribute.cmi \ + typing/printtyp.cmi \ + typing/primitive.cmi \ + typing/predef.cmi \ + typing/path.cmi \ + parsing/parsetree.cmi \ + typing/parmatch.cmi \ + utils/misc.cmi \ + lambda/matching.cmi \ + parsing/longident.cmi \ + parsing/location.cmi \ + lambda/lambda.cmi \ + typing/ident.cmi \ + typing/env.cmi \ + utils/config.cmi \ + utils/clflags.cmi \ + typing/btype.cmi \ + parsing/asttypes.cmi \ + lambda/translcore.cmi +lambda/translcore.cmx : \ + typing/types.cmx \ + typing/typeopt.cmx \ + typing/typedtree.cmx \ + typing/typecore.cmx \ + lambda/translprim.cmx \ + lambda/translobj.cmx \ + lambda/translattribute.cmx \ + typing/printtyp.cmx \ + typing/primitive.cmx \ + typing/predef.cmx \ + typing/path.cmx \ + parsing/parsetree.cmi \ + typing/parmatch.cmx \ + utils/misc.cmx \ + lambda/matching.cmx \ + parsing/longident.cmx \ + parsing/location.cmx \ + lambda/lambda.cmx \ + typing/ident.cmx \ + typing/env.cmx \ + utils/config.cmx \ + utils/clflags.cmx \ + typing/btype.cmx \ + parsing/asttypes.cmi \ + lambda/translcore.cmi +lambda/translcore.cmi : \ + typing/typedtree.cmi \ + typing/path.cmi \ + parsing/location.cmi \ + lambda/lambda.cmi \ + typing/ident.cmi \ + typing/env.cmi \ + parsing/asttypes.cmi +lambda/translmod.cmo : \ + typing/types.cmi \ + typing/typedtree.cmi \ + lambda/translprim.cmi \ + lambda/translobj.cmi \ + lambda/translcore.cmi \ + lambda/translclass.cmi \ + lambda/translattribute.cmi \ + typing/primitive.cmi \ + typing/predef.cmi \ + typing/path.cmi \ + typing/mtype.cmi \ + utils/misc.cmi \ + parsing/location.cmi \ + lambda/lambda.cmi \ + typing/ident.cmi \ + typing/env.cmi \ + typing/ctype.cmi \ + utils/clflags.cmi \ + parsing/asttypes.cmi \ + lambda/translmod.cmi +lambda/translmod.cmx : \ + typing/types.cmx \ + typing/typedtree.cmx \ + lambda/translprim.cmx \ + lambda/translobj.cmx \ + lambda/translcore.cmx \ + lambda/translclass.cmx \ + lambda/translattribute.cmx \ + typing/primitive.cmx \ + typing/predef.cmx \ + typing/path.cmx \ + typing/mtype.cmx \ + utils/misc.cmx \ + parsing/location.cmx \ + lambda/lambda.cmx \ + typing/ident.cmx \ + typing/env.cmx \ + typing/ctype.cmx \ + utils/clflags.cmx \ + parsing/asttypes.cmi \ + lambda/translmod.cmi +lambda/translmod.cmi : \ + typing/typedtree.cmi \ + typing/primitive.cmi \ + parsing/location.cmi \ + lambda/lambda.cmi \ + typing/ident.cmi +lambda/translobj.cmo : \ + typing/primitive.cmi \ + utils/misc.cmi \ + parsing/location.cmi \ + lambda/lambda.cmi \ + typing/ident.cmi \ + typing/env.cmi \ + utils/config.cmi \ + utils/clflags.cmi \ + typing/btype.cmi \ + parsing/asttypes.cmi \ + lambda/translobj.cmi +lambda/translobj.cmx : \ + typing/primitive.cmx \ + utils/misc.cmx \ + parsing/location.cmx \ + lambda/lambda.cmx \ + typing/ident.cmx \ + typing/env.cmx \ + utils/config.cmx \ + utils/clflags.cmx \ + typing/btype.cmx \ + parsing/asttypes.cmi \ + lambda/translobj.cmi +lambda/translobj.cmi : \ + lambda/lambda.cmi \ + typing/ident.cmi \ + typing/env.cmi +lambda/translprim.cmo : \ + typing/types.cmi \ + typing/typeopt.cmi \ + typing/typedtree.cmi \ + typing/primitive.cmi \ + typing/predef.cmi \ + typing/path.cmi \ + utils/misc.cmi \ + lambda/matching.cmi \ + parsing/location.cmi \ + lambda/lambda.cmi \ + typing/ident.cmi \ + typing/env.cmi \ + utils/config.cmi \ + utils/clflags.cmi \ + parsing/asttypes.cmi \ + lambda/translprim.cmi +lambda/translprim.cmx : \ + typing/types.cmx \ + typing/typeopt.cmx \ + typing/typedtree.cmx \ + typing/primitive.cmx \ + typing/predef.cmx \ + typing/path.cmx \ + utils/misc.cmx \ + lambda/matching.cmx \ + parsing/location.cmx \ + lambda/lambda.cmx \ + typing/ident.cmx \ + typing/env.cmx \ + utils/config.cmx \ + utils/clflags.cmx \ + parsing/asttypes.cmi \ + lambda/translprim.cmi +lambda/translprim.cmi : \ + typing/types.cmi \ + typing/typedtree.cmi \ + typing/primitive.cmi \ + typing/path.cmi \ + parsing/location.cmi \ + lambda/lambda.cmi \ + typing/ident.cmi \ + typing/env.cmi +file_formats/cmi_format.cmo : \ + typing/types.cmi \ + utils/misc.cmi \ + parsing/location.cmi \ + utils/config.cmi \ + file_formats/cmi_format.cmi +file_formats/cmi_format.cmx : \ + typing/types.cmx \ + utils/misc.cmx \ + parsing/location.cmx \ + utils/config.cmx \ + file_formats/cmi_format.cmi +file_formats/cmi_format.cmi : \ + typing/types.cmi \ + utils/misc.cmi +file_formats/cmo_format.cmi : \ + utils/misc.cmi \ + lambda/lambda.cmi \ + typing/ident.cmi +file_formats/cmt_format.cmo : \ + typing/types.cmi \ + typing/typedtree.cmi \ + typing/tast_mapper.cmi \ + utils/misc.cmi \ + parsing/location.cmi \ + utils/load_path.cmi \ + parsing/lexer.cmi \ + typing/env.cmi \ + utils/config.cmi \ + file_formats/cmi_format.cmi \ + utils/clflags.cmi \ + file_formats/cmt_format.cmi +file_formats/cmt_format.cmx : \ + typing/types.cmx \ + typing/typedtree.cmx \ + typing/tast_mapper.cmx \ + utils/misc.cmx \ + parsing/location.cmx \ + utils/load_path.cmx \ + parsing/lexer.cmx \ + typing/env.cmx \ + utils/config.cmx \ + file_formats/cmi_format.cmx \ + utils/clflags.cmx \ + file_formats/cmt_format.cmi +file_formats/cmt_format.cmi : \ + typing/types.cmi \ + typing/typedtree.cmi \ + utils/misc.cmi \ + parsing/location.cmi \ + typing/env.cmi \ + file_formats/cmi_format.cmi +file_formats/cmx_format.cmi : \ + utils/misc.cmi \ + middle_end/flambda/export_info.cmi \ + middle_end/clambda.cmi +file_formats/cmxs_format.cmi : \ + utils/misc.cmi +middle_end/closure/closure.cmo : \ + utils/warnings.cmi \ + lambda/switch.cmi \ + lambda/simplif.cmi \ + middle_end/semantics_of_primitives.cmi \ + typing/primitive.cmi \ + utils/numbers.cmi \ + utils/misc.cmi \ + parsing/location.cmi \ + lambda/lambda.cmi \ + typing/ident.cmi \ + typing/env.cmi \ + lambda/debuginfo.cmi \ + middle_end/convert_primitives.cmi \ + utils/config.cmi \ + middle_end/compilenv.cmi \ + utils/clflags.cmi \ + middle_end/clambda_primitives.cmi \ + middle_end/clambda.cmi \ + middle_end/backend_var.cmi \ + middle_end/backend_intf.cmi \ + parsing/asttypes.cmi \ + middle_end/closure/closure.cmi +middle_end/closure/closure.cmx : \ + utils/warnings.cmx \ + lambda/switch.cmx \ + lambda/simplif.cmx \ + middle_end/semantics_of_primitives.cmx \ + typing/primitive.cmx \ + utils/numbers.cmx \ + utils/misc.cmx \ + parsing/location.cmx \ + lambda/lambda.cmx \ + typing/ident.cmx \ + typing/env.cmx \ + lambda/debuginfo.cmx \ + middle_end/convert_primitives.cmx \ + utils/config.cmx \ + middle_end/compilenv.cmx \ + utils/clflags.cmx \ + middle_end/clambda_primitives.cmx \ + middle_end/clambda.cmx \ + middle_end/backend_var.cmx \ + middle_end/backend_intf.cmi \ + parsing/asttypes.cmi \ + middle_end/closure/closure.cmi +middle_end/closure/closure.cmi : \ + lambda/lambda.cmi \ + middle_end/clambda.cmi \ + middle_end/backend_intf.cmi +middle_end/flambda/alias_analysis.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/flambda/base_types/tag.cmi \ + middle_end/symbol.cmi \ + utils/misc.cmi \ + lambda/lambda.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/flambda.cmi \ + parsing/asttypes.cmi \ + middle_end/flambda/allocated_const.cmi \ + middle_end/flambda/alias_analysis.cmi +middle_end/flambda/alias_analysis.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/var_within_closure.cmx \ + middle_end/flambda/base_types/tag.cmx \ + middle_end/symbol.cmx \ + utils/misc.cmx \ + lambda/lambda.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/flambda.cmx \ + parsing/asttypes.cmi \ + middle_end/flambda/allocated_const.cmx \ + middle_end/flambda/alias_analysis.cmi +middle_end/flambda/alias_analysis.cmi : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/tag.cmi \ + middle_end/symbol.cmi \ + lambda/lambda.cmi \ + middle_end/flambda/flambda.cmi \ + parsing/asttypes.cmi \ + middle_end/flambda/allocated_const.cmi +middle_end/flambda/allocated_const.cmo : \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/allocated_const.cmi +middle_end/flambda/allocated_const.cmx : \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/allocated_const.cmi +middle_end/flambda/allocated_const.cmi : +middle_end/flambda/augment_specialised_args.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/projection.cmi \ + middle_end/flambda/pass_wrapper.cmi \ + middle_end/flambda/parameter.cmi \ + utils/misc.cmi \ + middle_end/internal_variable_names.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/inlining_cost.cmi \ + middle_end/flambda/inline_and_simplify_aux.cmi \ utils/identifiable.cmi \ - middle_end/flambda_utils.cmi \ - middle_end/flambda.cmi \ - middle_end/debuginfo.cmi \ - middle_end/base_types/closure_origin.cmi \ - middle_end/base_types/closure_id.cmi \ + middle_end/flambda/flambda_utils.cmi \ + middle_end/flambda/flambda.cmi \ + lambda/debuginfo.cmi \ + middle_end/flambda/base_types/closure_origin.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ utils/clflags.cmi \ middle_end/backend_intf.cmi \ - middle_end/augment_specialised_args.cmi -middle_end/augment_specialised_args.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/projection.cmx \ - middle_end/pass_wrapper.cmx \ - middle_end/parameter.cmx \ + middle_end/flambda/augment_specialised_args.cmi +middle_end/flambda/augment_specialised_args.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/projection.cmx \ + middle_end/flambda/pass_wrapper.cmx \ + middle_end/flambda/parameter.cmx \ utils/misc.cmx \ middle_end/internal_variable_names.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/inlining_cost.cmx \ - middle_end/inline_and_simplify_aux.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/inlining_cost.cmx \ + middle_end/flambda/inline_and_simplify_aux.cmx \ utils/identifiable.cmx \ - middle_end/flambda_utils.cmx \ - middle_end/flambda.cmx \ - middle_end/debuginfo.cmx \ - middle_end/base_types/closure_origin.cmx \ - middle_end/base_types/closure_id.cmx \ + middle_end/flambda/flambda_utils.cmx \ + middle_end/flambda/flambda.cmx \ + lambda/debuginfo.cmx \ + middle_end/flambda/base_types/closure_origin.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ utils/clflags.cmx \ middle_end/backend_intf.cmi \ - middle_end/augment_specialised_args.cmi -middle_end/augment_specialised_args.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/projection.cmi \ - middle_end/inlining_cost.cmi \ - middle_end/inline_and_simplify_aux.cmi \ - middle_end/flambda.cmi -middle_end/backend_intf.cmi : \ - middle_end/base_types/symbol.cmi \ - middle_end/simple_value_approx.cmi \ - typing/ident.cmi \ - middle_end/base_types/closure_id.cmi -middle_end/closure_conversion.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/tag.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/base_types/static_exception.cmi \ - bytecomp/simplif.cmi \ + middle_end/flambda/augment_specialised_args.cmi +middle_end/flambda/augment_specialised_args.cmi : \ + middle_end/variable.cmi \ + middle_end/flambda/projection.cmi \ + middle_end/flambda/inlining_cost.cmi \ + middle_end/flambda/inline_and_simplify_aux.cmi \ + middle_end/flambda/flambda.cmi +middle_end/flambda/build_export_info.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/flambda/traverse_for_exported_symbols.cmi \ + middle_end/flambda/base_types/tag.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + middle_end/flambda/base_types/set_of_closures_id.cmi \ + utils/misc.cmi \ + middle_end/flambda/invariant_params.cmi \ + middle_end/flambda/inline_and_simplify_aux.cmi \ + middle_end/flambda/flambda_utils.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/find_recursive_functions.cmi \ + middle_end/flambda/export_info.cmi \ + middle_end/flambda/base_types/export_id.cmi \ + middle_end/compilenv.cmi \ + middle_end/compilation_unit.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ + utils/clflags.cmi \ + middle_end/backend_intf.cmi \ + middle_end/flambda/allocated_const.cmi \ + middle_end/flambda/build_export_info.cmi +middle_end/flambda/build_export_info.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/var_within_closure.cmx \ + middle_end/flambda/traverse_for_exported_symbols.cmx \ + middle_end/flambda/base_types/tag.cmx \ + middle_end/symbol.cmx \ + middle_end/flambda/simple_value_approx.cmx \ + middle_end/flambda/base_types/set_of_closures_id.cmx \ + utils/misc.cmx \ + middle_end/flambda/invariant_params.cmx \ + middle_end/flambda/inline_and_simplify_aux.cmx \ + middle_end/flambda/flambda_utils.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/find_recursive_functions.cmx \ + middle_end/flambda/export_info.cmx \ + middle_end/flambda/base_types/export_id.cmx \ + middle_end/compilenv.cmx \ + middle_end/compilation_unit.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ + utils/clflags.cmx \ + middle_end/backend_intf.cmi \ + middle_end/flambda/allocated_const.cmx \ + middle_end/flambda/build_export_info.cmi +middle_end/flambda/build_export_info.cmi : \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/export_info.cmi \ + middle_end/backend_intf.cmi +middle_end/flambda/closure_conversion.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/tag.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/base_types/static_exception.cmi \ + lambda/simplif.cmi \ typing/predef.cmi \ - middle_end/parameter.cmi \ + middle_end/flambda/parameter.cmi \ utils/numbers.cmi \ - middle_end/base_types/mutable_variable.cmi \ + middle_end/flambda/base_types/mutable_variable.cmi \ utils/misc.cmi \ - middle_end/lift_code.cmi \ - bytecomp/lambda.cmi \ + middle_end/flambda/lift_code.cmi \ + lambda/lambda.cmi \ middle_end/internal_variable_names.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ + utils/int_replace_polymorphic_compare.cmi \ typing/ident.cmi \ - middle_end/flambda_utils.cmi \ - middle_end/flambda.cmi \ - middle_end/debuginfo.cmi \ - asmcomp/convert_primitives.cmi \ + middle_end/flambda/flambda_utils.cmi \ + middle_end/flambda/flambda.cmi \ + lambda/debuginfo.cmi \ + middle_end/convert_primitives.cmi \ utils/config.cmi \ - middle_end/base_types/compilation_unit.cmi \ - middle_end/base_types/closure_origin.cmi \ - middle_end/base_types/closure_id.cmi \ - middle_end/closure_conversion_aux.cmi \ + middle_end/compilation_unit.cmi \ + middle_end/flambda/base_types/closure_origin.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ + middle_end/flambda/closure_conversion_aux.cmi \ utils/clflags.cmi \ - asmcomp/clambda_primitives.cmi \ + middle_end/clambda_primitives.cmi \ middle_end/backend_intf.cmi \ - middle_end/closure_conversion.cmi -middle_end/closure_conversion.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/tag.cmx \ - middle_end/base_types/symbol.cmx \ - middle_end/base_types/static_exception.cmx \ - bytecomp/simplif.cmx \ + middle_end/flambda/closure_conversion.cmi +middle_end/flambda/closure_conversion.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/tag.cmx \ + middle_end/symbol.cmx \ + middle_end/flambda/base_types/static_exception.cmx \ + lambda/simplif.cmx \ typing/predef.cmx \ - middle_end/parameter.cmx \ + middle_end/flambda/parameter.cmx \ utils/numbers.cmx \ - middle_end/base_types/mutable_variable.cmx \ + middle_end/flambda/base_types/mutable_variable.cmx \ utils/misc.cmx \ - middle_end/lift_code.cmx \ - bytecomp/lambda.cmx \ + middle_end/flambda/lift_code.cmx \ + lambda/lambda.cmx \ middle_end/internal_variable_names.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ + utils/int_replace_polymorphic_compare.cmx \ typing/ident.cmx \ - middle_end/flambda_utils.cmx \ - middle_end/flambda.cmx \ - middle_end/debuginfo.cmx \ - asmcomp/convert_primitives.cmx \ + middle_end/flambda/flambda_utils.cmx \ + middle_end/flambda/flambda.cmx \ + lambda/debuginfo.cmx \ + middle_end/convert_primitives.cmx \ utils/config.cmx \ - middle_end/base_types/compilation_unit.cmx \ - middle_end/base_types/closure_origin.cmx \ - middle_end/base_types/closure_id.cmx \ - middle_end/closure_conversion_aux.cmx \ + middle_end/compilation_unit.cmx \ + middle_end/flambda/base_types/closure_origin.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ + middle_end/flambda/closure_conversion_aux.cmx \ utils/clflags.cmx \ - asmcomp/clambda_primitives.cmx \ + middle_end/clambda_primitives.cmx \ middle_end/backend_intf.cmi \ - middle_end/closure_conversion.cmi -middle_end/closure_conversion.cmi : \ - bytecomp/lambda.cmi \ + middle_end/flambda/closure_conversion.cmi +middle_end/flambda/closure_conversion.cmi : \ + lambda/lambda.cmi \ typing/ident.cmi \ - middle_end/flambda.cmi \ + middle_end/flambda/flambda.cmi \ middle_end/backend_intf.cmi -middle_end/closure_conversion_aux.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/base_types/static_exception.cmi \ +middle_end/flambda/closure_conversion_aux.cmo : \ + middle_end/variable.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/base_types/static_exception.cmi \ utils/numbers.cmi \ - middle_end/base_types/mutable_variable.cmi \ + middle_end/flambda/base_types/mutable_variable.cmi \ utils/misc.cmi \ parsing/location.cmi \ - bytecomp/lambda.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ + lambda/lambda.cmi \ + utils/int_replace_polymorphic_compare.cmi \ typing/ident.cmi \ - middle_end/closure_conversion_aux.cmi -middle_end/closure_conversion_aux.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/symbol.cmx \ - middle_end/base_types/static_exception.cmx \ + middle_end/flambda/closure_conversion_aux.cmi +middle_end/flambda/closure_conversion_aux.cmx : \ + middle_end/variable.cmx \ + middle_end/symbol.cmx \ + middle_end/flambda/base_types/static_exception.cmx \ utils/numbers.cmx \ - middle_end/base_types/mutable_variable.cmx \ + middle_end/flambda/base_types/mutable_variable.cmx \ utils/misc.cmx \ parsing/location.cmx \ - bytecomp/lambda.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ + lambda/lambda.cmx \ + utils/int_replace_polymorphic_compare.cmx \ typing/ident.cmx \ - middle_end/closure_conversion_aux.cmi -middle_end/closure_conversion_aux.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/base_types/static_exception.cmi \ - middle_end/base_types/mutable_variable.cmi \ + middle_end/flambda/closure_conversion_aux.cmi +middle_end/flambda/closure_conversion_aux.cmi : \ + middle_end/variable.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/base_types/static_exception.cmi \ + middle_end/flambda/base_types/mutable_variable.cmi \ parsing/location.cmi \ - bytecomp/lambda.cmi \ + lambda/lambda.cmi \ typing/ident.cmi -middle_end/debuginfo.cmo : \ - parsing/location.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/debuginfo.cmi -middle_end/debuginfo.cmx : \ - parsing/location.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/debuginfo.cmi -middle_end/debuginfo.cmi : \ - parsing/location.cmi -middle_end/effect_analysis.cmo : \ - asmcomp/semantics_of_primitives.cmi \ - utils/misc.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/flambda.cmi \ - asmcomp/clambda_primitives.cmi \ - middle_end/effect_analysis.cmi -middle_end/effect_analysis.cmx : \ - asmcomp/semantics_of_primitives.cmx \ - utils/misc.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/flambda.cmx \ - asmcomp/clambda_primitives.cmx \ - middle_end/effect_analysis.cmi -middle_end/effect_analysis.cmi : \ - middle_end/flambda.cmi -middle_end/extract_projections.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/simple_value_approx.cmi \ - middle_end/projection.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/inline_and_simplify_aux.cmi \ - middle_end/freshening.cmi \ - middle_end/flambda_iterators.cmi \ - middle_end/flambda.cmi \ - middle_end/base_types/closure_id.cmi \ - middle_end/extract_projections.cmi -middle_end/extract_projections.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/var_within_closure.cmx \ - middle_end/simple_value_approx.cmx \ - middle_end/projection.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/inline_and_simplify_aux.cmx \ - middle_end/freshening.cmx \ - middle_end/flambda_iterators.cmx \ - middle_end/flambda.cmx \ - middle_end/base_types/closure_id.cmx \ - middle_end/extract_projections.cmi -middle_end/extract_projections.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/projection.cmi \ - middle_end/inline_and_simplify_aux.cmi \ - middle_end/flambda.cmi -middle_end/find_recursive_functions.cmo : \ - middle_end/base_types/variable.cmi \ +middle_end/flambda/closure_offsets.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + utils/misc.cmi \ + middle_end/flambda/flambda_utils.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ + middle_end/flambda/closure_offsets.cmi +middle_end/flambda/closure_offsets.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/var_within_closure.cmx \ + utils/misc.cmx \ + middle_end/flambda/flambda_utils.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ + middle_end/flambda/closure_offsets.cmi +middle_end/flambda/closure_offsets.cmi : \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/base_types/closure_id.cmi +middle_end/flambda/effect_analysis.cmo : \ + middle_end/semantics_of_primitives.cmi \ + utils/misc.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/clambda_primitives.cmi \ + middle_end/flambda/effect_analysis.cmi +middle_end/flambda/effect_analysis.cmx : \ + middle_end/semantics_of_primitives.cmx \ + utils/misc.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/clambda_primitives.cmx \ + middle_end/flambda/effect_analysis.cmi +middle_end/flambda/effect_analysis.cmi : \ + middle_end/flambda/flambda.cmi +middle_end/flambda/export_info.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/flambda/base_types/tag.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + middle_end/flambda/base_types/set_of_closures_id.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/base_types/export_id.cmi \ + middle_end/compilation_unit.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ + middle_end/flambda/export_info.cmi +middle_end/flambda/export_info.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/var_within_closure.cmx \ + middle_end/flambda/base_types/tag.cmx \ + middle_end/symbol.cmx \ + middle_end/flambda/simple_value_approx.cmx \ + middle_end/flambda/base_types/set_of_closures_id.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/base_types/export_id.cmx \ + middle_end/compilation_unit.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ + middle_end/flambda/export_info.cmi +middle_end/flambda/export_info.cmi : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/flambda/base_types/tag.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + middle_end/flambda/base_types/set_of_closures_id.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/base_types/export_id.cmi \ + middle_end/compilation_unit.cmi \ + middle_end/flambda/base_types/closure_id.cmi +middle_end/flambda/export_info_for_pack.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + middle_end/flambda/base_types/set_of_closures_origin.cmi \ + middle_end/flambda/base_types/set_of_closures_id.cmi \ + utils/misc.cmi \ + middle_end/flambda/flambda_iterators.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/export_info.cmi \ + middle_end/flambda/base_types/export_id.cmi \ + middle_end/compilation_unit.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ + middle_end/flambda/export_info_for_pack.cmi +middle_end/flambda/export_info_for_pack.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/var_within_closure.cmx \ + middle_end/symbol.cmx \ + middle_end/flambda/simple_value_approx.cmx \ + middle_end/flambda/base_types/set_of_closures_origin.cmx \ + middle_end/flambda/base_types/set_of_closures_id.cmx \ + utils/misc.cmx \ + middle_end/flambda/flambda_iterators.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/export_info.cmx \ + middle_end/flambda/base_types/export_id.cmx \ + middle_end/compilation_unit.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ + middle_end/flambda/export_info_for_pack.cmi +middle_end/flambda/export_info_for_pack.cmi : \ + middle_end/flambda/export_info.cmi \ + middle_end/compilation_unit.cmi +middle_end/flambda/extract_projections.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + middle_end/flambda/projection.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/inline_and_simplify_aux.cmi \ + middle_end/flambda/freshening.cmi \ + middle_end/flambda/flambda_iterators.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ + middle_end/flambda/extract_projections.cmi +middle_end/flambda/extract_projections.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/var_within_closure.cmx \ + middle_end/flambda/simple_value_approx.cmx \ + middle_end/flambda/projection.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/inline_and_simplify_aux.cmx \ + middle_end/flambda/freshening.cmx \ + middle_end/flambda/flambda_iterators.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ + middle_end/flambda/extract_projections.cmi +middle_end/flambda/extract_projections.cmi : \ + middle_end/variable.cmi \ + middle_end/flambda/projection.cmi \ + middle_end/flambda/inline_and_simplify_aux.cmi \ + middle_end/flambda/flambda.cmi +middle_end/flambda/find_recursive_functions.cmo : \ + middle_end/variable.cmi \ utils/strongly_connected_components.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/flambda_utils.cmi \ - middle_end/flambda.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/flambda_utils.cmi \ + middle_end/flambda/flambda.cmi \ middle_end/backend_intf.cmi \ - middle_end/find_recursive_functions.cmi -middle_end/find_recursive_functions.cmx : \ - middle_end/base_types/variable.cmx \ + middle_end/flambda/find_recursive_functions.cmi +middle_end/flambda/find_recursive_functions.cmx : \ + middle_end/variable.cmx \ utils/strongly_connected_components.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/flambda_utils.cmx \ - middle_end/flambda.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/flambda_utils.cmx \ + middle_end/flambda/flambda.cmx \ middle_end/backend_intf.cmi \ - middle_end/find_recursive_functions.cmi -middle_end/find_recursive_functions.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/flambda.cmi \ + middle_end/flambda/find_recursive_functions.cmi +middle_end/flambda/find_recursive_functions.cmi : \ + middle_end/variable.cmi \ + middle_end/flambda/flambda.cmi \ middle_end/backend_intf.cmi -middle_end/flambda.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/tag.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/base_types/static_exception.cmi \ - middle_end/base_types/set_of_closures_origin.cmi \ - middle_end/base_types/set_of_closures_id.cmi \ - middle_end/projection.cmi \ - bytecomp/printlambda.cmi \ - asmcomp/printclambda_primitives.cmi \ - middle_end/parameter.cmi \ +middle_end/flambda/flambda.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/tag.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/base_types/static_exception.cmi \ + middle_end/flambda/base_types/set_of_closures_origin.cmi \ + middle_end/flambda/base_types/set_of_closures_id.cmi \ + middle_end/flambda/projection.cmi \ + lambda/printlambda.cmi \ + middle_end/printclambda_primitives.cmi \ + middle_end/flambda/parameter.cmi \ utils/numbers.cmi \ - middle_end/base_types/mutable_variable.cmi \ + middle_end/flambda/base_types/mutable_variable.cmi \ utils/misc.cmi \ - bytecomp/lambda.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ + lambda/lambda.cmi \ + utils/int_replace_polymorphic_compare.cmi \ utils/identifiable.cmi \ - middle_end/debuginfo.cmi \ - middle_end/base_types/compilation_unit.cmi \ - middle_end/base_types/closure_origin.cmi \ - middle_end/base_types/closure_id.cmi \ + lambda/debuginfo.cmi \ + middle_end/compilation_unit.cmi \ + middle_end/flambda/base_types/closure_origin.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ utils/clflags.cmi \ - asmcomp/clambda_primitives.cmi \ - parsing/asttypes.cmi \ - middle_end/allocated_const.cmi \ - middle_end/flambda.cmi -middle_end/flambda.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/tag.cmx \ - middle_end/base_types/symbol.cmx \ - middle_end/base_types/static_exception.cmx \ - middle_end/base_types/set_of_closures_origin.cmx \ - middle_end/base_types/set_of_closures_id.cmx \ - middle_end/projection.cmx \ - bytecomp/printlambda.cmx \ - asmcomp/printclambda_primitives.cmx \ - middle_end/parameter.cmx \ + middle_end/clambda_primitives.cmi \ + parsing/asttypes.cmi \ + middle_end/flambda/allocated_const.cmi \ + middle_end/flambda/flambda.cmi +middle_end/flambda/flambda.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/tag.cmx \ + middle_end/symbol.cmx \ + middle_end/flambda/base_types/static_exception.cmx \ + middle_end/flambda/base_types/set_of_closures_origin.cmx \ + middle_end/flambda/base_types/set_of_closures_id.cmx \ + middle_end/flambda/projection.cmx \ + lambda/printlambda.cmx \ + middle_end/printclambda_primitives.cmx \ + middle_end/flambda/parameter.cmx \ utils/numbers.cmx \ - middle_end/base_types/mutable_variable.cmx \ + middle_end/flambda/base_types/mutable_variable.cmx \ utils/misc.cmx \ - bytecomp/lambda.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ + lambda/lambda.cmx \ + utils/int_replace_polymorphic_compare.cmx \ utils/identifiable.cmx \ - middle_end/debuginfo.cmx \ - middle_end/base_types/compilation_unit.cmx \ - middle_end/base_types/closure_origin.cmx \ - middle_end/base_types/closure_id.cmx \ + lambda/debuginfo.cmx \ + middle_end/compilation_unit.cmx \ + middle_end/flambda/base_types/closure_origin.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ utils/clflags.cmx \ - asmcomp/clambda_primitives.cmx \ - parsing/asttypes.cmi \ - middle_end/allocated_const.cmx \ - middle_end/flambda.cmi -middle_end/flambda.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/tag.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/base_types/static_exception.cmi \ - middle_end/base_types/set_of_closures_origin.cmi \ - middle_end/base_types/set_of_closures_id.cmi \ - middle_end/projection.cmi \ - middle_end/parameter.cmi \ + middle_end/clambda_primitives.cmx \ + parsing/asttypes.cmi \ + middle_end/flambda/allocated_const.cmx \ + middle_end/flambda/flambda.cmi +middle_end/flambda/flambda.cmi : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/tag.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/base_types/static_exception.cmi \ + middle_end/flambda/base_types/set_of_closures_origin.cmi \ + middle_end/flambda/base_types/set_of_closures_id.cmi \ + middle_end/flambda/projection.cmi \ + middle_end/flambda/parameter.cmi \ utils/numbers.cmi \ - middle_end/base_types/mutable_variable.cmi \ - bytecomp/lambda.cmi \ + middle_end/flambda/base_types/mutable_variable.cmi \ + lambda/lambda.cmi \ utils/identifiable.cmi \ - middle_end/debuginfo.cmi \ - middle_end/base_types/closure_origin.cmi \ - middle_end/base_types/closure_id.cmi \ - asmcomp/clambda_primitives.cmi \ - parsing/asttypes.cmi \ - middle_end/allocated_const.cmi -middle_end/flambda_invariants.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/base_types/tag.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/base_types/static_exception.cmi \ - middle_end/base_types/set_of_closures_origin.cmi \ - middle_end/base_types/set_of_closures_id.cmi \ - middle_end/projection.cmi \ - asmcomp/printclambda_primitives.cmi \ - middle_end/parameter.cmi \ + lambda/debuginfo.cmi \ + middle_end/flambda/base_types/closure_origin.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ + middle_end/clambda_primitives.cmi \ + parsing/asttypes.cmi \ + middle_end/flambda/allocated_const.cmi +middle_end/flambda/flambda_invariants.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/flambda/base_types/tag.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/base_types/static_exception.cmi \ + middle_end/flambda/base_types/set_of_closures_origin.cmi \ + middle_end/flambda/base_types/set_of_closures_id.cmi \ + middle_end/flambda/projection.cmi \ + middle_end/printclambda_primitives.cmi \ + middle_end/flambda/parameter.cmi \ + utils/numbers.cmi \ + middle_end/flambda/base_types/mutable_variable.cmi \ + utils/misc.cmi \ + lambda/lambda.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/flambda_iterators.cmi \ + middle_end/flambda/flambda.cmi \ + lambda/debuginfo.cmi \ + middle_end/compilation_unit.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ + middle_end/clambda_primitives.cmi \ + parsing/asttypes.cmi \ + middle_end/flambda/allocated_const.cmi \ + middle_end/flambda/flambda_invariants.cmi +middle_end/flambda/flambda_invariants.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/var_within_closure.cmx \ + middle_end/flambda/base_types/tag.cmx \ + middle_end/symbol.cmx \ + middle_end/flambda/base_types/static_exception.cmx \ + middle_end/flambda/base_types/set_of_closures_origin.cmx \ + middle_end/flambda/base_types/set_of_closures_id.cmx \ + middle_end/flambda/projection.cmx \ + middle_end/printclambda_primitives.cmx \ + middle_end/flambda/parameter.cmx \ + utils/numbers.cmx \ + middle_end/flambda/base_types/mutable_variable.cmx \ + utils/misc.cmx \ + lambda/lambda.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/flambda_iterators.cmx \ + middle_end/flambda/flambda.cmx \ + lambda/debuginfo.cmx \ + middle_end/compilation_unit.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ + middle_end/clambda_primitives.cmx \ + parsing/asttypes.cmi \ + middle_end/flambda/allocated_const.cmx \ + middle_end/flambda/flambda_invariants.cmi +middle_end/flambda/flambda_invariants.cmi : \ + middle_end/flambda/flambda.cmi +middle_end/flambda/flambda_iterators.cmo : \ + middle_end/variable.cmi \ + utils/misc.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/flambda_iterators.cmi +middle_end/flambda/flambda_iterators.cmx : \ + middle_end/variable.cmx \ + utils/misc.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/flambda_iterators.cmi +middle_end/flambda/flambda_iterators.cmi : \ + middle_end/variable.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/flambda.cmi +middle_end/flambda/flambda_middle_end.cmo : \ + utils/warnings.cmi \ + middle_end/variable.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/share_constants.cmi \ + middle_end/flambda/remove_unused_program_constructs.cmi \ + middle_end/flambda/remove_unused_closure_vars.cmi \ + middle_end/flambda/ref_to_variables.cmi \ + utils/profile.cmi \ + utils/misc.cmi \ + parsing/location.cmi \ + middle_end/flambda/lift_let_to_initialize_symbol.cmi \ + middle_end/flambda/lift_constants.cmi \ + middle_end/flambda/lift_code.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/inlining_cost.cmi \ + middle_end/flambda/inline_and_simplify.cmi \ + middle_end/flambda/initialize_symbol_to_let_symbol.cmi \ + middle_end/flambda/flambda_iterators.cmi \ + middle_end/flambda/flambda_invariants.cmi \ + middle_end/flambda/flambda.cmi \ + lambda/debuginfo.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ + middle_end/flambda/closure_conversion.cmi \ + utils/clflags.cmi \ + middle_end/backend_intf.cmi \ + middle_end/flambda/flambda_middle_end.cmi +middle_end/flambda/flambda_middle_end.cmx : \ + utils/warnings.cmx \ + middle_end/variable.cmx \ + middle_end/symbol.cmx \ + middle_end/flambda/share_constants.cmx \ + middle_end/flambda/remove_unused_program_constructs.cmx \ + middle_end/flambda/remove_unused_closure_vars.cmx \ + middle_end/flambda/ref_to_variables.cmx \ + utils/profile.cmx \ + utils/misc.cmx \ + parsing/location.cmx \ + middle_end/flambda/lift_let_to_initialize_symbol.cmx \ + middle_end/flambda/lift_constants.cmx \ + middle_end/flambda/lift_code.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/inlining_cost.cmx \ + middle_end/flambda/inline_and_simplify.cmx \ + middle_end/flambda/initialize_symbol_to_let_symbol.cmx \ + middle_end/flambda/flambda_iterators.cmx \ + middle_end/flambda/flambda_invariants.cmx \ + middle_end/flambda/flambda.cmx \ + lambda/debuginfo.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ + middle_end/flambda/closure_conversion.cmx \ + utils/clflags.cmx \ + middle_end/backend_intf.cmi \ + middle_end/flambda/flambda_middle_end.cmi +middle_end/flambda/flambda_middle_end.cmi : \ + lambda/lambda.cmi \ + typing/ident.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/backend_intf.cmi +middle_end/flambda/flambda_to_clambda.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/flambda/base_types/tag.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/base_types/static_exception.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + middle_end/flambda/base_types/set_of_closures_id.cmi \ + typing/primitive.cmi \ + middle_end/flambda/parameter.cmi \ utils/numbers.cmi \ - middle_end/base_types/mutable_variable.cmi \ - utils/misc.cmi \ - bytecomp/lambda.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/flambda_iterators.cmi \ - middle_end/flambda.cmi \ - middle_end/debuginfo.cmi \ - middle_end/base_types/compilation_unit.cmi \ - middle_end/base_types/closure_id.cmi \ - asmcomp/clambda_primitives.cmi \ - parsing/asttypes.cmi \ - middle_end/allocated_const.cmi \ - middle_end/flambda_invariants.cmi -middle_end/flambda_invariants.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/var_within_closure.cmx \ - middle_end/base_types/tag.cmx \ - middle_end/base_types/symbol.cmx \ - middle_end/base_types/static_exception.cmx \ - middle_end/base_types/set_of_closures_origin.cmx \ - middle_end/base_types/set_of_closures_id.cmx \ - middle_end/projection.cmx \ - asmcomp/printclambda_primitives.cmx \ - middle_end/parameter.cmx \ + middle_end/flambda/base_types/mutable_variable.cmi \ + utils/misc.cmi \ + middle_end/linkage_name.cmi \ + lambda/lambda.cmi \ + middle_end/flambda/initialize_symbol_to_let_symbol.cmi \ + middle_end/flambda/flambda_utils.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/export_info.cmi \ + lambda/debuginfo.cmi \ + middle_end/compilenv.cmi \ + middle_end/flambda/closure_offsets.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ + utils/clflags.cmi \ + middle_end/clambda.cmi \ + middle_end/backend_var.cmi \ + middle_end/flambda/allocated_const.cmi \ + middle_end/flambda/flambda_to_clambda.cmi +middle_end/flambda/flambda_to_clambda.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/var_within_closure.cmx \ + middle_end/flambda/base_types/tag.cmx \ + middle_end/symbol.cmx \ + middle_end/flambda/base_types/static_exception.cmx \ + middle_end/flambda/simple_value_approx.cmx \ + middle_end/flambda/base_types/set_of_closures_id.cmx \ + typing/primitive.cmx \ + middle_end/flambda/parameter.cmx \ utils/numbers.cmx \ - middle_end/base_types/mutable_variable.cmx \ - utils/misc.cmx \ - bytecomp/lambda.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/flambda_iterators.cmx \ - middle_end/flambda.cmx \ - middle_end/debuginfo.cmx \ - middle_end/base_types/compilation_unit.cmx \ - middle_end/base_types/closure_id.cmx \ - asmcomp/clambda_primitives.cmx \ - parsing/asttypes.cmi \ - middle_end/allocated_const.cmx \ - middle_end/flambda_invariants.cmi -middle_end/flambda_invariants.cmi : \ - middle_end/flambda.cmi -middle_end/flambda_iterators.cmo : \ - middle_end/base_types/variable.cmi \ - utils/misc.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/flambda.cmi \ - middle_end/flambda_iterators.cmi -middle_end/flambda_iterators.cmx : \ - middle_end/base_types/variable.cmx \ - utils/misc.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/flambda.cmx \ - middle_end/flambda_iterators.cmi -middle_end/flambda_iterators.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/flambda.cmi -middle_end/flambda_utils.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/base_types/symbol.cmi \ - bytecomp/switch.cmi \ - middle_end/base_types/static_exception.cmi \ - middle_end/base_types/set_of_closures_id.cmi \ - middle_end/projection.cmi \ - middle_end/parameter.cmi \ + middle_end/flambda/base_types/mutable_variable.cmx \ + utils/misc.cmx \ + middle_end/linkage_name.cmx \ + lambda/lambda.cmx \ + middle_end/flambda/initialize_symbol_to_let_symbol.cmx \ + middle_end/flambda/flambda_utils.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/export_info.cmx \ + lambda/debuginfo.cmx \ + middle_end/compilenv.cmx \ + middle_end/flambda/closure_offsets.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ + utils/clflags.cmx \ + middle_end/clambda.cmx \ + middle_end/backend_var.cmx \ + middle_end/flambda/allocated_const.cmx \ + middle_end/flambda/flambda_to_clambda.cmi +middle_end/flambda/flambda_to_clambda.cmi : \ + middle_end/symbol.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/export_info.cmi \ + middle_end/clambda.cmi +middle_end/flambda/flambda_utils.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/symbol.cmi \ + lambda/switch.cmi \ + middle_end/flambda/base_types/static_exception.cmi \ + middle_end/flambda/base_types/set_of_closures_id.cmi \ + middle_end/flambda/projection.cmi \ + middle_end/flambda/parameter.cmi \ utils/numbers.cmi \ - middle_end/base_types/mutable_variable.cmi \ + middle_end/flambda/base_types/mutable_variable.cmi \ utils/misc.cmi \ - bytecomp/lambda.cmi \ + lambda/lambda.cmi \ middle_end/internal_variable_names.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/flambda_iterators.cmi \ - middle_end/flambda.cmi \ - middle_end/debuginfo.cmi \ - middle_end/base_types/compilation_unit.cmi \ - middle_end/base_types/closure_origin.cmi \ - middle_end/base_types/closure_id.cmi \ - asmcomp/clambda_primitives.cmi \ - parsing/asttypes.cmi \ - middle_end/allocated_const.cmi \ - middle_end/flambda_utils.cmi -middle_end/flambda_utils.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/var_within_closure.cmx \ - middle_end/base_types/symbol.cmx \ - bytecomp/switch.cmx \ - middle_end/base_types/static_exception.cmx \ - middle_end/base_types/set_of_closures_id.cmx \ - middle_end/projection.cmx \ - middle_end/parameter.cmx \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/flambda_iterators.cmi \ + middle_end/flambda/flambda.cmi \ + lambda/debuginfo.cmi \ + middle_end/compilation_unit.cmi \ + middle_end/flambda/base_types/closure_origin.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ + middle_end/clambda_primitives.cmi \ + parsing/asttypes.cmi \ + middle_end/flambda/allocated_const.cmi \ + middle_end/flambda/flambda_utils.cmi +middle_end/flambda/flambda_utils.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/var_within_closure.cmx \ + middle_end/symbol.cmx \ + lambda/switch.cmx \ + middle_end/flambda/base_types/static_exception.cmx \ + middle_end/flambda/base_types/set_of_closures_id.cmx \ + middle_end/flambda/projection.cmx \ + middle_end/flambda/parameter.cmx \ utils/numbers.cmx \ - middle_end/base_types/mutable_variable.cmx \ + middle_end/flambda/base_types/mutable_variable.cmx \ utils/misc.cmx \ - bytecomp/lambda.cmx \ + lambda/lambda.cmx \ middle_end/internal_variable_names.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/flambda_iterators.cmx \ - middle_end/flambda.cmx \ - middle_end/debuginfo.cmx \ - middle_end/base_types/compilation_unit.cmx \ - middle_end/base_types/closure_origin.cmx \ - middle_end/base_types/closure_id.cmx \ - asmcomp/clambda_primitives.cmx \ - parsing/asttypes.cmi \ - middle_end/allocated_const.cmx \ - middle_end/flambda_utils.cmi -middle_end/flambda_utils.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/base_types/tag.cmi \ - middle_end/base_types/symbol.cmi \ - bytecomp/switch.cmi \ - middle_end/base_types/static_exception.cmi \ - middle_end/base_types/set_of_closures_id.cmi \ - middle_end/projection.cmi \ - middle_end/parameter.cmi \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/flambda_iterators.cmx \ + middle_end/flambda/flambda.cmx \ + lambda/debuginfo.cmx \ + middle_end/compilation_unit.cmx \ + middle_end/flambda/base_types/closure_origin.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ + middle_end/clambda_primitives.cmx \ + parsing/asttypes.cmi \ + middle_end/flambda/allocated_const.cmx \ + middle_end/flambda/flambda_utils.cmi +middle_end/flambda/flambda_utils.cmi : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/flambda/base_types/tag.cmi \ + middle_end/symbol.cmi \ + lambda/switch.cmi \ + middle_end/flambda/base_types/static_exception.cmi \ + middle_end/flambda/base_types/set_of_closures_id.cmi \ + middle_end/flambda/projection.cmi \ + middle_end/flambda/parameter.cmi \ middle_end/internal_variable_names.cmi \ - middle_end/flambda.cmi \ - middle_end/base_types/closure_id.cmi -middle_end/freshening.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/base_types/static_exception.cmi \ - middle_end/projection.cmi \ - middle_end/parameter.cmi \ - middle_end/base_types/mutable_variable.cmi \ - utils/misc.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/base_types/closure_id.cmi +middle_end/flambda/freshening.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/base_types/static_exception.cmi \ + middle_end/flambda/projection.cmi \ + middle_end/flambda/parameter.cmi \ + middle_end/flambda/base_types/mutable_variable.cmi \ + utils/misc.cmi \ + utils/int_replace_polymorphic_compare.cmi \ utils/identifiable.cmi \ - middle_end/flambda_utils.cmi \ - middle_end/flambda_iterators.cmi \ - middle_end/flambda.cmi \ - middle_end/base_types/closure_id.cmi \ - middle_end/freshening.cmi -middle_end/freshening.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/var_within_closure.cmx \ - middle_end/base_types/symbol.cmx \ - middle_end/base_types/static_exception.cmx \ - middle_end/projection.cmx \ - middle_end/parameter.cmx \ - middle_end/base_types/mutable_variable.cmx \ - utils/misc.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/flambda_utils.cmi \ + middle_end/flambda/flambda_iterators.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ + middle_end/flambda/freshening.cmi +middle_end/flambda/freshening.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/var_within_closure.cmx \ + middle_end/symbol.cmx \ + middle_end/flambda/base_types/static_exception.cmx \ + middle_end/flambda/projection.cmx \ + middle_end/flambda/parameter.cmx \ + middle_end/flambda/base_types/mutable_variable.cmx \ + utils/misc.cmx \ + utils/int_replace_polymorphic_compare.cmx \ utils/identifiable.cmx \ - middle_end/flambda_utils.cmx \ - middle_end/flambda_iterators.cmx \ - middle_end/flambda.cmx \ - middle_end/base_types/closure_id.cmx \ - middle_end/freshening.cmi -middle_end/freshening.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/base_types/static_exception.cmi \ - middle_end/base_types/mutable_variable.cmi \ - middle_end/flambda.cmi \ - middle_end/base_types/closure_id.cmi -middle_end/inconstant_idents.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/base_types/set_of_closures_id.cmi \ - middle_end/parameter.cmi \ + middle_end/flambda/flambda_utils.cmx \ + middle_end/flambda/flambda_iterators.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ + middle_end/flambda/freshening.cmi +middle_end/flambda/freshening.cmi : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/base_types/static_exception.cmi \ + middle_end/flambda/base_types/mutable_variable.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/base_types/closure_id.cmi +middle_end/flambda/import_approx.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + middle_end/flambda/base_types/set_of_closures_id.cmi \ + utils/misc.cmi \ + middle_end/flambda/freshening.cmi \ + middle_end/flambda/flambda_iterators.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/export_info.cmi \ + middle_end/flambda/base_types/export_id.cmi \ + middle_end/compilenv.cmi \ + middle_end/compilation_unit.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ + middle_end/flambda/import_approx.cmi +middle_end/flambda/import_approx.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/var_within_closure.cmx \ + middle_end/symbol.cmx \ + middle_end/flambda/simple_value_approx.cmx \ + middle_end/flambda/base_types/set_of_closures_id.cmx \ + utils/misc.cmx \ + middle_end/flambda/freshening.cmx \ + middle_end/flambda/flambda_iterators.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/export_info.cmx \ + middle_end/flambda/base_types/export_id.cmx \ + middle_end/compilenv.cmx \ + middle_end/compilation_unit.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ + middle_end/flambda/import_approx.cmi +middle_end/flambda/import_approx.cmi : \ + middle_end/symbol.cmi \ + middle_end/flambda/simple_value_approx.cmi +middle_end/flambda/inconstant_idents.cmo : \ + middle_end/variable.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/base_types/set_of_closures_id.cmi \ + middle_end/flambda/parameter.cmi \ utils/numbers.cmi \ utils/misc.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ + utils/int_replace_polymorphic_compare.cmi \ utils/identifiable.cmi \ - middle_end/flambda_utils.cmi \ - middle_end/flambda.cmi \ - middle_end/base_types/compilation_unit.cmi \ - middle_end/base_types/closure_id.cmi \ + middle_end/flambda/flambda_utils.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/compilation_unit.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ middle_end/backend_intf.cmi \ parsing/asttypes.cmi \ - middle_end/inconstant_idents.cmi -middle_end/inconstant_idents.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/symbol.cmx \ - middle_end/base_types/set_of_closures_id.cmx \ - middle_end/parameter.cmx \ + middle_end/flambda/inconstant_idents.cmi +middle_end/flambda/inconstant_idents.cmx : \ + middle_end/variable.cmx \ + middle_end/symbol.cmx \ + middle_end/flambda/base_types/set_of_closures_id.cmx \ + middle_end/flambda/parameter.cmx \ utils/numbers.cmx \ utils/misc.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ + utils/int_replace_polymorphic_compare.cmx \ utils/identifiable.cmx \ - middle_end/flambda_utils.cmx \ - middle_end/flambda.cmx \ - middle_end/base_types/compilation_unit.cmx \ - middle_end/base_types/closure_id.cmx \ + middle_end/flambda/flambda_utils.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/compilation_unit.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ middle_end/backend_intf.cmi \ parsing/asttypes.cmi \ - middle_end/inconstant_idents.cmi -middle_end/inconstant_idents.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/set_of_closures_id.cmi \ - middle_end/flambda.cmi \ - middle_end/base_types/compilation_unit.cmi \ + middle_end/flambda/inconstant_idents.cmi +middle_end/flambda/inconstant_idents.cmi : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/set_of_closures_id.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/compilation_unit.cmi \ middle_end/backend_intf.cmi -middle_end/initialize_symbol_to_let_symbol.cmo : \ - middle_end/base_types/variable.cmi \ - utils/misc.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/flambda.cmi \ - middle_end/initialize_symbol_to_let_symbol.cmi -middle_end/initialize_symbol_to_let_symbol.cmx : \ - middle_end/base_types/variable.cmx \ - utils/misc.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/flambda.cmx \ - middle_end/initialize_symbol_to_let_symbol.cmi -middle_end/initialize_symbol_to_let_symbol.cmi : \ - middle_end/flambda.cmi -middle_end/inline_and_simplify.cmo : \ +middle_end/flambda/initialize_symbol_to_let_symbol.cmo : \ + middle_end/variable.cmi \ + utils/misc.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/initialize_symbol_to_let_symbol.cmi +middle_end/flambda/initialize_symbol_to_let_symbol.cmx : \ + middle_end/variable.cmx \ + utils/misc.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/initialize_symbol_to_let_symbol.cmi +middle_end/flambda/initialize_symbol_to_let_symbol.cmi : \ + middle_end/flambda/flambda.cmi +middle_end/flambda/inline_and_simplify.cmo : \ utils/warnings.cmi \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/unbox_specialised_args.cmi \ - middle_end/unbox_free_vars_of_closures.cmi \ - middle_end/unbox_closures.cmi \ - middle_end/base_types/tag.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/base_types/static_exception.cmi \ - middle_end/simplify_primitives.cmi \ - middle_end/simple_value_approx.cmi \ - middle_end/remove_unused_arguments.cmi \ - middle_end/remove_free_vars_equal_to_args.cmi \ - middle_end/projection.cmi \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/flambda/unbox_specialised_args.cmi \ + middle_end/flambda/unbox_free_vars_of_closures.cmi \ + middle_end/flambda/unbox_closures.cmi \ + middle_end/flambda/base_types/tag.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/base_types/static_exception.cmi \ + middle_end/flambda/simplify_primitives.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + middle_end/flambda/remove_unused_arguments.cmi \ + middle_end/flambda/remove_free_vars_equal_to_args.cmi \ + middle_end/flambda/projection.cmi \ typing/predef.cmi \ - middle_end/parameter.cmi \ + middle_end/flambda/parameter.cmi \ utils/misc.cmi \ parsing/location.cmi \ - middle_end/lift_code.cmi \ - bytecomp/lambda.cmi \ - middle_end/invariant_params.cmi \ + middle_end/flambda/lift_code.cmi \ + lambda/lambda.cmi \ + middle_end/flambda/invariant_params.cmi \ middle_end/internal_variable_names.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/inlining_stats.cmi \ - middle_end/inlining_decision.cmi \ - middle_end/inlining_cost.cmi \ - middle_end/inline_and_simplify_aux.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/inlining_stats.cmi \ + middle_end/flambda/inlining_decision.cmi \ + middle_end/flambda/inlining_cost.cmi \ + middle_end/flambda/inline_and_simplify_aux.cmi \ typing/ident.cmi \ - middle_end/freshening.cmi \ - middle_end/flambda_utils.cmi \ - middle_end/flambda.cmi \ - middle_end/find_recursive_functions.cmi \ - middle_end/effect_analysis.cmi \ - middle_end/debuginfo.cmi \ + middle_end/flambda/freshening.cmi \ + middle_end/flambda/flambda_utils.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/find_recursive_functions.cmi \ + middle_end/flambda/effect_analysis.cmi \ + lambda/debuginfo.cmi \ utils/config.cmi \ - middle_end/base_types/closure_origin.cmi \ - middle_end/base_types/closure_id.cmi \ + middle_end/flambda/base_types/closure_origin.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ utils/clflags.cmi \ - asmcomp/clambda_primitives.cmi \ + middle_end/clambda_primitives.cmi \ middle_end/backend_intf.cmi \ - middle_end/allocated_const.cmi \ - middle_end/inline_and_simplify.cmi -middle_end/inline_and_simplify.cmx : \ + middle_end/flambda/allocated_const.cmi \ + middle_end/flambda/inline_and_simplify.cmi +middle_end/flambda/inline_and_simplify.cmx : \ utils/warnings.cmx \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/var_within_closure.cmx \ - middle_end/unbox_specialised_args.cmx \ - middle_end/unbox_free_vars_of_closures.cmx \ - middle_end/unbox_closures.cmx \ - middle_end/base_types/tag.cmx \ - middle_end/base_types/symbol.cmx \ - middle_end/base_types/static_exception.cmx \ - middle_end/simplify_primitives.cmx \ - middle_end/simple_value_approx.cmx \ - middle_end/remove_unused_arguments.cmx \ - middle_end/remove_free_vars_equal_to_args.cmx \ - middle_end/projection.cmx \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/var_within_closure.cmx \ + middle_end/flambda/unbox_specialised_args.cmx \ + middle_end/flambda/unbox_free_vars_of_closures.cmx \ + middle_end/flambda/unbox_closures.cmx \ + middle_end/flambda/base_types/tag.cmx \ + middle_end/symbol.cmx \ + middle_end/flambda/base_types/static_exception.cmx \ + middle_end/flambda/simplify_primitives.cmx \ + middle_end/flambda/simple_value_approx.cmx \ + middle_end/flambda/remove_unused_arguments.cmx \ + middle_end/flambda/remove_free_vars_equal_to_args.cmx \ + middle_end/flambda/projection.cmx \ typing/predef.cmx \ - middle_end/parameter.cmx \ + middle_end/flambda/parameter.cmx \ utils/misc.cmx \ parsing/location.cmx \ - middle_end/lift_code.cmx \ - bytecomp/lambda.cmx \ - middle_end/invariant_params.cmx \ + middle_end/flambda/lift_code.cmx \ + lambda/lambda.cmx \ + middle_end/flambda/invariant_params.cmx \ middle_end/internal_variable_names.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/inlining_stats.cmx \ - middle_end/inlining_decision.cmx \ - middle_end/inlining_cost.cmx \ - middle_end/inline_and_simplify_aux.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/inlining_stats.cmx \ + middle_end/flambda/inlining_decision.cmx \ + middle_end/flambda/inlining_cost.cmx \ + middle_end/flambda/inline_and_simplify_aux.cmx \ typing/ident.cmx \ - middle_end/freshening.cmx \ - middle_end/flambda_utils.cmx \ - middle_end/flambda.cmx \ - middle_end/find_recursive_functions.cmx \ - middle_end/effect_analysis.cmx \ - middle_end/debuginfo.cmx \ + middle_end/flambda/freshening.cmx \ + middle_end/flambda/flambda_utils.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/find_recursive_functions.cmx \ + middle_end/flambda/effect_analysis.cmx \ + lambda/debuginfo.cmx \ utils/config.cmx \ - middle_end/base_types/closure_origin.cmx \ - middle_end/base_types/closure_id.cmx \ + middle_end/flambda/base_types/closure_origin.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ utils/clflags.cmx \ - asmcomp/clambda_primitives.cmx \ + middle_end/clambda_primitives.cmx \ middle_end/backend_intf.cmi \ - middle_end/allocated_const.cmx \ - middle_end/inline_and_simplify.cmi -middle_end/inline_and_simplify.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/inline_and_simplify_aux.cmi \ - middle_end/flambda.cmi \ + middle_end/flambda/allocated_const.cmx \ + middle_end/flambda/inline_and_simplify.cmi +middle_end/flambda/inline_and_simplify.cmi : \ + middle_end/variable.cmi \ + middle_end/flambda/inline_and_simplify_aux.cmi \ + middle_end/flambda/flambda.cmi \ middle_end/backend_intf.cmi -middle_end/inline_and_simplify_aux.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/base_types/static_exception.cmi \ - middle_end/simple_value_approx.cmi \ - middle_end/base_types/set_of_closures_origin.cmi \ - middle_end/projection.cmi \ - middle_end/parameter.cmi \ - middle_end/base_types/mutable_variable.cmi \ - utils/misc.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/inlining_stats.cmi \ - middle_end/inlining_cost.cmi \ - middle_end/freshening.cmi \ - middle_end/flambda_utils.cmi \ - middle_end/flambda.cmi \ - middle_end/debuginfo.cmi \ - middle_end/base_types/compilation_unit.cmi \ - middle_end/base_types/closure_origin.cmi \ - middle_end/base_types/closure_id.cmi \ +middle_end/flambda/inline_and_simplify_aux.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/base_types/static_exception.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + middle_end/flambda/base_types/set_of_closures_origin.cmi \ + middle_end/flambda/projection.cmi \ + middle_end/flambda/parameter.cmi \ + middle_end/flambda/base_types/mutable_variable.cmi \ + utils/misc.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/inlining_stats.cmi \ + middle_end/flambda/inlining_cost.cmi \ + middle_end/flambda/freshening.cmi \ + middle_end/flambda/flambda_utils.cmi \ + middle_end/flambda/flambda.cmi \ + lambda/debuginfo.cmi \ + middle_end/compilation_unit.cmi \ + middle_end/flambda/base_types/closure_origin.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ utils/clflags.cmi \ middle_end/backend_intf.cmi \ - middle_end/inline_and_simplify_aux.cmi -middle_end/inline_and_simplify_aux.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/var_within_closure.cmx \ - middle_end/base_types/symbol.cmx \ - middle_end/base_types/static_exception.cmx \ - middle_end/simple_value_approx.cmx \ - middle_end/base_types/set_of_closures_origin.cmx \ - middle_end/projection.cmx \ - middle_end/parameter.cmx \ - middle_end/base_types/mutable_variable.cmx \ - utils/misc.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/inlining_stats.cmx \ - middle_end/inlining_cost.cmx \ - middle_end/freshening.cmx \ - middle_end/flambda_utils.cmx \ - middle_end/flambda.cmx \ - middle_end/debuginfo.cmx \ - middle_end/base_types/compilation_unit.cmx \ - middle_end/base_types/closure_origin.cmx \ - middle_end/base_types/closure_id.cmx \ + middle_end/flambda/inline_and_simplify_aux.cmi +middle_end/flambda/inline_and_simplify_aux.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/var_within_closure.cmx \ + middle_end/symbol.cmx \ + middle_end/flambda/base_types/static_exception.cmx \ + middle_end/flambda/simple_value_approx.cmx \ + middle_end/flambda/base_types/set_of_closures_origin.cmx \ + middle_end/flambda/projection.cmx \ + middle_end/flambda/parameter.cmx \ + middle_end/flambda/base_types/mutable_variable.cmx \ + utils/misc.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/inlining_stats.cmx \ + middle_end/flambda/inlining_cost.cmx \ + middle_end/flambda/freshening.cmx \ + middle_end/flambda/flambda_utils.cmx \ + middle_end/flambda/flambda.cmx \ + lambda/debuginfo.cmx \ + middle_end/compilation_unit.cmx \ + middle_end/flambda/base_types/closure_origin.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ utils/clflags.cmx \ middle_end/backend_intf.cmi \ - middle_end/inline_and_simplify_aux.cmi -middle_end/inline_and_simplify_aux.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/base_types/static_exception.cmi \ - middle_end/simple_value_approx.cmi \ - middle_end/base_types/set_of_closures_origin.cmi \ - middle_end/projection.cmi \ - middle_end/base_types/mutable_variable.cmi \ - middle_end/inlining_stats_types.cmi \ - middle_end/inlining_cost.cmi \ - middle_end/freshening.cmi \ - middle_end/flambda.cmi \ - middle_end/debuginfo.cmi \ - middle_end/base_types/closure_origin.cmi \ - middle_end/base_types/closure_id.cmi \ + middle_end/flambda/inline_and_simplify_aux.cmi +middle_end/flambda/inline_and_simplify_aux.cmi : \ + middle_end/variable.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/base_types/static_exception.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + middle_end/flambda/base_types/set_of_closures_origin.cmi \ + middle_end/flambda/projection.cmi \ + middle_end/flambda/base_types/mutable_variable.cmi \ + middle_end/flambda/inlining_stats_types.cmi \ + middle_end/flambda/inlining_cost.cmi \ + middle_end/flambda/freshening.cmi \ + middle_end/flambda/flambda.cmi \ + lambda/debuginfo.cmi \ + middle_end/flambda/base_types/closure_origin.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ middle_end/backend_intf.cmi -middle_end/inlining_cost.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/projection.cmi \ +middle_end/flambda/inlining_cost.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/projection.cmi \ typing/primitive.cmi \ utils/misc.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/flambda_iterators.cmi \ - middle_end/flambda.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/flambda_iterators.cmi \ + middle_end/flambda/flambda.cmi \ utils/clflags.cmi \ - asmcomp/clambda_primitives.cmi \ - middle_end/inlining_cost.cmi -middle_end/inlining_cost.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/projection.cmx \ + middle_end/clambda_primitives.cmi \ + middle_end/flambda/inlining_cost.cmi +middle_end/flambda/inlining_cost.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/projection.cmx \ typing/primitive.cmx \ utils/misc.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/flambda_iterators.cmx \ - middle_end/flambda.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/flambda_iterators.cmx \ + middle_end/flambda/flambda.cmx \ utils/clflags.cmx \ - asmcomp/clambda_primitives.cmx \ - middle_end/inlining_cost.cmi -middle_end/inlining_cost.cmi : \ - middle_end/projection.cmi \ - middle_end/flambda.cmi -middle_end/inlining_decision.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/simple_value_approx.cmi \ - middle_end/parameter.cmi \ - utils/misc.cmi \ - bytecomp/lambda.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/inlining_transforms.cmi \ - middle_end/inlining_stats_types.cmi \ - middle_end/inlining_cost.cmi \ - middle_end/inline_and_simplify_aux.cmi \ - middle_end/flambda.cmi \ - middle_end/base_types/closure_id.cmi \ + middle_end/clambda_primitives.cmx \ + middle_end/flambda/inlining_cost.cmi +middle_end/flambda/inlining_cost.cmi : \ + middle_end/flambda/projection.cmi \ + middle_end/flambda/flambda.cmi +middle_end/flambda/inlining_decision.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + middle_end/flambda/parameter.cmi \ + utils/misc.cmi \ + lambda/lambda.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/inlining_transforms.cmi \ + middle_end/flambda/inlining_stats_types.cmi \ + middle_end/flambda/inlining_cost.cmi \ + middle_end/flambda/inline_and_simplify_aux.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ utils/clflags.cmi \ - middle_end/inlining_decision.cmi -middle_end/inlining_decision.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/var_within_closure.cmx \ - middle_end/simple_value_approx.cmx \ - middle_end/parameter.cmx \ - utils/misc.cmx \ - bytecomp/lambda.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/inlining_transforms.cmx \ - middle_end/inlining_stats_types.cmx \ - middle_end/inlining_cost.cmx \ - middle_end/inline_and_simplify_aux.cmx \ - middle_end/flambda.cmx \ - middle_end/base_types/closure_id.cmx \ + middle_end/flambda/inlining_decision.cmi +middle_end/flambda/inlining_decision.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/var_within_closure.cmx \ + middle_end/flambda/simple_value_approx.cmx \ + middle_end/flambda/parameter.cmx \ + utils/misc.cmx \ + lambda/lambda.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/inlining_transforms.cmx \ + middle_end/flambda/inlining_stats_types.cmx \ + middle_end/flambda/inlining_cost.cmx \ + middle_end/flambda/inline_and_simplify_aux.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ utils/clflags.cmx \ - middle_end/inlining_decision.cmi -middle_end/inlining_decision.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/simple_value_approx.cmi \ - bytecomp/lambda.cmi \ - middle_end/inlining_decision_intf.cmi \ - middle_end/inline_and_simplify_aux.cmi \ - middle_end/flambda.cmi \ - middle_end/debuginfo.cmi \ - middle_end/base_types/closure_id.cmi -middle_end/inlining_decision_intf.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/simple_value_approx.cmi \ - middle_end/inline_and_simplify_aux.cmi \ - middle_end/flambda.cmi \ - middle_end/debuginfo.cmi \ - middle_end/base_types/closure_id.cmi -middle_end/inlining_stats.cmo : \ - utils/misc.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/inlining_stats_types.cmi \ - middle_end/debuginfo.cmi \ - middle_end/base_types/closure_id.cmi \ + middle_end/flambda/inlining_decision.cmi +middle_end/flambda/inlining_decision.cmi : \ + middle_end/variable.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + lambda/lambda.cmi \ + middle_end/flambda/inlining_decision_intf.cmi \ + middle_end/flambda/inline_and_simplify_aux.cmi \ + middle_end/flambda/flambda.cmi \ + lambda/debuginfo.cmi \ + middle_end/flambda/base_types/closure_id.cmi +middle_end/flambda/inlining_decision_intf.cmi : \ + middle_end/variable.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + middle_end/flambda/inline_and_simplify_aux.cmi \ + middle_end/flambda/flambda.cmi \ + lambda/debuginfo.cmi \ + middle_end/flambda/base_types/closure_id.cmi +middle_end/flambda/inlining_stats.cmo : \ + utils/misc.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/inlining_stats_types.cmi \ + lambda/debuginfo.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ utils/clflags.cmi \ - middle_end/inlining_stats.cmi -middle_end/inlining_stats.cmx : \ + middle_end/flambda/inlining_stats.cmi +middle_end/flambda/inlining_stats.cmx : \ utils/misc.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/inlining_stats_types.cmx \ - middle_end/debuginfo.cmx \ - middle_end/base_types/closure_id.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/inlining_stats_types.cmx \ + lambda/debuginfo.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ utils/clflags.cmx \ - middle_end/inlining_stats.cmi -middle_end/inlining_stats.cmi : \ - middle_end/inlining_stats_types.cmi \ - middle_end/debuginfo.cmi \ - middle_end/base_types/closure_id.cmi -middle_end/inlining_stats_types.cmo : \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/inlining_cost.cmi \ - middle_end/inlining_stats_types.cmi -middle_end/inlining_stats_types.cmx : \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/inlining_cost.cmx \ - middle_end/inlining_stats_types.cmi -middle_end/inlining_stats_types.cmi : \ - middle_end/inlining_cost.cmi -middle_end/inlining_transforms.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/simple_value_approx.cmi \ - middle_end/projection.cmi \ - middle_end/parameter.cmi \ - bytecomp/lambda.cmi \ + middle_end/flambda/inlining_stats.cmi +middle_end/flambda/inlining_stats.cmi : \ + middle_end/flambda/inlining_stats_types.cmi \ + lambda/debuginfo.cmi \ + middle_end/flambda/base_types/closure_id.cmi +middle_end/flambda/inlining_stats_types.cmo : \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/inlining_cost.cmi \ + middle_end/flambda/inlining_stats_types.cmi +middle_end/flambda/inlining_stats_types.cmx : \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/inlining_cost.cmx \ + middle_end/flambda/inlining_stats_types.cmi +middle_end/flambda/inlining_stats_types.cmi : \ + middle_end/flambda/inlining_cost.cmi +middle_end/flambda/inlining_transforms.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + middle_end/flambda/projection.cmi \ + middle_end/flambda/parameter.cmi \ + lambda/lambda.cmi \ middle_end/internal_variable_names.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/inlining_decision_intf.cmi \ - middle_end/inlining_cost.cmi \ - middle_end/inline_and_simplify_aux.cmi \ - middle_end/flambda_utils.cmi \ - middle_end/flambda_iterators.cmi \ - middle_end/flambda.cmi \ - middle_end/debuginfo.cmi \ - middle_end/base_types/compilation_unit.cmi \ - middle_end/base_types/closure_origin.cmi \ - middle_end/base_types/closure_id.cmi \ - middle_end/inlining_transforms.cmi -middle_end/inlining_transforms.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/var_within_closure.cmx \ - middle_end/simple_value_approx.cmx \ - middle_end/projection.cmx \ - middle_end/parameter.cmx \ - bytecomp/lambda.cmx \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/inlining_decision_intf.cmi \ + middle_end/flambda/inlining_cost.cmi \ + middle_end/flambda/inline_and_simplify_aux.cmi \ + middle_end/flambda/flambda_utils.cmi \ + middle_end/flambda/flambda_iterators.cmi \ + middle_end/flambda/flambda.cmi \ + lambda/debuginfo.cmi \ + middle_end/compilation_unit.cmi \ + middle_end/flambda/base_types/closure_origin.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ + middle_end/flambda/inlining_transforms.cmi +middle_end/flambda/inlining_transforms.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/var_within_closure.cmx \ + middle_end/flambda/simple_value_approx.cmx \ + middle_end/flambda/projection.cmx \ + middle_end/flambda/parameter.cmx \ + lambda/lambda.cmx \ middle_end/internal_variable_names.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/inlining_decision_intf.cmi \ - middle_end/inlining_cost.cmx \ - middle_end/inline_and_simplify_aux.cmx \ - middle_end/flambda_utils.cmx \ - middle_end/flambda_iterators.cmx \ - middle_end/flambda.cmx \ - middle_end/debuginfo.cmx \ - middle_end/base_types/compilation_unit.cmx \ - middle_end/base_types/closure_origin.cmx \ - middle_end/base_types/closure_id.cmx \ - middle_end/inlining_transforms.cmi -middle_end/inlining_transforms.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/simple_value_approx.cmi \ - bytecomp/lambda.cmi \ - middle_end/inlining_decision_intf.cmi \ - middle_end/inline_and_simplify_aux.cmi \ - middle_end/flambda.cmi \ - middle_end/debuginfo.cmi \ - middle_end/base_types/closure_id.cmi -middle_end/int_replace_polymorphic_compare.cmo : \ - middle_end/int_replace_polymorphic_compare.cmi -middle_end/int_replace_polymorphic_compare.cmx : \ - middle_end/int_replace_polymorphic_compare.cmi -middle_end/int_replace_polymorphic_compare.cmi : -middle_end/internal_variable_names.cmo : \ - parsing/location.cmi \ - bytecomp/lambda.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/internal_variable_names.cmi -middle_end/internal_variable_names.cmx : \ - parsing/location.cmx \ - bytecomp/lambda.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/internal_variable_names.cmi -middle_end/internal_variable_names.cmi : \ - parsing/location.cmi \ - bytecomp/lambda.cmi -middle_end/invariant_params.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/parameter.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/flambda_utils.cmi \ - middle_end/flambda_iterators.cmi \ - middle_end/flambda.cmi \ - middle_end/base_types/closure_id.cmi \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/inlining_decision_intf.cmi \ + middle_end/flambda/inlining_cost.cmx \ + middle_end/flambda/inline_and_simplify_aux.cmx \ + middle_end/flambda/flambda_utils.cmx \ + middle_end/flambda/flambda_iterators.cmx \ + middle_end/flambda/flambda.cmx \ + lambda/debuginfo.cmx \ + middle_end/compilation_unit.cmx \ + middle_end/flambda/base_types/closure_origin.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ + middle_end/flambda/inlining_transforms.cmi +middle_end/flambda/inlining_transforms.cmi : \ + middle_end/variable.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + lambda/lambda.cmi \ + middle_end/flambda/inlining_decision_intf.cmi \ + middle_end/flambda/inline_and_simplify_aux.cmi \ + middle_end/flambda/flambda.cmi \ + lambda/debuginfo.cmi \ + middle_end/flambda/base_types/closure_id.cmi +middle_end/flambda/invariant_params.cmo : \ + middle_end/variable.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/parameter.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/flambda_utils.cmi \ + middle_end/flambda/flambda_iterators.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ utils/clflags.cmi \ middle_end/backend_intf.cmi \ - middle_end/invariant_params.cmi -middle_end/invariant_params.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/symbol.cmx \ - middle_end/parameter.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/flambda_utils.cmx \ - middle_end/flambda_iterators.cmx \ - middle_end/flambda.cmx \ - middle_end/base_types/closure_id.cmx \ + middle_end/flambda/invariant_params.cmi +middle_end/flambda/invariant_params.cmx : \ + middle_end/variable.cmx \ + middle_end/symbol.cmx \ + middle_end/flambda/parameter.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/flambda_utils.cmx \ + middle_end/flambda/flambda_iterators.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ utils/clflags.cmx \ middle_end/backend_intf.cmi \ - middle_end/invariant_params.cmi -middle_end/invariant_params.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/flambda.cmi \ + middle_end/flambda/invariant_params.cmi +middle_end/flambda/invariant_params.cmi : \ + middle_end/variable.cmi \ + middle_end/flambda/flambda.cmi \ middle_end/backend_intf.cmi -middle_end/lift_code.cmo : \ - middle_end/base_types/variable.cmi \ +middle_end/flambda/lift_code.cmo : \ + middle_end/variable.cmi \ utils/strongly_connected_components.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/flambda_iterators.cmi \ - middle_end/flambda.cmi \ - middle_end/base_types/compilation_unit.cmi \ - middle_end/lift_code.cmi -middle_end/lift_code.cmx : \ - middle_end/base_types/variable.cmx \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/flambda_iterators.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/compilation_unit.cmi \ + middle_end/flambda/lift_code.cmi +middle_end/flambda/lift_code.cmx : \ + middle_end/variable.cmx \ utils/strongly_connected_components.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/flambda_iterators.cmx \ - middle_end/flambda.cmx \ - middle_end/base_types/compilation_unit.cmx \ - middle_end/lift_code.cmi -middle_end/lift_code.cmi : \ - middle_end/base_types/variable.cmi \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/flambda_iterators.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/compilation_unit.cmx \ + middle_end/flambda/lift_code.cmi +middle_end/flambda/lift_code.cmi : \ + middle_end/variable.cmi \ middle_end/internal_variable_names.cmi \ - middle_end/flambda.cmi -middle_end/lift_constants.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/base_types/tag.cmi \ - middle_end/base_types/symbol.cmi \ + middle_end/flambda/flambda.cmi +middle_end/flambda/lift_constants.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/flambda/base_types/tag.cmi \ + middle_end/symbol.cmi \ utils/strongly_connected_components.cmi \ - middle_end/simple_value_approx.cmi \ + middle_end/flambda/simple_value_approx.cmi \ utils/misc.cmi \ middle_end/internal_variable_names.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/inconstant_idents.cmi \ - middle_end/flambda_utils.cmi \ - middle_end/flambda_iterators.cmi \ - middle_end/flambda.cmi \ - middle_end/base_types/compilation_unit.cmi \ - middle_end/base_types/closure_id.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/inconstant_idents.cmi \ + middle_end/flambda/flambda_utils.cmi \ + middle_end/flambda/flambda_iterators.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/compilation_unit.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ middle_end/backend_intf.cmi \ parsing/asttypes.cmi \ - middle_end/allocated_const.cmi \ - middle_end/alias_analysis.cmi \ - middle_end/lift_constants.cmi -middle_end/lift_constants.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/var_within_closure.cmx \ - middle_end/base_types/tag.cmx \ - middle_end/base_types/symbol.cmx \ + middle_end/flambda/allocated_const.cmi \ + middle_end/flambda/alias_analysis.cmi \ + middle_end/flambda/lift_constants.cmi +middle_end/flambda/lift_constants.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/var_within_closure.cmx \ + middle_end/flambda/base_types/tag.cmx \ + middle_end/symbol.cmx \ utils/strongly_connected_components.cmx \ - middle_end/simple_value_approx.cmx \ + middle_end/flambda/simple_value_approx.cmx \ utils/misc.cmx \ middle_end/internal_variable_names.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/inconstant_idents.cmx \ - middle_end/flambda_utils.cmx \ - middle_end/flambda_iterators.cmx \ - middle_end/flambda.cmx \ - middle_end/base_types/compilation_unit.cmx \ - middle_end/base_types/closure_id.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/inconstant_idents.cmx \ + middle_end/flambda/flambda_utils.cmx \ + middle_end/flambda/flambda_iterators.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/compilation_unit.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ middle_end/backend_intf.cmi \ parsing/asttypes.cmi \ - middle_end/allocated_const.cmx \ - middle_end/alias_analysis.cmx \ - middle_end/lift_constants.cmi -middle_end/lift_constants.cmi : \ - middle_end/flambda.cmi \ + middle_end/flambda/allocated_const.cmx \ + middle_end/flambda/alias_analysis.cmx \ + middle_end/flambda/lift_constants.cmi +middle_end/flambda/lift_constants.cmi : \ + middle_end/flambda/flambda.cmi \ middle_end/backend_intf.cmi -middle_end/lift_let_to_initialize_symbol.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/tag.cmi \ - middle_end/base_types/symbol.cmi \ +middle_end/flambda/lift_let_to_initialize_symbol.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/tag.cmi \ + middle_end/symbol.cmi \ middle_end/internal_variable_names.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/flambda_utils.cmi \ - middle_end/flambda.cmi \ - middle_end/debuginfo.cmi \ - parsing/asttypes.cmi \ - middle_end/lift_let_to_initialize_symbol.cmi -middle_end/lift_let_to_initialize_symbol.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/tag.cmx \ - middle_end/base_types/symbol.cmx \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/flambda_utils.cmi \ + middle_end/flambda/flambda.cmi \ + lambda/debuginfo.cmi \ + parsing/asttypes.cmi \ + middle_end/flambda/lift_let_to_initialize_symbol.cmi +middle_end/flambda/lift_let_to_initialize_symbol.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/tag.cmx \ + middle_end/symbol.cmx \ middle_end/internal_variable_names.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/flambda_utils.cmx \ - middle_end/flambda.cmx \ - middle_end/debuginfo.cmx \ - parsing/asttypes.cmi \ - middle_end/lift_let_to_initialize_symbol.cmi -middle_end/lift_let_to_initialize_symbol.cmi : \ - middle_end/flambda.cmi \ - middle_end/backend_intf.cmi -middle_end/middle_end.cmo : \ - utils/warnings.cmi \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/share_constants.cmi \ - middle_end/remove_unused_program_constructs.cmi \ - middle_end/remove_unused_closure_vars.cmi \ - middle_end/ref_to_variables.cmi \ - utils/profile.cmi \ - utils/misc.cmi \ - parsing/location.cmi \ - middle_end/lift_let_to_initialize_symbol.cmi \ - middle_end/lift_constants.cmi \ - middle_end/lift_code.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/inlining_cost.cmi \ - middle_end/inline_and_simplify.cmi \ - middle_end/initialize_symbol_to_let_symbol.cmi \ - middle_end/flambda_iterators.cmi \ - middle_end/flambda_invariants.cmi \ - middle_end/flambda.cmi \ - middle_end/debuginfo.cmi \ - middle_end/base_types/closure_id.cmi \ - middle_end/closure_conversion.cmi \ - utils/clflags.cmi \ - middle_end/backend_intf.cmi \ - middle_end/middle_end.cmi -middle_end/middle_end.cmx : \ - utils/warnings.cmx \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/symbol.cmx \ - middle_end/share_constants.cmx \ - middle_end/remove_unused_program_constructs.cmx \ - middle_end/remove_unused_closure_vars.cmx \ - middle_end/ref_to_variables.cmx \ - utils/profile.cmx \ - utils/misc.cmx \ - parsing/location.cmx \ - middle_end/lift_let_to_initialize_symbol.cmx \ - middle_end/lift_constants.cmx \ - middle_end/lift_code.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/inlining_cost.cmx \ - middle_end/inline_and_simplify.cmx \ - middle_end/initialize_symbol_to_let_symbol.cmx \ - middle_end/flambda_iterators.cmx \ - middle_end/flambda_invariants.cmx \ - middle_end/flambda.cmx \ - middle_end/debuginfo.cmx \ - middle_end/base_types/closure_id.cmx \ - middle_end/closure_conversion.cmx \ - utils/clflags.cmx \ - middle_end/backend_intf.cmi \ - middle_end/middle_end.cmi -middle_end/middle_end.cmi : \ - bytecomp/lambda.cmi \ - typing/ident.cmi \ - middle_end/flambda.cmi \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/flambda_utils.cmx \ + middle_end/flambda/flambda.cmx \ + lambda/debuginfo.cmx \ + parsing/asttypes.cmi \ + middle_end/flambda/lift_let_to_initialize_symbol.cmi +middle_end/flambda/lift_let_to_initialize_symbol.cmi : \ + middle_end/flambda/flambda.cmi \ middle_end/backend_intf.cmi -middle_end/parameter.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ +middle_end/flambda/parameter.cmo : \ + middle_end/variable.cmi \ + utils/int_replace_polymorphic_compare.cmi \ utils/identifiable.cmi \ - middle_end/parameter.cmi -middle_end/parameter.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/parameter.cmi +middle_end/flambda/parameter.cmx : \ + middle_end/variable.cmx \ + utils/int_replace_polymorphic_compare.cmx \ utils/identifiable.cmx \ - middle_end/parameter.cmi -middle_end/parameter.cmi : \ - middle_end/base_types/variable.cmi \ + middle_end/flambda/parameter.cmi +middle_end/flambda/parameter.cmi : \ + middle_end/variable.cmi \ utils/identifiable.cmi \ - middle_end/base_types/compilation_unit.cmi -middle_end/pass_wrapper.cmo : \ - middle_end/int_replace_polymorphic_compare.cmi \ + middle_end/compilation_unit.cmi +middle_end/flambda/pass_wrapper.cmo : \ + utils/int_replace_polymorphic_compare.cmi \ utils/clflags.cmi \ - middle_end/pass_wrapper.cmi -middle_end/pass_wrapper.cmx : \ - middle_end/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/pass_wrapper.cmi +middle_end/flambda/pass_wrapper.cmx : \ + utils/int_replace_polymorphic_compare.cmx \ utils/clflags.cmx \ - middle_end/pass_wrapper.cmi -middle_end/pass_wrapper.cmi : -middle_end/projection.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/pass_wrapper.cmi +middle_end/flambda/pass_wrapper.cmi : +middle_end/flambda/projection.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + utils/int_replace_polymorphic_compare.cmi \ utils/identifiable.cmi \ - middle_end/base_types/closure_id.cmi \ - middle_end/projection.cmi -middle_end/projection.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/var_within_closure.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/base_types/closure_id.cmi \ + middle_end/flambda/projection.cmi +middle_end/flambda/projection.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/var_within_closure.cmx \ + utils/int_replace_polymorphic_compare.cmx \ utils/identifiable.cmx \ - middle_end/base_types/closure_id.cmx \ - middle_end/projection.cmi -middle_end/projection.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ + middle_end/flambda/base_types/closure_id.cmx \ + middle_end/flambda/projection.cmi +middle_end/flambda/projection.cmi : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ utils/identifiable.cmi \ - middle_end/base_types/closure_id.cmi -middle_end/ref_to_variables.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/mutable_variable.cmi \ + middle_end/flambda/base_types/closure_id.cmi +middle_end/flambda/ref_to_variables.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/mutable_variable.cmi \ utils/misc.cmi \ - bytecomp/lambda.cmi \ + lambda/lambda.cmi \ middle_end/internal_variable_names.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/flambda_iterators.cmi \ - middle_end/flambda.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/flambda_iterators.cmi \ + middle_end/flambda/flambda.cmi \ parsing/asttypes.cmi \ - middle_end/ref_to_variables.cmi -middle_end/ref_to_variables.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/mutable_variable.cmx \ + middle_end/flambda/ref_to_variables.cmi +middle_end/flambda/ref_to_variables.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/mutable_variable.cmx \ utils/misc.cmx \ - bytecomp/lambda.cmx \ + lambda/lambda.cmx \ middle_end/internal_variable_names.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/flambda_iterators.cmx \ - middle_end/flambda.cmx \ - parsing/asttypes.cmi \ - middle_end/ref_to_variables.cmi -middle_end/ref_to_variables.cmi : \ - middle_end/flambda.cmi -middle_end/remove_free_vars_equal_to_args.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/pass_wrapper.cmi \ - middle_end/parameter.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/flambda_utils.cmi \ - middle_end/flambda.cmi \ - middle_end/remove_free_vars_equal_to_args.cmi -middle_end/remove_free_vars_equal_to_args.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/pass_wrapper.cmx \ - middle_end/parameter.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/flambda_utils.cmx \ - middle_end/flambda.cmx \ - middle_end/remove_free_vars_equal_to_args.cmi -middle_end/remove_free_vars_equal_to_args.cmi : \ - middle_end/flambda.cmi -middle_end/remove_unused_arguments.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/projection.cmi \ - middle_end/parameter.cmi \ - middle_end/invariant_params.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/flambda_utils.cmi \ - middle_end/flambda_iterators.cmi \ - middle_end/flambda.cmi \ - middle_end/find_recursive_functions.cmi \ - middle_end/base_types/compilation_unit.cmi \ - middle_end/base_types/closure_origin.cmi \ - middle_end/base_types/closure_id.cmi \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/flambda_iterators.cmx \ + middle_end/flambda/flambda.cmx \ + parsing/asttypes.cmi \ + middle_end/flambda/ref_to_variables.cmi +middle_end/flambda/ref_to_variables.cmi : \ + middle_end/flambda/flambda.cmi +middle_end/flambda/remove_free_vars_equal_to_args.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/pass_wrapper.cmi \ + middle_end/flambda/parameter.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/flambda_utils.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/remove_free_vars_equal_to_args.cmi +middle_end/flambda/remove_free_vars_equal_to_args.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/pass_wrapper.cmx \ + middle_end/flambda/parameter.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/flambda_utils.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/remove_free_vars_equal_to_args.cmi +middle_end/flambda/remove_free_vars_equal_to_args.cmi : \ + middle_end/flambda/flambda.cmi +middle_end/flambda/remove_unused_arguments.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/projection.cmi \ + middle_end/flambda/parameter.cmi \ + middle_end/flambda/invariant_params.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/flambda_utils.cmi \ + middle_end/flambda/flambda_iterators.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/find_recursive_functions.cmi \ + middle_end/compilation_unit.cmi \ + middle_end/flambda/base_types/closure_origin.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ utils/clflags.cmi \ - middle_end/remove_unused_arguments.cmi -middle_end/remove_unused_arguments.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/projection.cmx \ - middle_end/parameter.cmx \ - middle_end/invariant_params.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/flambda_utils.cmx \ - middle_end/flambda_iterators.cmx \ - middle_end/flambda.cmx \ - middle_end/find_recursive_functions.cmx \ - middle_end/base_types/compilation_unit.cmx \ - middle_end/base_types/closure_origin.cmx \ - middle_end/base_types/closure_id.cmx \ + middle_end/flambda/remove_unused_arguments.cmi +middle_end/flambda/remove_unused_arguments.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/projection.cmx \ + middle_end/flambda/parameter.cmx \ + middle_end/flambda/invariant_params.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/flambda_utils.cmx \ + middle_end/flambda/flambda_iterators.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/find_recursive_functions.cmx \ + middle_end/compilation_unit.cmx \ + middle_end/flambda/base_types/closure_origin.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ utils/clflags.cmx \ - middle_end/remove_unused_arguments.cmi -middle_end/remove_unused_arguments.cmi : \ - middle_end/flambda.cmi \ + middle_end/flambda/remove_unused_arguments.cmi +middle_end/flambda/remove_unused_arguments.cmi : \ + middle_end/flambda/flambda.cmi \ middle_end/backend_intf.cmi -middle_end/remove_unused_closure_vars.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/parameter.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/flambda_utils.cmi \ - middle_end/flambda_iterators.cmi \ - middle_end/flambda.cmi \ - middle_end/base_types/closure_id.cmi \ - middle_end/remove_unused_closure_vars.cmi -middle_end/remove_unused_closure_vars.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/var_within_closure.cmx \ - middle_end/parameter.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/flambda_utils.cmx \ - middle_end/flambda_iterators.cmx \ - middle_end/flambda.cmx \ - middle_end/base_types/closure_id.cmx \ - middle_end/remove_unused_closure_vars.cmi -middle_end/remove_unused_closure_vars.cmi : \ - middle_end/flambda.cmi -middle_end/remove_unused_program_constructs.cmo : \ - middle_end/base_types/symbol.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/flambda.cmi \ - middle_end/effect_analysis.cmi \ - middle_end/remove_unused_program_constructs.cmi -middle_end/remove_unused_program_constructs.cmx : \ - middle_end/base_types/symbol.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/flambda.cmx \ - middle_end/effect_analysis.cmx \ - middle_end/remove_unused_program_constructs.cmi -middle_end/remove_unused_program_constructs.cmi : \ - middle_end/flambda.cmi -middle_end/share_constants.cmo : \ - middle_end/base_types/symbol.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/flambda_iterators.cmi \ - middle_end/flambda.cmi \ - middle_end/share_constants.cmi -middle_end/share_constants.cmx : \ - middle_end/base_types/symbol.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/flambda_iterators.cmx \ - middle_end/flambda.cmx \ - middle_end/share_constants.cmi -middle_end/share_constants.cmi : \ - middle_end/flambda.cmi -middle_end/simple_value_approx.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/base_types/tag.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/base_types/set_of_closures_origin.cmi \ - middle_end/base_types/set_of_closures_id.cmi \ - middle_end/parameter.cmi \ - utils/misc.cmi \ - bytecomp/lambda.cmi \ +middle_end/flambda/remove_unused_closure_vars.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/flambda/parameter.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/flambda_utils.cmi \ + middle_end/flambda/flambda_iterators.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ + middle_end/flambda/remove_unused_closure_vars.cmi +middle_end/flambda/remove_unused_closure_vars.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/var_within_closure.cmx \ + middle_end/flambda/parameter.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/flambda_utils.cmx \ + middle_end/flambda/flambda_iterators.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ + middle_end/flambda/remove_unused_closure_vars.cmi +middle_end/flambda/remove_unused_closure_vars.cmi : \ + middle_end/flambda/flambda.cmi +middle_end/flambda/remove_unused_program_constructs.cmo : \ + middle_end/symbol.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/effect_analysis.cmi \ + middle_end/flambda/remove_unused_program_constructs.cmi +middle_end/flambda/remove_unused_program_constructs.cmx : \ + middle_end/symbol.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/effect_analysis.cmx \ + middle_end/flambda/remove_unused_program_constructs.cmi +middle_end/flambda/remove_unused_program_constructs.cmi : \ + middle_end/flambda/flambda.cmi +middle_end/flambda/share_constants.cmo : \ + middle_end/symbol.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/flambda_iterators.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/share_constants.cmi +middle_end/flambda/share_constants.cmx : \ + middle_end/symbol.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/flambda_iterators.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/share_constants.cmi +middle_end/flambda/share_constants.cmi : \ + middle_end/flambda/flambda.cmi +middle_end/flambda/simple_value_approx.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/flambda/base_types/tag.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/base_types/set_of_closures_origin.cmi \ + middle_end/flambda/base_types/set_of_closures_id.cmi \ + middle_end/flambda/parameter.cmi \ + utils/misc.cmi \ + lambda/lambda.cmi \ middle_end/internal_variable_names.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/inlining_cost.cmi \ - middle_end/freshening.cmi \ - middle_end/flambda_utils.cmi \ - middle_end/flambda.cmi \ - middle_end/base_types/export_id.cmi \ - middle_end/effect_analysis.cmi \ - middle_end/debuginfo.cmi \ - middle_end/base_types/compilation_unit.cmi \ - middle_end/base_types/closure_origin.cmi \ - middle_end/base_types/closure_id.cmi \ - middle_end/allocated_const.cmi \ - middle_end/simple_value_approx.cmi -middle_end/simple_value_approx.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/base_types/var_within_closure.cmx \ - middle_end/base_types/tag.cmx \ - middle_end/base_types/symbol.cmx \ - middle_end/base_types/set_of_closures_origin.cmx \ - middle_end/base_types/set_of_closures_id.cmx \ - middle_end/parameter.cmx \ - utils/misc.cmx \ - bytecomp/lambda.cmx \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/inlining_cost.cmi \ + middle_end/flambda/freshening.cmi \ + middle_end/flambda/flambda_utils.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/base_types/export_id.cmi \ + middle_end/flambda/effect_analysis.cmi \ + lambda/debuginfo.cmi \ + middle_end/compilation_unit.cmi \ + middle_end/flambda/base_types/closure_origin.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ + middle_end/flambda/allocated_const.cmi \ + middle_end/flambda/simple_value_approx.cmi +middle_end/flambda/simple_value_approx.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/var_within_closure.cmx \ + middle_end/flambda/base_types/tag.cmx \ + middle_end/symbol.cmx \ + middle_end/flambda/base_types/set_of_closures_origin.cmx \ + middle_end/flambda/base_types/set_of_closures_id.cmx \ + middle_end/flambda/parameter.cmx \ + utils/misc.cmx \ + lambda/lambda.cmx \ middle_end/internal_variable_names.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/inlining_cost.cmx \ - middle_end/freshening.cmx \ - middle_end/flambda_utils.cmx \ - middle_end/flambda.cmx \ - middle_end/base_types/export_id.cmx \ - middle_end/effect_analysis.cmx \ - middle_end/debuginfo.cmx \ - middle_end/base_types/compilation_unit.cmx \ - middle_end/base_types/closure_origin.cmx \ - middle_end/base_types/closure_id.cmx \ - middle_end/allocated_const.cmx \ - middle_end/simple_value_approx.cmi -middle_end/simple_value_approx.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/var_within_closure.cmi \ - middle_end/base_types/tag.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/base_types/set_of_closures_origin.cmi \ - middle_end/base_types/set_of_closures_id.cmi \ - middle_end/parameter.cmi \ - bytecomp/lambda.cmi \ - middle_end/freshening.cmi \ - middle_end/flambda.cmi \ - middle_end/base_types/export_id.cmi \ - middle_end/debuginfo.cmi \ - middle_end/base_types/closure_origin.cmi \ - middle_end/base_types/closure_id.cmi -middle_end/simplify_boxed_integer_ops.cmo : \ - middle_end/simplify_common.cmi \ - middle_end/simplify_boxed_integer_ops_intf.cmi \ - middle_end/simple_value_approx.cmi \ - bytecomp/lambda.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/inlining_cost.cmi \ - asmcomp/clambda_primitives.cmi \ - middle_end/simplify_boxed_integer_ops.cmi -middle_end/simplify_boxed_integer_ops.cmx : \ - middle_end/simplify_common.cmx \ - middle_end/simplify_boxed_integer_ops_intf.cmi \ - middle_end/simple_value_approx.cmx \ - bytecomp/lambda.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/inlining_cost.cmx \ - asmcomp/clambda_primitives.cmx \ - middle_end/simplify_boxed_integer_ops.cmi -middle_end/simplify_boxed_integer_ops.cmi : \ - middle_end/simplify_boxed_integer_ops_intf.cmi -middle_end/simplify_boxed_integer_ops_intf.cmi : \ - middle_end/simple_value_approx.cmi \ - middle_end/inlining_cost.cmi \ - middle_end/flambda.cmi \ - asmcomp/clambda_primitives.cmi -middle_end/simplify_common.cmo : \ - middle_end/simple_value_approx.cmi \ - bytecomp/lambda.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/inlining_cost.cmi \ - middle_end/effect_analysis.cmi \ - middle_end/simplify_common.cmi -middle_end/simplify_common.cmx : \ - middle_end/simple_value_approx.cmx \ - bytecomp/lambda.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/inlining_cost.cmx \ - middle_end/effect_analysis.cmx \ - middle_end/simplify_common.cmi -middle_end/simplify_common.cmi : \ - middle_end/simple_value_approx.cmi \ - bytecomp/lambda.cmi \ - middle_end/inlining_cost.cmi \ - middle_end/flambda.cmi -middle_end/simplify_primitives.cmo : \ - middle_end/base_types/tag.cmi \ - middle_end/base_types/symbol.cmi \ - middle_end/simplify_common.cmi \ - middle_end/simplify_boxed_integer_ops.cmi \ - middle_end/simple_value_approx.cmi \ - asmcomp/semantics_of_primitives.cmi \ - utils/misc.cmi \ - bytecomp/lambda.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/inlining_cost.cmi \ - middle_end/flambda.cmi \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/inlining_cost.cmx \ + middle_end/flambda/freshening.cmx \ + middle_end/flambda/flambda_utils.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/base_types/export_id.cmx \ + middle_end/flambda/effect_analysis.cmx \ + lambda/debuginfo.cmx \ + middle_end/compilation_unit.cmx \ + middle_end/flambda/base_types/closure_origin.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ + middle_end/flambda/allocated_const.cmx \ + middle_end/flambda/simple_value_approx.cmi +middle_end/flambda/simple_value_approx.cmi : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/flambda/base_types/tag.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/base_types/set_of_closures_origin.cmi \ + middle_end/flambda/base_types/set_of_closures_id.cmi \ + middle_end/flambda/parameter.cmi \ + lambda/lambda.cmi \ + middle_end/flambda/freshening.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/base_types/export_id.cmi \ + lambda/debuginfo.cmi \ + middle_end/flambda/base_types/closure_origin.cmi \ + middle_end/flambda/base_types/closure_id.cmi +middle_end/flambda/simplify_boxed_integer_ops.cmo : \ + middle_end/flambda/simplify_common.cmi \ + middle_end/flambda/simplify_boxed_integer_ops_intf.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + lambda/lambda.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/inlining_cost.cmi \ + middle_end/clambda_primitives.cmi \ + middle_end/flambda/simplify_boxed_integer_ops.cmi +middle_end/flambda/simplify_boxed_integer_ops.cmx : \ + middle_end/flambda/simplify_common.cmx \ + middle_end/flambda/simplify_boxed_integer_ops_intf.cmi \ + middle_end/flambda/simple_value_approx.cmx \ + lambda/lambda.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/inlining_cost.cmx \ + middle_end/clambda_primitives.cmx \ + middle_end/flambda/simplify_boxed_integer_ops.cmi +middle_end/flambda/simplify_boxed_integer_ops.cmi : \ + middle_end/flambda/simplify_boxed_integer_ops_intf.cmi +middle_end/flambda/simplify_boxed_integer_ops_intf.cmi : \ + middle_end/flambda/simple_value_approx.cmi \ + middle_end/flambda/inlining_cost.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/clambda_primitives.cmi +middle_end/flambda/simplify_common.cmo : \ + middle_end/flambda/simple_value_approx.cmi \ + lambda/lambda.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/inlining_cost.cmi \ + middle_end/flambda/effect_analysis.cmi \ + middle_end/flambda/simplify_common.cmi +middle_end/flambda/simplify_common.cmx : \ + middle_end/flambda/simple_value_approx.cmx \ + lambda/lambda.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/inlining_cost.cmx \ + middle_end/flambda/effect_analysis.cmx \ + middle_end/flambda/simplify_common.cmi +middle_end/flambda/simplify_common.cmi : \ + middle_end/flambda/simple_value_approx.cmi \ + lambda/lambda.cmi \ + middle_end/flambda/inlining_cost.cmi \ + middle_end/flambda/flambda.cmi +middle_end/flambda/simplify_primitives.cmo : \ + middle_end/flambda/base_types/tag.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/simplify_common.cmi \ + middle_end/flambda/simplify_boxed_integer_ops.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + middle_end/semantics_of_primitives.cmi \ + utils/misc.cmi \ + lambda/lambda.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/inlining_cost.cmi \ + middle_end/flambda/flambda.cmi \ utils/clflags.cmi \ - asmcomp/clambda_primitives.cmi \ - parsing/asttypes.cmi \ - middle_end/simplify_primitives.cmi -middle_end/simplify_primitives.cmx : \ - middle_end/base_types/tag.cmx \ - middle_end/base_types/symbol.cmx \ - middle_end/simplify_common.cmx \ - middle_end/simplify_boxed_integer_ops.cmx \ - middle_end/simple_value_approx.cmx \ - asmcomp/semantics_of_primitives.cmx \ - utils/misc.cmx \ - bytecomp/lambda.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/inlining_cost.cmx \ - middle_end/flambda.cmx \ + middle_end/clambda_primitives.cmi \ + parsing/asttypes.cmi \ + middle_end/flambda/simplify_primitives.cmi +middle_end/flambda/simplify_primitives.cmx : \ + middle_end/flambda/base_types/tag.cmx \ + middle_end/symbol.cmx \ + middle_end/flambda/simplify_common.cmx \ + middle_end/flambda/simplify_boxed_integer_ops.cmx \ + middle_end/flambda/simple_value_approx.cmx \ + middle_end/semantics_of_primitives.cmx \ + utils/misc.cmx \ + lambda/lambda.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/inlining_cost.cmx \ + middle_end/flambda/flambda.cmx \ utils/clflags.cmx \ - asmcomp/clambda_primitives.cmx \ - parsing/asttypes.cmi \ - middle_end/simplify_primitives.cmi -middle_end/simplify_primitives.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/simple_value_approx.cmi \ - middle_end/inlining_cost.cmi \ - middle_end/flambda.cmi \ - middle_end/debuginfo.cmi \ - asmcomp/clambda_primitives.cmi -middle_end/unbox_closures.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/inlining_cost.cmi \ - middle_end/inline_and_simplify_aux.cmi \ - middle_end/flambda_utils.cmi \ - middle_end/flambda_iterators.cmi \ - middle_end/flambda.cmi \ - middle_end/base_types/closure_id.cmi \ + middle_end/clambda_primitives.cmx \ + parsing/asttypes.cmi \ + middle_end/flambda/simplify_primitives.cmi +middle_end/flambda/simplify_primitives.cmi : \ + middle_end/variable.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + middle_end/flambda/inlining_cost.cmi \ + middle_end/flambda/flambda.cmi \ + lambda/debuginfo.cmi \ + middle_end/clambda_primitives.cmi +middle_end/flambda/traverse_for_exported_symbols.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + middle_end/flambda/base_types/set_of_closures_id.cmi \ + utils/misc.cmi \ + middle_end/flambda/flambda_iterators.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/export_info.cmi \ + middle_end/flambda/base_types/export_id.cmi \ + middle_end/compilation_unit.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ + middle_end/flambda/traverse_for_exported_symbols.cmi +middle_end/flambda/traverse_for_exported_symbols.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/base_types/var_within_closure.cmx \ + middle_end/symbol.cmx \ + middle_end/flambda/simple_value_approx.cmx \ + middle_end/flambda/base_types/set_of_closures_id.cmx \ + utils/misc.cmx \ + middle_end/flambda/flambda_iterators.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/export_info.cmx \ + middle_end/flambda/base_types/export_id.cmx \ + middle_end/compilation_unit.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ + middle_end/flambda/traverse_for_exported_symbols.cmi +middle_end/flambda/traverse_for_exported_symbols.cmi : \ + middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/symbol.cmi \ + middle_end/flambda/simple_value_approx.cmi \ + middle_end/flambda/base_types/set_of_closures_id.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/export_info.cmi \ + middle_end/flambda/base_types/export_id.cmi \ + middle_end/flambda/base_types/closure_id.cmi +middle_end/flambda/un_anf.cmo : \ + middle_end/semantics_of_primitives.cmi \ + middle_end/printclambda.cmi \ + utils/misc.cmi \ + lambda/lambda.cmi \ + lambda/debuginfo.cmi \ utils/clflags.cmi \ - middle_end/augment_specialised_args.cmi \ - middle_end/unbox_closures.cmi -middle_end/unbox_closures.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/inlining_cost.cmx \ - middle_end/inline_and_simplify_aux.cmx \ - middle_end/flambda_utils.cmx \ - middle_end/flambda_iterators.cmx \ - middle_end/flambda.cmx \ - middle_end/base_types/closure_id.cmx \ + middle_end/clambda_primitives.cmi \ + middle_end/clambda.cmi \ + middle_end/backend_var.cmi \ + parsing/asttypes.cmi \ + middle_end/flambda/un_anf.cmi +middle_end/flambda/un_anf.cmx : \ + middle_end/semantics_of_primitives.cmx \ + middle_end/printclambda.cmx \ + utils/misc.cmx \ + lambda/lambda.cmx \ + lambda/debuginfo.cmx \ + utils/clflags.cmx \ + middle_end/clambda_primitives.cmx \ + middle_end/clambda.cmx \ + middle_end/backend_var.cmx \ + parsing/asttypes.cmi \ + middle_end/flambda/un_anf.cmi +middle_end/flambda/un_anf.cmi : \ + middle_end/clambda.cmi +middle_end/flambda/unbox_closures.cmo : \ + middle_end/variable.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/inlining_cost.cmi \ + middle_end/flambda/inline_and_simplify_aux.cmi \ + middle_end/flambda/flambda_utils.cmi \ + middle_end/flambda/flambda_iterators.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ + utils/clflags.cmi \ + middle_end/flambda/augment_specialised_args.cmi \ + middle_end/flambda/unbox_closures.cmi +middle_end/flambda/unbox_closures.cmx : \ + middle_end/variable.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/inlining_cost.cmx \ + middle_end/flambda/inline_and_simplify_aux.cmx \ + middle_end/flambda/flambda_utils.cmx \ + middle_end/flambda/flambda_iterators.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ utils/clflags.cmx \ - middle_end/augment_specialised_args.cmx \ - middle_end/unbox_closures.cmi -middle_end/unbox_closures.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/inlining_cost.cmi \ - middle_end/inline_and_simplify_aux.cmi \ - middle_end/flambda.cmi -middle_end/unbox_free_vars_of_closures.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/projection.cmi \ - middle_end/pass_wrapper.cmi \ + middle_end/flambda/augment_specialised_args.cmx \ + middle_end/flambda/unbox_closures.cmi +middle_end/flambda/unbox_closures.cmi : \ + middle_end/variable.cmi \ + middle_end/flambda/inlining_cost.cmi \ + middle_end/flambda/inline_and_simplify_aux.cmi \ + middle_end/flambda/flambda.cmi +middle_end/flambda/unbox_free_vars_of_closures.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/projection.cmi \ + middle_end/flambda/pass_wrapper.cmi \ utils/misc.cmi \ middle_end/internal_variable_names.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/inlining_cost.cmi \ - middle_end/inline_and_simplify_aux.cmi \ - middle_end/flambda_utils.cmi \ - middle_end/flambda_iterators.cmi \ - middle_end/flambda.cmi \ - middle_end/extract_projections.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/inlining_cost.cmi \ + middle_end/flambda/inline_and_simplify_aux.cmi \ + middle_end/flambda/flambda_utils.cmi \ + middle_end/flambda/flambda_iterators.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/extract_projections.cmi \ utils/clflags.cmi \ - middle_end/unbox_free_vars_of_closures.cmi -middle_end/unbox_free_vars_of_closures.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/projection.cmx \ - middle_end/pass_wrapper.cmx \ + middle_end/flambda/unbox_free_vars_of_closures.cmi +middle_end/flambda/unbox_free_vars_of_closures.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/projection.cmx \ + middle_end/flambda/pass_wrapper.cmx \ utils/misc.cmx \ middle_end/internal_variable_names.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/inlining_cost.cmx \ - middle_end/inline_and_simplify_aux.cmx \ - middle_end/flambda_utils.cmx \ - middle_end/flambda_iterators.cmx \ - middle_end/flambda.cmx \ - middle_end/extract_projections.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/inlining_cost.cmx \ + middle_end/flambda/inline_and_simplify_aux.cmx \ + middle_end/flambda/flambda_utils.cmx \ + middle_end/flambda/flambda_iterators.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/extract_projections.cmx \ utils/clflags.cmx \ - middle_end/unbox_free_vars_of_closures.cmi -middle_end/unbox_free_vars_of_closures.cmi : \ - middle_end/inlining_cost.cmi \ - middle_end/inline_and_simplify_aux.cmi \ - middle_end/flambda.cmi -middle_end/unbox_specialised_args.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/projection.cmi \ - middle_end/invariant_params.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/inline_and_simplify_aux.cmi \ - middle_end/flambda.cmi \ - middle_end/extract_projections.cmi \ + middle_end/flambda/unbox_free_vars_of_closures.cmi +middle_end/flambda/unbox_free_vars_of_closures.cmi : \ + middle_end/flambda/inlining_cost.cmi \ + middle_end/flambda/inline_and_simplify_aux.cmi \ + middle_end/flambda/flambda.cmi +middle_end/flambda/unbox_specialised_args.cmo : \ + middle_end/variable.cmi \ + middle_end/flambda/projection.cmi \ + middle_end/flambda/invariant_params.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/inline_and_simplify_aux.cmi \ + middle_end/flambda/flambda.cmi \ + middle_end/flambda/extract_projections.cmi \ utils/clflags.cmi \ - middle_end/augment_specialised_args.cmi \ - middle_end/unbox_specialised_args.cmi -middle_end/unbox_specialised_args.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/projection.cmx \ - middle_end/invariant_params.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/inline_and_simplify_aux.cmx \ - middle_end/flambda.cmx \ - middle_end/extract_projections.cmx \ + middle_end/flambda/augment_specialised_args.cmi \ + middle_end/flambda/unbox_specialised_args.cmi +middle_end/flambda/unbox_specialised_args.cmx : \ + middle_end/variable.cmx \ + middle_end/flambda/projection.cmx \ + middle_end/flambda/invariant_params.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/inline_and_simplify_aux.cmx \ + middle_end/flambda/flambda.cmx \ + middle_end/flambda/extract_projections.cmx \ utils/clflags.cmx \ - middle_end/augment_specialised_args.cmx \ - middle_end/unbox_specialised_args.cmi -middle_end/unbox_specialised_args.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/inlining_cost.cmi \ - middle_end/inline_and_simplify_aux.cmi \ - middle_end/flambda.cmi -middle_end/base_types/closure_element.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/base_types/closure_element.cmi -middle_end/base_types/closure_element.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/base_types/closure_element.cmi -middle_end/base_types/closure_element.cmi : \ - middle_end/base_types/variable.cmi \ + middle_end/flambda/augment_specialised_args.cmx \ + middle_end/flambda/unbox_specialised_args.cmi +middle_end/flambda/unbox_specialised_args.cmi : \ + middle_end/variable.cmi \ + middle_end/flambda/inlining_cost.cmi \ + middle_end/flambda/inline_and_simplify_aux.cmi \ + middle_end/flambda/flambda.cmi +middle_end/flambda/base_types/closure_element.cmo : \ + middle_end/variable.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/base_types/closure_element.cmi +middle_end/flambda/base_types/closure_element.cmx : \ + middle_end/variable.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/base_types/closure_element.cmi +middle_end/flambda/base_types/closure_element.cmi : \ + middle_end/variable.cmi \ utils/identifiable.cmi \ - middle_end/base_types/compilation_unit.cmi -middle_end/base_types/closure_id.cmo : \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/base_types/closure_element.cmi \ - middle_end/base_types/closure_id.cmi -middle_end/base_types/closure_id.cmx : \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/base_types/closure_element.cmx \ - middle_end/base_types/closure_id.cmi -middle_end/base_types/closure_id.cmi : \ - middle_end/base_types/closure_element.cmi -middle_end/base_types/closure_origin.cmo : \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/base_types/closure_id.cmi \ - middle_end/base_types/closure_origin.cmi -middle_end/base_types/closure_origin.cmx : \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/base_types/closure_id.cmx \ - middle_end/base_types/closure_origin.cmi -middle_end/base_types/closure_origin.cmi : \ - utils/identifiable.cmi \ - middle_end/base_types/compilation_unit.cmi \ - middle_end/base_types/closure_id.cmi -middle_end/base_types/compilation_unit.cmo : \ - utils/misc.cmi \ - middle_end/base_types/linkage_name.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - utils/identifiable.cmi \ - typing/ident.cmi \ - middle_end/base_types/compilation_unit.cmi -middle_end/base_types/compilation_unit.cmx : \ - utils/misc.cmx \ - middle_end/base_types/linkage_name.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - utils/identifiable.cmx \ - typing/ident.cmx \ - middle_end/base_types/compilation_unit.cmi -middle_end/base_types/compilation_unit.cmi : \ - middle_end/base_types/linkage_name.cmi \ + middle_end/compilation_unit.cmi +middle_end/flambda/base_types/closure_id.cmo : \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/base_types/closure_element.cmi \ + middle_end/flambda/base_types/closure_id.cmi +middle_end/flambda/base_types/closure_id.cmx : \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/base_types/closure_element.cmx \ + middle_end/flambda/base_types/closure_id.cmi +middle_end/flambda/base_types/closure_id.cmi : \ + middle_end/flambda/base_types/closure_element.cmi +middle_end/flambda/base_types/closure_origin.cmo : \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/base_types/closure_id.cmi \ + middle_end/flambda/base_types/closure_origin.cmi +middle_end/flambda/base_types/closure_origin.cmx : \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/base_types/closure_id.cmx \ + middle_end/flambda/base_types/closure_origin.cmi +middle_end/flambda/base_types/closure_origin.cmi : \ utils/identifiable.cmi \ - typing/ident.cmi -middle_end/base_types/export_id.cmo : \ - middle_end/int_replace_polymorphic_compare.cmi \ + middle_end/compilation_unit.cmi \ + middle_end/flambda/base_types/closure_id.cmi +middle_end/flambda/base_types/export_id.cmo : \ + utils/int_replace_polymorphic_compare.cmi \ utils/identifiable.cmi \ - middle_end/base_types/id_types.cmi \ - middle_end/base_types/compilation_unit.cmi \ - middle_end/base_types/export_id.cmi -middle_end/base_types/export_id.cmx : \ - middle_end/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/base_types/id_types.cmi \ + middle_end/compilation_unit.cmi \ + middle_end/flambda/base_types/export_id.cmi +middle_end/flambda/base_types/export_id.cmx : \ + utils/int_replace_polymorphic_compare.cmx \ utils/identifiable.cmx \ - middle_end/base_types/id_types.cmx \ - middle_end/base_types/compilation_unit.cmx \ - middle_end/base_types/export_id.cmi -middle_end/base_types/export_id.cmi : \ + middle_end/flambda/base_types/id_types.cmx \ + middle_end/compilation_unit.cmx \ + middle_end/flambda/base_types/export_id.cmi +middle_end/flambda/base_types/export_id.cmi : \ utils/identifiable.cmi \ - middle_end/base_types/compilation_unit.cmi -middle_end/base_types/id_types.cmo : \ - middle_end/int_replace_polymorphic_compare.cmi \ + middle_end/compilation_unit.cmi +middle_end/flambda/base_types/id_types.cmo : \ + utils/int_replace_polymorphic_compare.cmi \ utils/identifiable.cmi \ - middle_end/base_types/id_types.cmi -middle_end/base_types/id_types.cmx : \ - middle_end/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/base_types/id_types.cmi +middle_end/flambda/base_types/id_types.cmx : \ + utils/int_replace_polymorphic_compare.cmx \ utils/identifiable.cmx \ - middle_end/base_types/id_types.cmi -middle_end/base_types/id_types.cmi : \ + middle_end/flambda/base_types/id_types.cmi +middle_end/flambda/base_types/id_types.cmi : \ utils/identifiable.cmi -middle_end/base_types/linkage_name.cmo : \ - middle_end/int_replace_polymorphic_compare.cmi \ - utils/identifiable.cmi \ - middle_end/base_types/linkage_name.cmi -middle_end/base_types/linkage_name.cmx : \ - middle_end/int_replace_polymorphic_compare.cmx \ - utils/identifiable.cmx \ - middle_end/base_types/linkage_name.cmi -middle_end/base_types/linkage_name.cmi : \ - utils/identifiable.cmi -middle_end/base_types/mutable_variable.cmo : \ - middle_end/base_types/variable.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/base_types/mutable_variable.cmi -middle_end/base_types/mutable_variable.cmx : \ - middle_end/base_types/variable.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/base_types/mutable_variable.cmi -middle_end/base_types/mutable_variable.cmi : \ - middle_end/base_types/variable.cmi \ +middle_end/flambda/base_types/mutable_variable.cmo : \ + middle_end/variable.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/base_types/mutable_variable.cmi +middle_end/flambda/base_types/mutable_variable.cmx : \ + middle_end/variable.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/base_types/mutable_variable.cmi +middle_end/flambda/base_types/mutable_variable.cmi : \ + middle_end/variable.cmi \ middle_end/internal_variable_names.cmi \ utils/identifiable.cmi \ typing/ident.cmi \ - middle_end/base_types/compilation_unit.cmi -middle_end/base_types/set_of_closures_id.cmo : \ - middle_end/int_replace_polymorphic_compare.cmi \ + middle_end/compilation_unit.cmi +middle_end/flambda/base_types/set_of_closures_id.cmo : \ + utils/int_replace_polymorphic_compare.cmi \ utils/identifiable.cmi \ - middle_end/base_types/id_types.cmi \ - middle_end/base_types/compilation_unit.cmi \ - middle_end/base_types/set_of_closures_id.cmi -middle_end/base_types/set_of_closures_id.cmx : \ - middle_end/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/base_types/id_types.cmi \ + middle_end/compilation_unit.cmi \ + middle_end/flambda/base_types/set_of_closures_id.cmi +middle_end/flambda/base_types/set_of_closures_id.cmx : \ + utils/int_replace_polymorphic_compare.cmx \ utils/identifiable.cmx \ - middle_end/base_types/id_types.cmx \ - middle_end/base_types/compilation_unit.cmx \ - middle_end/base_types/set_of_closures_id.cmi -middle_end/base_types/set_of_closures_id.cmi : \ + middle_end/flambda/base_types/id_types.cmx \ + middle_end/compilation_unit.cmx \ + middle_end/flambda/base_types/set_of_closures_id.cmi +middle_end/flambda/base_types/set_of_closures_id.cmi : \ utils/identifiable.cmi \ - middle_end/base_types/compilation_unit.cmi -middle_end/base_types/set_of_closures_origin.cmo : \ - middle_end/base_types/set_of_closures_id.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/base_types/set_of_closures_origin.cmi -middle_end/base_types/set_of_closures_origin.cmx : \ - middle_end/base_types/set_of_closures_id.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/base_types/set_of_closures_origin.cmi -middle_end/base_types/set_of_closures_origin.cmi : \ - middle_end/base_types/set_of_closures_id.cmi \ + middle_end/compilation_unit.cmi +middle_end/flambda/base_types/set_of_closures_origin.cmo : \ + middle_end/flambda/base_types/set_of_closures_id.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/base_types/set_of_closures_origin.cmi +middle_end/flambda/base_types/set_of_closures_origin.cmx : \ + middle_end/flambda/base_types/set_of_closures_id.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/base_types/set_of_closures_origin.cmi +middle_end/flambda/base_types/set_of_closures_origin.cmi : \ + middle_end/flambda/base_types/set_of_closures_id.cmi \ utils/identifiable.cmi \ - middle_end/base_types/compilation_unit.cmi -middle_end/base_types/static_exception.cmo : \ + middle_end/compilation_unit.cmi +middle_end/flambda/base_types/static_exception.cmo : \ utils/numbers.cmi \ - bytecomp/lambda.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/base_types/static_exception.cmi -middle_end/base_types/static_exception.cmx : \ + lambda/lambda.cmi \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/base_types/static_exception.cmi +middle_end/flambda/base_types/static_exception.cmx : \ utils/numbers.cmx \ - bytecomp/lambda.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/base_types/static_exception.cmi -middle_end/base_types/static_exception.cmi : \ + lambda/lambda.cmx \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/base_types/static_exception.cmi +middle_end/flambda/base_types/static_exception.cmi : \ utils/identifiable.cmi -middle_end/base_types/symbol.cmo : \ - middle_end/base_types/variable.cmi \ - utils/misc.cmi \ - middle_end/base_types/linkage_name.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - utils/identifiable.cmi \ - middle_end/base_types/compilation_unit.cmi \ - middle_end/base_types/symbol.cmi -middle_end/base_types/symbol.cmx : \ - middle_end/base_types/variable.cmx \ - utils/misc.cmx \ - middle_end/base_types/linkage_name.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - utils/identifiable.cmx \ - middle_end/base_types/compilation_unit.cmx \ - middle_end/base_types/symbol.cmi -middle_end/base_types/symbol.cmi : \ - middle_end/base_types/variable.cmi \ - middle_end/base_types/linkage_name.cmi \ - utils/identifiable.cmi \ - middle_end/base_types/compilation_unit.cmi -middle_end/base_types/tag.cmo : \ +middle_end/flambda/base_types/tag.cmo : \ utils/numbers.cmi \ utils/misc.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ + utils/int_replace_polymorphic_compare.cmi \ utils/identifiable.cmi \ - middle_end/base_types/tag.cmi -middle_end/base_types/tag.cmx : \ + middle_end/flambda/base_types/tag.cmi +middle_end/flambda/base_types/tag.cmx : \ utils/numbers.cmx \ utils/misc.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ + utils/int_replace_polymorphic_compare.cmx \ utils/identifiable.cmx \ - middle_end/base_types/tag.cmi -middle_end/base_types/tag.cmi : \ + middle_end/flambda/base_types/tag.cmi +middle_end/flambda/base_types/tag.cmi : \ utils/identifiable.cmi -middle_end/base_types/var_within_closure.cmo : \ - middle_end/int_replace_polymorphic_compare.cmi \ - middle_end/base_types/closure_element.cmi \ - middle_end/base_types/var_within_closure.cmi -middle_end/base_types/var_within_closure.cmx : \ - middle_end/int_replace_polymorphic_compare.cmx \ - middle_end/base_types/closure_element.cmx \ - middle_end/base_types/var_within_closure.cmi -middle_end/base_types/var_within_closure.cmi : \ - middle_end/base_types/closure_element.cmi -middle_end/base_types/variable.cmo : \ - utils/misc.cmi \ - middle_end/internal_variable_names.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ - utils/identifiable.cmi \ - typing/ident.cmi \ - middle_end/base_types/compilation_unit.cmi \ - middle_end/base_types/variable.cmi -middle_end/base_types/variable.cmx : \ - utils/misc.cmx \ - middle_end/internal_variable_names.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ - utils/identifiable.cmx \ - typing/ident.cmx \ - middle_end/base_types/compilation_unit.cmx \ - middle_end/base_types/variable.cmi -middle_end/base_types/variable.cmi : \ - middle_end/internal_variable_names.cmi \ - utils/identifiable.cmi \ - typing/ident.cmi \ - middle_end/base_types/compilation_unit.cmi +middle_end/flambda/base_types/var_within_closure.cmo : \ + utils/int_replace_polymorphic_compare.cmi \ + middle_end/flambda/base_types/closure_element.cmi \ + middle_end/flambda/base_types/var_within_closure.cmi +middle_end/flambda/base_types/var_within_closure.cmx : \ + utils/int_replace_polymorphic_compare.cmx \ + middle_end/flambda/base_types/closure_element.cmx \ + middle_end/flambda/base_types/var_within_closure.cmi +middle_end/flambda/base_types/var_within_closure.cmi : \ + middle_end/flambda/base_types/closure_element.cmi asmcomp/debug/available_regs.cmo : \ asmcomp/debug/reg_with_debug_info.cmi \ asmcomp/debug/reg_availability_set.cmi \ @@ -5413,7 +5414,7 @@ asmcomp/debug/available_regs.cmo : \ utils/misc.cmi \ asmcomp/mach.cmi \ utils/clflags.cmi \ - asmcomp/backend_var.cmi \ + middle_end/backend_var.cmi \ asmcomp/debug/available_regs.cmi asmcomp/debug/available_regs.cmx : \ asmcomp/debug/reg_with_debug_info.cmx \ @@ -5424,7 +5425,7 @@ asmcomp/debug/available_regs.cmx : \ utils/misc.cmx \ asmcomp/mach.cmx \ utils/clflags.cmx \ - asmcomp/backend_var.cmx \ + middle_end/backend_var.cmx \ asmcomp/debug/available_regs.cmi asmcomp/debug/available_regs.cmi : \ asmcomp/mach.cmi @@ -5433,7 +5434,7 @@ asmcomp/debug/compute_ranges.cmo : \ utils/numbers.cmi \ utils/misc.cmi \ asmcomp/linearize.cmi \ - middle_end/int_replace_polymorphic_compare.cmi \ + utils/int_replace_polymorphic_compare.cmi \ asmcomp/debug/compute_ranges_intf.cmo \ asmcomp/cmm.cmi \ asmcomp/debug/compute_ranges.cmi @@ -5442,7 +5443,7 @@ asmcomp/debug/compute_ranges.cmx : \ utils/numbers.cmx \ utils/misc.cmx \ asmcomp/linearize.cmx \ - middle_end/int_replace_polymorphic_compare.cmx \ + utils/int_replace_polymorphic_compare.cmx \ asmcomp/debug/compute_ranges_intf.cmx \ asmcomp/cmm.cmx \ asmcomp/debug/compute_ranges.cmi @@ -5458,26 +5459,26 @@ asmcomp/debug/compute_ranges_intf.cmx : \ utils/identifiable.cmx asmcomp/debug/reg_availability_set.cmo : \ asmcomp/debug/reg_with_debug_info.cmi \ - asmcomp/backend_var.cmi \ + middle_end/backend_var.cmi \ asmcomp/debug/reg_availability_set.cmi asmcomp/debug/reg_availability_set.cmx : \ asmcomp/debug/reg_with_debug_info.cmx \ - asmcomp/backend_var.cmx \ + middle_end/backend_var.cmx \ asmcomp/debug/reg_availability_set.cmi asmcomp/debug/reg_availability_set.cmi : \ asmcomp/debug/reg_with_debug_info.cmi \ asmcomp/reg.cmi asmcomp/debug/reg_with_debug_info.cmo : \ asmcomp/reg.cmi \ - asmcomp/backend_var.cmi \ + middle_end/backend_var.cmi \ asmcomp/debug/reg_with_debug_info.cmi asmcomp/debug/reg_with_debug_info.cmx : \ asmcomp/reg.cmx \ - asmcomp/backend_var.cmx \ + middle_end/backend_var.cmx \ asmcomp/debug/reg_with_debug_info.cmi asmcomp/debug/reg_with_debug_info.cmi : \ asmcomp/reg.cmi \ - asmcomp/backend_var.cmi + middle_end/backend_var.cmi driver/compenv.cmo : \ utils/warnings.cmi \ utils/profile.cmi \ @@ -5498,26 +5499,26 @@ driver/compenv.cmx : \ driver/compenv.cmi driver/compenv.cmi : driver/compile.cmo : \ - bytecomp/translmod.cmi \ - bytecomp/simplif.cmi \ + lambda/translmod.cmi \ + lambda/simplif.cmi \ utils/profile.cmi \ - bytecomp/printlambda.cmi \ + lambda/printlambda.cmi \ bytecomp/printinstr.cmi \ utils/misc.cmi \ - bytecomp/lambda.cmi \ + lambda/lambda.cmi \ bytecomp/emitcode.cmi \ driver/compile_common.cmi \ utils/clflags.cmi \ bytecomp/bytegen.cmi \ driver/compile.cmi driver/compile.cmx : \ - bytecomp/translmod.cmx \ - bytecomp/simplif.cmx \ + lambda/translmod.cmx \ + lambda/simplif.cmx \ utils/profile.cmx \ - bytecomp/printlambda.cmx \ + lambda/printlambda.cmx \ bytecomp/printinstr.cmx \ utils/misc.cmx \ - bytecomp/lambda.cmx \ + lambda/lambda.cmx \ bytecomp/emitcode.cmx \ driver/compile_common.cmx \ utils/clflags.cmx \ @@ -5684,29 +5685,29 @@ driver/makedepend.cmx : \ driver/makedepend.cmi driver/makedepend.cmi : driver/optcompile.cmo : \ - bytecomp/translmod.cmi \ - bytecomp/simplif.cmi \ + lambda/translmod.cmi \ + lambda/simplif.cmi \ utils/profile.cmi \ - bytecomp/printlambda.cmi \ + lambda/printlambda.cmi \ utils/misc.cmi \ - middle_end/middle_end.cmi \ - bytecomp/lambda.cmi \ + lambda/lambda.cmi \ + middle_end/flambda/flambda_middle_end.cmi \ utils/config.cmi \ - asmcomp/compilenv.cmi \ + middle_end/compilenv.cmi \ driver/compile_common.cmi \ utils/clflags.cmi \ asmcomp/asmgen.cmi \ driver/optcompile.cmi driver/optcompile.cmx : \ - bytecomp/translmod.cmx \ - bytecomp/simplif.cmx \ + lambda/translmod.cmx \ + lambda/simplif.cmx \ utils/profile.cmx \ - bytecomp/printlambda.cmx \ + lambda/printlambda.cmx \ utils/misc.cmx \ - middle_end/middle_end.cmx \ - bytecomp/lambda.cmx \ + lambda/lambda.cmx \ + middle_end/flambda/flambda_middle_end.cmx \ utils/config.cmx \ - asmcomp/compilenv.cmx \ + middle_end/compilenv.cmx \ driver/compile_common.cmx \ utils/clflags.cmx \ asmcomp/asmgen.cmx \ @@ -5732,10 +5733,10 @@ driver/optmain.cmo : \ driver/makedepend.cmi \ driver/main_args.cmi \ parsing/location.cmi \ - asmcomp/import_approx.cmi \ + middle_end/flambda/import_approx.cmi \ utils/config.cmi \ driver/compmisc.cmi \ - asmcomp/compilenv.cmi \ + middle_end/compilenv.cmi \ driver/compenv.cmi \ utils/clflags.cmi \ middle_end/backend_intf.cmi \ @@ -5754,10 +5755,10 @@ driver/optmain.cmx : \ driver/makedepend.cmx \ driver/main_args.cmx \ parsing/location.cmx \ - asmcomp/import_approx.cmx \ + middle_end/flambda/import_approx.cmx \ utils/config.cmx \ driver/compmisc.cmx \ - asmcomp/compilenv.cmx \ + middle_end/compilenv.cmx \ driver/compenv.cmx \ utils/clflags.cmx \ middle_end/backend_intf.cmi \ @@ -5797,13 +5798,13 @@ driver/pparse.cmi : \ parsing/parsetree.cmi toplevel/expunge.cmo : \ bytecomp/symtable.cmi \ - bytecomp/runtimedef.cmi \ + lambda/runtimedef.cmi \ utils/misc.cmi \ typing/ident.cmi \ bytecomp/bytesections.cmi toplevel/expunge.cmx : \ bytecomp/symtable.cmx \ - bytecomp/runtimedef.cmx \ + lambda/runtimedef.cmx \ utils/misc.cmx \ typing/ident.cmx \ bytecomp/bytesections.cmx @@ -5880,12 +5881,12 @@ toplevel/opttoploop.cmo : \ typing/typemod.cmi \ typing/typedtree.cmi \ typing/typecore.cmi \ - bytecomp/translmod.cmi \ - bytecomp/simplif.cmi \ + lambda/translmod.cmi \ + lambda/simplif.cmi \ asmcomp/proc.cmi \ typing/printtyped.cmi \ typing/printtyp.cmi \ - bytecomp/printlambda.cmi \ + lambda/printlambda.cmi \ parsing/printast.cmi \ typing/predef.cmi \ parsing/pprintast.cmi \ @@ -5896,20 +5897,20 @@ toplevel/opttoploop.cmo : \ typing/outcometree.cmi \ typing/oprint.cmi \ utils/misc.cmi \ - middle_end/middle_end.cmi \ parsing/longident.cmi \ parsing/location.cmi \ utils/load_path.cmi \ parsing/lexer.cmi \ - bytecomp/lambda.cmi \ + lambda/lambda.cmi \ typing/includemod.cmi \ - asmcomp/import_approx.cmi \ + middle_end/flambda/import_approx.cmi \ typing/ident.cmi \ toplevel/genprintval.cmi \ + middle_end/flambda/flambda_middle_end.cmi \ typing/env.cmi \ utils/config.cmi \ driver/compmisc.cmi \ - asmcomp/compilenv.cmi \ + middle_end/compilenv.cmi \ driver/compenv.cmi \ utils/clflags.cmi \ typing/btype.cmi \ @@ -5926,12 +5927,12 @@ toplevel/opttoploop.cmx : \ typing/typemod.cmx \ typing/typedtree.cmx \ typing/typecore.cmx \ - bytecomp/translmod.cmx \ - bytecomp/simplif.cmx \ + lambda/translmod.cmx \ + lambda/simplif.cmx \ asmcomp/proc.cmx \ typing/printtyped.cmx \ typing/printtyp.cmx \ - bytecomp/printlambda.cmx \ + lambda/printlambda.cmx \ parsing/printast.cmx \ typing/predef.cmx \ parsing/pprintast.cmx \ @@ -5942,20 +5943,20 @@ toplevel/opttoploop.cmx : \ typing/outcometree.cmi \ typing/oprint.cmx \ utils/misc.cmx \ - middle_end/middle_end.cmx \ parsing/longident.cmx \ parsing/location.cmx \ utils/load_path.cmx \ parsing/lexer.cmx \ - bytecomp/lambda.cmx \ + lambda/lambda.cmx \ typing/includemod.cmx \ - asmcomp/import_approx.cmx \ + middle_end/flambda/import_approx.cmx \ typing/ident.cmx \ toplevel/genprintval.cmx \ + middle_end/flambda/flambda_middle_end.cmx \ typing/env.cmx \ utils/config.cmx \ driver/compmisc.cmx \ - asmcomp/compilenv.cmx \ + middle_end/compilenv.cmx \ driver/compenv.cmx \ utils/clflags.cmx \ typing/btype.cmx \ @@ -6027,7 +6028,7 @@ toplevel/topdirs.cmo : \ bytecomp/dll.cmi \ typing/ctype.cmi \ utils/config.cmi \ - bytecomp/cmo_format.cmi \ + file_formats/cmo_format.cmi \ utils/clflags.cmi \ typing/btype.cmi \ parsing/asttypes.cmi \ @@ -6056,7 +6057,7 @@ toplevel/topdirs.cmx : \ bytecomp/dll.cmx \ typing/ctype.cmx \ utils/config.cmx \ - bytecomp/cmo_format.cmi \ + file_formats/cmo_format.cmi \ utils/clflags.cmx \ typing/btype.cmx \ parsing/asttypes.cmi \ @@ -6071,12 +6072,12 @@ toplevel/toploop.cmo : \ typing/typemod.cmi \ typing/typedtree.cmi \ typing/typecore.cmi \ - bytecomp/translmod.cmi \ + lambda/translmod.cmi \ bytecomp/symtable.cmi \ - bytecomp/simplif.cmi \ + lambda/simplif.cmi \ typing/printtyped.cmi \ typing/printtyp.cmi \ - bytecomp/printlambda.cmi \ + lambda/printlambda.cmi \ bytecomp/printinstr.cmi \ parsing/printast.cmi \ typing/predef.cmi \ @@ -6115,12 +6116,12 @@ toplevel/toploop.cmx : \ typing/typemod.cmx \ typing/typedtree.cmx \ typing/typecore.cmx \ - bytecomp/translmod.cmx \ + lambda/translmod.cmx \ bytecomp/symtable.cmx \ - bytecomp/simplif.cmx \ + lambda/simplif.cmx \ typing/printtyped.cmx \ typing/printtyp.cmx \ - bytecomp/printlambda.cmx \ + lambda/printlambda.cmx \ bytecomp/printinstr.cmx \ parsing/printast.cmx \ typing/predef.cmx \ diff --git a/Changes b/Changes index 062c959c55..fc38092af3 100644 --- a/Changes +++ b/Changes @@ -73,6 +73,9 @@ Working version - #2280: Don't make more Clambda constants after starting Cmmgen (Mark Shinwell, review by Vincent Laviron) +- #2281: Move some middle-end files around + (Mark Shinwell) + - #2283: Add [is_prefix] and [find_and_chop_longest_common_prefix] to [Misc.Stdlib.List] (Mark Shinwell, review by Alain Frisch and Stephen Dolan) diff --git a/Makefile b/Makefile index 1b6d2ff077..efc5b9d1d7 100644 --- a/Makefile +++ b/Makefile @@ -46,8 +46,10 @@ include stdlib/StdlibModules CAMLC=$(BOOT_OCAMLC) -g -nostdlib -I boot -use-prims runtime/primitives CAMLOPT=$(CAMLRUN) ./ocamlopt -g -nostdlib -I stdlib -I otherlibs/dynlink ARCHES=amd64 i386 arm arm64 power s390x -INCLUDES=-I utils -I parsing -I typing -I bytecomp -I middle_end \ - -I middle_end/base_types -I asmcomp -I asmcomp/debug \ +INCLUDES=-I utils -I parsing -I typing -I bytecomp -I file_formats \ + -I lambda -I middle_end -I middle_end/closure \ + -I middle_end/flambda -I middle_end/flambda/base_types \ + -I asmcomp -I asmcomp/debug \ -I driver -I toplevel COMPFLAGS=-strict-sequence -principal -absname -w +a-4-9-41-42-44-45-48-66 \ @@ -76,7 +78,8 @@ UTILS=utils/config.cmo utils/build_path_prefix_map.cmo utils/misc.cmo \ utils/terminfo.cmo utils/ccomp.cmo utils/warnings.cmo \ utils/consistbl.cmo \ utils/strongly_connected_components.cmo \ - utils/targetint.cmo + utils/targetint.cmo \ + utils/int_replace_polymorphic_compare.cmo PARSING=parsing/location.cmo parsing/longident.cmo \ parsing/docstrings.cmo parsing/syntaxerr.cmo \ @@ -91,14 +94,13 @@ TYPING=typing/ident.cmo typing/path.cmo \ typing/primitive.cmo typing/types.cmo \ typing/btype.cmo typing/oprint.cmo \ typing/subst.cmo typing/predef.cmo \ - typing/datarepr.cmo typing/cmi_format.cmo \ - typing/persistent_env.cmo \ - typing/env.cmo \ + typing/datarepr.cmo file_formats/cmi_format.cmo \ + typing/persistent_env.cmo typing/env.cmo \ typing/typedtree.cmo typing/printtyped.cmo typing/ctype.cmo \ typing/printtyp.cmo typing/includeclass.cmo \ typing/mtype.cmo typing/envaux.cmo typing/includecore.cmo \ typing/tast_iterator.cmo typing/tast_mapper.cmo \ - typing/cmt_format.cmo typing/untypeast.cmo \ + file_formats/cmt_format.cmo typing/untypeast.cmo \ typing/includemod.cmo typing/typetexp.cmo typing/printpat.cmo \ typing/parmatch.cmo typing/stypes.cmo \ typing/typedecl_properties.cmo typing/typedecl_variance.cmo \ @@ -107,12 +109,15 @@ TYPING=typing/ident.cmo typing/path.cmo \ typing/rec_check.cmo typing/typecore.cmo typing/typeclass.cmo \ typing/typemod.cmo -COMP=bytecomp/lambda.cmo bytecomp/printlambda.cmo \ - bytecomp/switch.cmo bytecomp/matching.cmo \ - bytecomp/translobj.cmo bytecomp/translattribute.cmo \ - bytecomp/translprim.cmo bytecomp/translcore.cmo \ - bytecomp/translclass.cmo bytecomp/translmod.cmo \ - bytecomp/simplif.cmo bytecomp/runtimedef.cmo \ +LAMBDA=lambda/debuginfo.cmo \ + lambda/lambda.cmo lambda/printlambda.cmo \ + lambda/switch.cmo lambda/matching.cmo \ + lambda/translobj.cmo lambda/translattribute.cmo \ + lambda/translprim.cmo lambda/translcore.cmo \ + lambda/translclass.cmo lambda/translmod.cmo \ + lambda/simplif.cmo lambda/runtimedef.cmo + +COMP=\ bytecomp/meta.cmo bytecomp/opcodes.cmo \ bytecomp/bytesections.cmo bytecomp/dll.cmo \ bytecomp/symtable.cmo \ @@ -121,8 +126,7 @@ COMP=bytecomp/lambda.cmo bytecomp/printlambda.cmo \ driver/makedepend.cmo \ driver/compile_common.cmo - -COMMON=$(UTILS) $(PARSING) $(TYPING) $(COMP) +COMMON=$(UTILS) $(PARSING) $(TYPING) $(LAMBDA) $(COMP) BYTECOMP=bytecomp/instruct.cmo bytecomp/bytegen.cmo \ bytecomp/printinstr.cmo bytecomp/emitcode.cmo \ @@ -150,22 +154,10 @@ endif ASMCOMP=\ $(ARCH_SPECIFIC_ASMCOMP) \ asmcomp/arch.cmo \ - asmcomp/backend_var.cmo \ asmcomp/cmm.cmo asmcomp/printcmm.cmo \ asmcomp/reg.cmo asmcomp/debug/reg_with_debug_info.cmo \ asmcomp/debug/reg_availability_set.cmo \ asmcomp/mach.cmo asmcomp/proc.cmo \ - asmcomp/clambda.cmo asmcomp/printclambda.cmo \ - asmcomp/export_info.cmo \ - asmcomp/export_info_for_pack.cmo \ - asmcomp/compilenv.cmo \ - asmcomp/closure.cmo \ - asmcomp/traverse_for_exported_symbols.cmo \ - asmcomp/build_export_info.cmo \ - asmcomp/closure_offsets.cmo \ - asmcomp/flambda_to_clambda.cmo \ - asmcomp/import_approx.cmo \ - asmcomp/un_anf.cmo \ asmcomp/afl_instrument.cmo \ asmcomp/strmatch.cmo \ asmcomp/cmmgen_state.cmo \ @@ -192,72 +184,96 @@ ASMCOMP=\ asmcomp/asmlink.cmo asmcomp/asmlibrarian.cmo asmcomp/asmpackager.cmo \ driver/opterrors.cmo driver/optcompile.cmo +# Files under middle_end/ are not to reference files under asmcomp/. +# This ensures that the middle end can be linked (e.g. for objinfo) even when +# the native code compiler is not present for some particular target. + +MIDDLE_END_CLOSURE=\ + middle_end/closure/closure.cmo + +# Owing to dependencies through [Compilenv], which would be +# difficult to remove, some of the lower parts of Flambda (anything that is +# saved in a .cmx file) have to be included in the [MIDDLE_END] stanza, below. +MIDDLE_END_FLAMBDA=\ + middle_end/flambda/import_approx.cmo \ + middle_end/flambda/lift_code.cmo \ + middle_end/flambda/closure_conversion_aux.cmo \ + middle_end/flambda/closure_conversion.cmo \ + middle_end/flambda/initialize_symbol_to_let_symbol.cmo \ + middle_end/flambda/lift_let_to_initialize_symbol.cmo \ + middle_end/flambda/find_recursive_functions.cmo \ + middle_end/flambda/invariant_params.cmo \ + middle_end/flambda/inconstant_idents.cmo \ + middle_end/flambda/alias_analysis.cmo \ + middle_end/flambda/lift_constants.cmo \ + middle_end/flambda/share_constants.cmo \ + middle_end/flambda/simplify_common.cmo \ + middle_end/flambda/remove_unused_arguments.cmo \ + middle_end/flambda/remove_unused_closure_vars.cmo \ + middle_end/flambda/remove_unused_program_constructs.cmo \ + middle_end/flambda/simplify_boxed_integer_ops.cmo \ + middle_end/flambda/simplify_primitives.cmo \ + middle_end/flambda/inlining_stats_types.cmo \ + middle_end/flambda/inlining_stats.cmo \ + middle_end/flambda/inline_and_simplify_aux.cmo \ + middle_end/flambda/remove_free_vars_equal_to_args.cmo \ + middle_end/flambda/extract_projections.cmo \ + middle_end/flambda/augment_specialised_args.cmo \ + middle_end/flambda/unbox_free_vars_of_closures.cmo \ + middle_end/flambda/unbox_specialised_args.cmo \ + middle_end/flambda/unbox_closures.cmo \ + middle_end/flambda/inlining_transforms.cmo \ + middle_end/flambda/inlining_decision.cmo \ + middle_end/flambda/inline_and_simplify.cmo \ + middle_end/flambda/ref_to_variables.cmo \ + middle_end/flambda/flambda_invariants.cmo \ + middle_end/flambda/traverse_for_exported_symbols.cmo \ + middle_end/flambda/build_export_info.cmo \ + middle_end/flambda/closure_offsets.cmo \ + middle_end/flambda/un_anf.cmo \ + middle_end/flambda/flambda_to_clambda.cmo \ + middle_end/flambda/flambda_middle_end.cmo + MIDDLE_END=\ - middle_end/int_replace_polymorphic_compare.cmo \ - middle_end/debuginfo.cmo \ - asmcomp/clambda_primitives.cmo \ - asmcomp/semantics_of_primitives.cmo \ - asmcomp/convert_primitives.cmo \ - asmcomp/printclambda_primitives.cmo \ - middle_end/base_types/tag.cmo \ - middle_end/base_types/linkage_name.cmo \ - middle_end/base_types/compilation_unit.cmo \ middle_end/internal_variable_names.cmo \ - middle_end/base_types/variable.cmo \ - middle_end/base_types/mutable_variable.cmo \ - middle_end/base_types/id_types.cmo \ - middle_end/base_types/set_of_closures_id.cmo \ - middle_end/base_types/set_of_closures_origin.cmo \ - middle_end/base_types/closure_element.cmo \ - middle_end/base_types/closure_id.cmo \ - middle_end/base_types/closure_origin.cmo \ - middle_end/base_types/var_within_closure.cmo \ - middle_end/base_types/static_exception.cmo \ - middle_end/base_types/export_id.cmo \ - middle_end/base_types/symbol.cmo \ - middle_end/pass_wrapper.cmo \ - middle_end/allocated_const.cmo \ - middle_end/parameter.cmo \ - middle_end/projection.cmo \ - middle_end/flambda.cmo \ - middle_end/flambda_iterators.cmo \ - middle_end/flambda_utils.cmo \ - middle_end/inlining_cost.cmo \ - middle_end/effect_analysis.cmo \ - middle_end/freshening.cmo \ - middle_end/simple_value_approx.cmo \ - middle_end/lift_code.cmo \ - middle_end/closure_conversion_aux.cmo \ - middle_end/closure_conversion.cmo \ - middle_end/initialize_symbol_to_let_symbol.cmo \ - middle_end/lift_let_to_initialize_symbol.cmo \ - middle_end/find_recursive_functions.cmo \ - middle_end/invariant_params.cmo \ - middle_end/inconstant_idents.cmo \ - middle_end/alias_analysis.cmo \ - middle_end/lift_constants.cmo \ - middle_end/share_constants.cmo \ - middle_end/simplify_common.cmo \ - middle_end/remove_unused_arguments.cmo \ - middle_end/remove_unused_closure_vars.cmo \ - middle_end/remove_unused_program_constructs.cmo \ - middle_end/simplify_boxed_integer_ops.cmo \ - middle_end/simplify_primitives.cmo \ - middle_end/inlining_stats_types.cmo \ - middle_end/inlining_stats.cmo \ - middle_end/inline_and_simplify_aux.cmo \ - middle_end/remove_free_vars_equal_to_args.cmo \ - middle_end/extract_projections.cmo \ - middle_end/augment_specialised_args.cmo \ - middle_end/unbox_free_vars_of_closures.cmo \ - middle_end/unbox_specialised_args.cmo \ - middle_end/unbox_closures.cmo \ - middle_end/inlining_transforms.cmo \ - middle_end/inlining_decision.cmo \ - middle_end/inline_and_simplify.cmo \ - middle_end/ref_to_variables.cmo \ - middle_end/flambda_invariants.cmo \ - middle_end/middle_end.cmo + middle_end/linkage_name.cmo \ + middle_end/compilation_unit.cmo \ + middle_end/variable.cmo \ + middle_end/flambda/base_types/closure_element.cmo \ + middle_end/flambda/base_types/closure_id.cmo \ + middle_end/symbol.cmo \ + middle_end/backend_var.cmo \ + middle_end/clambda_primitives.cmo \ + middle_end/printclambda_primitives.cmo \ + middle_end/clambda.cmo \ + middle_end/printclambda.cmo \ + middle_end/semantics_of_primitives.cmo \ + middle_end/convert_primitives.cmo \ + middle_end/flambda/base_types/id_types.cmo \ + middle_end/flambda/base_types/export_id.cmo \ + middle_end/flambda/base_types/tag.cmo \ + middle_end/flambda/base_types/mutable_variable.cmo \ + middle_end/flambda/base_types/set_of_closures_id.cmo \ + middle_end/flambda/base_types/set_of_closures_origin.cmo \ + middle_end/flambda/base_types/closure_origin.cmo \ + middle_end/flambda/base_types/var_within_closure.cmo \ + middle_end/flambda/base_types/static_exception.cmo \ + middle_end/flambda/pass_wrapper.cmo \ + middle_end/flambda/allocated_const.cmo \ + middle_end/flambda/parameter.cmo \ + middle_end/flambda/projection.cmo \ + middle_end/flambda/flambda.cmo \ + middle_end/flambda/flambda_iterators.cmo \ + middle_end/flambda/flambda_utils.cmo \ + middle_end/flambda/freshening.cmo \ + middle_end/flambda/effect_analysis.cmo \ + middle_end/flambda/inlining_cost.cmo \ + middle_end/flambda/simple_value_approx.cmo \ + middle_end/flambda/export_info.cmo \ + middle_end/flambda/export_info_for_pack.cmo \ + middle_end/compilenv.cmo \ + $(MIDDLE_END_CLOSURE) \ + $(MIDDLE_END_FLAMBDA) OPTCOMP=$(MIDDLE_END) $(ASMCOMP) @@ -541,6 +557,8 @@ endif parsing/*.cmi \ typing/*.cmi \ bytecomp/*.cmi \ + file_formats/*.cmi \ + lambda/*.cmi \ driver/*.cmi \ toplevel/*.cmi \ "$(INSTALL_COMPLIBDIR)" @@ -549,6 +567,8 @@ ifeq "$(INSTALL_SOURCE_ARTIFACTS)" "true" utils/*.cmt utils/*.cmti utils/*.mli \ parsing/*.cmt parsing/*.cmti parsing/*.mli \ typing/*.cmt typing/*.cmti typing/*.mli \ + file_formats/*.cmt file_formats/*.cmti file_formats/*.mli \ + lambda/*.cmt lambda/*.cmti lambda/*.mli \ bytecomp/*.cmt bytecomp/*.cmti bytecomp/*.mli \ driver/*.cmt driver/*.cmti driver/*.mli \ toplevel/*.cmt toplevel/*.cmti toplevel/*.mli \ @@ -614,7 +634,13 @@ endif middle_end/*.cmi \ "$(INSTALL_COMPLIBDIR)" $(INSTALL_DATA) \ - middle_end/base_types/*.cmi \ + middle_end/closure/*.cmi \ + "$(INSTALL_COMPLIBDIR)" + $(INSTALL_DATA) \ + middle_end/flambda/*.cmi \ + "$(INSTALL_COMPLIBDIR)" + $(INSTALL_DATA) \ + middle_end/flambda/base_types/*.cmi \ "$(INSTALL_COMPLIBDIR)" $(INSTALL_DATA) \ asmcomp/*.cmi \ @@ -625,8 +651,17 @@ ifeq "$(INSTALL_SOURCE_ARTIFACTS)" "true" middle_end/*.mli \ "$(INSTALL_COMPLIBDIR)" $(INSTALL_DATA) \ - middle_end/base_types/*.cmt middle_end/base_types/*.cmti \ - middle_end/base_types/*.mli \ + middle_end/closure/*.cmt middle_end/closure/*.cmti \ + middle_end/closure/*.mli \ + "$(INSTALL_COMPLIBDIR)" + $(INSTALL_DATA) \ + middle_end/flambda/*.cmt middle_end/flambda/*.cmti \ + middle_end/flambda/*.mli \ + "$(INSTALL_COMPLIBDIR)" + $(INSTALL_DATA) \ + middle_end/flambda/base_types/*.cmt \ + middle_end/flambda/base_types/*.cmti \ + middle_end/flambda/base_types/*.mli \ "$(INSTALL_COMPLIBDIR)" $(INSTALL_DATA) \ asmcomp/*.cmt asmcomp/*.cmti \ @@ -670,8 +705,13 @@ installoptopt: $(LN) ocamllex.opt$(EXE) ocamllex$(EXE) $(INSTALL_DATA) \ utils/*.cmx parsing/*.cmx typing/*.cmx bytecomp/*.cmx \ + file_formats/*.cmx \ + lambda/*.cmx \ driver/*.cmx asmcomp/*.cmx middle_end/*.cmx \ - middle_end/base_types/*.cmx "$(INSTALL_COMPLIBDIR)" + middle_end/closure/*.cmx \ + middle_end/flambda/*.cmx \ + middle_end/flambda/base_types/*.cmx \ + "$(INSTALL_COMPLIBDIR)" $(INSTALL_DATA) \ compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlcommon.$(A) \ compilerlibs/ocamlbytecomp.cmxa compilerlibs/ocamlbytecomp.$(A) \ @@ -700,7 +740,10 @@ install-compiler-sources: ifeq "$(INSTALL_SOURCE_ARTIFACTS)" "true" $(INSTALL_DATA) \ utils/*.ml parsing/*.ml typing/*.ml bytecomp/*.ml driver/*.ml \ - toplevel/*.ml middle_end/*.ml middle_end/base_types/*.ml \ + file_formats/*.ml \ + lambda/*.ml \ + toplevel/*.ml middle_end/*.ml middle_end/closure/*.ml \ + middle_end/flambda/*.ml middle_end/flambda/base_types/*.ml \ asmcomp/*.ml \ "$(INSTALL_COMPLIBDIR)" endif @@ -857,14 +900,14 @@ $(COMMON:.cmo=.cmx) $(BYTECOMP:.cmo=.cmx) $(OPTCOMP:.cmo=.cmx): ocamlopt runtime/primitives: $(MAKE) -C runtime primitives -bytecomp/runtimedef.ml: bytecomp/generate_runtimedef.sh runtime/caml/fail.h \ +lambda/runtimedef.ml: lambda/generate_runtimedef.sh runtime/caml/fail.h \ runtime/primitives $^ > $@ partialclean:: - rm -f bytecomp/runtimedef.ml + rm -f lambda/runtimedef.ml -beforedepend:: bytecomp/runtimedef.ml +beforedepend:: lambda/runtimedef.ml # Choose the right machine-dependent files @@ -1109,10 +1152,7 @@ lintapidiff: grep -Ev internal\|obj\|spacetime\|stdLabels\|moreLabels |\ tools/lintapidiff.opt $(VERSIONS) -# The middle end (whose .cma library is currently only used for linking -# the "ocamlobjinfo" program, since we cannot depend on the whole native code -# compiler for "make world" and the list of dependencies for -# asmcomp/export_info.cmo is long). +# The middle end. compilerlibs/ocamlmiddleend.cma: $(MIDDLE_END) $(CAMLC) -a -o $@ $^ @@ -1126,9 +1166,7 @@ partialclean:: # Tools .PHONY: ocamltools -ocamltools: ocamlc ocamllex asmcomp/cmx_format.cmi \ - asmcomp/printclambda.cmo compilerlibs/ocamlmiddleend.cma \ - asmcomp/export_info.cmo +ocamltools: ocamlc ocamllex compilerlibs/ocamlmiddleend.cma $(MAKE) -C tools all .PHONY: ocamltoolsopt @@ -1136,9 +1174,7 @@ ocamltoolsopt: ocamlopt $(MAKE) -C tools opt .PHONY: ocamltoolsopt.opt -ocamltoolsopt.opt: ocamlc.opt ocamllex.opt asmcomp/cmx_format.cmi \ - asmcomp/printclambda.cmx compilerlibs/ocamlmiddleend.cmxa \ - asmcomp/export_info.cmx +ocamltoolsopt.opt: ocamlc.opt ocamllex.opt compilerlibs/ocamlmiddleend.cmxa $(MAKE) -C tools opt.opt partialclean:: @@ -1261,8 +1297,10 @@ partialclean:: $(CAMLOPT) $(COMPFLAGS) -c $< partialclean:: - for d in utils parsing typing bytecomp asmcomp middle_end \ - middle_end/base_types asmcomp/debug driver toplevel tools; do \ + for d in utils parsing typing bytecomp asmcomp middle_end file_formats \ + lambda middle_end/closure middle_end/flambda \ + middle_end/flambda/base_types asmcomp/debug \ + driver toplevel tools; do \ rm -f $$d/*.cm[ioxt] $$d/*.cmti $$d/*.annot $$d/*.$(S) \ $$d/*.$(O) $$d/*.$(SO) $$d/*~; \ done @@ -1271,9 +1309,11 @@ partialclean:: .PHONY: depend depend: beforedepend (for d in utils parsing typing bytecomp asmcomp middle_end \ - middle_end/base_types asmcomp/debug driver toplevel; \ - do $(CAMLDEP) $(DEPFLAGS) $(DEPINCLUDES) $$d/*.mli $$d/*.ml || exit; \ - done) > .depend + lambda file_formats middle_end/closure middle_end/flambda \ + middle_end/flambda/base_types asmcomp/debug \ + driver toplevel; \ + do $(CAMLDEP) $(DEPFLAGS) $(DEPINCLUDES) $$d/*.mli $$d/*.ml || exit; \ + done) > .depend .PHONY: distclean distclean: clean diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp index 4b6d25e970..d16c51790e 100644 --- a/asmcomp/amd64/emit.mlp +++ b/asmcomp/amd64/emit.mlp @@ -33,6 +33,7 @@ module String = Misc.Stdlib.String emit.mlp files for certain other targets; the reference here ensures that when releases are being prepared the .depend files are correct for all targets. *) +[@@@ocaml.warning "-66"] open! Branch_relaxation let _label s = D.label ~typ:QWORD s diff --git a/asmcomp/asmgen.ml b/asmcomp/asmgen.ml index 4af472d36b..46f7b27046 100644 --- a/asmcomp/asmgen.ml +++ b/asmcomp/asmgen.ml @@ -221,9 +221,11 @@ let flambda_gen_implementation ?toplevel ~backend ~ppf_dump end_gen_implementation ?toplevel ~ppf_dump (clambda, preallocated, constants) -let lambda_gen_implementation ?toplevel ~ppf_dump +let lambda_gen_implementation ?toplevel ~backend ~ppf_dump (lambda:Lambda.program) = - let clambda = Closure.intro lambda.main_module_block_size lambda.code in + let clambda = + Closure.intro ~backend ~size:lambda.main_module_block_size lambda.code + in let provenance : Clambda.usymbol_provenance = { original_idents = []; module_path = @@ -259,10 +261,10 @@ let compile_implementation_gen ?toplevel prefixname gen_implementation ?toplevel ~ppf_dump program) let compile_implementation_clambda ?toplevel prefixname - ~ppf_dump (program:Lambda.program) = + ~backend ~ppf_dump (program:Lambda.program) = compile_implementation_gen ?toplevel prefixname ~required_globals:program.Lambda.required_globals - ~ppf_dump lambda_gen_implementation program + ~ppf_dump (lambda_gen_implementation ~backend) program let compile_implementation_flambda ?toplevel prefixname ~required_globals ~backend ~ppf_dump (program:Flambda.program) = diff --git a/asmcomp/asmgen.mli b/asmcomp/asmgen.mli index f2f4ccaef3..160456215a 100644 --- a/asmcomp/asmgen.mli +++ b/asmcomp/asmgen.mli @@ -25,6 +25,7 @@ val compile_implementation_flambda : val compile_implementation_clambda : ?toplevel:(string -> bool) -> string -> + backend:(module Backend_intf.S) -> ppf_dump:Format.formatter -> Lambda.program -> unit val compile_phrase : diff --git a/asmcomp/asmpackager.ml b/asmcomp/asmpackager.ml index cddb34631d..1bed76f7bd 100644 --- a/asmcomp/asmpackager.ml +++ b/asmcomp/asmpackager.ml @@ -102,7 +102,7 @@ let make_package_object ~ppf_dump members targetobj targetname coercion if Config.flambda then begin let size, lam = Translmod.transl_package_flambda components coercion in let flam = - Middle_end.middle_end ~ppf_dump + Flambda_middle_end.middle_end ~ppf_dump ~prefixname ~backend ~size @@ -117,7 +117,7 @@ let make_package_object ~ppf_dump members targetobj targetname coercion Translmod.transl_store_package components (Ident.create_persistent targetname) coercion in Asmgen.compile_implementation_clambda - prefixname ~ppf_dump { Lambda.code; main_module_block_size; + prefixname ~backend ~ppf_dump { Lambda.code; main_module_block_size; module_ident; required_globals = Ident.Set.empty } end; let objfiles = diff --git a/asmcomp/backend_var.ml b/asmcomp/backend_var.ml deleted file mode 100644 index 39af7f6062..0000000000 --- a/asmcomp/backend_var.ml +++ /dev/null @@ -1,87 +0,0 @@ -(**************************************************************************) -(* *) -(* 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/asmcomp/backend_var.mli b/asmcomp/backend_var.mli deleted file mode 100644 index f236be1e47..0000000000 --- a/asmcomp/backend_var.mli +++ /dev/null @@ -1,54 +0,0 @@ -(**************************************************************************) -(* *) -(* 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/asmcomp/build_export_info.ml b/asmcomp/build_export_info.ml deleted file mode 100644 index c3d811deea..0000000000 --- a/asmcomp/build_export_info.ml +++ /dev/null @@ -1,711 +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 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/asmcomp/build_export_info.mli b/asmcomp/build_export_info.mli deleted file mode 100644 index 0380604bf8..0000000000 --- a/asmcomp/build_export_info.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"] - -(** 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/asmcomp/clambda.ml b/asmcomp/clambda.ml deleted file mode 100644 index 406bfbccda..0000000000 --- a/asmcomp/clambda.ml +++ /dev/null @@ -1,203 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the 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/asmcomp/clambda.mli b/asmcomp/clambda.mli deleted file mode 100644 index ddd0956dee..0000000000 --- a/asmcomp/clambda.mli +++ /dev/null @@ -1,153 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the 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/asmcomp/clambda_primitives.ml b/asmcomp/clambda_primitives.ml deleted file mode 100644 index a7c9798f36..0000000000 --- a/asmcomp/clambda_primitives.ml +++ /dev/null @@ -1,155 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the 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/asmcomp/clambda_primitives.mli b/asmcomp/clambda_primitives.mli deleted file mode 100644 index d534ca9cfa..0000000000 --- a/asmcomp/clambda_primitives.mli +++ /dev/null @@ -1,158 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the 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/asmcomp/closure.ml b/asmcomp/closure.ml deleted file mode 100644 index 21708f936d..0000000000 --- a/asmcomp/closure.ml +++ /dev/null @@ -1,1453 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the 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 - -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 fpc p (args, approxs) dbg = - 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 * Arch.size_int -> - make_const_int (n1 lsl n2) - | Plsrint when 0 <= n2 && n2 < 8 * Arch.size_int -> - make_const_int (n1 lsr n2) - | Pasrint when 0 <= n2 && n2 < 8 * Arch.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 * Arch.size_int -> - make_const_natint (Nativeint.shift_left n1 n2) - | Plsrbint Pnativeint when 0 <= n2 && n2 < 8 * Arch.size_int -> - make_const_natint (Nativeint.shift_right_logical n1 n2) - | Pasrbint Pnativeint when 0 <= n2 && n2 < 8 * Arch.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 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 fpc p (args, approxs) dbg - -let simplif_prim fpc p (args, approxs as args_approxs) dbg = - if List.for_all is_pure args - then simplif_prim_pure 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 fpc 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 fpc sb rn) args, dbg) - | Ugeneric_apply(fn, args, dbg) -> - let dbg = subst_debuginfo loc dbg in - Ugeneric_apply(substitute loc fpc sb rn fn, - List.map (substitute loc fpc 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 fpc sb rn) env) - | Uoffset(u, ofs) -> Uoffset(substitute loc fpc sb rn u, ofs) - | Ulet(str, kind, id, u1, u2) -> - let id' = VP.rename id in - Ulet(str, kind, id', substitute loc fpc sb rn u1, - substitute loc fpc - (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 fpc sb' rn rhs)) - bindings1, - substitute loc fpc sb' rn body) - | Uprim(p, args, dbg) -> - let sargs = List.map (substitute loc fpc sb rn) args in - let dbg = subst_debuginfo loc dbg in - let (res, _) = - simplif_prim fpc p (sargs, List.map approx_ulam sargs) dbg in - res - | Uswitch(arg, sw, dbg) -> - let sarg = substitute loc fpc 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 fpc sb rn u - | None -> - Uswitch(sarg, - { sw with - us_actions_consts = - Array.map (substitute loc fpc sb rn) sw.us_actions_consts; - us_actions_blocks = - Array.map (substitute loc fpc sb rn) sw.us_actions_blocks; - }, - dbg) - end - | Ustringswitch(arg,sw,d) -> - Ustringswitch - (substitute loc fpc sb rn arg, - List.map (fun (s,act) -> s,substitute loc fpc sb rn act) sw, - Misc.may_map (substitute loc fpc 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 fpc 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 fpc sb rn u1, - substitute loc fpc sb' rn u2) - | Utrywith(u1, id, u2) -> - let id' = VP.rename id in - Utrywith(substitute loc fpc sb rn u1, id', - substitute loc fpc - (V.Map.add (VP.var id) (Uvar (VP.var id')) sb) rn u2) - | Uifthenelse(u1, u2, u3) -> - begin match substitute loc fpc sb rn u1 with - Uconst (Uconst_ptr n) -> - if n <> 0 then - substitute loc fpc sb rn u2 - else - substitute loc fpc sb rn u3 - | Uprim(P.Pmakeblock _, _, _) -> - substitute loc fpc sb rn u2 - | su1 -> - Uifthenelse(su1, substitute loc fpc sb rn u2, - substitute loc fpc sb rn u3) - end - | Usequence(u1, u2) -> - Usequence(substitute loc fpc sb rn u1, substitute loc fpc sb rn u2) - | Uwhile(u1, u2) -> - Uwhile(substitute loc fpc sb rn u1, substitute loc fpc sb rn u2) - | Ufor(id, u1, u2, dir, u3) -> - let id' = VP.rename id in - Ufor(id', substitute loc fpc sb rn u1, substitute loc fpc sb rn u2, dir, - substitute loc fpc - (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 fpc sb rn u) - | Usend(k, u1, u2, ul, dbg) -> - let dbg = subst_debuginfo loc dbg in - Usend(k, substitute loc fpc sb rn u1, substitute loc fpc sb rn u2, - List.map (substitute loc fpc 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 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 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 - -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 fenv cenv id = - let (ulam, _app) = close_approx_var fenv cenv id in ulam - -let rec close fenv cenv = function - Lvar id -> - close_approx_var fenv cenv 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 fenv cenv (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 fenv cenv funct, close_list fenv cenv args) with - ((ufunct, Value_closure(fundesc, approx_res)), - [Uprim(P.Pmakeblock _, uargs, _)]) - when List.length uargs = - fundesc.fun_arity -> - let app = - direct_apply ~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 ~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 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 ~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 fenv cenv met in - let (uobj, _) = close fenv cenv obj in - let dbg = Debuginfo.from_location loc in - (Usend(kind, umet, uobj, close_list fenv cenv args, dbg), - Value_unknown) - | Llet(str, kind, id, lam, body) -> - let (ulam, alam) = close_named fenv cenv id lam in - begin match (str, alam) with - (Variable, _) -> - let (ubody, abody) = close fenv cenv body in - (Ulet(Mutable, kind, VP.create id, ulam, ubody), abody) - | (_, Value_const _) - when str = Alias || is_pure ulam -> - close (V.Map.add id alam fenv) cenv body - | (_, _) -> - let (ubody, abody) = close (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 fenv cenv 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 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 !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 fenv cenv 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 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 Arch.big_endian - | Word_size -> make_const_int (8*Arch.size_int) - | Int_size -> make_const_int (8*Arch.size_int - 1) - | Max_wosize -> make_const_int ((1 lsl ((8*Arch.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 fenv cenv 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 fenv cenv arg), expr), approx - | Lprim((Pidentity | Pbytes_to_string | Pbytes_of_string), [arg], _loc) -> - close fenv cenv arg - | Lprim(Pdirapply,[funct;arg], loc) - | Lprim(Prevapply,[arg;funct], loc) -> - close fenv cenv (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 fenv cenv 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 fenv cenv 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 fenv cenv 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 !Clflags.float_const_prop - p (close_list_approx fenv cenv args) dbg - | Lswitch(arg, sw, dbg) -> - let fn fail = - let (uarg, _) = close fenv cenv arg in - let const_index, const_actions, fconst = - close_switch fenv cenv sw.sw_consts sw.sw_numconsts fail - and block_index, block_actions, fblock = - close_switch fenv cenv 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 fenv cenv lamfail in - Ucatch (i,[],ubody,uhandler),Value_unknown - else fn fail - end - | Lstringswitch(arg,sw,d,_) -> - let uarg,_ = close fenv cenv arg in - let usw = - List.map - (fun (s,act) -> - let uact,_ = close fenv cenv act in - s,uact) - sw in - let ud = - Misc.may_map - (fun d -> - let ud,_ = close fenv cenv d in - ud) d in - Ustringswitch (uarg,usw,ud),Value_unknown - | Lstaticraise (i, args) -> - (Ustaticfail (i, close_list fenv cenv args), Value_unknown) - | Lstaticcatch(body, (i, vars), handler) -> - let (ubody, _) = close fenv cenv body in - let (uhandler, _) = close fenv cenv 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 fenv cenv body in - let (uhandler, _) = close fenv cenv handler in - (Utrywith(ubody, VP.create id, uhandler), Value_unknown) - | Lifthenelse(arg, ifso, ifnot) -> - begin match close fenv cenv arg with - (uarg, Value_const (Uconst_ptr n)) -> - sequence_constant_expr uarg - (close fenv cenv (if n = 0 then ifnot else ifso)) - | (uarg, _ ) -> - let (uifso, _) = close fenv cenv ifso in - let (uifnot, _) = close fenv cenv ifnot in - (Uifthenelse(uarg, uifso, uifnot), Value_unknown) - end - | Lsequence(lam1, lam2) -> - let (ulam1, _) = close fenv cenv lam1 in - let (ulam2, approx) = close fenv cenv lam2 in - (Usequence(ulam1, ulam2), approx) - | Lwhile(cond, body) -> - let (ucond, _) = close fenv cenv cond in - let (ubody, _) = close fenv cenv body in - (Uwhile(ucond, ubody), Value_unknown) - | Lfor(id, lo, hi, dir, body) -> - let (ulo, _) = close fenv cenv lo in - let (uhi, _) = close fenv cenv hi in - let (ubody, _) = close fenv cenv body in - (Ufor(VP.create id, ulo, uhi, dir, ubody), Value_unknown) - | Lassign(id, lam) -> - let (ulam, _) = close fenv cenv lam in - (Uassign(id, ulam), Value_unknown) - | Levent(lam, _) -> - close fenv cenv lam - | Lifused _ -> - assert false - -and close_list fenv cenv = function - [] -> [] - | lam :: rem -> - let (ulam, _) = close fenv cenv lam in - ulam :: close_list fenv cenv rem - -and close_list_approx fenv cenv = function - [] -> ([], []) - | lam :: rem -> - let (ulam, approx) = close fenv cenv lam in - let (ulams, approxs) = close_list_approx fenv cenv rem in - (ulam :: ulams, approx :: approxs) - -and close_named fenv cenv id = function - Lfunction _ as funct -> - close_one_function fenv cenv id funct - | lam -> - close fenv cenv lam - -(* Build a shared closure for a set of mutually recursive functions *) - -and close_functions 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 fenv_rec 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 fenv cenv) fv), infos) - -(* Same, for one non-recursive function *) - -and close_one_function fenv cenv id funct = - match close_functions fenv cenv [id, funct] with - | (clos, (i, _, approx) :: _) when id = i -> (clos, approx) - | _ -> fatal_error "Closure.close_one_function" - -(* Close a switch *) - -and close_switch fenv cenv 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 fenv cenv lam in - ulam - | Shared lam -> - let ulam,_ = close fenv cenv 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 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 V.Map.empty 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/asmcomp/closure.mli b/asmcomp/closure.mli deleted file mode 100644 index f930e0fe52..0000000000 --- a/asmcomp/closure.mli +++ /dev/null @@ -1,19 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the 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: int -> Lambda.lambda -> Clambda.ulambda -val reset : unit -> unit diff --git a/asmcomp/closure_offsets.ml b/asmcomp/closure_offsets.ml deleted file mode 100644 index 51a09f02cb..0000000000 --- a/asmcomp/closure_offsets.ml +++ /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"] - -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/asmcomp/closure_offsets.mli b/asmcomp/closure_offsets.mli deleted file mode 100644 index 7ecf9c276d..0000000000 --- a/asmcomp/closure_offsets.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"] - -(** 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/asmcomp/cmx_format.mli b/asmcomp/cmx_format.mli deleted file mode 100644 index 0efa32eec3..0000000000 --- a/asmcomp/cmx_format.mli +++ /dev/null @@ -1,56 +0,0 @@ -(**************************************************************************) -(* *) -(* 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. *) -(* *) -(**************************************************************************) - -(* Format of .cmx, .cmxa and .cmxs files *) - -open Misc - -(* Each .o file has a matching .cmx file that provides the following infos - on the compilation unit: - - list of other units imported, with MD5s of their .cmx files - - approximation of the structure implemented - (includes descriptions of known functions: arity and direct entry - points) - - list of currying functions and application functions needed - The .cmx file contains these infos (as an externed record) plus a MD5 - of these infos *) - -type export_info = - | Clambda of Clambda.value_approximation - | Flambda of Export_info.t - -type unit_infos = - { mutable ui_name: modname; (* Name of unit implemented *) - mutable ui_symbol: string; (* Prefix for symbols *) - mutable ui_defines: string list; (* Unit and sub-units implemented *) - mutable ui_imports_cmi: crcs; (* Interfaces imported *) - mutable ui_imports_cmx: crcs; (* Infos imported *) - mutable ui_curry_fun: int list; (* Currying functions needed *) - mutable ui_apply_fun: int list; (* Apply functions needed *) - mutable ui_send_fun: int list; (* Send functions needed *) - mutable ui_export_info: export_info; - mutable ui_force_link: bool } (* Always linked *) - -(* Each .a library has a matching .cmxa file that provides the following - infos on the library: *) - -type library_infos = - { lib_units: (unit_infos * Digest.t) list; (* List of unit infos w/ MD5s *) - lib_ccobjs: string list; (* C object files needed *) - lib_ccopts: string list } (* Extra opts to C compiler *) diff --git a/asmcomp/cmxs_format.mli b/asmcomp/cmxs_format.mli deleted file mode 100644 index c670024f92..0000000000 --- a/asmcomp/cmxs_format.mli +++ /dev/null @@ -1,35 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) -(* *) -(* Copyright 2010 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. *) -(* *) -(**************************************************************************) - -(* Format of .cmxs files *) - -open Misc - -(* Each .cmxs dynamically-loaded plugin contains a symbol - "caml_plugin_header" containing the following info - (as an externed record) *) - -type dynunit = { - dynu_name: modname; - dynu_crc: Digest.t; - dynu_imports_cmi: crcs; - dynu_imports_cmx: crcs; - dynu_defines: string list; -} - -type dynheader = { - dynu_magic: string; - dynu_units: dynunit list; -} diff --git a/asmcomp/compilenv.ml b/asmcomp/compilenv.ml deleted file mode 100644 index add4e90e57..0000000000 --- a/asmcomp/compilenv.ml +++ /dev/null @@ -1,452 +0,0 @@ -(**************************************************************************) -(* *) -(* 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/asmcomp/compilenv.mli b/asmcomp/compilenv.mli deleted file mode 100644 index 569d51ea08..0000000000 --- a/asmcomp/compilenv.mli +++ /dev/null @@ -1,153 +0,0 @@ -(**************************************************************************) -(* *) -(* 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/asmcomp/convert_primitives.ml b/asmcomp/convert_primitives.ml deleted file mode 100644 index 17d17ea8af..0000000000 --- a/asmcomp/convert_primitives.ml +++ /dev/null @@ -1,153 +0,0 @@ -(**************************************************************************) -(* *) -(* 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/asmcomp/convert_primitives.mli b/asmcomp/convert_primitives.mli deleted file mode 100644 index 8c3691268a..0000000000 --- a/asmcomp/convert_primitives.mli +++ /dev/null @@ -1,17 +0,0 @@ -(**************************************************************************) -(* *) -(* 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/asmcomp/export_info.ml b/asmcomp/export_info.ml deleted file mode 100644 index 22dbb6c583..0000000000 --- a/asmcomp/export_info.ml +++ /dev/null @@ -1,555 +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 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/asmcomp/export_info.mli b/asmcomp/export_info.mli deleted file mode 100644 index f93698be4f..0000000000 --- a/asmcomp/export_info.mli +++ /dev/null @@ -1,195 +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"] - -(** 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/asmcomp/export_info_for_pack.ml b/asmcomp/export_info_for_pack.ml deleted file mode 100644 index 42a8155347..0000000000 --- a/asmcomp/export_info_for_pack.ml +++ /dev/null @@ -1,231 +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 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/asmcomp/export_info_for_pack.mli b/asmcomp/export_info_for_pack.mli deleted file mode 100644 index 2ba3a35d8b..0000000000 --- a/asmcomp/export_info_for_pack.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"] - -(** 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/asmcomp/flambda_to_clambda.ml b/asmcomp/flambda_to_clambda.ml deleted file mode 100644 index 2f60f9fcfc..0000000000 --- a/asmcomp/flambda_to_clambda.ml +++ /dev/null @@ -1,749 +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 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/asmcomp/flambda_to_clambda.mli b/asmcomp/flambda_to_clambda.mli deleted file mode 100644 index 8c493d40d6..0000000000 --- a/asmcomp/flambda_to_clambda.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"] - -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/asmcomp/import_approx.ml b/asmcomp/import_approx.ml deleted file mode 100644 index 64fbbb8bff..0000000000 --- a/asmcomp/import_approx.ml +++ /dev/null @@ -1,222 +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 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/asmcomp/import_approx.mli b/asmcomp/import_approx.mli deleted file mode 100644 index 23d9d29482..0000000000 --- a/asmcomp/import_approx.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"] - -(** 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/asmcomp/printclambda.ml b/asmcomp/printclambda.ml deleted file mode 100644 index fceb34851d..0000000000 --- a/asmcomp/printclambda.ml +++ /dev/null @@ -1,272 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the 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/asmcomp/printclambda.mli b/asmcomp/printclambda.mli deleted file mode 100644 index 121667e2a4..0000000000 --- a/asmcomp/printclambda.mli +++ /dev/null @@ -1,26 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the 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/asmcomp/printclambda_primitives.ml b/asmcomp/printclambda_primitives.ml deleted file mode 100644 index 3f627063d4..0000000000 --- a/asmcomp/printclambda_primitives.ml +++ /dev/null @@ -1,202 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the 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/asmcomp/printclambda_primitives.mli b/asmcomp/printclambda_primitives.mli deleted file mode 100644 index 07db5a1ce6..0000000000 --- a/asmcomp/printclambda_primitives.mli +++ /dev/null @@ -1,18 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the 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/asmcomp/semantics_of_primitives.ml b/asmcomp/semantics_of_primitives.ml deleted file mode 100644 index 2daf167ecd..0000000000 --- a/asmcomp/semantics_of_primitives.ml +++ /dev/null @@ -1,153 +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 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/asmcomp/semantics_of_primitives.mli b/asmcomp/semantics_of_primitives.mli deleted file mode 100644 index 78407df71d..0000000000 --- a/asmcomp/semantics_of_primitives.mli +++ /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"] - -(** 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/asmcomp/traverse_for_exported_symbols.ml b/asmcomp/traverse_for_exported_symbols.ml deleted file mode 100644 index 1b7ce57f54..0000000000 --- a/asmcomp/traverse_for_exported_symbols.ml +++ /dev/null @@ -1,267 +0,0 @@ -(**************************************************************************) -(* *) -(* 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/asmcomp/traverse_for_exported_symbols.mli b/asmcomp/traverse_for_exported_symbols.mli deleted file mode 100644 index 2825a38623..0000000000 --- a/asmcomp/traverse_for_exported_symbols.mli +++ /dev/null @@ -1,41 +0,0 @@ -(**************************************************************************) -(* *) -(* 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/asmcomp/un_anf.ml b/asmcomp/un_anf.ml deleted file mode 100644 index 50f9e7b1e2..0000000000 --- a/asmcomp/un_anf.ml +++ /dev/null @@ -1,817 +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"] - -(* 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/asmcomp/un_anf.mli b/asmcomp/un_anf.mli deleted file mode 100644 index 92ea06cd03..0000000000 --- a/asmcomp/un_anf.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. *) -(* *) -(**************************************************************************) - -(** 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/bytecomp/cmo_format.mli b/bytecomp/cmo_format.mli deleted file mode 100644 index d953a8817a..0000000000 --- a/bytecomp/cmo_format.mli +++ /dev/null @@ -1,66 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, 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. *) -(* *) -(**************************************************************************) - -(* Symbol table information for .cmo and .cma files *) - -open Misc - -(* Relocation information *) - -type reloc_info = - Reloc_literal of Lambda.structured_constant (* structured constant *) - | Reloc_getglobal of Ident.t (* reference to a global *) - | Reloc_setglobal of Ident.t (* definition of a global *) - | Reloc_primitive of string (* C primitive number *) - -(* Descriptor for compilation units *) - -type compilation_unit = - { cu_name: modname; (* Name of compilation unit *) - mutable cu_pos: int; (* Absolute position in file *) - cu_codesize: int; (* Size of code block *) - cu_reloc: (reloc_info * int) list; (* Relocation information *) - cu_imports: crcs; (* Names and CRC of intfs imported *) - cu_required_globals: Ident.t list; (* Compilation units whose - initialization side effects - must occur before this one. *) - cu_primitives: string list; (* Primitives declared inside *) - mutable cu_force_link: bool; (* Must be linked even if unref'ed *) - mutable cu_debug: int; (* Position of debugging info, or 0 *) - cu_debugsize: int } (* Length of debugging info *) - -(* Format of a .cmo file: - magic number (Config.cmo_magic_number) - absolute offset of compilation unit descriptor - block of relocatable bytecode - debugging information if any - compilation unit descriptor *) - -(* Descriptor for libraries *) - -type library = - { lib_units: compilation_unit list; (* List of compilation units *) - lib_custom: bool; (* Requires custom mode linking? *) - lib_ccobjs: string list; (* C object files needed for -custom *) - lib_ccopts: string list; (* Extra opts to C compiler *) - lib_dllibs: string list } (* DLLs needed *) - -(* Format of a .cma file: - magic number (Config.cma_magic_number) - absolute offset of library descriptor - object code for first library member - ... - object code for last library member - library descriptor *) diff --git a/bytecomp/dune b/bytecomp/dune index b2409cf4f1..655cb57ebe 100644 --- a/bytecomp/dune +++ b/bytecomp/dune @@ -18,11 +18,3 @@ (deps (:instr (file ../runtime/caml/instruct.h))) (action (bash "%{dep:../tools/make_opcodes.exe} -opcodes < %{instr} > %{targets}"))) - -(rule - (targets runtimedef.ml) - (mode fallback) - (deps (:fail (file ../runtime/caml/fail.h)) - (:prim (file ../runtime/primitives))) - (action (with-stdout-to %{targets} - (run ./generate_runtimedef.sh %{fail} %{prim})))) diff --git a/bytecomp/generate_runtimedef.sh b/bytecomp/generate_runtimedef.sh deleted file mode 100755 index 66ccf3ce5d..0000000000 --- a/bytecomp/generate_runtimedef.sh +++ /dev/null @@ -1,25 +0,0 @@ -#!/bin/sh - -#************************************************************************** -#* * -#* OCaml * -#* * -#* Xavier Leroy, projet Cristal, INRIA Rocquencourt * -#* * -#* Copyright 1999 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. * -#* * -#************************************************************************** - -echo 'let builtin_exceptions = [|' -cat "$1" | tr -d '\r' | \ - sed -n -e 's|.*/\* \("[A-Za-z_]*"\) \*/$| \1;|p' -echo '|]' - -echo 'let builtin_primitives = [|' -sed -e 's/.*/ "&";/' "$2" -echo '|]' diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml deleted file mode 100644 index f06d9a820d..0000000000 --- a/bytecomp/lambda.ml +++ /dev/null @@ -1,886 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -open Misc -open Asttypes - -type compile_time_constant = - | Big_endian - | Word_size - | Int_size - | Max_wosize - | Ostype_unix - | Ostype_win32 - | Ostype_cygwin - | Backend_type - -type immediate_or_pointer = - | Immediate - | Pointer - -type initialization_or_assignment = - | Assignment - | Heap_initialization - | Root_initialization - -type is_safe = - | Safe - | Unsafe - -type primitive = - | Pidentity - | Pbytes_to_string - | Pbytes_of_string - | Pignore - | Prevapply - | Pdirapply - (* Globals *) - | Pgetglobal of Ident.t - | Psetglobal of Ident.t - (* 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 - (* Force lazy values *) - (* 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 - | 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 Bigarrays: (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 Bigarray *) - | Pbigarraydim of int - (* load/set 16,32,64 bits from a string: (unsafe)*) - | Pstring_load_16 of bool - | Pstring_load_32 of bool - | Pstring_load_64 of bool - | Pbytes_load_16 of bool - | Pbytes_load_32 of bool - | Pbytes_load_64 of bool - | Pbytes_set_16 of bool - | Pbytes_set_32 of bool - | Pbytes_set_64 of bool - (* load/set 16,32,64 bits from a - (char, int8_unsigned_elt, c_layout) Bigarray.Array1.t : (unsafe) *) - | Pbigstring_load_16 of bool - | Pbigstring_load_32 of bool - | Pbigstring_load_64 of bool - | Pbigstring_set_16 of bool - | Pbigstring_set_32 of bool - | Pbigstring_set_64 of bool - (* Compile time constants *) - | Pctconst of compile_time_constant - (* byte swap *) - | Pbswap16 - | Pbbswap of boxed_integer - (* Integer to external pointer *) - | Pint_as_pointer - (* Inhibition of optimisation *) - | Popaque - -and integer_comparison = - Ceq | Cne | Clt | Cgt | Cle | Cge - -and float_comparison = - CFeq | CFneq | CFlt | CFnlt | CFgt | CFngt | CFle | CFnle | CFge | CFnge - -and value_kind = - Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval - -and block_shape = - value_kind list option - -and array_kind = - Pgenarray | Paddrarray | Pintarray | Pfloatarray - -and boxed_integer = Primitive.boxed_integer = - Pnativeint | Pint32 | Pint64 - -and 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 = - Pbigarray_unknown_layout - | Pbigarray_c_layout - | Pbigarray_fortran_layout - -and raise_kind = - | Raise_regular - | Raise_reraise - | Raise_notrace - -let equal_boxed_integer x y = - match x, y with - | Pnativeint, Pnativeint - | Pint32, Pint32 - | Pint64, Pint64 -> - true - | (Pnativeint | Pint32 | Pint64), _ -> - false - -let equal_primitive = - (* Should be implemented like [equal_value_kind] of [equal_boxed_integer], - i.e. by matching over the various constructors but the type has more - than 100 constructors... *) - (=) - -let equal_value_kind x y = - match x, y with - | Pgenval, Pgenval -> true - | Pfloatval, Pfloatval -> true - | Pboxedintval bi1, Pboxedintval bi2 -> equal_boxed_integer bi1 bi2 - | Pintval, Pintval -> true - | (Pgenval | Pfloatval | Pboxedintval _ | Pintval), _ -> false - - -type structured_constant = - Const_base of constant - | Const_pointer of int - | Const_block of int * structured_constant list - | Const_float_array of string list - | Const_immstring of string - -type inline_attribute = - | Always_inline (* [@inline] or [@inline always] *) - | Never_inline (* [@inline never] *) - | Unroll of int (* [@unroll x] *) - | Default_inline (* no [@inline] attribute *) - -let equal_inline_attribute x y = - match x, y with - | Always_inline, Always_inline - | Never_inline, Never_inline - | Default_inline, Default_inline - -> - true - | Unroll u, Unroll v -> - u = v - | (Always_inline | Never_inline | Unroll _ | Default_inline), _ -> - false - -type specialise_attribute = - | Always_specialise (* [@specialise] or [@specialise always] *) - | Never_specialise (* [@specialise never] *) - | Default_specialise (* no [@specialise] attribute *) - -let equal_specialise_attribute x y = - match x, y with - | Always_specialise, Always_specialise - | Never_specialise, Never_specialise - | Default_specialise, Default_specialise -> - true - | (Always_specialise | Never_specialise | Default_specialise), _ -> - false - -type local_attribute = - | Always_local (* [@local] or [@local always] *) - | Never_local (* [@local never] *) - | Default_local (* [@local maybe] or no [@local] attribute *) - -type function_kind = Curried | Tupled - -type let_kind = Strict | Alias | StrictOpt | Variable - -type meth_kind = Self | Public | Cached - -let equal_meth_kind x y = - match x, y with - | Self, Self -> true - | Public, Public -> true - | Cached, Cached -> true - | (Self | Public | Cached), _ -> false - -type shared_code = (int * int) list - -type function_attribute = { - inline : inline_attribute; - specialise : specialise_attribute; - local: local_attribute; - is_a_functor: bool; - stub: bool; -} - -type lambda = - Lvar of Ident.t - | Lconst of structured_constant - | Lapply of lambda_apply - | Lfunction of lfunction - | Llet of let_kind * value_kind * Ident.t * lambda * lambda - | Lletrec of (Ident.t * lambda) list * lambda - | Lprim of primitive * lambda list * Location.t - | Lswitch of lambda * lambda_switch * Location.t - | Lstringswitch of - lambda * (string * lambda) list * lambda option * Location.t - | Lstaticraise of int * lambda list - | Lstaticcatch of lambda * (int * (Ident.t * value_kind) list) * lambda - | Ltrywith of lambda * Ident.t * lambda - | Lifthenelse of lambda * lambda * lambda - | Lsequence of lambda * lambda - | Lwhile of lambda * lambda - | Lfor of Ident.t * lambda * lambda * direction_flag * lambda - | Lassign of Ident.t * lambda - | Lsend of meth_kind * lambda * lambda * lambda list * Location.t - | Levent of lambda * lambda_event - | Lifused of Ident.t * lambda - -and lfunction = - { kind: function_kind; - params: (Ident.t * value_kind) list; - return: value_kind; - body: lambda; - attr: function_attribute; (* specified with [@inline] attribute *) - loc: Location.t; } - -and lambda_apply = - { ap_func : lambda; - ap_args : lambda list; - ap_loc : Location.t; - ap_should_be_tailcall : bool; - ap_inlined : inline_attribute; - ap_specialised : specialise_attribute; } - -and lambda_switch = - { sw_numconsts: int; - sw_consts: (int * lambda) list; - sw_numblocks: int; - sw_blocks: (int * lambda) list; - sw_failaction : lambda option} - -and lambda_event = - { lev_loc: Location.t; - lev_kind: lambda_event_kind; - lev_repr: int ref option; - lev_env: Env.t } - -and lambda_event_kind = - Lev_before - | Lev_after of Types.type_expr - | Lev_function - | Lev_pseudo - | Lev_module_definition of Ident.t - -type program = - { module_ident : Ident.t; - main_module_block_size : int; - required_globals : Ident.Set.t; - code : lambda } - -let const_unit = Const_pointer 0 - -let lambda_unit = Lconst const_unit - -let default_function_attribute = { - inline = Default_inline; - specialise = Default_specialise; - local = Default_local; - is_a_functor = false; - stub = false; -} - -let default_stub_attribute = - { default_function_attribute with stub = true } - -(* Build sharing keys *) -(* - Those keys are later compared with Stdlib.compare. - For that reason, they should not include cycles. -*) - -exception Not_simple - -let max_raw = 32 - -let make_key e = - let count = ref 0 (* Used for controlling size *) - and make_key = Ident.make_key_generator () in - (* make_key is used for normalizing let-bound variables *) - let rec tr_rec env e = - incr count ; - if !count > max_raw then raise Not_simple ; (* Too big ! *) - match e with - | Lvar id -> - begin - try Ident.find_same id env - with Not_found -> e - end - | Lconst (Const_base (Const_string _)) -> - (* Mutable constants are not shared *) - raise Not_simple - | Lconst _ -> e - | Lapply ap -> - Lapply {ap with ap_func = tr_rec env ap.ap_func; - ap_args = tr_recs env ap.ap_args; - ap_loc = Location.none} - | Llet (Alias,_k,x,ex,e) -> (* Ignore aliases -> substitute *) - let ex = tr_rec env ex in - tr_rec (Ident.add x ex env) e - | Llet ((Strict | StrictOpt),_k,x,ex,Lvar v) when Ident.same v x -> - tr_rec env ex - | Llet (str,k,x,ex,e) -> - (* Because of side effects, keep other lets with normalized names *) - let ex = tr_rec env ex in - let y = make_key x in - Llet (str,k,y,ex,tr_rec (Ident.add x (Lvar y) env) e) - | Lprim (p,es,_) -> - Lprim (p,tr_recs env es, Location.none) - | Lswitch (e,sw,loc) -> - Lswitch (tr_rec env e,tr_sw env sw,loc) - | Lstringswitch (e,sw,d,_) -> - Lstringswitch - (tr_rec env e, - List.map (fun (s,e) -> s,tr_rec env e) sw, - tr_opt env d, - Location.none) - | Lstaticraise (i,es) -> - Lstaticraise (i,tr_recs env es) - | Lstaticcatch (e1,xs,e2) -> - Lstaticcatch (tr_rec env e1,xs,tr_rec env e2) - | Ltrywith (e1,x,e2) -> - Ltrywith (tr_rec env e1,x,tr_rec env e2) - | Lifthenelse (cond,ifso,ifnot) -> - Lifthenelse (tr_rec env cond,tr_rec env ifso,tr_rec env ifnot) - | Lsequence (e1,e2) -> - Lsequence (tr_rec env e1,tr_rec env e2) - | Lassign (x,e) -> - Lassign (x,tr_rec env e) - | Lsend (m,e1,e2,es,_loc) -> - Lsend (m,tr_rec env e1,tr_rec env e2,tr_recs env es,Location.none) - | Lifused (id,e) -> Lifused (id,tr_rec env e) - | Lletrec _|Lfunction _ - | Lfor _ | Lwhile _ -(* Beware: (PR#6412) the event argument to Levent - may include cyclic structure of type Type.typexpr *) - | Levent _ -> - raise Not_simple - - and tr_recs env es = List.map (tr_rec env) es - - and tr_sw env sw = - { sw with - sw_consts = List.map (fun (i,e) -> i,tr_rec env e) sw.sw_consts ; - sw_blocks = List.map (fun (i,e) -> i,tr_rec env e) sw.sw_blocks ; - sw_failaction = tr_opt env sw.sw_failaction ; } - - and tr_opt env = function - | None -> None - | Some e -> Some (tr_rec env e) in - - try - Some (tr_rec Ident.empty e) - with Not_simple -> None - -(***************) - -let name_lambda strict arg fn = - match arg with - Lvar id -> fn id - | _ -> - let id = Ident.create_local "let" in - Llet(strict, Pgenval, id, arg, fn id) - -let name_lambda_list args fn = - let rec name_list names = function - [] -> fn (List.rev names) - | (Lvar _ as arg) :: rem -> - name_list (arg :: names) rem - | arg :: rem -> - let id = Ident.create_local "let" in - Llet(Strict, Pgenval, id, arg, name_list (Lvar id :: names) rem) in - name_list [] args - - -let iter_opt f = function - | None -> () - | Some e -> f e - -let shallow_iter ~tail ~non_tail:f = function - Lvar _ - | Lconst _ -> () - | Lapply{ap_func = fn; ap_args = args} -> - f fn; List.iter f args - | Lfunction{body} -> - f body - | Llet(_str, _k, _id, arg, body) -> - f arg; tail body - | Lletrec(decl, body) -> - tail body; - List.iter (fun (_id, exp) -> f exp) decl - | Lprim (Pidentity, [l], _) -> - tail l - | Lprim (Psequand, [l1; l2], _) - | Lprim (Psequor, [l1; l2], _) -> - f l1; - tail l2 - | Lprim(_p, args, _loc) -> - List.iter f args - | Lswitch(arg, sw,_) -> - f arg; - List.iter (fun (_key, case) -> tail case) sw.sw_consts; - List.iter (fun (_key, case) -> tail case) sw.sw_blocks; - iter_opt tail sw.sw_failaction - | Lstringswitch (arg,cases,default,_) -> - f arg ; - List.iter (fun (_,act) -> tail act) cases ; - iter_opt tail default - | Lstaticraise (_,args) -> - List.iter f args - | Lstaticcatch(e1, _, e2) -> - tail e1; tail e2 - | Ltrywith(e1, _, e2) -> - f e1; tail e2 - | Lifthenelse(e1, e2, e3) -> - f e1; tail e2; tail e3 - | Lsequence(e1, e2) -> - f e1; tail e2 - | Lwhile(e1, e2) -> - f e1; f e2 - | Lfor(_v, e1, e2, _dir, e3) -> - f e1; f e2; f e3 - | Lassign(_, e) -> - f e - | Lsend (_k, met, obj, args, _) -> - List.iter f (met::obj::args) - | Levent (e, _evt) -> - tail e - | Lifused (_v, e) -> - tail e - -let iter_head_constructor f l = - shallow_iter ~tail:f ~non_tail:f l - -let rec free_variables = function - | Lvar id -> Ident.Set.singleton id - | Lconst _ -> Ident.Set.empty - | Lapply{ap_func = fn; ap_args = args} -> - free_variables_list (free_variables fn) args - | Lfunction{body; params} -> - Ident.Set.diff (free_variables body) - (Ident.Set.of_list (List.map fst params)) - | Llet(_str, _k, id, arg, body) -> - Ident.Set.union - (free_variables arg) - (Ident.Set.remove id (free_variables body)) - | Lletrec(decl, body) -> - let set = free_variables_list (free_variables body) (List.map snd decl) in - Ident.Set.diff set (Ident.Set.of_list (List.map fst decl)) - | Lprim(_p, args, _loc) -> - free_variables_list Ident.Set.empty args - | Lswitch(arg, sw,_) -> - let set = - free_variables_list - (free_variables_list (free_variables arg) - (List.map snd sw.sw_consts)) - (List.map snd sw.sw_blocks) - in - begin match sw.sw_failaction with - | None -> set - | Some failaction -> Ident.Set.union set (free_variables failaction) - end - | Lstringswitch (arg,cases,default,_) -> - let set = - free_variables_list (free_variables arg) - (List.map snd cases) - in - begin match default with - | None -> set - | Some default -> Ident.Set.union set (free_variables default) - end - | Lstaticraise (_,args) -> - free_variables_list Ident.Set.empty args - | Lstaticcatch(body, (_, params), handler) -> - Ident.Set.union - (Ident.Set.diff - (free_variables handler) - (Ident.Set.of_list (List.map fst params))) - (free_variables body) - | Ltrywith(body, param, handler) -> - Ident.Set.union - (Ident.Set.remove - param - (free_variables handler)) - (free_variables body) - | Lifthenelse(e1, e2, e3) -> - Ident.Set.union - (Ident.Set.union (free_variables e1) (free_variables e2)) - (free_variables e3) - | Lsequence(e1, e2) -> - Ident.Set.union (free_variables e1) (free_variables e2) - | Lwhile(e1, e2) -> - Ident.Set.union (free_variables e1) (free_variables e2) - | Lfor(v, lo, hi, _dir, body) -> - let set = Ident.Set.union (free_variables lo) (free_variables hi) in - Ident.Set.union set (Ident.Set.remove v (free_variables body)) - | Lassign(id, e) -> - Ident.Set.add id (free_variables e) - | Lsend (_k, met, obj, args, _) -> - free_variables_list - (Ident.Set.union (free_variables met) (free_variables obj)) - args - | Levent (lam, _evt) -> - free_variables lam - | Lifused (_v, e) -> - (* Shouldn't v be considered a free variable ? *) - free_variables e - -and free_variables_list set exprs = - List.fold_left (fun set expr -> Ident.Set.union (free_variables expr) set) - set exprs - -(* Check if an action has a "when" guard *) -let raise_count = ref 0 - -let next_raise_count () = - incr raise_count ; - !raise_count - -(* Anticipated staticraise, for guards *) -let staticfail = Lstaticraise (0,[]) - -let rec is_guarded = function - | Lifthenelse(_cond, _body, Lstaticraise (0,[])) -> true - | Llet(_str, _k, _id, _lam, body) -> is_guarded body - | Levent(lam, _ev) -> is_guarded lam - | _ -> false - -let rec patch_guarded patch = function - | Lifthenelse (cond, body, Lstaticraise (0,[])) -> - Lifthenelse (cond, body, patch) - | Llet(str, k, id, lam, body) -> - Llet (str, k, id, lam, patch_guarded patch body) - | Levent(lam, ev) -> - Levent (patch_guarded patch lam, ev) - | _ -> fatal_error "Lambda.patch_guarded" - -(* Translate an access path *) - -let rec transl_address loc = function - | Env.Aident id -> - if Ident.global id - then Lprim(Pgetglobal id, [], loc) - else Lvar id - | Env.Adot(addr, pos) -> - Lprim(Pfield pos, [transl_address loc addr], loc) - -let transl_path find loc env path = - match find path env with - | exception Not_found -> - fatal_error ("Cannot find address for: " ^ (Path.name path)) - | addr -> transl_address loc addr - -(* Translation of identifiers *) - -let transl_module_path loc env path = - transl_path Env.find_module_address loc env path - -let transl_value_path loc env path = - transl_path Env.find_value_address loc env path - -let transl_extension_path loc env path = - transl_path Env.find_constructor_address loc env path - -let transl_class_path loc env path = - transl_path Env.find_class_address loc env path - -let transl_prim mod_name name = - let pers = Ident.create_persistent mod_name in - let env = Env.add_persistent_structure pers Env.empty in - let lid = Longident.Ldot (Longident.Lident mod_name, name) in - match Env.lookup_value lid env with - | path, _ -> transl_value_path Location.none env path - | exception Not_found -> - fatal_error ("Primitive " ^ name ^ " not found.") - -(* Compile a sequence of expressions *) - -let rec make_sequence fn = function - [] -> lambda_unit - | [x] -> fn x - | x::rem -> - let lam = fn x in Lsequence(lam, make_sequence fn rem) - -(* Apply a substitution to a lambda-term. - Assumes that the image of the substitution is out of reach - of the bound variables of the lambda-term (no capture). *) - -let subst update_env s lam = - let rec subst s lam = - let remove_list l s = - List.fold_left (fun s (id, _kind) -> Ident.Map.remove id s) s l - in - let module M = Ident.Map in - match lam with - | Lvar id as l -> - begin try Ident.Map.find id s with Not_found -> l end - | Lconst _ as l -> l - | Lapply ap -> - Lapply{ap with ap_func = subst s ap.ap_func; - ap_args = subst_list s ap.ap_args} - | Lfunction lf -> - let s = - List.fold_right - (fun (id, _) s -> Ident.Map.remove id s) - lf.params s - in - Lfunction {lf with body = subst s lf.body} - | Llet(str, k, id, arg, body) -> - Llet(str, k, id, subst s arg, subst (Ident.Map.remove id s) body) - | Lletrec(decl, body) -> - let s = - List.fold_left (fun s (id, _) -> Ident.Map.remove id s) - s decl - in - Lletrec(List.map (subst_decl s) decl, subst s body) - | Lprim(p, args, loc) -> Lprim(p, subst_list s args, loc) - | Lswitch(arg, sw, loc) -> - Lswitch(subst s arg, - {sw with sw_consts = List.map (subst_case s) sw.sw_consts; - sw_blocks = List.map (subst_case s) sw.sw_blocks; - sw_failaction = subst_opt s sw.sw_failaction; }, - loc) - | Lstringswitch (arg,cases,default,loc) -> - Lstringswitch - (subst s arg,List.map (subst_strcase s) cases,subst_opt s default,loc) - | Lstaticraise (i,args) -> Lstaticraise (i, subst_list s args) - | Lstaticcatch(body, (id, params), handler) -> - Lstaticcatch(subst s body, (id, params), - subst (remove_list params s) handler) - | Ltrywith(body, exn, handler) -> - Ltrywith(subst s body, exn, subst (Ident.Map.remove exn s) handler) - | Lifthenelse(e1, e2, e3) -> Lifthenelse(subst s e1, subst s e2, subst s e3) - | Lsequence(e1, e2) -> Lsequence(subst s e1, subst s e2) - | Lwhile(e1, e2) -> Lwhile(subst s e1, subst s e2) - | Lfor(v, lo, hi, dir, body) -> - Lfor(v, subst s lo, subst s hi, dir, - subst (Ident.Map.remove v s) body) - | Lassign(id, e) -> - assert(not (Ident.Map.mem id s)); - Lassign(id, subst s e) - | Lsend (k, met, obj, args, loc) -> - Lsend (k, subst s met, subst s obj, subst_list s args, loc) - | Levent (lam, evt) -> - let lev_env = - Ident.Map.fold (fun id _ env -> - match Env.find_value (Path.Pident id) evt.lev_env with - | exception Not_found -> env - | vd -> update_env id vd env - ) s evt.lev_env - in - Levent (subst s lam, { evt with lev_env }) - | Lifused (v, e) -> Lifused (v, subst s e) - and subst_list s l = List.map (subst s) l - and subst_decl s (id, exp) = (id, subst s exp) - and subst_case s (key, case) = (key, subst s case) - and subst_strcase s (key, case) = (key, subst s case) - and subst_opt s = function - | None -> None - | Some e -> Some (subst s e) - in - subst s lam - -let rename idmap lam = - let update_env oldid vd env = - let newid = Ident.Map.find oldid idmap in - Env.add_value newid vd env - in - let s = Ident.Map.map (fun new_id -> Lvar new_id) idmap in - subst update_env s lam - -let shallow_map f = function - | Lvar _ - | Lconst _ as lam -> lam - | Lapply { ap_func; ap_args; ap_loc; ap_should_be_tailcall; - ap_inlined; ap_specialised } -> - Lapply { - ap_func = f ap_func; - ap_args = List.map f ap_args; - ap_loc; - ap_should_be_tailcall; - ap_inlined; - ap_specialised; - } - | Lfunction { kind; params; return; body; attr; loc; } -> - Lfunction { kind; params; return; body = f body; attr; loc; } - | Llet (str, k, v, e1, e2) -> - Llet (str, k, v, f e1, f e2) - | Lletrec (idel, e2) -> - Lletrec (List.map (fun (v, e) -> (v, f e)) idel, f e2) - | Lprim (p, el, loc) -> - Lprim (p, List.map f el, loc) - | Lswitch (e, sw, loc) -> - Lswitch (f e, - { sw_numconsts = sw.sw_numconsts; - sw_consts = List.map (fun (n, e) -> (n, f e)) sw.sw_consts; - sw_numblocks = sw.sw_numblocks; - sw_blocks = List.map (fun (n, e) -> (n, f e)) sw.sw_blocks; - sw_failaction = Misc.may_map f sw.sw_failaction; - }, - loc) - | Lstringswitch (e, sw, default, loc) -> - Lstringswitch ( - f e, - List.map (fun (s, e) -> (s, f e)) sw, - Misc.may_map f default, - loc) - | Lstaticraise (i, args) -> - Lstaticraise (i, List.map f args) - | Lstaticcatch (body, id, handler) -> - Lstaticcatch (f body, id, f handler) - | Ltrywith (e1, v, e2) -> - Ltrywith (f e1, v, f e2) - | Lifthenelse (e1, e2, e3) -> - Lifthenelse (f e1, f e2, f e3) - | Lsequence (e1, e2) -> - Lsequence (f e1, f e2) - | Lwhile (e1, e2) -> - Lwhile (f e1, f e2) - | Lfor (v, e1, e2, dir, e3) -> - Lfor (v, f e1, f e2, dir, f e3) - | Lassign (v, e) -> - Lassign (v, f e) - | Lsend (k, m, o, el, loc) -> - Lsend (k, f m, f o, List.map f el, loc) - | Levent (l, ev) -> - Levent (f l, ev) - | Lifused (v, e) -> - Lifused (v, f e) - -let map f = - let rec g lam = f (shallow_map g lam) in - g - -(* To let-bind expressions to variables *) - -let bind_with_value_kind str (var, kind) exp body = - match exp with - Lvar var' when Ident.same var var' -> body - | _ -> Llet(str, kind, var, exp, body) - -let bind str var exp body = - bind_with_value_kind str (var, Pgenval) exp body - -let negate_integer_comparison = function - | Ceq -> Cne - | Cne -> Ceq - | Clt -> Cge - | Cle -> Cgt - | Cgt -> Cle - | Cge -> Clt - -let swap_integer_comparison = function - | Ceq -> Ceq - | Cne -> Cne - | Clt -> Cgt - | Cle -> Cge - | Cgt -> Clt - | Cge -> Cle - -let negate_float_comparison = function - | CFeq -> CFneq - | CFneq -> CFeq - | CFlt -> CFnlt - | CFnlt -> CFlt - | CFgt -> CFngt - | CFngt -> CFgt - | CFle -> CFnle - | CFnle -> CFle - | CFge -> CFnge - | CFnge -> CFge - -let swap_float_comparison = function - | CFeq -> CFeq - | CFneq -> CFneq - | CFlt -> CFgt - | CFnlt -> CFngt - | CFle -> CFge - | CFnle -> CFnge - | CFgt -> CFlt - | CFngt -> CFnlt - | CFge -> CFle - | CFnge -> CFnle - -let raise_kind = function - | Raise_regular -> "raise" - | Raise_reraise -> "reraise" - | Raise_notrace -> "raise_notrace" - -let merge_inline_attributes attr1 attr2 = - match attr1, attr2 with - | Default_inline, _ -> Some attr2 - | _, Default_inline -> Some attr1 - | _, _ -> - if attr1 = attr2 then Some attr1 - else None - -let reset () = - raise_count := 0 diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli deleted file mode 100644 index 39c7f265ca..0000000000 --- a/bytecomp/lambda.mli +++ /dev/null @@ -1,426 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* The "lambda" intermediate code *) - -open Asttypes - -type compile_time_constant = - | Big_endian - | Word_size - | Int_size - | Max_wosize - | Ostype_unix - | Ostype_win32 - | Ostype_cygwin - | Backend_type - -type immediate_or_pointer = - | Immediate - | Pointer - -type initialization_or_assignment = - | Assignment - (* Initialization of in heap values, like [caml_initialize] C primitive. The - field should not have been read before and initialization should happen - only once. *) - | Heap_initialization - (* Initialization of roots only. Compiles to a simple store. - No checks are done to preserve GC invariants. *) - | Root_initialization - -type is_safe = - | Safe - | Unsafe - -type primitive = - | Pidentity - | Pbytes_to_string - | Pbytes_of_string - | Pignore - | Prevapply - | Pdirapply - (* Globals *) - | Pgetglobal of Ident.t - | Psetglobal of Ident.t - (* 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 Bigarrays: (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 Bigarray *) - | Pbigarraydim of int - (* load/set 16,32,64 bits from a string: (unsafe)*) - | Pstring_load_16 of bool - | Pstring_load_32 of bool - | Pstring_load_64 of bool - | Pbytes_load_16 of bool - | Pbytes_load_32 of bool - | Pbytes_load_64 of bool - | Pbytes_set_16 of bool - | Pbytes_set_32 of bool - | Pbytes_set_64 of bool - (* load/set 16,32,64 bits from a - (char, int8_unsigned_elt, c_layout) Bigarray.Array1.t : (unsafe) *) - | Pbigstring_load_16 of bool - | Pbigstring_load_32 of bool - | Pbigstring_load_64 of bool - | Pbigstring_set_16 of bool - | Pbigstring_set_32 of bool - | Pbigstring_set_64 of bool - (* Compile time constants *) - | Pctconst of compile_time_constant - (* byte swap *) - | Pbswap16 - | Pbbswap of boxed_integer - (* Integer to external pointer *) - | Pint_as_pointer - (* Inhibition of optimisation *) - | Popaque - -and integer_comparison = - Ceq | Cne | Clt | Cgt | Cle | Cge - -and float_comparison = - CFeq | CFneq | CFlt | CFnlt | CFgt | CFngt | CFle | CFnle | CFge | CFnge - -and array_kind = - Pgenarray | Paddrarray | Pintarray | Pfloatarray - -and value_kind = - Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval - -and block_shape = - value_kind list option - -and boxed_integer = Primitive.boxed_integer = - Pnativeint | Pint32 | Pint64 - -and 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 = - Pbigarray_unknown_layout - | Pbigarray_c_layout - | Pbigarray_fortran_layout - -and raise_kind = - | Raise_regular - | Raise_reraise - | Raise_notrace - -val equal_primitive : primitive -> primitive -> bool - -val equal_value_kind : value_kind -> value_kind -> bool - -val equal_boxed_integer : boxed_integer -> boxed_integer -> bool - -type structured_constant = - Const_base of constant - | Const_pointer of int - | Const_block of int * structured_constant list - | Const_float_array of string list - | Const_immstring of string - -type inline_attribute = - | Always_inline (* [@inline] or [@inline always] *) - | Never_inline (* [@inline never] *) - | Unroll of int (* [@unroll x] *) - | Default_inline (* no [@inline] attribute *) - -val equal_inline_attribute : inline_attribute -> inline_attribute -> bool - -type specialise_attribute = - | Always_specialise (* [@specialise] or [@specialise always] *) - | Never_specialise (* [@specialise never] *) - | Default_specialise (* no [@specialise] attribute *) - -val equal_specialise_attribute - : specialise_attribute - -> specialise_attribute - -> bool - -type local_attribute = - | Always_local (* [@local] or [@local always] *) - | Never_local (* [@local never] *) - | Default_local (* [@local maybe] or no [@local] attribute *) - -type function_kind = Curried | Tupled - -type let_kind = Strict | Alias | StrictOpt | Variable -(* Meaning of kinds for let x = e in e': - Strict: e may have side-effects; always evaluate e first - (If e is a simple expression, e.g. a variable or constant, - we may still substitute e'[x/e].) - Alias: e is pure, we can substitute e'[x/e] if x has 0 or 1 occurrences - in e' - StrictOpt: e does not have side-effects, but depend on the store; - we can discard e if x does not appear in e' - Variable: the variable x is assigned later in e' - *) - -type meth_kind = Self | Public | Cached - -val equal_meth_kind : meth_kind -> meth_kind -> bool - -type shared_code = (int * int) list (* stack size -> code label *) - -type function_attribute = { - inline : inline_attribute; - specialise : specialise_attribute; - local: local_attribute; - is_a_functor: bool; - stub: bool; -} - -type lambda = - Lvar of Ident.t - | Lconst of structured_constant - | Lapply of lambda_apply - | Lfunction of lfunction - | Llet of let_kind * value_kind * Ident.t * lambda * lambda - | Lletrec of (Ident.t * lambda) list * lambda - | Lprim of primitive * lambda list * Location.t - | Lswitch of lambda * lambda_switch * Location.t -(* switch on strings, clauses are sorted by string order, - strings are pairwise distinct *) - | Lstringswitch of - lambda * (string * lambda) list * lambda option * Location.t - | Lstaticraise of int * lambda list - | Lstaticcatch of lambda * (int * (Ident.t * value_kind) list) * lambda - | Ltrywith of lambda * Ident.t * lambda - | Lifthenelse of lambda * lambda * lambda - | Lsequence of lambda * lambda - | Lwhile of lambda * lambda - | Lfor of Ident.t * lambda * lambda * direction_flag * lambda - | Lassign of Ident.t * lambda - | Lsend of meth_kind * lambda * lambda * lambda list * Location.t - | Levent of lambda * lambda_event - | Lifused of Ident.t * lambda - -and lfunction = - { kind: function_kind; - params: (Ident.t * value_kind) list; - return: value_kind; - body: lambda; - attr: function_attribute; (* specified with [@inline] attribute *) - loc : Location.t; } - -and lambda_apply = - { ap_func : lambda; - ap_args : lambda list; - ap_loc : Location.t; - ap_should_be_tailcall : bool; (* true if [@tailcall] was specified *) - ap_inlined : inline_attribute; (* specified with the [@inlined] attribute *) - ap_specialised : specialise_attribute; } - -and lambda_switch = - { sw_numconsts: int; (* Number of integer cases *) - sw_consts: (int * lambda) list; (* Integer cases *) - sw_numblocks: int; (* Number of tag block cases *) - sw_blocks: (int * lambda) list; (* Tag block cases *) - sw_failaction : lambda option} (* Action to take if failure *) -and lambda_event = - { lev_loc: Location.t; - lev_kind: lambda_event_kind; - lev_repr: int ref option; - lev_env: Env.t } - -and lambda_event_kind = - Lev_before - | Lev_after of Types.type_expr - | Lev_function - | Lev_pseudo - | Lev_module_definition of Ident.t - -type program = - { module_ident : Ident.t; - main_module_block_size : int; - required_globals : Ident.Set.t; (* Modules whose initializer side effects - must occur before [code]. *) - code : lambda } -(* Lambda code for the middle-end. - * In the closure case the code is a sequence of assignments to a - preallocated block of size [main_module_block_size] using - (Setfield(Getglobal(module_ident))). The size is used to preallocate - the block. - * In the flambda case the code is an expression returning a block - value of size [main_module_block_size]. The size is used to build - the module root as an initialize_symbol - Initialize_symbol(module_name, 0, - [getfield 0; ...; getfield (main_module_block_size - 1)]) -*) - -(* Sharing key *) -val make_key: lambda -> lambda option - -val const_unit: structured_constant -val lambda_unit: lambda -val name_lambda: let_kind -> lambda -> (Ident.t -> lambda) -> lambda -val name_lambda_list: lambda list -> (lambda list -> lambda) -> lambda - -val iter_head_constructor: (lambda -> unit) -> lambda -> unit -(** [iter_head_constructor f lam] apply [f] to only the first level of - sub expressions of [lam]. It does not recursively traverse the - expression. -*) - -val shallow_iter: - tail:(lambda -> unit) -> - non_tail:(lambda -> unit) -> - lambda -> unit -(** Same as [iter_head_constructor], but use a different callback for - sub-terms which are in tail position or not. *) - -val transl_prim: string -> string -> lambda -(** Translate a value from a persistent module. For instance: - - {[ - transl_internal_value "CamlinternalLazy" "force" - ]} -*) - -val free_variables: lambda -> Ident.Set.t - -val transl_module_path: Location.t -> Env.t -> Path.t -> lambda -val transl_value_path: Location.t -> Env.t -> Path.t -> lambda -val transl_extension_path: Location.t -> Env.t -> Path.t -> lambda -val transl_class_path: Location.t -> Env.t -> Path.t -> lambda - -val make_sequence: ('a -> lambda) -> 'a list -> lambda - -val subst: (Ident.t -> Types.value_description -> Env.t -> Env.t) -> - lambda Ident.Map.t -> lambda -> lambda -(** [subst env_update_fun s lt] applies a substitution [s] to the lambda-term - [lt]. - - Assumes that the image of the substitution is out of reach - of the bound variables of the lambda-term (no capture). - - [env_update_fun] is used to refresh the environment contained in debug - events. *) - -val rename : Ident.t Ident.Map.t -> lambda -> lambda -(** A version of [subst] specialized for the case where we're just renaming - idents. *) - -val map : (lambda -> lambda) -> lambda -> lambda - (** Bottom-up rewriting, applying the function on - each node from the leaves to the root. *) - -val shallow_map : (lambda -> lambda) -> lambda -> lambda - (** Rewrite each immediate sub-term with the function. *) - -val bind : let_kind -> Ident.t -> lambda -> lambda -> lambda -val bind_with_value_kind: - let_kind -> (Ident.t * value_kind) -> lambda -> lambda -> lambda - -val negate_integer_comparison : integer_comparison -> integer_comparison -val swap_integer_comparison : integer_comparison -> integer_comparison - -val negate_float_comparison : float_comparison -> float_comparison -val swap_float_comparison : float_comparison -> float_comparison - -val default_function_attribute : function_attribute -val default_stub_attribute : function_attribute - -(***********************) -(* For static failures *) -(***********************) - -(* Get a new static failure ident *) -val next_raise_count : unit -> int - -val staticfail : lambda (* Anticipated static failure *) - -(* Check anticipated failure, substitute its final value *) -val is_guarded: lambda -> bool -val patch_guarded : lambda -> lambda -> lambda - -val raise_kind: raise_kind -> string - -val merge_inline_attributes - : inline_attribute - -> inline_attribute - -> inline_attribute option - -val reset: unit -> unit diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml deleted file mode 100644 index 0b31ecbc1e..0000000000 --- a/bytecomp/matching.ml +++ /dev/null @@ -1,3240 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Compilation of pattern matching *) - -open Misc -open Asttypes -open Types -open Typedtree -open Lambda -open Parmatch -open Printf -open Printpat - - -let dbg = false - -(* See Peyton-Jones, ``The Implementation of functional programming - languages'', chapter 5. *) -(* - Well, it was true at the beginning of the world. - Now, see Lefessant-Maranget ``Optimizing Pattern-Matching'' ICFP'2001 -*) - -(* - Compatibility predicate that considers potential rebindings of constructors - of an extension type. - - "may_compat p q" returns false when p and q never admit a common instance; - returns true when they may have a common instance. -*) - -module MayCompat = - Parmatch.Compat (struct let equal = Types.may_equal_constr end) -let may_compat = MayCompat.compat -and may_compats = MayCompat.compats - -(* - Many functions on the various data structures of the algorithm : - - Pattern matrices. - - Default environments: mapping from matrices to exit numbers. - - Contexts: matrices whose column are partitioned into - left and right. - - Jump summaries: mapping from exit numbers to contexts -*) - - -let string_of_lam lam = - Printlambda.lambda Format.str_formatter lam ; - Format.flush_str_formatter () - -let all_record_args lbls = match lbls with -| (_,{lbl_all=lbl_all},_)::_ -> - let t = - Array.map - (fun lbl -> mknoloc (Longident.Lident "?temp?"), lbl,omega) - lbl_all in - List.iter - (fun ((_, lbl,_) as x) -> t.(lbl.lbl_pos) <- x) - lbls ; - Array.to_list t -| _ -> fatal_error "Parmatch.all_record_args" - -type matrix = pattern list list - -let add_omega_column pss = List.map (fun ps -> omega::ps) pss - -type ctx = {left:pattern list ; right:pattern list} - -let pretty_ctx ctx = - List.iter - (fun {left=left ; right=right} -> - Format.eprintf "LEFT:%a RIGHT:%a\n" pretty_line left pretty_line right) - ctx - -let le_ctx c1 c2 = - le_pats c1.left c2.left && - le_pats c1.right c2.right - -let lshift {left=left ; right=right} = match right with -| x::xs -> {left=x::left ; right=xs} -| _ -> assert false - -let lforget {left=left ; right=right} = match right with -| _::xs -> {left=omega::left ; right=xs} -| _ -> assert false - -let rec small_enough n = function - | [] -> true - | _::rem -> - if n <= 0 then false - else small_enough (n-1) rem - -let ctx_lshift ctx = - if small_enough (!Clflags.match_context_rows - 1) ctx then - List.map lshift ctx - else (* Context pruning *) begin - get_mins le_ctx (List.map lforget ctx) - end - -let rshift {left=left ; right=right} = match left with -| p::ps -> {left=ps ; right=p::right} -| _ -> assert false - -let ctx_rshift ctx = List.map rshift ctx - -let rec nchars n ps = - if n <= 0 then [],ps - else match ps with - | p::rem -> - let chars, cdrs = nchars (n-1) rem in - p::chars,cdrs - | _ -> assert false - -let rshift_num n {left=left ; right=right} = - let shifted,left = nchars n left in - {left=left ; right = shifted@right} - -let ctx_rshift_num n ctx = List.map (rshift_num n) ctx - -(* Recombination of contexts (eg: (_,_)::p1::p2::rem -> (p1,p2)::rem) - All mutable fields are replaced by '_', since side-effects in - guards can alter these fields *) - -let combine {left=left ; right=right} = match left with -| p::ps -> {left=ps ; right=set_args_erase_mutable p right} -| _ -> assert false - -let ctx_combine ctx = List.map combine ctx - -let ncols = function - | [] -> 0 - | ps::_ -> List.length ps - - -exception NoMatch -exception OrPat - -let filter_matrix matcher pss = - - let rec filter_rec = function - | (p::ps)::rem -> - begin match p.pat_desc with - | Tpat_alias (p,_,_) -> - filter_rec ((p::ps)::rem) - | Tpat_var _ -> - filter_rec ((omega::ps)::rem) - | _ -> - begin - let rem = filter_rec rem in - try - matcher p ps::rem - with - | NoMatch -> rem - | OrPat -> - match p.pat_desc with - | Tpat_or (p1,p2,_) -> filter_rec [(p1::ps) ;(p2::ps)]@rem - | _ -> assert false - end - end - | [] -> [] - | _ -> - pretty_matrix Format.err_formatter pss ; - fatal_error "Matching.filter_matrix" in - filter_rec pss - -let make_default matcher env = - let rec make_rec = function - | [] -> [] - | ([[]],i)::_ -> [[[]],i] - | (pss,i)::rem -> - let rem = make_rec rem in - match filter_matrix matcher pss with - | [] -> rem - | ([]::_) -> ([[]],i)::rem - | pss -> (pss,i)::rem in - make_rec env - -let ctx_matcher p = - let p = normalize_pat p in - match p.pat_desc with - | Tpat_construct (_, cstr,omegas) -> - (fun q rem -> match q.pat_desc with - | Tpat_construct (_, cstr',args) -(* NB: may_constr_equal considers (potential) constructor rebinding *) - when Types.may_equal_constr cstr cstr' -> - p,args@rem - | Tpat_any -> p,omegas @ rem - | _ -> raise NoMatch) - | Tpat_constant cst -> - (fun q rem -> match q.pat_desc with - | Tpat_constant cst' when const_compare cst cst' = 0 -> - p,rem - | Tpat_any -> p,rem - | _ -> raise NoMatch) - | Tpat_variant (lab,Some omega,_) -> - (fun q rem -> match q.pat_desc with - | Tpat_variant (lab',Some arg,_) when lab=lab' -> - p,arg::rem - | Tpat_any -> p,omega::rem - | _ -> raise NoMatch) - | Tpat_variant (lab,None,_) -> - (fun q rem -> match q.pat_desc with - | Tpat_variant (lab',None,_) when lab=lab' -> - p,rem - | Tpat_any -> p,rem - | _ -> raise NoMatch) - | Tpat_array omegas -> - let len = List.length omegas in - (fun q rem -> match q.pat_desc with - | Tpat_array args when List.length args = len -> p,args @ rem - | Tpat_any -> p, omegas @ rem - | _ -> raise NoMatch) - | Tpat_tuple omegas -> - let len = List.length omegas in - (fun q rem -> match q.pat_desc with - | Tpat_tuple args when List.length args = len -> p,args @ rem - | Tpat_any -> p, omegas @ rem - | _ -> raise NoMatch) - | Tpat_record (((_, lbl, _) :: _) as l,_) -> (* Records are normalized *) - let len = Array.length lbl.lbl_all in - (fun q rem -> match q.pat_desc with - | Tpat_record (((_, lbl', _) :: _) as l',_) - when Array.length lbl'.lbl_all = len -> - let l' = all_record_args l' in - p, List.fold_right (fun (_, _,p) r -> p::r) l' rem - | Tpat_any -> p,List.fold_right (fun (_, _,p) r -> p::r) l rem - | _ -> raise NoMatch) - | Tpat_lazy omega -> - (fun q rem -> match q.pat_desc with - | Tpat_lazy arg -> p, (arg::rem) - | Tpat_any -> p, (omega::rem) - | _ -> raise NoMatch) - | _ -> fatal_error "Matching.ctx_matcher" - - - - -let filter_ctx q ctx = - - let matcher = ctx_matcher q in - - let rec filter_rec = function - | ({right=p::ps} as l)::rem -> - begin match p.pat_desc with - | Tpat_or (p1,p2,_) -> - filter_rec ({l with right=p1::ps}::{l with right=p2::ps}::rem) - | Tpat_alias (p,_,_) -> - filter_rec ({l with right=p::ps}::rem) - | Tpat_var _ -> - filter_rec ({l with right=omega::ps}::rem) - | _ -> - begin let rem = filter_rec rem in - try - let to_left, right = matcher p ps in - {left=to_left::l.left ; right=right}::rem - with - | NoMatch -> rem - end - end - | [] -> [] - | _ -> fatal_error "Matching.filter_ctx" in - - filter_rec ctx - -let select_columns pss ctx = - let n = ncols pss in - List.fold_right - (fun ps r -> - List.fold_right - (fun {left=left ; right=right} r -> - let transfert, right = nchars n right in - try - {left = lubs transfert ps @ left ; right=right}::r - with - | Empty -> r) - ctx r) - pss [] - -let ctx_lub p ctx = - List.fold_right - (fun {left=left ; right=right} r -> - match right with - | q::rem -> - begin try - {left=left ; right = lub p q::rem}::r - with - | Empty -> r - end - | _ -> fatal_error "Matching.ctx_lub") - ctx [] - -let ctx_match ctx pss = - List.exists - (fun {right=qs} -> List.exists (fun ps -> may_compats qs ps) pss) - ctx - -type jumps = (int * ctx list) list - -let pretty_jumps (env : jumps) = match env with -| [] -> () -| _ -> - List.iter - (fun (i,ctx) -> - Printf.fprintf stderr "jump for %d\n" i ; - pretty_ctx ctx) - env - - -let rec jumps_extract i = function - | [] -> [],[] - | (j,pss) as x::rem as all -> - if i=j then pss,rem - else if j < i then [],all - else - let r,rem = jumps_extract i rem in - r,(x::rem) - -let rec jumps_remove i = function - | [] -> [] - | (j,_)::rem when i=j -> rem - | x::rem -> x::jumps_remove i rem - -let jumps_empty = [] -and jumps_is_empty = function - | [] -> true - | _ -> false - -let jumps_singleton i = function - | [] -> [] - | ctx -> [i,ctx] - -let jumps_add i pss jumps = match pss with -| [] -> jumps -| _ -> - let rec add = function - | [] -> [i,pss] - | (j,qss) as x::rem as all -> - if j > i then x::add rem - else if j < i then (i,pss)::all - else (i,(get_mins le_ctx (pss@qss)))::rem in - add jumps - - -let rec jumps_union (env1:(int*ctx list)list) env2 = match env1,env2 with -| [],_ -> env2 -| _,[] -> env1 -| ((i1,pss1) as x1::rem1), ((i2,pss2) as x2::rem2) -> - if i1=i2 then - (i1,get_mins le_ctx (pss1@pss2))::jumps_union rem1 rem2 - else if i1 > i2 then - x1::jumps_union rem1 env2 - else - x2::jumps_union env1 rem2 - - -let rec merge = function - | env1::env2::rem -> jumps_union env1 env2::merge rem - | envs -> envs - -let rec jumps_unions envs = match envs with - | [] -> [] - | [env] -> env - | _ -> jumps_unions (merge envs) - -let jumps_map f env = - List.map - (fun (i,pss) -> i,f pss) - env - -(* Pattern matching before any compilation *) - -type pattern_matching = - { mutable cases : (pattern list * lambda) list; - args : (lambda * let_kind) list ; - default : (matrix * int) list} - -(* Pattern matching after application of both the or-pat rule and the - mixture rule *) - -type pm_or_compiled = - {body : pattern_matching ; - handlers : - (matrix * int * (Ident.t * Lambda.value_kind) list * pattern_matching) - list; - or_matrix : matrix ; } - -type pm_half_compiled = - | PmOr of pm_or_compiled - | PmVar of pm_var_compiled - | Pm of pattern_matching - -and pm_var_compiled = - {inside : pm_half_compiled ; var_arg : lambda ; } - -type pm_half_compiled_info = - {me : pm_half_compiled ; - matrix : matrix ; - top_default : (matrix * int) list ; } - -let pretty_cases cases = - List.iter - (fun (ps,_l) -> - List.iter - (fun p -> Format.eprintf " %a%!" top_pretty p) - ps ; - Format.eprintf "\n") - cases - -let pretty_def def = - Format.eprintf "+++++ Defaults +++++\n" ; - List.iter - (fun (pss,i) -> Format.eprintf "Matrix for %d\n%a" i pretty_matrix pss) - def ; - Format.eprintf "+++++++++++++++++++++\n" - -let pretty_pm pm = - pretty_cases pm.cases ; - if pm.default <> [] then - pretty_def pm.default - - -let rec pretty_precompiled = function - | Pm pm -> - Format.eprintf "++++ PM ++++\n" ; - pretty_pm pm - | PmVar x -> - Format.eprintf "++++ VAR ++++\n" ; - pretty_precompiled x.inside - | PmOr x -> - Format.eprintf "++++ OR ++++\n" ; - pretty_pm x.body ; - pretty_matrix Format.err_formatter x.or_matrix ; - List.iter - (fun (_,i,_,pm) -> - eprintf "++ Handler %d ++\n" i ; - pretty_pm pm) - x.handlers - -let pretty_precompiled_res first nexts = - pretty_precompiled first ; - List.iter - (fun (e, pmh) -> - eprintf "** DEFAULT %d **\n" e ; - pretty_precompiled pmh) - nexts - - - -(* Identifying some semantically equivalent lambda-expressions, - Our goal here is also to - find alpha-equivalent (simple) terms *) - -(* However, as shown by PR#6359 such sharing may hinders the - lambda-code invariant that all bound idents are unique, - when switches are compiled to test sequences. - The definitive fix is the systematic introduction of exit/catch - in case action sharing is present. -*) - - -module StoreExp = - Switch.Store - (struct - type t = lambda - type key = lambda - let compare_key = Stdlib.compare - let make_key = Lambda.make_key - end) - - -let make_exit i = Lstaticraise (i,[]) - -(* Introduce a catch, if worth it *) -let make_catch d k = match d with -| Lstaticraise (_,[]) -> k d -| _ -> - let e = next_raise_count () in - Lstaticcatch (k (make_exit e),(e,[]),d) - -(* Introduce a catch, if worth it, delayed version *) -let rec as_simple_exit = function - | Lstaticraise (i,[]) -> Some i - | Llet (Alias,_k,_,_,e) -> as_simple_exit e - | _ -> None - - -let make_catch_delayed handler = match as_simple_exit handler with -| Some i -> i,(fun act -> act) -| None -> - let i = next_raise_count () in -(* - Printf.eprintf "SHARE LAMBDA: %i\n%s\n" i (string_of_lam handler); -*) - i, - (fun body -> match body with - | Lstaticraise (j,_) -> - if i=j then handler else body - | _ -> Lstaticcatch (body,(i,[]),handler)) - - -let raw_action l = - match make_key l with | Some l -> l | None -> l - - -let tr_raw act = match make_key act with -| Some act -> act -| None -> raise Exit - -let same_actions = function - | [] -> None - | [_,act] -> Some act - | (_,act0) :: rem -> - try - let raw_act0 = tr_raw act0 in - let rec s_rec = function - | [] -> Some act0 - | (_,act)::rem -> - if raw_act0 = tr_raw act then - s_rec rem - else - None in - s_rec rem - with - | Exit -> None - - -(* Test for swapping two clauses *) - -let up_ok_action act1 act2 = - try - let raw1 = tr_raw act1 - and raw2 = tr_raw act2 in - raw1 = raw2 - with - | Exit -> false - -let up_ok (ps,act_p) l = - List.for_all - (fun (qs,act_q) -> - up_ok_action act_p act_q || not (may_compats ps qs)) - l - -(* - The simplify function normalizes the first column of the match - - records are expanded so that they possess all fields - - aliases are removed and replaced by bindings in actions. - However or-patterns are simplified differently, - - aliases are not removed - - or-patterns (_|p) are changed into _ -*) - -exception Var of pattern - -let simplify_or p = - let rec simpl_rec p = match p with - | {pat_desc = Tpat_any|Tpat_var _} -> raise (Var p) - | {pat_desc = Tpat_alias (q,id,s)} -> - begin try - {p with pat_desc = Tpat_alias (simpl_rec q,id,s)} - with - | Var q -> raise (Var {p with pat_desc = Tpat_alias (q,id,s)}) - end - | {pat_desc = Tpat_or (p1,p2,o)} -> - let q1 = simpl_rec p1 in - begin try - let q2 = simpl_rec p2 in - {p with pat_desc = Tpat_or (q1, q2, o)} - with - | Var q2 -> raise (Var {p with pat_desc = Tpat_or (q1, q2, o)}) - end - | {pat_desc = Tpat_record (lbls,closed)} -> - let all_lbls = all_record_args lbls in - {p with pat_desc=Tpat_record (all_lbls, closed)} - | _ -> p in - try - simpl_rec p - with - | Var p -> p - -let simplify_cases args cls = match args with -| [] -> assert false -| (arg,_)::_ -> - let rec simplify = function - | [] -> [] - | ((pat :: patl, action) as cl) :: rem -> - begin match pat.pat_desc with - | Tpat_var (id, _) -> - let k = Typeopt.value_kind pat.pat_env pat.pat_type in - (omega :: patl, bind_with_value_kind Alias (id, k) arg action) :: - simplify rem - | Tpat_any -> - cl :: simplify rem - | Tpat_alias(p, id,_) -> - let k = Typeopt.value_kind pat.pat_env pat.pat_type in - simplify ((p :: patl, - bind_with_value_kind Alias (id, k) arg action) :: rem) - | Tpat_record ([],_) -> - (omega :: patl, action):: - simplify rem - | Tpat_record (lbls, closed) -> - let all_lbls = all_record_args lbls in - let full_pat = - {pat with pat_desc=Tpat_record (all_lbls, closed)} in - (full_pat::patl,action):: - simplify rem - | Tpat_or _ -> - let pat_simple = simplify_or pat in - begin match pat_simple.pat_desc with - | Tpat_or _ -> - (pat_simple :: patl, action) :: - simplify rem - | _ -> - simplify ((pat_simple::patl,action) :: rem) - end - | _ -> cl :: simplify rem - end - | _ -> assert false in - - simplify cls - - - -(* Once matchings are simplified one can easily find - their nature *) - -let rec what_is_cases cases = match cases with -| ({pat_desc=Tpat_any} :: _, _) :: rem -> what_is_cases rem -| (({pat_desc=(Tpat_var _|Tpat_or (_,_,_)|Tpat_alias (_,_,_))}::_),_)::_ - -> assert false (* applies to simplified matchings only *) -| (p::_,_)::_ -> p -| [] -> omega -| _ -> assert false - - - -(* A few operations on default environments *) -let as_matrix cases = get_mins le_pats (List.map (fun (ps,_) -> ps) cases) - -let cons_default matrix raise_num default = - match matrix with - | [] -> default - | _ -> (matrix,raise_num)::default - -let default_compat p def = - List.fold_right - (fun (pss,i) r -> - let qss = - List.fold_right - (fun qs r -> match qs with - | q::rem when may_compat p q -> rem::r - | _ -> r) - pss [] in - match qss with - | [] -> r - | _ -> (qss,i)::r) - def [] - -(* Or-pattern expansion, variables are a complication w.r.t. the article *) - -exception Cannot_flatten - -let mk_alpha_env arg aliases ids = - List.map - (fun id -> id, - if List.mem id aliases then - match arg with - | Some v -> v - | _ -> raise Cannot_flatten - else - Ident.create_local (Ident.name id)) - ids - -let rec explode_or_pat arg patl mk_action rem vars aliases = function - | {pat_desc = Tpat_or (p1,p2,_)} -> - explode_or_pat - arg patl mk_action - (explode_or_pat arg patl mk_action rem vars aliases p2) - vars aliases p1 - | {pat_desc = Tpat_alias (p,id, _)} -> - explode_or_pat arg patl mk_action rem vars (id::aliases) p - | {pat_desc = Tpat_var (x, _)} -> - let env = mk_alpha_env arg (x::aliases) vars in - (omega::patl,mk_action (List.map snd env))::rem - | p -> - let env = mk_alpha_env arg aliases vars in - (alpha_pat env p::patl,mk_action (List.map snd env))::rem - -let pm_free_variables {cases=cases} = - List.fold_right - (fun (_,act) r -> Ident.Set.union (free_variables act) r) - cases Ident.Set.empty - - -(* Basic grouping predicates *) -let pat_as_constr = function - | {pat_desc=Tpat_construct (_, cstr,_)} -> cstr - | _ -> fatal_error "Matching.pat_as_constr" - -let group_const_int = function - | {pat_desc= Tpat_constant Const_int _ } -> true - | _ -> false - -let group_const_char = function - | {pat_desc= Tpat_constant Const_char _ } -> true - | _ -> false - -let group_const_string = function - | {pat_desc= Tpat_constant Const_string _ } -> true - | _ -> false - -let group_const_float = function - | {pat_desc= Tpat_constant Const_float _ } -> true - | _ -> false - -let group_const_int32 = function - | {pat_desc= Tpat_constant Const_int32 _ } -> true - | _ -> false - -let group_const_int64 = function - | {pat_desc= Tpat_constant Const_int64 _ } -> true - | _ -> false - -let group_const_nativeint = function - | {pat_desc= Tpat_constant Const_nativeint _ } -> true - | _ -> false - -and group_constructor = function - | {pat_desc = Tpat_construct (_,_,_)} -> true - | _ -> false - -and group_variant = function - | {pat_desc = Tpat_variant (_, _, _)} -> true - | _ -> false - -and group_var = function - | {pat_desc=Tpat_any} -> true - | _ -> false - -and group_tuple = function - | {pat_desc = (Tpat_tuple _|Tpat_any)} -> true - | _ -> false - -and group_record = function - | {pat_desc = (Tpat_record _|Tpat_any)} -> true - | _ -> false - -and group_array = function - | {pat_desc=Tpat_array _} -> true - | _ -> false - -and group_lazy = function - | {pat_desc = Tpat_lazy _} -> true - | _ -> false - -let get_group p = match p.pat_desc with -| Tpat_any -> group_var -| Tpat_constant Const_int _ -> group_const_int -| Tpat_constant Const_char _ -> group_const_char -| Tpat_constant Const_string _ -> group_const_string -| Tpat_constant Const_float _ -> group_const_float -| Tpat_constant Const_int32 _ -> group_const_int32 -| Tpat_constant Const_int64 _ -> group_const_int64 -| Tpat_constant Const_nativeint _ -> group_const_nativeint -| Tpat_construct _ -> group_constructor -| Tpat_tuple _ -> group_tuple -| Tpat_record _ -> group_record -| Tpat_array _ -> group_array -| Tpat_variant (_,_,_) -> group_variant -| Tpat_lazy _ -> group_lazy -| _ -> fatal_error "Matching.get_group" - - - -let is_or p = match p.pat_desc with -| Tpat_or _ -> true -| _ -> false - -(* Conditions for appending to the Or matrix *) -let conda p q = not (may_compat p q) -and condb act ps qs = not (is_guarded act) && Parmatch.le_pats qs ps - -let or_ok p ps l = - List.for_all - (function - | ({pat_desc=Tpat_or _} as q::qs,act) -> - conda p q || condb act ps qs - | _ -> true) - l - -(* Insert or append a pattern in the Or matrix *) - -let equiv_pat p q = le_pat p q && le_pat q p - -let rec get_equiv p l = match l with - | (q::_,_) as cl::rem -> - if equiv_pat p q then - let others,rem = get_equiv p rem in - cl::others,rem - else - [],l - | _ -> [],l - - -let insert_or_append p ps act ors no = - let rec attempt seen = function - | (q::qs,act_q) as cl::rem -> - if is_or q then begin - if may_compat p q then - if - Typedtree.pat_bound_idents p = [] && - Typedtree.pat_bound_idents q = [] && - equiv_pat p q - then (* attempt insert, for equivalent orpats with no variables *) - let _, not_e = get_equiv q rem in - if - or_ok p ps not_e && (* check append condition for head of O *) - List.for_all (* check insert condition for tail of O *) - (fun cl -> match cl with - | (q::_,_) -> not (may_compat p q) - | _ -> assert false) - seen - then (* insert *) - List.rev_append seen ((p::ps,act)::cl::rem), no - else (* fail to insert or append *) - ors,(p::ps,act)::no - else if condb act_q ps qs then (* check condition (b) for append *) - attempt (cl::seen) rem - else - ors,(p::ps,act)::no - else (* p # q, go on with append/insert *) - attempt (cl::seen) rem - end else (* q is not an or-pat, go on with append/insert *) - attempt (cl::seen) rem - | _ -> (* [] in fact *) - (p::ps,act)::ors,no in (* success in appending *) - attempt [] ors - -(* Reconstruct default information from half_compiled pm list *) - -let rec rebuild_matrix pmh = match pmh with - | Pm pm -> as_matrix pm.cases - | PmOr {or_matrix=m} -> m - | PmVar x -> add_omega_column (rebuild_matrix x.inside) - -let rec rebuild_default nexts def = match nexts with -| [] -> def -| (e, pmh)::rem -> - (add_omega_column (rebuild_matrix pmh), e):: - rebuild_default rem def - -let rebuild_nexts arg nexts k = - List.fold_right - (fun (e, pm) k -> (e, PmVar {inside=pm ; var_arg=arg})::k) - nexts k - - -(* - Split a matching. - Splitting is first directed by or-patterns, then by - tests (e.g. constructors)/variable transitions. - - The approach is greedy, every split function attempts to - raise rows as much as possible in the top matrix, - then splitting applies again to the remaining rows. - - Some precompilation of or-patterns and - variable pattern occurs. Mostly this means that bindings - are performed now, being replaced by let-bindings - in actions (cf. simplify_cases). - - Additionally, if the match argument is a variable, matchings whose - first column is made of variables only are split further - (cf. precompile_var). - -*) - - -let rec split_or argo cls args def = - - let cls = simplify_cases args cls in - - let rec do_split before ors no = function - | [] -> - cons_next - (List.rev before) (List.rev ors) (List.rev no) - | ((p::ps,act) as cl)::rem -> - if up_ok cl no then - if is_or p then - let ors, no = insert_or_append p ps act ors no in - do_split before ors no rem - else begin - if up_ok cl ors then - do_split (cl::before) ors no rem - else if or_ok p ps ors then - do_split before (cl::ors) no rem - else - do_split before ors (cl::no) rem - end - else - do_split before ors (cl::no) rem - | _ -> assert false - - and cons_next yes yesor = function - | [] -> - precompile_or argo yes yesor args def [] - | rem -> - let {me=next ; matrix=matrix ; top_default=def},nexts = - do_split [] [] [] rem in - let idef = next_raise_count () in - precompile_or - argo yes yesor args - (cons_default matrix idef def) - ((idef,next)::nexts) in - - do_split [] [] [] cls - -(* Ultra-naive splitting, close to semantics, used for extension, - as potential rebind prevents any kind of optimisation *) - -and split_naive cls args def k = - - let rec split_exc cstr0 yes = function - | [] -> - let yes = List.rev yes in - { me = Pm {cases=yes; args=args; default=def;} ; - matrix = as_matrix yes ; - top_default=def}, - k - | (p::_,_ as cl)::rem -> - if group_constructor p then - let cstr = pat_as_constr p in - if cstr = cstr0 then split_exc cstr0 (cl::yes) rem - else - let yes = List.rev yes in - let {me=next ; matrix=matrix ; top_default=def}, nexts = - split_exc cstr [cl] rem in - let idef = next_raise_count () in - let def = cons_default matrix idef def in - { me = Pm {cases=yes; args=args; default=def} ; - matrix = as_matrix yes ; - top_default = def; }, - (idef,next)::nexts - else - let yes = List.rev yes in - let {me=next ; matrix=matrix ; top_default=def}, nexts = - split_noexc [cl] rem in - let idef = next_raise_count () in - let def = cons_default matrix idef def in - { me = Pm {cases=yes; args=args; default=def} ; - matrix = as_matrix yes ; - top_default = def; }, - (idef,next)::nexts - | _ -> assert false - - and split_noexc yes = function - | [] -> precompile_var args (List.rev yes) def k - | (p::_,_ as cl)::rem -> - if group_constructor p then - let yes= List.rev yes in - let {me=next; matrix=matrix; top_default=def;},nexts = - split_exc (pat_as_constr p) [cl] rem in - let idef = next_raise_count () in - precompile_var - args yes - (cons_default matrix idef def) - ((idef,next)::nexts) - else split_noexc (cl::yes) rem - | _ -> assert false in - - match cls with - | [] -> assert false - | (p::_,_ as cl)::rem -> - if group_constructor p then - split_exc (pat_as_constr p) [cl] rem - else - split_noexc [cl] rem - | _ -> assert false - -and split_constr cls args def k = - let ex_pat = what_is_cases cls in - match ex_pat.pat_desc with - | Tpat_any -> precompile_var args cls def k - | Tpat_construct (_,{cstr_tag=Cstr_extension _},_) -> - split_naive cls args def k - | _ -> - - let group = get_group ex_pat in - - let rec split_ex yes no = function - | [] -> - let yes = List.rev yes and no = List.rev no in - begin match no with - | [] -> - {me = Pm {cases=yes ; args=args ; default=def} ; - matrix = as_matrix yes ; - top_default = def}, - k - | cl::rem -> - begin match yes with - | [] -> - (* Could not success in raising up a constr matching up *) - split_noex [cl] [] rem - | _ -> - let {me=next ; matrix=matrix ; top_default=def}, nexts = - split_noex [cl] [] rem in - let idef = next_raise_count () in - let def = cons_default matrix idef def in - {me = Pm {cases=yes ; args=args ; default=def} ; - matrix = as_matrix yes ; - top_default = def }, - (idef, next)::nexts - end - end - | (p::_,_) as cl::rem -> - if group p && up_ok cl no then - split_ex (cl::yes) no rem - else - split_ex yes (cl::no) rem - | _ -> assert false - - and split_noex yes no = function - | [] -> - let yes = List.rev yes and no = List.rev no in - begin match no with - | [] -> precompile_var args yes def k - | cl::rem -> - let {me=next ; matrix=matrix ; top_default=def}, nexts = - split_ex [cl] [] rem in - let idef = next_raise_count () in - precompile_var - args yes - (cons_default matrix idef def) - ((idef,next)::nexts) - end - | [ps,_ as cl] - when List.for_all group_var ps && yes <> [] -> - (* This enables an extra division in some frequent cases : - last row is made of variables only *) - split_noex yes (cl::no) [] - | (p::_,_) as cl::rem -> - if not (group p) && up_ok cl no then - split_noex (cl::yes) no rem - else - split_noex yes (cl::no) rem - | _ -> assert false in - - match cls with - | ((p::_,_) as cl)::rem -> - if group p then split_ex [cl] [] rem - else split_noex [cl] [] rem - | _ -> assert false - -and precompile_var args cls def k = match args with -| [] -> assert false -| _::((Lvar v as av,_) as arg)::rargs -> - begin match cls with - | [_] -> (* as split as it can *) - dont_precompile_var args cls def k - | _ -> -(* Precompile *) - let var_cls = - List.map - (fun (ps,act) -> match ps with - | _::ps -> ps,act | _ -> assert false) - cls - and var_def = make_default (fun _ rem -> rem) def in - let {me=first ; matrix=matrix}, nexts = - split_or (Some v) var_cls (arg::rargs) var_def in - -(* Compute top information *) - match nexts with - | [] -> (* If you need *) - dont_precompile_var args cls def k - | _ -> - let rfirst = - {me = PmVar {inside=first ; var_arg = av} ; - matrix = add_omega_column matrix ; - top_default = rebuild_default nexts def ; } - and rnexts = rebuild_nexts av nexts k in - rfirst, rnexts - end -| _ -> - dont_precompile_var args cls def k - -and dont_precompile_var args cls def k = - {me = Pm {cases = cls ; args = args ; default = def } ; - matrix=as_matrix cls ; - top_default=def},k - -and precompile_or argo cls ors args def k = match ors with -| [] -> split_constr cls args def k -| _ -> - let rec do_cases = function - | ({pat_desc=Tpat_or _} as orp::patl, action)::rem -> - let others,rem = get_equiv orp rem in - let orpm = - {cases = - (patl, action):: - List.map - (function - | (_::ps,action) -> ps,action - | _ -> assert false) - others ; - args = (match args with _::r -> r | _ -> assert false) ; - default = default_compat orp def} in - let pm_fv = pm_free_variables orpm in - let vars = - Typedtree.pat_bound_idents_full orp - |> List.filter (fun (id, _, _) -> Ident.Set.mem id pm_fv) - |> List.map (fun (id,_,ty) -> id,Typeopt.value_kind orp.pat_env ty) - in - let or_num = next_raise_count () in - let new_patl = Parmatch.omega_list patl in - - let mk_new_action vs = - Lstaticraise - (or_num, List.map (fun v -> Lvar v) vs) in - - let body,handlers = do_cases rem in - explode_or_pat - argo new_patl mk_new_action body (List.map fst vars) [] orp, - let mat = [[orp]] in - ((mat, or_num, vars , orpm):: handlers) - | cl::rem -> - let new_ord,new_to_catch = do_cases rem in - cl::new_ord,new_to_catch - | [] -> [],[] in - - let end_body, handlers = do_cases ors in - let matrix = as_matrix (cls@ors) - and body = {cases=cls@end_body ; args=args ; default=def} in - {me = PmOr {body=body ; handlers=handlers ; or_matrix=matrix} ; - matrix=matrix ; - top_default=def}, - k - -let split_precompile argo pm = - let {me=next}, nexts = split_or argo pm.cases pm.args pm.default in - if dbg && (nexts <> [] || (match next with PmOr _ -> true | _ -> false)) - then begin - Format.eprintf "** SPLIT **\n" ; - pretty_pm pm ; - pretty_precompiled_res next nexts - end ; - next, nexts - - -(* General divide functions *) - -let add_line patl_action pm = pm.cases <- patl_action :: pm.cases; pm - -type cell = - {pm : pattern_matching ; - ctx : ctx list ; - pat : pattern} - -let add make_matching_fun division eq_key key patl_action args = - try - let (_,cell) = List.find (fun (k,_) -> eq_key key k) division in - cell.pm.cases <- patl_action :: cell.pm.cases; - division - with Not_found -> - let cell = make_matching_fun args in - cell.pm.cases <- [patl_action] ; - (key, cell) :: division - - -let divide make eq_key get_key get_args ctx pm = - - let rec divide_rec = function - | (p::patl,action) :: rem -> - let this_match = divide_rec rem in - add - (make p pm.default ctx) - this_match eq_key (get_key p) (get_args p patl,action) pm.args - | _ -> [] in - - divide_rec pm.cases - - -let divide_line make_ctx make get_args pat ctx pm = - let rec divide_rec = function - | (p::patl,action) :: rem -> - let this_match = divide_rec rem in - add_line (get_args p patl, action) this_match - | _ -> make pm.default pm.args in - - {pm = divide_rec pm.cases ; - ctx=make_ctx ctx ; - pat=pat} - - - -(* Then come various functions, - There is one set of functions per matching style - (constants, constructors etc.) - - - matcher functions are arguments to make_default (for default handlers) - They may raise NoMatch or OrPat and perform the full - matching (selection + arguments). - - - - get_args and get_key are for the compiled matrices, note that - selection and getting arguments are separated. - - - make_ _matching combines the previous functions for producing - new ``pattern_matching'' records. -*) - - - -let rec matcher_const cst p rem = match p.pat_desc with -| Tpat_or (p1,p2,_) -> - begin try - matcher_const cst p1 rem with - | NoMatch -> matcher_const cst p2 rem - end -| Tpat_constant c1 when const_compare c1 cst = 0 -> rem -| Tpat_any -> rem -| _ -> raise NoMatch - -let get_key_constant caller = function - | {pat_desc= Tpat_constant cst} -> cst - | p -> - Format.eprintf "BAD: %s" caller ; - pretty_pat p ; - assert false - -let get_args_constant _ rem = rem - -let make_constant_matching p def ctx = function - [] -> fatal_error "Matching.make_constant_matching" - | (_ :: argl) -> - let def = - make_default - (matcher_const (get_key_constant "make" p)) def - and ctx = - filter_ctx p ctx in - {pm = {cases = []; args = argl ; default = def} ; - ctx = ctx ; - pat = normalize_pat p} - - - - -let divide_constant ctx m = - divide - make_constant_matching - (fun c d -> const_compare c d = 0) (get_key_constant "divide") - get_args_constant - ctx m - -(* Matching against a constructor *) - - -let make_field_args loc binding_kind arg first_pos last_pos argl = - let rec make_args pos = - if pos > last_pos - then argl - else (Lprim(Pfield pos, [arg], loc), binding_kind) :: make_args (pos + 1) - in make_args first_pos - -let get_key_constr = function - | {pat_desc=Tpat_construct (_, cstr,_)} -> cstr.cstr_tag - | _ -> assert false - -let get_args_constr p rem = match p with -| {pat_desc=Tpat_construct (_, _, args)} -> args @ rem -| _ -> assert false - -(* NB: matcher_constr applies to default matrices. - - In that context, matching by constructors of extensible - types degrades to arity checking, due to potential rebinding. - This comparison is performed by Types.may_equal_constr. -*) - -let matcher_constr cstr = match cstr.cstr_arity with -| 0 -> - let rec matcher_rec q rem = match q.pat_desc with - | Tpat_or (p1,p2,_) -> - begin - try matcher_rec p1 rem - with NoMatch -> matcher_rec p2 rem - end - | Tpat_construct (_, cstr',[]) - when Types.may_equal_constr cstr cstr' -> rem - | Tpat_any -> rem - | _ -> raise NoMatch in - matcher_rec -| 1 -> - let rec matcher_rec q rem = match q.pat_desc with - | Tpat_or (p1,p2,_) -> - let r1 = try Some (matcher_rec p1 rem) with NoMatch -> None - and r2 = try Some (matcher_rec p2 rem) with NoMatch -> None in - begin match r1,r2 with - | None, None -> raise NoMatch - | Some r1, None -> r1 - | None, Some r2 -> r2 - | Some (a1::_), Some (a2::_) -> - {a1 with - pat_loc = Location.none ; - pat_desc = Tpat_or (a1, a2, None)}:: - rem - | _, _ -> assert false - end - | Tpat_construct (_, cstr', [arg]) - when Types.may_equal_constr cstr cstr' -> arg::rem - | Tpat_any -> omega::rem - | _ -> raise NoMatch in - matcher_rec -| _ -> - fun q rem -> match q.pat_desc with - | Tpat_or (_,_,_) -> raise OrPat - | Tpat_construct (_,cstr',args) - when Types.may_equal_constr cstr cstr' -> args @ rem - | Tpat_any -> Parmatch.omegas cstr.cstr_arity @ rem - | _ -> raise NoMatch - -let make_constr_matching p def ctx = function - [] -> fatal_error "Matching.make_constr_matching" - | ((arg, _mut) :: argl) -> - let cstr = pat_as_constr p in - let newargs = - if cstr.cstr_inlined <> None then - (arg, Alias) :: argl - else match cstr.cstr_tag with - Cstr_constant _ | Cstr_block _ -> - make_field_args p.pat_loc Alias arg 0 (cstr.cstr_arity - 1) argl - | Cstr_unboxed -> (arg, Alias) :: argl - | Cstr_extension _ -> - make_field_args p.pat_loc Alias arg 1 cstr.cstr_arity argl in - {pm= - {cases = []; args = newargs; - default = make_default (matcher_constr cstr) def} ; - ctx = filter_ctx p ctx ; - pat=normalize_pat p} - - -let divide_constructor ctx pm = - divide - make_constr_matching - (=) get_key_constr get_args_constr - ctx pm - -(* Matching against a variant *) - -let rec matcher_variant_const lab p rem = match p.pat_desc with -| Tpat_or (p1, p2, _) -> - begin - try - matcher_variant_const lab p1 rem - with - | NoMatch -> matcher_variant_const lab p2 rem - end -| Tpat_variant (lab1,_,_) when lab1=lab -> rem -| Tpat_any -> rem -| _ -> raise NoMatch - - -let make_variant_matching_constant p lab def ctx = function - [] -> fatal_error "Matching.make_variant_matching_constant" - | (_ :: argl) -> - let def = make_default (matcher_variant_const lab) def - and ctx = filter_ctx p ctx in - {pm={ cases = []; args = argl ; default=def} ; - ctx=ctx ; - pat = normalize_pat p} - -let matcher_variant_nonconst lab p rem = match p.pat_desc with -| Tpat_or (_,_,_) -> raise OrPat -| Tpat_variant (lab1,Some arg,_) when lab1=lab -> arg::rem -| Tpat_any -> omega::rem -| _ -> raise NoMatch - - -let make_variant_matching_nonconst p lab def ctx = function - [] -> fatal_error "Matching.make_variant_matching_nonconst" - | ((arg, _mut) :: argl) -> - let def = make_default (matcher_variant_nonconst lab) def - and ctx = filter_ctx p ctx in - {pm= - {cases = []; args = (Lprim(Pfield 1, [arg], p.pat_loc), Alias) :: argl; - default=def} ; - ctx=ctx ; - pat = normalize_pat p} - -let divide_variant row ctx {cases = cl; args = al; default=def} = - let row = Btype.row_repr row in - let rec divide = function - ({pat_desc = Tpat_variant(lab, pato, _)} as p:: patl, action) :: rem -> - let variants = divide rem in - if try Btype.row_field_repr (List.assoc lab row.row_fields) = Rabsent - with Not_found -> true - then - variants - else begin - let tag = Btype.hash_variant lab in - match pato with - None -> - add (make_variant_matching_constant p lab def ctx) variants - (=) (Cstr_constant tag) (patl, action) al - | Some pat -> - add (make_variant_matching_nonconst p lab def ctx) variants - (=) (Cstr_block tag) (pat :: patl, action) al - end - | _ -> [] - in - divide cl - -(* - Three ``no-test'' cases - *) - -(* Matching against a variable *) - -let get_args_var _ rem = rem - - -let make_var_matching def = function - | [] -> fatal_error "Matching.make_var_matching" - | _::argl -> - {cases=[] ; - args = argl ; - default= make_default get_args_var def} - -let divide_var ctx pm = - divide_line ctx_lshift make_var_matching get_args_var omega ctx pm - -(* Matching and forcing a lazy value *) - -let get_arg_lazy p rem = match p with -| {pat_desc = Tpat_any} -> omega :: rem -| {pat_desc = Tpat_lazy arg} -> arg :: rem -| _ -> assert false - -let matcher_lazy p rem = match p.pat_desc with -| Tpat_or (_,_,_) -> raise OrPat -| Tpat_any -| Tpat_var _ -> omega :: rem -| Tpat_lazy arg -> arg :: rem -| _ -> raise NoMatch - -(* Inlining the tag tests before calling the primitive that works on - lazy blocks. This is also used in translcore.ml. - No other call than Obj.tag when the value has been forced before. -*) - -let prim_obj_tag = - Primitive.simple ~name:"caml_obj_tag" ~arity:1 ~alloc:false - -let get_mod_field modname field = - lazy ( - let mod_ident = Ident.create_persistent modname in - let env = Env.add_persistent_structure mod_ident Env.initial_safe_string in - match Env.open_pers_signature modname env with - | exception Not_found -> fatal_error ("Module "^modname^" unavailable.") - | env -> begin - match Env.lookup_value (Longident.Lident field) env with - | exception Not_found -> - fatal_error ("Primitive "^modname^"."^field^" not found.") - | (path, _) -> transl_value_path Location.none env path - end - ) - -let code_force_lazy_block = - get_mod_field "CamlinternalLazy" "force_lazy_block" -let code_force_lazy = - get_mod_field "CamlinternalLazy" "force" -;; - -(* inline_lazy_force inlines the beginning of the code of Lazy.force. When - the value argument is tagged as: - - forward, take field 0 - - lazy, call the primitive that forces (without testing again the tag) - - anything else, return it - - Using Lswitch below relies on the fact that the GC does not shortcut - Forward(val_out_of_heap). -*) - -let inline_lazy_force_cond arg loc = - let idarg = Ident.create_local "lzarg" in - let varg = Lvar idarg in - let tag = Ident.create_local "tag" in - let force_fun = Lazy.force code_force_lazy_block in - Llet(Strict, Pgenval, idarg, arg, - Llet(Alias, Pgenval, tag, Lprim(Pccall prim_obj_tag, [varg], loc), - Lifthenelse( - (* if (tag == Obj.forward_tag) then varg.(0) else ... *) - Lprim(Pintcomp Ceq, - [Lvar tag; Lconst(Const_base(Const_int Obj.forward_tag))], - loc), - Lprim(Pfield 0, [varg], loc), - Lifthenelse( - (* ... if (tag == Obj.lazy_tag) then Lazy.force varg else ... *) - Lprim(Pintcomp Ceq, - [Lvar tag; Lconst(Const_base(Const_int Obj.lazy_tag))], - loc), - Lapply{ap_should_be_tailcall=false; - ap_loc=loc; - ap_func=force_fun; - ap_args=[varg]; - ap_inlined=Default_inline; - ap_specialised=Default_specialise}, - (* ... arg *) - varg)))) - -let inline_lazy_force_switch arg loc = - let idarg = Ident.create_local "lzarg" in - let varg = Lvar idarg in - let force_fun = Lazy.force code_force_lazy_block in - Llet(Strict, Pgenval, idarg, arg, - Lifthenelse( - Lprim(Pisint, [varg], loc), varg, - (Lswitch - (varg, - { sw_numconsts = 0; sw_consts = []; - sw_numblocks = 256; (* PR#6033 - tag ranges from 0 to 255 *) - sw_blocks = - [ (Obj.forward_tag, Lprim(Pfield 0, [varg], loc)); - (Obj.lazy_tag, - Lapply{ap_should_be_tailcall=false; - ap_loc=loc; - ap_func=force_fun; - ap_args=[varg]; - ap_inlined=Default_inline; - ap_specialised=Default_specialise}) ]; - sw_failaction = Some varg }, loc )))) - -let inline_lazy_force arg loc = - if !Clflags.afl_instrument then - (* Disable inlining optimisation if AFL instrumentation active, - so that the GC forwarding optimisation is not visible in the - instrumentation output. - (see https://github.com/stedolan/crowbar/issues/14) *) - Lapply{ap_should_be_tailcall = false; - ap_loc=loc; - ap_func=Lazy.force code_force_lazy; - ap_args=[arg]; - ap_inlined=Default_inline; - ap_specialised=Default_specialise} - else - if !Clflags.native_code then - (* Lswitch generates compact and efficient native code *) - inline_lazy_force_switch arg loc - else - (* generating bytecode: Lswitch would generate too many rather big - tables (~ 250 elts); conditionals are better *) - inline_lazy_force_cond arg loc - -let make_lazy_matching def = function - [] -> fatal_error "Matching.make_lazy_matching" - | (arg,_mut) :: argl -> - { cases = []; - args = - (inline_lazy_force arg Location.none, Strict) :: argl; - default = make_default matcher_lazy def } - -let divide_lazy p ctx pm = - divide_line - (filter_ctx p) - make_lazy_matching - get_arg_lazy - p ctx pm - -(* Matching against a tuple pattern *) - - -let get_args_tuple arity p rem = match p with -| {pat_desc = Tpat_any} -> omegas arity @ rem -| {pat_desc = Tpat_tuple args} -> - args @ rem -| _ -> assert false - -let matcher_tuple arity p rem = match p.pat_desc with -| Tpat_or (_,_,_) -> raise OrPat -| Tpat_any -| Tpat_var _ -> omegas arity @ rem -| Tpat_tuple args when List.length args = arity -> args @ rem -| _ -> raise NoMatch - -let make_tuple_matching loc arity def = function - [] -> fatal_error "Matching.make_tuple_matching" - | (arg, _mut) :: argl -> - let rec make_args pos = - if pos >= arity - then argl - else (Lprim(Pfield pos, [arg], loc), Alias) :: make_args (pos + 1) in - {cases = []; args = make_args 0 ; - default=make_default (matcher_tuple arity) def} - - -let divide_tuple arity p ctx pm = - divide_line - (filter_ctx p) - (make_tuple_matching p.pat_loc arity) - (get_args_tuple arity) p ctx pm - -(* Matching against a record pattern *) - - -let record_matching_line num_fields lbl_pat_list = - let patv = Array.make num_fields omega in - List.iter (fun (_, lbl, pat) -> patv.(lbl.lbl_pos) <- pat) lbl_pat_list; - Array.to_list patv - -let get_args_record num_fields p rem = match p with -| {pat_desc=Tpat_any} -> - record_matching_line num_fields [] @ rem -| {pat_desc=Tpat_record (lbl_pat_list,_)} -> - record_matching_line num_fields lbl_pat_list @ rem -| _ -> assert false - -let matcher_record num_fields p rem = match p.pat_desc with -| Tpat_or (_,_,_) -> raise OrPat -| Tpat_any -| Tpat_var _ -> - record_matching_line num_fields [] @ rem -| Tpat_record ([], _) when num_fields = 0 -> rem -| Tpat_record ((_, lbl, _) :: _ as lbl_pat_list, _) - when Array.length lbl.lbl_all = num_fields -> - record_matching_line num_fields lbl_pat_list @ rem -| _ -> raise NoMatch - -let make_record_matching loc all_labels def = function - [] -> fatal_error "Matching.make_record_matching" - | ((arg, _mut) :: argl) -> - let rec make_args pos = - if pos >= Array.length all_labels then argl else begin - let lbl = all_labels.(pos) in - let access = - match lbl.lbl_repres with - | Record_regular | Record_inlined _ -> - Lprim (Pfield lbl.lbl_pos, [arg], loc) - | Record_unboxed _ -> arg - | Record_float -> Lprim (Pfloatfield lbl.lbl_pos, [arg], loc) - | Record_extension _ -> Lprim (Pfield (lbl.lbl_pos + 1), [arg], loc) - in - let str = - match lbl.lbl_mut with - Immutable -> Alias - | Mutable -> StrictOpt in - (access, str) :: make_args(pos + 1) - end in - let nfields = Array.length all_labels in - let def= make_default (matcher_record nfields) def in - {cases = []; args = make_args 0 ; default = def} - - -let divide_record all_labels p ctx pm = - let get_args = get_args_record (Array.length all_labels) in - divide_line - (filter_ctx p) - (make_record_matching p.pat_loc all_labels) - get_args - p ctx pm - -(* Matching against an array pattern *) - -let get_key_array = function - | {pat_desc=Tpat_array patl} -> List.length patl - | _ -> assert false - -let get_args_array p rem = match p with -| {pat_desc=Tpat_array patl} -> patl@rem -| _ -> assert false - -let matcher_array len p rem = match p.pat_desc with -| Tpat_or (_,_,_) -> raise OrPat -| Tpat_array args when List.length args=len -> args @ rem -| Tpat_any -> Parmatch.omegas len @ rem -| _ -> raise NoMatch - -let make_array_matching kind p def ctx = function - | [] -> fatal_error "Matching.make_array_matching" - | ((arg, _mut) :: argl) -> - let len = get_key_array p in - let rec make_args pos = - if pos >= len - then argl - else (Lprim(Parrayrefu kind, - [arg; Lconst(Const_base(Const_int pos))], - p.pat_loc), - StrictOpt) :: make_args (pos + 1) in - let def = make_default (matcher_array len) def - and ctx = filter_ctx p ctx in - {pm={cases = []; args = make_args 0 ; default = def} ; - ctx=ctx ; - pat = normalize_pat p} - -let divide_array kind ctx pm = - divide - (make_array_matching kind) - (=) get_key_array get_args_array ctx pm - - -(* - Specific string test sequence - Will be called by the bytecode compiler, from bytegen.ml. - The strategy is first dichotomic search (we perform 3-way tests - with compare_string), then sequence of equality tests - when there are less then T=strings_test_threshold static strings to match. - - Increasing T entails (slightly) less code, decreasing T - (slightly) favors runtime speed. - T=8 looks a decent tradeoff. -*) - -(* Utilities *) - -let strings_test_threshold = 8 - -let prim_string_notequal = - Pccall(Primitive.simple - ~name:"caml_string_notequal" - ~arity:2 - ~alloc:false) - -let prim_string_compare = - Pccall(Primitive.simple - ~name:"caml_string_compare" - ~arity:2 - ~alloc:false) - -let bind_sw arg k = match arg with -| Lvar _ -> k arg -| _ -> - let id = Ident.create_local "switch" in - Llet (Strict,Pgenval,id,arg,k (Lvar id)) - - -(* Sequential equality tests *) - -let make_string_test_sequence loc arg sw d = - let d,sw = match d with - | None -> - begin match sw with - | (_,d)::sw -> d,sw - | [] -> assert false - end - | Some d -> d,sw in - bind_sw arg - (fun arg -> - List.fold_right - (fun (s,lam) k -> - Lifthenelse - (Lprim - (prim_string_notequal, - [arg; Lconst (Const_immstring s)], loc), - k,lam)) - sw d) - -let rec split k xs = match xs with -| [] -> assert false -| x0::xs -> - if k <= 1 then [],x0,xs - else - let xs,y0,ys = split (k-2) xs in - x0::xs,y0,ys - -let zero_lam = Lconst (Const_base (Const_int 0)) - -let tree_way_test loc arg lt eq gt = - Lifthenelse - (Lprim (Pintcomp Clt,[arg;zero_lam], loc),lt, - Lifthenelse(Lprim (Pintcomp Clt,[zero_lam;arg], loc),gt,eq)) - -(* Dichotomic tree *) - - -let rec do_make_string_test_tree loc arg sw delta d = - let len = List.length sw in - if len <= strings_test_threshold+delta then - make_string_test_sequence loc arg sw d - else - let lt,(s,act),gt = split len sw in - bind_sw - (Lprim - (prim_string_compare, - [arg; Lconst (Const_immstring s)], loc)) - (fun r -> - tree_way_test loc r - (do_make_string_test_tree loc arg lt delta d) - act - (do_make_string_test_tree loc arg gt delta d)) - -(* Entry point *) -let expand_stringswitch loc arg sw d = match d with -| None -> - bind_sw arg - (fun arg -> do_make_string_test_tree loc arg sw 0 None) -| Some e -> - bind_sw arg - (fun arg -> - make_catch e - (fun d -> do_make_string_test_tree loc arg sw 1 (Some d))) - -(**********************) -(* Generic test trees *) -(**********************) - -(* Sharing *) - -(* Add handler, if shared *) -let handle_shared () = - let hs = ref (fun x -> x) in - let handle_shared act = match act with - | Switch.Single act -> act - | Switch.Shared act -> - let i,h = make_catch_delayed act in - let ohs = !hs in - hs := (fun act -> h (ohs act)) ; - make_exit i in - hs,handle_shared - - -let share_actions_tree sw d = - let store = StoreExp.mk_store () in -(* Default action is always shared *) - let d = - match d with - | None -> None - | Some d -> Some (store.Switch.act_store_shared () d) in -(* Store all other actions *) - let sw = - List.map (fun (cst,act) -> cst,store.Switch.act_store () act) sw in - -(* Retrieve all actions, including potential default *) - let acts = store.Switch.act_get_shared () in - -(* Array of actual actions *) - let hs,handle_shared = handle_shared () in - let acts = Array.map handle_shared acts in - -(* Reconstruct default and switch list *) - let d = match d with - | None -> None - | Some d -> Some (acts.(d)) in - let sw = List.map (fun (cst,j) -> cst,acts.(j)) sw in - !hs,sw,d - -(* Note: dichotomic search requires sorted input with no duplicates *) -let rec uniq_lambda_list sw = match sw with - | []|[_] -> sw - | (c1,_ as p1)::((c2,_)::sw2 as sw1) -> - if const_compare c1 c2 = 0 then uniq_lambda_list (p1::sw2) - else p1::uniq_lambda_list sw1 - -let sort_lambda_list l = - let l = - List.stable_sort (fun (x,_) (y,_) -> const_compare x y) l in - uniq_lambda_list l - -let rec cut n l = - if n = 0 then [],l - else match l with - [] -> raise (Invalid_argument "cut") - | a::l -> let l1,l2 = cut (n-1) l in a::l1, l2 - -let rec do_tests_fail loc fail tst arg = function - | [] -> fail - | (c, act)::rem -> - Lifthenelse - (Lprim (tst, [arg ; Lconst (Const_base c)], loc), - do_tests_fail loc fail tst arg rem, - act) - -let rec do_tests_nofail loc tst arg = function - | [] -> fatal_error "Matching.do_tests_nofail" - | [_,act] -> act - | (c,act)::rem -> - Lifthenelse - (Lprim (tst, [arg ; Lconst (Const_base c)], loc), - do_tests_nofail loc tst arg rem, - act) - -let make_test_sequence loc fail tst lt_tst arg const_lambda_list = - let const_lambda_list = sort_lambda_list const_lambda_list in - let hs,const_lambda_list,fail = - share_actions_tree const_lambda_list fail in - - let rec make_test_sequence const_lambda_list = - if List.length const_lambda_list >= 4 && lt_tst <> Pignore then - split_sequence const_lambda_list - else match fail with - | None -> do_tests_nofail loc tst arg const_lambda_list - | Some fail -> do_tests_fail loc fail tst arg const_lambda_list - - and split_sequence const_lambda_list = - let list1, list2 = - cut (List.length const_lambda_list / 2) const_lambda_list in - Lifthenelse(Lprim(lt_tst, - [arg; Lconst(Const_base (fst(List.hd list2)))], - loc), - make_test_sequence list1, make_test_sequence list2) - in - hs (make_test_sequence const_lambda_list) - - -module SArg = struct - type primitive = Lambda.primitive - - let eqint = Pintcomp Ceq - let neint = Pintcomp Cne - let leint = Pintcomp Cle - let ltint = Pintcomp Clt - let geint = Pintcomp Cge - let gtint = Pintcomp Cgt - - type act = Lambda.lambda - - let make_prim p args = Lprim (p,args,Location.none) - let make_offset arg n = match n with - | 0 -> arg - | _ -> Lprim (Poffsetint n,[arg],Location.none) - - let bind arg body = - let newvar,newarg = match arg with - | Lvar v -> v,arg - | _ -> - let newvar = Ident.create_local "switcher" in - newvar,Lvar newvar in - bind Alias newvar arg (body newarg) - let make_const i = Lconst (Const_base (Const_int i)) - let make_isout h arg = Lprim (Pisout, [h ; arg],Location.none) - let make_isin h arg = Lprim (Pnot,[make_isout h arg],Location.none) - let make_if cond ifso ifnot = Lifthenelse (cond, ifso, ifnot) - let make_switch loc arg cases acts = - let l = ref [] in - for i = Array.length cases-1 downto 0 do - l := (i,acts.(cases.(i))) :: !l - done ; - Lswitch(arg, - {sw_numconsts = Array.length cases ; sw_consts = !l ; - sw_numblocks = 0 ; sw_blocks = [] ; - sw_failaction = None}, loc) - let make_catch = make_catch_delayed - let make_exit = make_exit - -end - -(* Action sharing for Lswitch argument *) -let share_actions_sw sw = -(* Attempt sharing on all actions *) - let store = StoreExp.mk_store () in - let fail = match sw.sw_failaction with - | None -> None - | Some fail -> - (* Fail is translated to exit, whatever happens *) - Some (store.Switch.act_store_shared () fail) in - let consts = - List.map - (fun (i,e) -> i,store.Switch.act_store () e) - sw.sw_consts - and blocks = - List.map - (fun (i,e) -> i,store.Switch.act_store () e) - sw.sw_blocks in - let acts = store.Switch.act_get_shared () in - let hs,handle_shared = handle_shared () in - let acts = Array.map handle_shared acts in - let fail = match fail with - | None -> None - | Some fail -> Some (acts.(fail)) in - !hs, - { sw with - sw_consts = List.map (fun (i,j) -> i,acts.(j)) consts ; - sw_blocks = List.map (fun (i,j) -> i,acts.(j)) blocks ; - sw_failaction = fail; } - -(* Reintroduce fail action in switch argument, - for the sake of avoiding carrying over huge switches *) - -let reintroduce_fail sw = match sw.sw_failaction with -| None -> - let t = Hashtbl.create 17 in - let seen (_,l) = match as_simple_exit l with - | Some i -> - let old = try Hashtbl.find t i with Not_found -> 0 in - Hashtbl.replace t i (old+1) - | None -> () in - List.iter seen sw.sw_consts ; - List.iter seen sw.sw_blocks ; - let i_max = ref (-1) - and max = ref (-1) in - Hashtbl.iter - (fun i c -> - if c > !max then begin - i_max := i ; - max := c - end) t ; - if !max >= 3 then - let default = !i_max in - let remove = - List.filter - (fun (_,lam) -> match as_simple_exit lam with - | Some j -> j <> default - | None -> true) in - {sw with - sw_consts = remove sw.sw_consts ; - sw_blocks = remove sw.sw_blocks ; - sw_failaction = Some (make_exit default)} - else sw -| Some _ -> sw - - -module Switcher = Switch.Make(SArg) -open Switch - -let rec last def = function - | [] -> def - | [x,_] -> x - | _::rem -> last def rem - -let get_edges low high l = match l with -| [] -> low, high -| (x,_)::_ -> x, last high l - - -let as_interval_canfail fail low high l = - let store = StoreExp.mk_store () in - - let do_store _tag act = - - let i = store.act_store () act in -(* - eprintf "STORE [%s] %i %s\n" tag i (string_of_lam act) ; -*) - i in - - let rec nofail_rec cur_low cur_high cur_act = function - | [] -> - if cur_high = high then - [cur_low,cur_high,cur_act] - else - [(cur_low,cur_high,cur_act) ; (cur_high+1,high, 0)] - | ((i,act_i)::rem) as all -> - let act_index = do_store "NO" act_i in - if cur_high+1= i then - if act_index=cur_act then - nofail_rec cur_low i cur_act rem - else if act_index=0 then - (cur_low,i-1, cur_act)::fail_rec i i rem - else - (cur_low, i-1, cur_act)::nofail_rec i i act_index rem - else if act_index = 0 then - (cur_low, cur_high, cur_act):: - fail_rec (cur_high+1) (cur_high+1) all - else - (cur_low, cur_high, cur_act):: - (cur_high+1,i-1,0):: - nofail_rec i i act_index rem - - and fail_rec cur_low cur_high = function - | [] -> [(cur_low, cur_high, 0)] - | (i,act_i)::rem -> - let index = do_store "YES" act_i in - if index=0 then fail_rec cur_low i rem - else - (cur_low,i-1,0):: - nofail_rec i i index rem in - - let init_rec = function - | [] -> [low,high,0] - | (i,act_i)::rem -> - let index = do_store "INIT" act_i in - if index=0 then - fail_rec low i rem - else - if low < i then - (low,i-1,0)::nofail_rec i i index rem - else - nofail_rec i i index rem in - - assert (do_store "FAIL" fail = 0) ; (* fail has action index 0 *) - let r = init_rec l in - Array.of_list r, store - -let as_interval_nofail l = - let store = StoreExp.mk_store () in - let rec some_hole = function - | []|[_] -> false - | (i,_)::((j,_)::_ as rem) -> - j > i+1 || some_hole rem in - let rec i_rec cur_low cur_high cur_act = function - | [] -> - [cur_low, cur_high, cur_act] - | (i,act)::rem -> - let act_index = store.act_store () act in - if act_index = cur_act then - i_rec cur_low i cur_act rem - else - (cur_low, cur_high, cur_act):: - i_rec i i act_index rem in - let inters = match l with - | (i,act)::rem -> - let act_index = - (* In case there is some hole and that a switch is emitted, - action 0 will be used as the action of unreachable - cases (cf. switch.ml, make_switch). - Hence, this action will be shared *) - if some_hole rem then - store.act_store_shared () act - else - store.act_store () act in - assert (act_index = 0) ; - i_rec i i act_index rem - | _ -> assert false in - - Array.of_list inters, store - - -let sort_int_lambda_list l = - List.sort - (fun (i1,_) (i2,_) -> - if i1 < i2 then -1 - else if i2 < i1 then 1 - else 0) - l - -let as_interval fail low high l = - let l = sort_int_lambda_list l in - get_edges low high l, - (match fail with - | None -> as_interval_nofail l - | Some act -> as_interval_canfail act low high l) - -let call_switcher loc fail arg low high int_lambda_list = - let edges, (cases, actions) = - as_interval fail low high int_lambda_list in - Switcher.zyva loc edges arg cases actions - - -let rec list_as_pat = function - | [] -> fatal_error "Matching.list_as_pat" - | [pat] -> pat - | pat::rem -> - {pat with pat_desc = Tpat_or (pat,list_as_pat rem,None)} - - -let complete_pats_constrs = function - | p::_ as pats -> - List.map - (pat_of_constr p) - (complete_constrs p (List.map get_key_constr pats)) - | _ -> assert false - - -(* - Following two ``failaction'' function compute n, the trap handler - to jump to in case of failure of elementary tests -*) - -let mk_failaction_neg partial ctx def = match partial with -| Partial -> - begin match def with - | (_,idef)::_ -> - Some (Lstaticraise (idef,[])),jumps_singleton idef ctx - | [] -> - (* Act as Total, this means - If no appropriate default matrix exists, - then this switch cannot fail *) - None, jumps_empty - end -| Total -> - None, jumps_empty - - - -(* In line with the article and simpler than before *) -let mk_failaction_pos partial seen ctx defs = - if dbg then begin - Format.eprintf "**POS**\n" ; - pretty_def defs ; - () - end ; - let rec scan_def env to_test defs = match to_test,defs with - | ([],_)|(_,[]) -> - List.fold_left - (fun (klist,jumps) (pats,i)-> - let action = Lstaticraise (i,[]) in - let klist = - List.fold_right - (fun pat r -> (get_key_constr pat,action)::r) - pats klist - and jumps = - jumps_add i (ctx_lub (list_as_pat pats) ctx) jumps in - klist,jumps) - ([],jumps_empty) env - | _,(pss,idef)::rem -> - let now, later = - List.partition - (fun (_p,p_ctx) -> ctx_match p_ctx pss) to_test in - match now with - | [] -> scan_def env to_test rem - | _ -> scan_def ((List.map fst now,idef)::env) later rem in - - let fail_pats = complete_pats_constrs seen in - if List.length fail_pats < !Clflags.match_context_rows then begin - let fail,jmps = - scan_def - [] - (List.map - (fun pat -> pat, ctx_lub pat ctx) - fail_pats) - defs in - if dbg then begin - eprintf "POSITIVE JUMPS [%i]:\n" (List.length fail_pats); - pretty_jumps jmps - end ; - None,fail,jmps - end else begin (* Too many non-matched constructors -> reduced information *) - if dbg then eprintf "POS->NEG!!!\n%!" ; - let fail,jumps = mk_failaction_neg partial ctx defs in - if dbg then - eprintf "FAIL: %s\n" - (match fail with - | None -> "" - | Some lam -> string_of_lam lam) ; - fail,[],jumps - end - -let combine_constant loc arg cst partial ctx def - (const_lambda_list, total, _pats) = - let fail, local_jumps = - mk_failaction_neg partial ctx def in - let lambda1 = - match cst with - | Const_int _ -> - let int_lambda_list = - List.map (function Const_int n, l -> n,l | _ -> assert false) - const_lambda_list in - call_switcher loc fail arg min_int max_int int_lambda_list - | Const_char _ -> - let int_lambda_list = - List.map (function Const_char c, l -> (Char.code c, l) - | _ -> assert false) - const_lambda_list in - call_switcher loc fail arg 0 255 int_lambda_list - | Const_string _ -> -(* Note as the bytecode compiler may resort to dichotomic search, - the clauses of stringswitch are sorted with duplicates removed. - This partly applies to the native code compiler, which requires - no duplicates *) - let const_lambda_list = sort_lambda_list const_lambda_list in - let sw = - List.map - (fun (c,act) -> match c with - | Const_string (s,_) -> s,act - | _ -> assert false) - const_lambda_list in - let hs,sw,fail = share_actions_tree sw fail in - hs (Lstringswitch (arg,sw,fail,loc)) - | Const_float _ -> - make_test_sequence loc - fail - (Pfloatcomp CFneq) (Pfloatcomp CFlt) - arg const_lambda_list - | Const_int32 _ -> - make_test_sequence loc - fail - (Pbintcomp(Pint32, Cne)) (Pbintcomp(Pint32, Clt)) - arg const_lambda_list - | Const_int64 _ -> - make_test_sequence loc - fail - (Pbintcomp(Pint64, Cne)) (Pbintcomp(Pint64, Clt)) - arg const_lambda_list - | Const_nativeint _ -> - make_test_sequence loc - fail - (Pbintcomp(Pnativeint, Cne)) (Pbintcomp(Pnativeint, Clt)) - arg const_lambda_list - in lambda1,jumps_union local_jumps total - - - -let split_cases tag_lambda_list = - let rec split_rec = function - [] -> ([], []) - | (cstr, act) :: rem -> - let (consts, nonconsts) = split_rec rem in - match cstr with - Cstr_constant n -> ((n, act) :: consts, nonconsts) - | Cstr_block n -> (consts, (n, act) :: nonconsts) - | Cstr_unboxed -> (consts, (0, act) :: nonconsts) - | Cstr_extension _ -> assert false in - let const, nonconst = split_rec tag_lambda_list in - sort_int_lambda_list const, - sort_int_lambda_list nonconst - -let split_extension_cases tag_lambda_list = - let rec split_rec = function - [] -> ([], []) - | (cstr, act) :: rem -> - let (consts, nonconsts) = split_rec rem in - match cstr with - Cstr_extension(path, true) -> ((path, act) :: consts, nonconsts) - | Cstr_extension(path, false) -> (consts, (path, act) :: nonconsts) - | _ -> assert false in - split_rec tag_lambda_list - - -let combine_constructor loc arg ex_pat cstr partial ctx def - (tag_lambda_list, total1, pats) = - if cstr.cstr_consts < 0 then begin - (* Special cases for extensions *) - let fail, local_jumps = - mk_failaction_neg partial ctx def in - let lambda1 = - let consts, nonconsts = split_extension_cases tag_lambda_list in - let default, consts, nonconsts = - match fail with - | None -> - begin match consts, nonconsts with - | _, (_, act)::rem -> act, consts, rem - | (_, act)::rem, _ -> act, rem, nonconsts - | _ -> assert false - end - | Some fail -> fail, consts, nonconsts in - let nonconst_lambda = - match nonconsts with - [] -> default - | _ -> - let tag = Ident.create_local "tag" in - let tests = - List.fold_right - (fun (path, act) rem -> - let ext = transl_extension_path loc ex_pat.pat_env path in - Lifthenelse(Lprim(Pintcomp Ceq, [Lvar tag; ext], loc), - act, rem)) - nonconsts - default - in - Llet(Alias, Pgenval,tag, Lprim(Pfield 0, [arg], loc), tests) - in - List.fold_right - (fun (path, act) rem -> - let ext = transl_extension_path loc ex_pat.pat_env path in - Lifthenelse(Lprim(Pintcomp Ceq, [arg; ext], loc), - act, rem)) - consts - nonconst_lambda - in - lambda1, jumps_union local_jumps total1 - end else begin - (* Regular concrete type *) - let ncases = List.length tag_lambda_list - and nconstrs = cstr.cstr_consts + cstr.cstr_nonconsts in - let sig_complete = ncases = nconstrs in - let fail_opt,fails,local_jumps = - if sig_complete then None,[],jumps_empty - else - mk_failaction_pos partial pats ctx def in - - let tag_lambda_list = fails @ tag_lambda_list in - let (consts, nonconsts) = split_cases tag_lambda_list in - let lambda1 = - match fail_opt,same_actions tag_lambda_list with - | None,Some act -> act (* Identical actions, no failure *) - | _ -> - match - (cstr.cstr_consts, cstr.cstr_nonconsts, consts, nonconsts) - with - | (1, 1, [0, act1], [0, act2]) -> - (* Typically, match on lists, will avoid isint primitive in that - case *) - Lifthenelse(arg, act2, act1) - | (n,0,_,[]) -> (* The type defines constant constructors only *) - call_switcher loc fail_opt arg 0 (n-1) consts - | (n, _, _, _) -> - let act0 = - (* = Some act when all non-const constructors match to act *) - match fail_opt,nonconsts with - | Some a,[] -> Some a - | Some _,_ -> - if List.length nonconsts = cstr.cstr_nonconsts then - same_actions nonconsts - else None - | None,_ -> same_actions nonconsts in - match act0 with - | Some act -> - Lifthenelse - (Lprim (Pisint, [arg], loc), - call_switcher loc - fail_opt arg - 0 (n-1) consts, - act) -(* Emit a switch, as bytecode implements this sophisticated instruction *) - | None -> - let sw = - {sw_numconsts = cstr.cstr_consts; sw_consts = consts; - sw_numblocks = cstr.cstr_nonconsts; sw_blocks = nonconsts; - sw_failaction = fail_opt} in - let hs,sw = share_actions_sw sw in - let sw = reintroduce_fail sw in - hs (Lswitch (arg,sw,loc)) in - lambda1, jumps_union local_jumps total1 - end - -let make_test_sequence_variant_constant fail arg int_lambda_list = - let _, (cases, actions) = - as_interval fail min_int max_int int_lambda_list in - Switcher.test_sequence arg cases actions - -let call_switcher_variant_constant loc fail arg int_lambda_list = - call_switcher loc fail arg min_int max_int int_lambda_list - - -let call_switcher_variant_constr loc fail arg int_lambda_list = - let v = Ident.create_local "variant" in - Llet(Alias, Pgenval, v, Lprim(Pfield 0, [arg], loc), - call_switcher loc - fail (Lvar v) min_int max_int int_lambda_list) - -let combine_variant loc row arg partial ctx def - (tag_lambda_list, total1, _pats) = - let row = Btype.row_repr row in - let num_constr = ref 0 in - if row.row_closed then - List.iter - (fun (_, f) -> - match Btype.row_field_repr f with - Rabsent | Reither(true, _::_, _, _) -> () - | _ -> incr num_constr) - row.row_fields - else - num_constr := max_int; - let test_int_or_block arg if_int if_block = - Lifthenelse(Lprim (Pisint, [arg], loc), if_int, if_block) in - let sig_complete = List.length tag_lambda_list = !num_constr - and one_action = same_actions tag_lambda_list in - let fail, local_jumps = - if - sig_complete || (match partial with Total -> true | _ -> false) - then - None, jumps_empty - else - mk_failaction_neg partial ctx def in - let (consts, nonconsts) = split_cases tag_lambda_list in - let lambda1 = match fail, one_action with - | None, Some act -> act - | _,_ -> - match (consts, nonconsts) with - | ([_, act1], [_, act2]) when fail=None -> - test_int_or_block arg act1 act2 - | (_, []) -> (* One can compare integers and pointers *) - make_test_sequence_variant_constant fail arg consts - | ([], _) -> - let lam = call_switcher_variant_constr loc - fail arg nonconsts in - (* One must not dereference integers *) - begin match fail with - | None -> lam - | Some fail -> test_int_or_block arg fail lam - end - | (_, _) -> - let lam_const = - call_switcher_variant_constant loc - fail arg consts - and lam_nonconst = - call_switcher_variant_constr loc - fail arg nonconsts in - test_int_or_block arg lam_const lam_nonconst - in - lambda1, jumps_union local_jumps total1 - - -let combine_array loc arg kind partial ctx def - (len_lambda_list, total1, _pats) = - let fail, local_jumps = mk_failaction_neg partial ctx def in - let lambda1 = - let newvar = Ident.create_local "len" in - let switch = - call_switcher loc - fail (Lvar newvar) - 0 max_int len_lambda_list in - bind - Alias newvar (Lprim(Parraylength kind, [arg], loc)) switch in - lambda1, jumps_union local_jumps total1 - -(* Insertion of debugging events *) - -let rec event_branch repr lam = - begin match lam, repr with - (_, None) -> - lam - | (Levent(lam', ev), Some r) -> - incr r; - Levent(lam', {lev_loc = ev.lev_loc; - lev_kind = ev.lev_kind; - lev_repr = repr; - lev_env = ev.lev_env}) - | (Llet(str, k, id, lam, body), _) -> - Llet(str, k, id, lam, event_branch repr body) - | Lstaticraise _,_ -> lam - | (_, Some _) -> - Printlambda.lambda Format.str_formatter lam ; - fatal_error - ("Matching.event_branch: "^Format.flush_str_formatter ()) - end - - -(* - This exception is raised when the compiler cannot produce code - because control cannot reach the compiled clause, - - Unused is raised initially in compile_test. - - compile_list (for compiling switch results) catch Unused - - comp_match_handlers (for compiling split matches) - may reraise Unused - - -*) - -exception Unused - -let compile_list compile_fun division = - - let rec c_rec totals = function - | [] -> [], jumps_unions totals, [] - | (key, cell) :: rem -> - begin match cell.ctx with - | [] -> c_rec totals rem - | _ -> - try - let (lambda1, total1) = compile_fun cell.ctx cell.pm in - let c_rem, total, new_pats = - c_rec - (jumps_map ctx_combine total1::totals) rem in - ((key,lambda1)::c_rem), total, (cell.pat::new_pats) - with - | Unused -> c_rec totals rem - end in - c_rec [] division - - -let compile_orhandlers compile_fun lambda1 total1 ctx to_catch = - let rec do_rec r total_r = function - | [] -> r,total_r - | (mat,i,vars,pm)::rem -> - begin try - let ctx = select_columns mat ctx in - let handler_i, total_i = - compile_fun ctx pm in - match raw_action r with - | Lstaticraise (j,args) -> - if i=j then - List.fold_right2 (bind_with_value_kind Alias) - vars args handler_i, - jumps_map (ctx_rshift_num (ncols mat)) total_i - else - do_rec r total_r rem - | _ -> - do_rec - (Lstaticcatch (r,(i,vars), handler_i)) - (jumps_union - (jumps_remove i total_r) - (jumps_map (ctx_rshift_num (ncols mat)) total_i)) - rem - with - | Unused -> - do_rec (Lstaticcatch (r, (i,vars), lambda_unit)) total_r rem - end in - do_rec lambda1 total1 to_catch - - -let compile_test compile_fun partial divide combine ctx to_match = - let division = divide ctx to_match in - let c_div = compile_list compile_fun division in - match c_div with - | [],_,_ -> - begin match mk_failaction_neg partial ctx to_match.default with - | None,_ -> raise Unused - | Some l,total -> l,total - end - | _ -> - combine ctx to_match.default c_div - -(* Attempt to avoid some useless bindings by lowering them *) - -(* Approximation of v present in lam *) -let rec approx_present v = function - | Lconst _ -> false - | Lstaticraise (_,args) -> - List.exists (fun lam -> approx_present v lam) args - | Lprim (_,args,_) -> - List.exists (fun lam -> approx_present v lam) args - | Llet (Alias, _k, _, l1, l2) -> - approx_present v l1 || approx_present v l2 - | Lvar vv -> Ident.same v vv - | _ -> true - -let rec lower_bind v arg lam = match lam with -| Lifthenelse (cond, ifso, ifnot) -> - let pcond = approx_present v cond - and pso = approx_present v ifso - and pnot = approx_present v ifnot in - begin match pcond, pso, pnot with - | false, false, false -> lam - | false, true, false -> - Lifthenelse (cond, lower_bind v arg ifso, ifnot) - | false, false, true -> - Lifthenelse (cond, ifso, lower_bind v arg ifnot) - | _,_,_ -> bind Alias v arg lam - end -| Lswitch (ls,({sw_consts=[i,act] ; sw_blocks = []} as sw), loc) - when not (approx_present v ls) -> - Lswitch (ls, {sw with sw_consts = [i,lower_bind v arg act]}, loc) -| Lswitch (ls,({sw_consts=[] ; sw_blocks = [i,act]} as sw), loc) - when not (approx_present v ls) -> - Lswitch (ls, {sw with sw_blocks = [i,lower_bind v arg act]}, loc) -| Llet (Alias, k, vv, lv, l) -> - if approx_present v lv then - bind Alias v arg lam - else - Llet (Alias, k, vv, lv, lower_bind v arg l) -| _ -> - bind Alias v arg lam - -let bind_check str v arg lam = match str,arg with -| _, Lvar _ ->bind str v arg lam -| Alias,_ -> lower_bind v arg lam -| _,_ -> bind str v arg lam - -let comp_exit ctx m = match m.default with -| (_,i)::_ -> Lstaticraise (i,[]), jumps_singleton i ctx -| _ -> fatal_error "Matching.comp_exit" - - - -let rec comp_match_handlers comp_fun partial ctx arg first_match next_matchs = - match next_matchs with - | [] -> comp_fun partial ctx arg first_match - | rem -> - let rec c_rec body total_body = function - | [] -> body, total_body - (* Hum, -1 means never taken - | (-1,pm)::rem -> c_rec body total_body rem *) - | (i,pm)::rem -> - let ctx_i,total_rem = jumps_extract i total_body in - begin match ctx_i with - | [] -> c_rec body total_body rem - | _ -> - try - let li,total_i = - comp_fun - (match rem with [] -> partial | _ -> Partial) - ctx_i arg pm in - c_rec - (Lstaticcatch (body,(i,[]),li)) - (jumps_union total_i total_rem) - rem - with - | Unused -> - c_rec (Lstaticcatch (body,(i,[]),lambda_unit)) - total_rem rem - end in - try - let first_lam,total = comp_fun Partial ctx arg first_match in - c_rec first_lam total rem - with Unused -> match next_matchs with - | [] -> raise Unused - | (_,x)::xs -> comp_match_handlers comp_fun partial ctx arg x xs - -(* To find reasonable names for variables *) - -let rec name_pattern default = function - (pat :: _, _) :: rem -> - begin match pat.pat_desc with - Tpat_var (id, _) -> id - | Tpat_alias(_, id, _) -> id - | _ -> name_pattern default rem - end - | _ -> Ident.create_local default - -let arg_to_var arg cls = match arg with -| Lvar v -> v,arg -| _ -> - let v = name_pattern "*match*" cls in - v,Lvar v - - -(* - The main compilation function. - Input: - repr=used for inserting debug events - partial=exhaustiveness information from Parmatch - ctx=a context - m=a pattern matching - - Output: a lambda term, a jump summary {..., exit number -> context, .. } -*) - -let rec compile_match repr partial ctx m = match m with -| { cases = []; args = [] } -> comp_exit ctx m -| { cases = ([], action) :: rem } -> - if is_guarded action then begin - let (lambda, total) = - compile_match None partial ctx { m with cases = rem } in - event_branch repr (patch_guarded lambda action), total - end else - (event_branch repr action, jumps_empty) -| { args = (arg, str)::argl } -> - let v,newarg = arg_to_var arg m.cases in - let first_match,rem = - split_precompile (Some v) - { m with args = (newarg, Alias) :: argl } in - let (lam, total) = - comp_match_handlers - ((if dbg then do_compile_matching_pr else do_compile_matching) repr) - partial ctx newarg first_match rem in - bind_check str v arg lam, total -| _ -> assert false - - -(* verbose version of do_compile_matching, for debug *) - -and do_compile_matching_pr repr partial ctx arg x = - Format.eprintf "COMPILE: %s\nMATCH\n" - (match partial with Partial -> "Partial" | Total -> "Total") ; - pretty_precompiled x ; - Format.eprintf "CTX\n" ; - pretty_ctx ctx ; - let (_, jumps) as r = do_compile_matching repr partial ctx arg x in - Format.eprintf "JUMPS\n" ; - pretty_jumps jumps ; - r - -and do_compile_matching repr partial ctx arg pmh = match pmh with -| Pm pm -> - let pat = what_is_cases pm.cases in - begin match pat.pat_desc with - | Tpat_any -> - compile_no_test - divide_var ctx_rshift repr partial ctx pm - | Tpat_tuple patl -> - compile_no_test - (divide_tuple (List.length patl) (normalize_pat pat)) ctx_combine - repr partial ctx pm - | Tpat_record ((_, lbl,_)::_,_) -> - compile_no_test - (divide_record lbl.lbl_all (normalize_pat pat)) - ctx_combine repr partial ctx pm - | Tpat_constant cst -> - compile_test - (compile_match repr partial) partial - divide_constant - (combine_constant pat.pat_loc arg cst partial) - ctx pm - | Tpat_construct (_, cstr, _) -> - compile_test - (compile_match repr partial) partial - divide_constructor - (combine_constructor pat.pat_loc arg pat cstr partial) - ctx pm - | Tpat_array _ -> - let kind = Typeopt.array_pattern_kind pat in - compile_test (compile_match repr partial) partial - (divide_array kind) (combine_array pat.pat_loc arg kind partial) - ctx pm - | Tpat_lazy _ -> - compile_no_test - (divide_lazy (normalize_pat pat)) - ctx_combine repr partial ctx pm - | Tpat_variant(_, _, row) -> - compile_test (compile_match repr partial) partial - (divide_variant !row) - (combine_variant pat.pat_loc !row arg partial) - ctx pm - | _ -> assert false - end -| PmVar {inside=pmh ; var_arg=arg} -> - let lam, total = - do_compile_matching repr partial (ctx_lshift ctx) arg pmh in - lam, jumps_map ctx_rshift total -| PmOr {body=body ; handlers=handlers} -> - let lam, total = compile_match repr partial ctx body in - compile_orhandlers (compile_match repr partial) lam total ctx handlers - -and compile_no_test divide up_ctx repr partial ctx to_match = - let {pm=this_match ; ctx=this_ctx } = divide ctx to_match in - let lambda,total = compile_match repr partial this_ctx this_match in - lambda, jumps_map up_ctx total - - - - -(* The entry points *) - -(* - If there is a guard in a matching or a lazy pattern, - then set exhaustiveness info to Partial. - (because of side effects, assume the worst). - - Notice that exhaustiveness information is trusted by the compiler, - that is, a match flagged as Total should not fail at runtime. - More specifically, for instance if match y with x::_ -> x is flagged - total (as it happens during JoCaml compilation) then y cannot be [] - at runtime. As a consequence, the static Total exhaustiveness information - have to be downgraded to Partial, in the dubious cases where guards - or lazy pattern execute arbitrary code that may perform side effects - and change the subject values. -LM: - Lazy pattern was PR#5992, initial patch by lpw25. - I have generalized the patch, so as to also find mutable fields. -*) - -let find_in_pat pred = - let rec find_rec p = - pred p.pat_desc || - begin match p.pat_desc with - | Tpat_alias (p,_,_) | Tpat_variant (_,Some p,_) | Tpat_lazy p -> - find_rec p - | Tpat_tuple ps|Tpat_construct (_,_,ps) | Tpat_array ps -> - List.exists find_rec ps - | Tpat_record (lpats,_) -> - List.exists - (fun (_, _, p) -> find_rec p) - lpats - | Tpat_or (p,q,_) -> - find_rec p || find_rec q - | Tpat_constant _ | Tpat_var _ - | Tpat_any | Tpat_variant (_,None,_) -> false - | Tpat_exception _ -> assert false - end in - find_rec - -let is_lazy_pat = function - | Tpat_lazy _ -> true - | Tpat_alias _ | Tpat_variant _ | Tpat_record _ - | Tpat_tuple _|Tpat_construct _ | Tpat_array _ - | Tpat_or _ | Tpat_constant _ | Tpat_var _ | Tpat_any - -> false - | Tpat_exception _ -> assert false - -let is_lazy p = find_in_pat is_lazy_pat p - -let have_mutable_field p = match p with -| Tpat_record (lps,_) -> - List.exists - (fun (_,lbl,_) -> - match lbl.Types.lbl_mut with - | Mutable -> true - | Immutable -> false) - lps -| Tpat_alias _ | Tpat_variant _ | Tpat_lazy _ -| Tpat_tuple _|Tpat_construct _ | Tpat_array _ -| Tpat_or _ -| Tpat_constant _ | Tpat_var _ | Tpat_any - -> false -| Tpat_exception _ -> assert false - -let is_mutable p = find_in_pat have_mutable_field p - -(* Downgrade Total when - 1. Matching accesses some mutable fields; - 2. And there are guards or lazy patterns. -*) - -let check_partial is_mutable is_lazy pat_act_list = function - | Partial -> Partial - | Total -> - if - pat_act_list = [] || (* allow empty case list *) - List.exists - (fun (pats, lam) -> - is_mutable pats && (is_guarded lam || is_lazy pats)) - pat_act_list - then Partial - else Total - -let check_partial_list = - check_partial (List.exists is_mutable) (List.exists is_lazy) -let check_partial = check_partial is_mutable is_lazy - -(* have toplevel handler when appropriate *) - -let start_ctx n = [{left=[] ; right = omegas n}] - -let check_total total lambda i handler_fun = - if jumps_is_empty total then - lambda - else begin - Lstaticcatch(lambda, (i,[]), handler_fun()) - end - -let compile_matching repr handler_fun arg pat_act_list partial = - let partial = check_partial pat_act_list partial in - match partial with - | Partial -> - let raise_num = next_raise_count () in - let pm = - { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; - args = [arg, Strict] ; - default = [[[omega]],raise_num]} in - begin try - let (lambda, total) = compile_match repr partial (start_ctx 1) pm in - check_total total lambda raise_num handler_fun - with - | Unused -> assert false (* ; handler_fun() *) - end - | Total -> - let pm = - { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; - args = [arg, Strict] ; - default = []} in - let (lambda, total) = compile_match repr partial (start_ctx 1) pm in - assert (jumps_is_empty total) ; - lambda - - -let partial_function loc () = - let slot = - transl_extension_path loc - Env.initial_safe_string Predef.path_match_failure - in - let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in - Lprim(Praise Raise_regular, [Lprim(Pmakeblock(0, Immutable, None), - [slot; Lconst(Const_block(0, - [Const_base(Const_string (fname, None)); - Const_base(Const_int line); - Const_base(Const_int char)]))], loc)], loc) - -let for_function loc repr param pat_act_list partial = - compile_matching repr (partial_function loc) param pat_act_list partial - -(* In the following two cases, exhaustiveness info is not available! *) -let for_trywith param pat_act_list = - compile_matching None - (fun () -> Lprim(Praise Raise_reraise, [param], Location.none)) - param pat_act_list Partial - -let simple_for_let loc param pat body = - compile_matching None (partial_function loc) param [pat, body] Partial - - -(* Optimize binding of immediate tuples - - The goal of the implementation of 'for_let' below, which replaces - 'simple_for_let', is to avoid tuple allocation in cases such as - this one: - - let (x,y) = - let foo = ... in - if foo then (1, 2) else (3,4) - in bar - - The compiler easily optimizes the simple `let (x,y) = (1,2) in ...` - case (call to Matching.for_multiple_match from Translcore), but - didn't optimize situations where the rhs tuples are hidden under - a more complex context. - - The idea comes from Alain Frisch who suggested and implemented - the following compilation method, based on Lassign: - - let x = dummy in let y = dummy in - begin - let foo = ... in - if foo then - (let x1 = 1 in let y1 = 2 in x <- x1; y <- y1) - else - (let x2 = 3 in let y2 = 4 in x <- x2; y <- y2) - end; - bar - - The current implementation from Gabriel Scherer uses Lstaticcatch / - Lstaticraise instead: - - catch - let foo = ... in - if foo then - (let x1 = 1 in let y1 = 2 in exit x1 y1) - else - (let x2 = 3 in let y2 = 4 in exit x2 y2) - with x y -> - bar - - The catch/exit is used to avoid duplication of the let body ('bar' - in the example), on 'if' branches for example; it is useless for - linear contexts such as 'let', but we don't need to be careful to - generate nice code because Simplif will remove such useless - catch/exit. -*) - -let rec map_return f = function - | Llet (str, k, id, l1, l2) -> Llet (str, k, id, l1, map_return f l2) - | Lletrec (l1, l2) -> Lletrec (l1, map_return f l2) - | Lifthenelse (lcond, lthen, lelse) -> - Lifthenelse (lcond, map_return f lthen, map_return f lelse) - | Lsequence (l1, l2) -> Lsequence (l1, map_return f l2) - | Levent (l, ev) -> Levent (map_return f l, ev) - | Ltrywith (l1, id, l2) -> Ltrywith (map_return f l1, id, map_return f l2) - | Lstaticcatch (l1, b, l2) -> - Lstaticcatch (map_return f l1, b, map_return f l2) - | Lstaticraise _ | Lprim(Praise _, _, _) as l -> l - | l -> f l - -(* The 'opt' reference indicates if the optimization is worthy. - - It is shared by the different calls to 'assign_pat' performed from - 'map_return'. For example with the code - let (x, y) = if foo then z else (1,2) - the else-branch will activate the optimization for both branches. - - That means that the optimization is activated if *there exists* an - interesting tuple in one hole of the let-rhs context. We could - choose to activate it only if *all* holes are interesting. We made - that choice because being optimistic is extremely cheap (one static - exit/catch overhead in the "wrong cases"), while being pessimistic - can be costly (one unnecessary tuple allocation). -*) - -let assign_pat opt nraise catch_ids loc pat lam = - let rec collect acc pat lam = match pat.pat_desc, lam with - | Tpat_tuple patl, Lprim(Pmakeblock _, lams, _) -> - opt := true; - List.fold_left2 collect acc patl lams - | Tpat_tuple patl, Lconst(Const_block(_, scl)) -> - opt := true; - let collect_const acc pat sc = collect acc pat (Lconst sc) in - List.fold_left2 collect_const acc patl scl - | _ -> - (* pattern idents will be bound in staticcatch (let body), so we - refresh them here to guarantee binders uniqueness *) - let pat_ids = pat_bound_idents pat in - let fresh_ids = List.map (fun id -> id, Ident.rename id) pat_ids in - (fresh_ids, alpha_pat fresh_ids pat, lam) :: acc - in - - (* sublets were accumulated by 'collect' with the leftmost tuple - pattern at the bottom of the list; to respect right-to-left - evaluation order for tuples, we must evaluate sublets - top-to-bottom. To preserve tail-rec, we will fold_left the - reversed list. *) - let rev_sublets = List.rev (collect [] pat lam) in - let exit = - (* build an Ident.tbl to avoid quadratic refreshing costs *) - let add t (id, fresh_id) = Ident.add id fresh_id t in - let add_ids acc (ids, _pat, _lam) = List.fold_left add acc ids in - let tbl = List.fold_left add_ids Ident.empty rev_sublets in - let fresh_var id = Lvar (Ident.find_same id tbl) in - Lstaticraise(nraise, List.map fresh_var catch_ids) - in - let push_sublet code (_ids, pat, lam) = simple_for_let loc lam pat code in - List.fold_left push_sublet exit rev_sublets - -let for_let loc param pat body = - match pat.pat_desc with - | Tpat_any -> - (* This eliminates a useless variable (and stack slot in bytecode) - for "let _ = ...". See #6865. *) - Lsequence(param, body) - | Tpat_var (id, _) -> - (* fast path, and keep track of simple bindings to unboxable numbers *) - let k = Typeopt.value_kind pat.pat_env pat.pat_type in - Llet(Strict, k, id, param, body) - | _ -> - let opt = ref false in - let nraise = next_raise_count () in - let catch_ids = pat_bound_idents_full pat in - let ids_with_kinds = - List.map (fun (id, _, typ) -> id, Typeopt.value_kind pat.pat_env typ) - catch_ids - in - let ids = List.map (fun (id, _, _) -> id) catch_ids in - let bind = map_return (assign_pat opt nraise ids loc pat) param in - if !opt then Lstaticcatch(bind, (nraise, ids_with_kinds), body) - else simple_for_let loc param pat body - -(* Handling of tupled functions and matchings *) - -(* Easy case since variables are available *) -let for_tupled_function loc paraml pats_act_list partial = - let partial = check_partial_list pats_act_list partial in - let raise_num = next_raise_count () in - let omegas = [List.map (fun _ -> omega) paraml] in - let pm = - { cases = pats_act_list; - args = List.map (fun id -> (Lvar id, Strict)) paraml ; - default = [omegas,raise_num] - } in - try - let (lambda, total) = compile_match None partial - (start_ctx (List.length paraml)) pm in - check_total total lambda raise_num (partial_function loc) - with - | Unused -> partial_function loc () - - - -let flatten_pattern size p = match p.pat_desc with -| Tpat_tuple args -> args -| Tpat_any -> omegas size -| _ -> raise Cannot_flatten - -let rec flatten_pat_line size p k = match p.pat_desc with -| Tpat_any -> omegas size::k -| Tpat_tuple args -> args::k -| Tpat_or (p1,p2,_) -> flatten_pat_line size p1 (flatten_pat_line size p2 k) -| Tpat_alias (p,_,_) -> (* Note: if this 'as' pat is here, then this is a - useless binding, solves PR#3780 *) - flatten_pat_line size p k -| _ -> fatal_error "Matching.flatten_pat_line" - -let flatten_cases size cases = - List.map - (fun (ps,action) -> match ps with - | [p] -> flatten_pattern size p,action - | _ -> fatal_error "Matching.flatten_case") - cases - -let flatten_matrix size pss = - List.fold_right - (fun ps r -> match ps with - | [p] -> flatten_pat_line size p r - | _ -> fatal_error "Matching.flatten_matrix") - pss [] - -let flatten_def size def = - List.map - (fun (pss,i) -> flatten_matrix size pss,i) - def - -let flatten_pm size args pm = - {args = args ; cases = flatten_cases size pm.cases ; - default = flatten_def size pm.default} - - -let flatten_precompiled size args pmh = match pmh with -| Pm pm -> Pm (flatten_pm size args pm) -| PmOr {body=b ; handlers=hs ; or_matrix=m} -> - PmOr - {body=flatten_pm size args b ; - handlers= - List.map - (fun (mat,i,vars,pm) -> flatten_matrix size mat,i,vars,pm) - hs ; - or_matrix=flatten_matrix size m ;} -| PmVar _ -> assert false - -(* - compiled_flattened is a ``comp_fun'' argument to comp_match_handlers. - Hence it needs a fourth argument, which it ignores -*) - -let compile_flattened repr partial ctx _ pmh = match pmh with -| Pm pm -> compile_match repr partial ctx pm -| PmOr {body=b ; handlers=hs} -> - let lam, total = compile_match repr partial ctx b in - compile_orhandlers (compile_match repr partial) lam total ctx hs -| PmVar _ -> assert false - -let do_for_multiple_match loc paraml pat_act_list partial = - let repr = None in - let partial = check_partial pat_act_list partial in - let raise_num,pm1 = - match partial with - | Partial -> - let raise_num = next_raise_count () in - raise_num, - { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; - args = [Lprim(Pmakeblock(0, Immutable, None), paraml, loc), Strict]; - default = [[[omega]],raise_num] } - | _ -> - -1, - { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; - args = [Lprim(Pmakeblock(0, Immutable, None), paraml, loc), Strict]; - default = [] } in - - try - try -(* Once for checking that compilation is possible *) - let next, nexts = split_precompile None pm1 in - - let size = List.length paraml - and idl = List.map (fun _ -> Ident.create_local "*match*") paraml in - let args = List.map (fun id -> Lvar id, Alias) idl in - - let flat_next = flatten_precompiled size args next - and flat_nexts = - List.map - (fun (e,pm) -> e,flatten_precompiled size args pm) - nexts in - - let lam, total = - comp_match_handlers - (compile_flattened repr) - partial (start_ctx size) () flat_next flat_nexts in - List.fold_right2 (bind Strict) idl paraml - (match partial with - | Partial -> - check_total total lam raise_num (partial_function loc) - | Total -> - assert (jumps_is_empty total) ; - lam) - with Cannot_flatten -> - let (lambda, total) = compile_match None partial (start_ctx 1) pm1 in - begin match partial with - | Partial -> - check_total total lambda raise_num (partial_function loc) - | Total -> - assert (jumps_is_empty total) ; - lambda - end - with Unused -> - assert false (* ; partial_function loc () *) - -(* PR#4828: Believe it or not, the 'paraml' argument below - may not be side effect free. *) - -let param_to_var param = match param with -| Lvar v -> v,None -| _ -> Ident.create_local "*match*",Some param - -let bind_opt (v,eo) k = match eo with -| None -> k -| Some e -> Lambda.bind Strict v e k - -let for_multiple_match loc paraml pat_act_list partial = - let v_paraml = List.map param_to_var paraml in - let paraml = List.map (fun (v,_) -> Lvar v) v_paraml in - List.fold_right bind_opt v_paraml - (do_for_multiple_match loc paraml pat_act_list partial) diff --git a/bytecomp/matching.mli b/bytecomp/matching.mli deleted file mode 100644 index f29901bd0c..0000000000 --- a/bytecomp/matching.mli +++ /dev/null @@ -1,46 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Compilation of pattern-matching *) - -open Typedtree -open Lambda - - -(* Entry points to match compiler *) -val for_function: - Location.t -> int ref option -> lambda -> (pattern * lambda) list -> - partial -> lambda -val for_trywith: - lambda -> (pattern * lambda) list -> lambda -val for_let: - Location.t -> lambda -> pattern -> lambda -> lambda -val for_multiple_match: - Location.t -> lambda list -> (pattern * lambda) list -> partial -> - lambda - -val for_tupled_function: - Location.t -> Ident.t list -> (pattern list * lambda) list -> - partial -> lambda - -exception Cannot_flatten - -val flatten_pattern: int -> pattern -> pattern list - -(* Expand stringswitch to string test tree *) -val expand_stringswitch: - Location.t -> lambda -> (string * lambda) list -> lambda option -> lambda - -val inline_lazy_force : lambda -> Location.t -> lambda diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml deleted file mode 100644 index e4bb26a686..0000000000 --- a/bytecomp/printlambda.ml +++ /dev/null @@ -1,648 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -open Format -open Asttypes -open Primitive -open Types -open Lambda - - -let rec struct_const ppf = function - | Const_base(Const_int n) -> fprintf ppf "%i" n - | Const_base(Const_char c) -> fprintf ppf "%C" c - | Const_base(Const_string (s, _)) -> fprintf ppf "%S" s - | Const_immstring s -> fprintf ppf "#%S" s - | Const_base(Const_float f) -> fprintf ppf "%s" f - | Const_base(Const_int32 n) -> fprintf ppf "%lil" n - | Const_base(Const_int64 n) -> fprintf ppf "%LiL" n - | Const_base(Const_nativeint n) -> fprintf ppf "%nin" n - | Const_pointer n -> fprintf ppf "%ia" n - | Const_block(tag, []) -> - fprintf ppf "[%i]" tag - | Const_block(tag, sc1::scl) -> - let sconsts ppf scl = - List.iter (fun sc -> fprintf ppf "@ %a" struct_const sc) scl in - fprintf ppf "@[<1>[%i:@ @[%a%a@]]@]" tag struct_const sc1 sconsts scl - | Const_float_array [] -> - fprintf ppf "[| |]" - | Const_float_array (f1 :: fl) -> - let floats ppf fl = - List.iter (fun f -> fprintf ppf "@ %s" f) fl in - fprintf ppf "@[<1>[|@[%s%a@]|]@]" f1 floats fl - -let array_kind = function - | Pgenarray -> "gen" - | Paddrarray -> "addr" - | Pintarray -> "int" - | Pfloatarray -> "float" - -let boxed_integer_name = function - | Pnativeint -> "nativeint" - | Pint32 -> "int32" - | Pint64 -> "int64" - -let value_kind ppf = function - | Pgenval -> () - | Pintval -> fprintf ppf "[int]" - | Pfloatval -> fprintf ppf "[float]" - | Pboxedintval bi -> fprintf ppf "[%s]" (boxed_integer_name bi) - -let return_kind ppf = function - | Pgenval -> () - | Pintval -> fprintf ppf ": int@ " - | Pfloatval -> fprintf ppf ": float@ " - | Pboxedintval bi -> fprintf ppf ": %s@ " (boxed_integer_name bi) - -let field_kind = function - | Pgenval -> "*" - | Pintval -> "int" - | Pfloatval -> "float" - | Pboxedintval bi -> boxed_integer_name bi - -let print_boxed_integer_conversion ppf bi1 bi2 = - fprintf ppf "%s_of_%s" (boxed_integer_name bi2) (boxed_integer_name bi1) - -let boxed_integer_mark name = function - | Pnativeint -> Printf.sprintf "Nativeint.%s" name - | Pint32 -> Printf.sprintf "Int32.%s" name - | Pint64 -> Printf.sprintf "Int64.%s" name - -let print_boxed_integer name ppf bi = - fprintf ppf "%s" (boxed_integer_mark name bi);; - -let print_bigarray name unsafe kind ppf layout = - fprintf ppf "Bigarray.%s[%s,%s]" - (if unsafe then "unsafe_"^ name else name) - (match kind with - | Pbigarray_unknown -> "generic" - | Pbigarray_float32 -> "float32" - | Pbigarray_float64 -> "float64" - | Pbigarray_sint8 -> "sint8" - | Pbigarray_uint8 -> "uint8" - | Pbigarray_sint16 -> "sint16" - | Pbigarray_uint16 -> "uint16" - | Pbigarray_int32 -> "int32" - | Pbigarray_int64 -> "int64" - | Pbigarray_caml_int -> "camlint" - | Pbigarray_native_int -> "nativeint" - | Pbigarray_complex32 -> "complex32" - | Pbigarray_complex64 -> "complex64") - (match layout with - | Pbigarray_unknown_layout -> "unknown" - | Pbigarray_c_layout -> "C" - | Pbigarray_fortran_layout -> "Fortran") - -let record_rep ppf r = - match r with - | Record_regular -> fprintf ppf "regular" - | Record_inlined i -> fprintf ppf "inlined(%i)" i - | Record_unboxed false -> fprintf ppf "unboxed" - | Record_unboxed true -> fprintf ppf "inlined(unboxed)" - | Record_float -> fprintf ppf "float" - | Record_extension path -> fprintf ppf "ext(%a)" Printtyp.path path -;; - -let block_shape ppf shape = match shape with - | None | Some [] -> () - | Some l when List.for_all ((=) Pgenval) l -> () - | Some [elt] -> - Format.fprintf ppf " (%s)" (field_kind elt) - | Some (h :: t) -> - Format.fprintf ppf " (%s" (field_kind h); - List.iter (fun elt -> - Format.fprintf ppf ",%s" (field_kind elt)) - t; - Format.fprintf ppf ")" - -let integer_comparison ppf = function - | Ceq -> fprintf ppf "==" - | Cne -> fprintf ppf "!=" - | Clt -> fprintf ppf "<" - | Cle -> fprintf ppf "<=" - | Cgt -> fprintf ppf ">" - | Cge -> fprintf ppf ">=" - -let float_comparison ppf = function - | CFeq -> fprintf ppf "==." - | CFneq -> fprintf ppf "!=." - | CFlt -> fprintf ppf "<." - | CFnlt -> fprintf ppf "!<." - | CFle -> fprintf ppf "<=." - | CFnle -> fprintf ppf "!<=." - | CFgt -> fprintf ppf ">." - | CFngt -> fprintf ppf "!>." - | CFge -> fprintf ppf ">=." - | CFnge -> fprintf ppf "!>=." - -let primitive ppf = function - | Pidentity -> fprintf ppf "id" - | Pbytes_to_string -> fprintf ppf "bytes_to_string" - | Pbytes_of_string -> fprintf ppf "bytes_of_string" - | Pignore -> fprintf ppf "ignore" - | Prevapply -> fprintf ppf "revapply" - | Pdirapply -> fprintf ppf "dirapply" - | Pgetglobal id -> fprintf ppf "global %a" Ident.print id - | Psetglobal id -> fprintf ppf "setglobal %a" Ident.print id - | Pmakeblock(tag, Immutable, shape) -> - fprintf ppf "makeblock %i%a" tag block_shape shape - | Pmakeblock(tag, Mutable, shape) -> - fprintf ppf "makemutable %i%a" tag 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" record_rep rep size - | Pccall p -> fprintf ppf "%s" p.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) -> 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) -> 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) - | Pctconst c -> - let const_name = match c with - | Big_endian -> "big_endian" - | Word_size -> "word_size" - | Int_size -> "int_size" - | Max_wosize -> "max_wosize" - | Ostype_unix -> "ostype_unix" - | Ostype_win32 -> "ostype_win32" - | Ostype_cygwin -> "ostype_cygwin" - | Backend_type -> "backend_type" in - fprintf ppf "sys.constant_%s" const_name - | 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) -> print_boxed_integer_conversion ppf bi1 bi2 - | 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) -> - print_bigarray "get" unsafe kind ppf layout - | Pbigarrayset(unsafe, _n, kind, layout) -> - print_bigarray "set" unsafe kind ppf layout - | Pbigarraydim(n) -> fprintf ppf "Bigarray.dim_%i" n - | Pstring_load_16(unsafe) -> - if unsafe then fprintf ppf "string.unsafe_get16" - else fprintf ppf "string.get16" - | Pstring_load_32(unsafe) -> - if unsafe then fprintf ppf "string.unsafe_get32" - else fprintf ppf "string.get32" - | Pstring_load_64(unsafe) -> - if unsafe then fprintf ppf "string.unsafe_get64" - else fprintf ppf "string.get64" - | Pbytes_load_16(unsafe) -> - if unsafe then fprintf ppf "bytes.unsafe_get16" - else fprintf ppf "bytes.get16" - | Pbytes_load_32(unsafe) -> - if unsafe then fprintf ppf "bytes.unsafe_get32" - else fprintf ppf "bytes.get32" - | Pbytes_load_64(unsafe) -> - if unsafe then fprintf ppf "bytes.unsafe_get64" - else fprintf ppf "bytes.get64" - | Pbytes_set_16(unsafe) -> - if unsafe then fprintf ppf "bytes.unsafe_set16" - else fprintf ppf "bytes.set16" - | Pbytes_set_32(unsafe) -> - if unsafe then fprintf ppf "bytes.unsafe_set32" - else fprintf ppf "bytes.set32" - | Pbytes_set_64(unsafe) -> - if unsafe then fprintf ppf "bytes.unsafe_set64" - else fprintf ppf "bytes.set64" - | Pbigstring_load_16(unsafe) -> - if unsafe then fprintf ppf "bigarray.array1.unsafe_get16" - else fprintf ppf "bigarray.array1.get16" - | Pbigstring_load_32(unsafe) -> - if unsafe then fprintf ppf "bigarray.array1.unsafe_get32" - else fprintf ppf "bigarray.array1.get32" - | Pbigstring_load_64(unsafe) -> - if unsafe then fprintf ppf "bigarray.array1.unsafe_get64" - else fprintf ppf "bigarray.array1.get64" - | Pbigstring_set_16(unsafe) -> - if unsafe then fprintf ppf "bigarray.array1.unsafe_set16" - else fprintf ppf "bigarray.array1.set16" - | Pbigstring_set_32(unsafe) -> - if unsafe then fprintf ppf "bigarray.array1.unsafe_set32" - else fprintf ppf "bigarray.array1.set32" - | Pbigstring_set_64(unsafe) -> - if unsafe then fprintf ppf "bigarray.array1.unsafe_set64" - else fprintf ppf "bigarray.array1.set64" - | Pbswap16 -> fprintf ppf "bswap16" - | Pbbswap(bi) -> print_boxed_integer "bswap" ppf bi - | Pint_as_pointer -> fprintf ppf "int_as_pointer" - | Popaque -> fprintf ppf "opaque" - -let name_of_primitive = function - | Pidentity -> "Pidentity" - | Pbytes_of_string -> "Pbytes_of_string" - | Pbytes_to_string -> "Pbytes_to_string" - | Pignore -> "Pignore" - | Prevapply -> "Prevapply" - | Pdirapply -> "Pdirapply" - | Pgetglobal _ -> "Pgetglobal" - | Psetglobal _ -> "Psetglobal" - | Pmakeblock _ -> "Pmakeblock" - | Pfield _ -> "Pfield" - | Pfield_computed -> "Pfield_computed" - | Psetfield _ -> "Psetfield" - | Psetfield_computed _ -> "Psetfield_computed" - | Pfloatfield _ -> "Pfloatfield" - | Psetfloatfield _ -> "Psetfloatfield" - | Pduprecord _ -> "Pduprecord" - | Pccall _ -> "Pccall" - | Praise _ -> "Praise" - | Psequand -> "Psequand" - | Psequor -> "Psequor" - | Pnot -> "Pnot" - | Pnegint -> "Pnegint" - | Paddint -> "Paddint" - | Psubint -> "Psubint" - | Pmulint -> "Pmulint" - | Pdivint _ -> "Pdivint" - | Pmodint _ -> "Pmodint" - | Pandint -> "Pandint" - | Porint -> "Porint" - | Pxorint -> "Pxorint" - | Plslint -> "Plslint" - | Plsrint -> "Plsrint" - | Pasrint -> "Pasrint" - | Pintcomp _ -> "Pintcomp" - | Poffsetint _ -> "Poffsetint" - | Poffsetref _ -> "Poffsetref" - | Pintoffloat -> "Pintoffloat" - | Pfloatofint -> "Pfloatofint" - | Pnegfloat -> "Pnegfloat" - | Pabsfloat -> "Pabsfloat" - | Paddfloat -> "Paddfloat" - | Psubfloat -> "Psubfloat" - | Pmulfloat -> "Pmulfloat" - | Pdivfloat -> "Pdivfloat" - | Pfloatcomp _ -> "Pfloatcomp" - | Pstringlength -> "Pstringlength" - | Pstringrefu -> "Pstringrefu" - | Pstringrefs -> "Pstringrefs" - | Pbyteslength -> "Pbyteslength" - | Pbytesrefu -> "Pbytesrefu" - | Pbytessetu -> "Pbytessetu" - | Pbytesrefs -> "Pbytesrefs" - | Pbytessets -> "Pbytessets" - | Parraylength _ -> "Parraylength" - | Pmakearray _ -> "Pmakearray" - | Pduparray _ -> "Pduparray" - | Parrayrefu _ -> "Parrayrefu" - | Parraysetu _ -> "Parraysetu" - | Parrayrefs _ -> "Parrayrefs" - | Parraysets _ -> "Parraysets" - | Pctconst _ -> "Pctconst" - | Pisint -> "Pisint" - | Pisout -> "Pisout" - | Pbintofint _ -> "Pbintofint" - | Pintofbint _ -> "Pintofbint" - | Pcvtbint _ -> "Pcvtbint" - | Pnegbint _ -> "Pnegbint" - | Paddbint _ -> "Paddbint" - | Psubbint _ -> "Psubbint" - | Pmulbint _ -> "Pmulbint" - | Pdivbint _ -> "Pdivbint" - | Pmodbint _ -> "Pmodbint" - | Pandbint _ -> "Pandbint" - | Porbint _ -> "Porbint" - | Pxorbint _ -> "Pxorbint" - | Plslbint _ -> "Plslbint" - | Plsrbint _ -> "Plsrbint" - | Pasrbint _ -> "Pasrbint" - | Pbintcomp _ -> "Pbintcomp" - | Pbigarrayref _ -> "Pbigarrayref" - | Pbigarrayset _ -> "Pbigarrayset" - | Pbigarraydim _ -> "Pbigarraydim" - | Pstring_load_16 _ -> "Pstring_load_16" - | Pstring_load_32 _ -> "Pstring_load_32" - | Pstring_load_64 _ -> "Pstring_load_64" - | Pbytes_load_16 _ -> "Pbytes_load_16" - | Pbytes_load_32 _ -> "Pbytes_load_32" - | Pbytes_load_64 _ -> "Pbytes_load_64" - | Pbytes_set_16 _ -> "Pbytes_set_16" - | Pbytes_set_32 _ -> "Pbytes_set_32" - | Pbytes_set_64 _ -> "Pbytes_set_64" - | Pbigstring_load_16 _ -> "Pbigstring_load_16" - | Pbigstring_load_32 _ -> "Pbigstring_load_32" - | Pbigstring_load_64 _ -> "Pbigstring_load_64" - | Pbigstring_set_16 _ -> "Pbigstring_set_16" - | Pbigstring_set_32 _ -> "Pbigstring_set_32" - | Pbigstring_set_64 _ -> "Pbigstring_set_64" - | Pbswap16 -> "Pbswap16" - | Pbbswap _ -> "Pbbswap" - | Pint_as_pointer -> "Pint_as_pointer" - | Popaque -> "Popaque" - -let function_attribute ppf { inline; specialise; local; is_a_functor; stub } = - if is_a_functor then - fprintf ppf "is_a_functor@ "; - if stub then - fprintf ppf "stub@ "; - begin match inline with - | Default_inline -> () - | Always_inline -> fprintf ppf "always_inline@ " - | Never_inline -> fprintf ppf "never_inline@ " - | Unroll i -> fprintf ppf "unroll(%i)@ " i - end; - begin match specialise with - | Default_specialise -> () - | Always_specialise -> fprintf ppf "always_specialise@ " - | Never_specialise -> fprintf ppf "never_specialise@ " - end; - begin match local with - | Default_local -> () - | Always_local -> fprintf ppf "always_local@ " - | Never_local -> fprintf ppf "never_local@ " - end - -let apply_tailcall_attribute ppf tailcall = - if tailcall then - fprintf ppf " @@tailcall" - -let apply_inlined_attribute ppf = function - | Default_inline -> () - | Always_inline -> fprintf ppf " always_inline" - | Never_inline -> fprintf ppf " never_inline" - | Unroll i -> fprintf ppf " never_inline(%i)" i - -let apply_specialised_attribute ppf = function - | Default_specialise -> () - | Always_specialise -> fprintf ppf " always_specialise" - | Never_specialise -> fprintf ppf " never_specialise" - -let rec lam ppf = function - | Lvar id -> - Ident.print ppf id - | Lconst cst -> - struct_const ppf cst - | Lapply ap -> - let lams ppf largs = - List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in - fprintf ppf "@[<2>(apply@ %a%a%a%a%a)@]" lam ap.ap_func lams ap.ap_args - apply_tailcall_attribute ap.ap_should_be_tailcall - apply_inlined_attribute ap.ap_inlined - apply_specialised_attribute ap.ap_specialised - | Lfunction{kind; params; return; body; attr} -> - let pr_params ppf params = - match kind with - | Curried -> - List.iter (fun (param, k) -> - fprintf ppf "@ %a%a" Ident.print param value_kind k) params - | Tupled -> - fprintf ppf " ("; - let first = ref true in - List.iter - (fun (param, k) -> - if !first then first := false else fprintf ppf ",@ "; - Ident.print ppf param; - value_kind ppf k) - params; - fprintf ppf ")" in - fprintf ppf "@[<2>(function%a@ %a%a%a)@]" pr_params params - function_attribute attr return_kind return lam body - | Llet(str, k, id, arg, body) -> - let kind = function - Alias -> "a" | Strict -> "" | StrictOpt -> "o" | Variable -> "v" - in - let rec letbody = function - | Llet(str, k, id, arg, body) -> - fprintf ppf "@ @[<2>%a =%s%a@ %a@]" - Ident.print id (kind str) value_kind k lam arg; - letbody body - | expr -> expr in - fprintf ppf "@[<2>(let@ @[(@[<2>%a =%s%a@ %a@]" - Ident.print id (kind str) value_kind k lam arg; - let expr = letbody body in - fprintf ppf ")@]@ %a)@]" lam expr - | Lletrec(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@]" Ident.print id lam l) - id_arg_list in - fprintf ppf - "@[<2>(letrec@ (@[%a@])@ %a)@]" bindings id_arg_list lam body - | Lprim(prim, largs, _) -> - let lams ppf largs = - List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in - fprintf ppf "@[<2>(%a%a)@]" primitive prim lams largs - | Lswitch(larg, sw, _loc) -> - let switch ppf sw = - 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.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.sw_blocks ; - begin match sw.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 %a@ @[%a@])@]" - (match sw.sw_failaction with None -> "switch*" | _ -> "switch") - lam larg switch sw - | Lstringswitch(arg, cases, default, _) -> - let switch ppf cases = - let spc = ref false in - List.iter - (fun (s, l) -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[case \"%s\":@ %a@]" (String.escaped s) lam l) - cases; - 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@])@]" lam arg switch cases - | Lstaticraise (i, ls) -> - let lams ppf largs = - List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in - fprintf ppf "@[<2>(exit@ %d%a)@]" i lams ls; - | Lstaticcatch(lbody, (i, vars), lhandler) -> - fprintf ppf "@[<2>(catch@ %a@;<1 -1>with (%d%a)@ %a)@]" - lam lbody i - (fun ppf vars -> - List.iter - (fun (x, k) -> fprintf ppf " %a%a" Ident.print x value_kind k) - vars - ) - vars - lam lhandler - | Ltrywith(lbody, param, lhandler) -> - fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]" - lam lbody Ident.print param lam lhandler - | Lifthenelse(lcond, lif, lelse) -> - fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" lam lcond lam lif lam lelse - | Lsequence(l1, l2) -> - fprintf ppf "@[<2>(seq@ %a@ %a)@]" lam l1 sequence l2 - | Lwhile(lcond, lbody) -> - fprintf ppf "@[<2>(while@ %a@ %a)@]" lam lcond lam lbody - | Lfor(param, lo, hi, dir, body) -> - fprintf ppf "@[<2>(for %a@ %a@ %s@ %a@ %a)@]" - Ident.print param lam lo - (match dir with Upto -> "to" | Downto -> "downto") - lam hi lam body - | Lassign(id, expr) -> - fprintf ppf "@[<2>(assign@ %a@ %a)@]" Ident.print id lam expr - | Lsend (k, met, obj, largs, _) -> - let args ppf largs = - List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in - let kind = - if k = Self then "self" else if k = Cached then "cache" else "" in - fprintf ppf "@[<2>(send%s@ %a@ %a%a)@]" kind lam obj lam met args largs - | Levent(expr, ev) -> - let kind = - match ev.lev_kind with - | Lev_before -> "before" - | Lev_after _ -> "after" - | Lev_function -> "funct-body" - | Lev_pseudo -> "pseudo" - | Lev_module_definition ident -> - Format.asprintf "module-defn(%a)" Ident.print ident - in - fprintf ppf "@[<2>(%s %s(%i)%s:%i-%i@ %a)@]" kind - ev.lev_loc.Location.loc_start.Lexing.pos_fname - ev.lev_loc.Location.loc_start.Lexing.pos_lnum - (if ev.lev_loc.Location.loc_ghost then "" else "") - ev.lev_loc.Location.loc_start.Lexing.pos_cnum - ev.lev_loc.Location.loc_end.Lexing.pos_cnum - lam expr - | Lifused(id, expr) -> - fprintf ppf "@[<2>(ifused@ %a@ %a)@]" Ident.print id lam expr - -and sequence ppf = function - | Lsequence(l1, l2) -> - fprintf ppf "%a@ %a" sequence l1 sequence l2 - | l -> - lam ppf l - -let structured_constant = struct_const - -let lambda = lam - -let program ppf { code } = lambda ppf code diff --git a/bytecomp/printlambda.mli b/bytecomp/printlambda.mli deleted file mode 100644 index 7dab5229ac..0000000000 --- a/bytecomp/printlambda.mli +++ /dev/null @@ -1,32 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -open Lambda - -open Format - -val integer_comparison: formatter -> integer_comparison -> unit -val float_comparison: formatter -> float_comparison -> unit -val structured_constant: formatter -> structured_constant -> unit -val lambda: formatter -> lambda -> unit -val program: formatter -> program -> unit -val primitive: formatter -> primitive -> unit -val name_of_primitive : primitive -> string -val value_kind : formatter -> value_kind -> unit -val block_shape : formatter -> value_kind list option -> unit -val record_rep : formatter -> Types.record_representation -> unit -val print_bigarray : - string -> bool -> Lambda.bigarray_kind -> formatter -> - Lambda.bigarray_layout -> unit diff --git a/bytecomp/runtimedef.mli b/bytecomp/runtimedef.mli deleted file mode 100644 index 3baabb643b..0000000000 --- a/bytecomp/runtimedef.mli +++ /dev/null @@ -1,19 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Values and functions known and/or provided by the runtime system *) - -val builtin_exceptions: string array -val builtin_primitives: string array diff --git a/bytecomp/simplif.ml b/bytecomp/simplif.ml deleted file mode 100644 index d57171e8b1..0000000000 --- a/bytecomp/simplif.ml +++ /dev/null @@ -1,854 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Elimination of useless Llet(Alias) bindings. - Also transform let-bound references into variables. *) - -open Asttypes -open Lambda - -(* To transform let-bound references into variables *) - -exception Real_reference - -let rec eliminate_ref id = function - Lvar v as lam -> - if Ident.same v id then raise Real_reference else lam - | Lconst _ as lam -> lam - | Lapply ap -> - Lapply{ap with ap_func = eliminate_ref id ap.ap_func; - ap_args = List.map (eliminate_ref id) ap.ap_args} - | Lfunction _ as lam -> - if Ident.Set.mem id (free_variables lam) - then raise Real_reference - else lam - | Llet(str, kind, v, e1, e2) -> - Llet(str, kind, v, eliminate_ref id e1, eliminate_ref id e2) - | Lletrec(idel, e2) -> - Lletrec(List.map (fun (v, e) -> (v, eliminate_ref id e)) idel, - eliminate_ref id e2) - | Lprim(Pfield 0, [Lvar v], _) when Ident.same v id -> - Lvar id - | Lprim(Psetfield(0, _, _), [Lvar v; e], _) when Ident.same v id -> - Lassign(id, eliminate_ref id e) - | Lprim(Poffsetref delta, [Lvar v], loc) when Ident.same v id -> - Lassign(id, Lprim(Poffsetint delta, [Lvar id], loc)) - | Lprim(p, el, loc) -> - Lprim(p, List.map (eliminate_ref id) el, loc) - | Lswitch(e, sw, loc) -> - Lswitch(eliminate_ref id e, - {sw_numconsts = sw.sw_numconsts; - sw_consts = - List.map (fun (n, e) -> (n, eliminate_ref id e)) sw.sw_consts; - sw_numblocks = sw.sw_numblocks; - sw_blocks = - List.map (fun (n, e) -> (n, eliminate_ref id e)) sw.sw_blocks; - sw_failaction = - Misc.may_map (eliminate_ref id) sw.sw_failaction; }, - loc) - | Lstringswitch(e, sw, default, loc) -> - Lstringswitch - (eliminate_ref id e, - List.map (fun (s, e) -> (s, eliminate_ref id e)) sw, - Misc.may_map (eliminate_ref id) default, loc) - | Lstaticraise (i,args) -> - Lstaticraise (i,List.map (eliminate_ref id) args) - | Lstaticcatch(e1, i, e2) -> - Lstaticcatch(eliminate_ref id e1, i, eliminate_ref id e2) - | Ltrywith(e1, v, e2) -> - Ltrywith(eliminate_ref id e1, v, eliminate_ref id e2) - | Lifthenelse(e1, e2, e3) -> - Lifthenelse(eliminate_ref id e1, - eliminate_ref id e2, - eliminate_ref id e3) - | Lsequence(e1, e2) -> - Lsequence(eliminate_ref id e1, eliminate_ref id e2) - | Lwhile(e1, e2) -> - Lwhile(eliminate_ref id e1, eliminate_ref id e2) - | Lfor(v, e1, e2, dir, e3) -> - Lfor(v, eliminate_ref id e1, eliminate_ref id e2, - dir, eliminate_ref id e3) - | Lassign(v, e) -> - Lassign(v, eliminate_ref id e) - | Lsend(k, m, o, el, loc) -> - Lsend(k, eliminate_ref id m, eliminate_ref id o, - List.map (eliminate_ref id) el, loc) - | Levent(l, ev) -> - Levent(eliminate_ref id l, ev) - | Lifused(v, e) -> - Lifused(v, eliminate_ref id e) - -(* Simplification of exits *) - -type exit = { - mutable count: int; - mutable max_depth: int; -} - -let simplify_exits lam = - - (* Count occurrences of (exit n ...) statements *) - let exits = Hashtbl.create 17 in - - let try_depth = ref 0 in - - let get_exit i = - try Hashtbl.find exits i - with Not_found -> {count = 0; max_depth = 0} - - and incr_exit i nb d = - match Hashtbl.find_opt exits i with - | Some r -> - r.count <- r.count + nb; - r.max_depth <- max r.max_depth d - | None -> - let r = {count = nb; max_depth = d} in - Hashtbl.add exits i r - in - - let rec count = function - | (Lvar _| Lconst _) -> () - | Lapply ap -> count ap.ap_func; List.iter count ap.ap_args - | Lfunction {body} -> count body - | Llet(_str, _kind, _v, l1, l2) -> - count l2; count l1 - | Lletrec(bindings, body) -> - List.iter (fun (_v, l) -> count l) bindings; - count body - | Lprim(_p, ll, _) -> List.iter count ll - | Lswitch(l, sw, _loc) -> - count_default sw ; - count l; - List.iter (fun (_, l) -> count l) sw.sw_consts; - List.iter (fun (_, l) -> count l) sw.sw_blocks - | Lstringswitch(l, sw, d, _) -> - count l; - List.iter (fun (_, l) -> count l) sw; - begin match d with - | None -> () - | Some d -> match sw with - | []|[_] -> count d - | _ -> count d; count d (* default will get replicated *) - end - | Lstaticraise (i,ls) -> incr_exit i 1 !try_depth; List.iter count ls - | Lstaticcatch (l1,(i,[]),Lstaticraise (j,[])) -> - (* i will be replaced by j in l1, so each occurrence of i in l1 - increases j's ref count *) - count l1 ; - let ic = get_exit i in - incr_exit j ic.count (max !try_depth ic.max_depth) - | Lstaticcatch(l1, (i,_), l2) -> - count l1; - (* If l1 does not contain (exit i), - l2 will be removed, so don't count its exits *) - if (get_exit i).count > 0 then - count l2 - | Ltrywith(l1, _v, l2) -> incr try_depth; count l1; decr try_depth; count l2 - | Lifthenelse(l1, l2, l3) -> count l1; count l2; count l3 - | Lsequence(l1, l2) -> count l1; count l2 - | Lwhile(l1, l2) -> count l1; count l2 - | Lfor(_, l1, l2, _dir, l3) -> count l1; count l2; count l3 - | Lassign(_v, l) -> count l - | Lsend(_k, m, o, ll, _) -> List.iter count (m::o::ll) - | Levent(l, _) -> count l - | Lifused(_v, l) -> count l - - and count_default sw = match sw.sw_failaction with - | None -> () - | Some al -> - let nconsts = List.length sw.sw_consts - and nblocks = List.length sw.sw_blocks in - if - nconsts < sw.sw_numconsts && nblocks < sw.sw_numblocks - then begin (* default action will occur twice in native code *) - count al ; count al - end else begin (* default action will occur once *) - assert (nconsts < sw.sw_numconsts || nblocks < sw.sw_numblocks) ; - count al - end - in - count lam; - assert(!try_depth = 0); - - (* - Second pass simplify ``catch body with (i ...) handler'' - - if (exit i ...) does not occur in body, suppress catch - - if (exit i ...) occurs exactly once in body, - substitute it with handler - - If handler is a single variable, replace (exit i ..) with it - Note: - In ``catch body with (i x1 .. xn) handler'' - Substituted expression is - let y1 = x1 and ... yn = xn in - handler[x1 <- y1 ; ... ; xn <- yn] - For the sake of preserving the uniqueness of bound variables. - (No alpha conversion of ``handler'' is presently needed, since - substitution of several ``(exit i ...)'' - occurs only when ``handler'' is a variable.) - *) - - let subst = Hashtbl.create 17 in - - let rec simplif = function - | (Lvar _|Lconst _) as l -> l - | Lapply ap -> - Lapply{ap with ap_func = simplif ap.ap_func; - ap_args = List.map simplif ap.ap_args} - | Lfunction{kind; params; return; body = l; attr; loc} -> - Lfunction{kind; params; return; body = simplif l; attr; loc} - | Llet(str, kind, v, l1, l2) -> Llet(str, kind, v, simplif l1, simplif l2) - | Lletrec(bindings, body) -> - Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body) - | Lprim(p, ll, loc) -> begin - let ll = List.map simplif ll in - match p, ll with - (* Simplify %revapply, for n-ary functions with n > 1 *) - | Prevapply, [x; Lapply ap] - | Prevapply, [x; Levent (Lapply ap,_)] -> - Lapply {ap with ap_args = ap.ap_args @ [x]; ap_loc = loc} - | Prevapply, [x; f] -> Lapply {ap_should_be_tailcall=false; - ap_loc=loc; - ap_func=f; - ap_args=[x]; - ap_inlined=Default_inline; - ap_specialised=Default_specialise} - - (* Simplify %apply, for n-ary functions with n > 1 *) - | Pdirapply, [Lapply ap; x] - | Pdirapply, [Levent (Lapply ap,_); x] -> - Lapply {ap with ap_args = ap.ap_args @ [x]; ap_loc = loc} - | Pdirapply, [f; x] -> Lapply {ap_should_be_tailcall=false; - ap_loc=loc; - ap_func=f; - ap_args=[x]; - ap_inlined=Default_inline; - ap_specialised=Default_specialise} - (* Simplify %identity *) - | Pidentity, [e] -> e - - (* Simplify Obj.with_tag *) - | Pccall { Primitive.prim_name = "caml_obj_with_tag"; _ }, - [Lconst (Const_base (Const_int tag)); - Lprim (Pmakeblock (_, mut, shape), fields, loc)] -> - Lprim (Pmakeblock(tag, mut, shape), fields, loc) - | Pccall { Primitive.prim_name = "caml_obj_with_tag"; _ }, - [Lconst (Const_base (Const_int tag)); - Lconst (Const_block (_, fields))] -> - Lconst (Const_block (tag, fields)) - - | _ -> Lprim(p, ll, loc) - end - | Lswitch(l, sw, loc) -> - let new_l = simplif l - and new_consts = List.map (fun (n, e) -> (n, simplif e)) sw.sw_consts - and new_blocks = List.map (fun (n, e) -> (n, simplif e)) sw.sw_blocks - and new_fail = Misc.may_map simplif sw.sw_failaction in - Lswitch - (new_l, - {sw with sw_consts = new_consts ; sw_blocks = new_blocks; - sw_failaction = new_fail}, - loc) - | Lstringswitch(l,sw,d,loc) -> - Lstringswitch - (simplif l,List.map (fun (s,l) -> s,simplif l) sw, - Misc.may_map simplif d,loc) - | Lstaticraise (i,[]) as l -> - begin try - let _,handler = Hashtbl.find subst i in - handler - with - | Not_found -> l - end - | Lstaticraise (i,ls) -> - let ls = List.map simplif ls in - begin try - let xs,handler = Hashtbl.find subst i in - let ys = List.map (fun (x, k) -> Ident.rename x, k) xs in - let env = - List.fold_right2 - (fun (x, _) (y, _) env -> Ident.Map.add x y env) - xs ys Ident.Map.empty - in - List.fold_right2 - (fun (y, kind) l r -> Llet (Strict, kind, y, l, r)) - ys ls (Lambda.rename env handler) - with - | Not_found -> Lstaticraise (i,ls) - end - | Lstaticcatch (l1,(i,[]),(Lstaticraise (_j,[]) as l2)) -> - Hashtbl.add subst i ([],simplif l2) ; - simplif l1 - | Lstaticcatch (l1,(i,xs),l2) -> - let {count; max_depth} = get_exit i in - if count = 0 then - (* Discard staticcatch: not matching exit *) - simplif l1 - else if count = 1 && max_depth <= !try_depth then begin - (* Inline handler if there is a single occurrence and it is not - nested within an inner try..with *) - assert(max_depth = !try_depth); - Hashtbl.add subst i (xs,simplif l2); - simplif l1 - end else - Lstaticcatch (simplif l1, (i,xs), simplif l2) - | Ltrywith(l1, v, l2) -> - incr try_depth; - let l1 = simplif l1 in - decr try_depth; - Ltrywith(l1, v, simplif l2) - | Lifthenelse(l1, l2, l3) -> Lifthenelse(simplif l1, simplif l2, simplif l3) - | Lsequence(l1, l2) -> Lsequence(simplif l1, simplif l2) - | Lwhile(l1, l2) -> Lwhile(simplif l1, simplif l2) - | Lfor(v, l1, l2, dir, l3) -> - Lfor(v, simplif l1, simplif l2, dir, simplif l3) - | Lassign(v, l) -> Lassign(v, simplif l) - | Lsend(k, m, o, ll, loc) -> - Lsend(k, simplif m, simplif o, List.map simplif ll, loc) - | Levent(l, ev) -> Levent(simplif l, ev) - | Lifused(v, l) -> Lifused (v,simplif l) - in - simplif lam - -(* Compile-time beta-reduction of functions immediately applied: - Lapply(Lfunction(Curried, params, body), args, loc) -> - let paramN = argN in ... let param1 = arg1 in body - Lapply(Lfunction(Tupled, params, body), [Lprim(Pmakeblock(args))], loc) -> - let paramN = argN in ... let param1 = arg1 in body - Assumes |args| = |params|. -*) - -let beta_reduce params body args = - List.fold_left2 (fun l (param, kind) arg -> Llet(Strict, kind, param, arg, l)) - body params args - -(* Simplification of lets *) - -let simplify_lets lam = - - (* Disable optimisations for bytecode compilation with -g flag *) - let optimize = !Clflags.native_code || not !Clflags.debug in - - (* First pass: count the occurrences of all let-bound identifiers *) - - let occ = (Hashtbl.create 83: (Ident.t, int ref) Hashtbl.t) in - (* The global table [occ] associates to each let-bound identifier - the number of its uses (as a reference): - - 0 if never used - - 1 if used exactly once in and not under a lambda or within a loop - - > 1 if used several times or under a lambda or within a loop. - The local table [bv] associates to each locally-let-bound variable - its reference count, as above. [bv] is enriched at let bindings - but emptied when crossing lambdas and loops. *) - - (* Current use count of a variable. *) - let count_var v = - try - !(Hashtbl.find occ v) - with Not_found -> - 0 - - (* Entering a [let]. Returns updated [bv]. *) - and bind_var bv v = - let r = ref 0 in - Hashtbl.add occ v r; - Ident.Map.add v r bv - - (* Record a use of a variable *) - and use_var bv v n = - try - let r = Ident.Map.find v bv in r := !r + n - with Not_found -> - (* v is not locally bound, therefore this is a use under a lambda - or within a loop. Increase use count by 2 -- enough so - that single-use optimizations will not apply. *) - try - let r = Hashtbl.find occ v in r := !r + 2 - with Not_found -> - (* Not a let-bound variable, ignore *) - () in - - let rec count bv = function - | Lconst _ -> () - | Lvar v -> - use_var bv v 1 - | Lapply{ap_func = Lfunction{kind = Curried; params; body}; ap_args = args} - when optimize && List.length params = List.length args -> - count bv (beta_reduce params body args) - | Lapply{ap_func = Lfunction{kind = Tupled; params; body}; - ap_args = [Lprim(Pmakeblock _, args, _)]} - when optimize && List.length params = List.length args -> - count bv (beta_reduce params body args) - | Lapply{ap_func = l1; ap_args = ll} -> - count bv l1; List.iter (count bv) ll - | Lfunction {body} -> - count Ident.Map.empty body - | Llet(_str, _k, v, Lvar w, l2) when optimize -> - (* v will be replaced by w in l2, so each occurrence of v in l2 - increases w's refcount *) - count (bind_var bv v) l2; - use_var bv w (count_var v) - | Llet(str, _kind, v, l1, l2) -> - count (bind_var bv v) l2; - (* If v is unused, l1 will be removed, so don't count its variables *) - if str = Strict || count_var v > 0 then count bv l1 - | Lletrec(bindings, body) -> - List.iter (fun (_v, l) -> count bv l) bindings; - count bv body - | Lprim(_p, ll, _) -> List.iter (count bv) ll - | Lswitch(l, sw, _loc) -> - count_default bv sw ; - count bv l; - List.iter (fun (_, l) -> count bv l) sw.sw_consts; - List.iter (fun (_, l) -> count bv l) sw.sw_blocks - | Lstringswitch(l, sw, d, _) -> - count bv l ; - List.iter (fun (_, l) -> count bv l) sw ; - begin match d with - | Some d -> - begin match sw with - | []|[_] -> count bv d - | _ -> count bv d ; count bv d - end - | None -> () - end - | Lstaticraise (_i,ls) -> List.iter (count bv) ls - | Lstaticcatch(l1, _, l2) -> count bv l1; count bv l2 - | Ltrywith(l1, _v, l2) -> count bv l1; count bv l2 - | Lifthenelse(l1, l2, l3) -> count bv l1; count bv l2; count bv l3 - | Lsequence(l1, l2) -> count bv l1; count bv l2 - | Lwhile(l1, l2) -> count Ident.Map.empty l1; count Ident.Map.empty l2 - | Lfor(_, l1, l2, _dir, l3) -> - count bv l1; count bv l2; count Ident.Map.empty l3 - | Lassign(_v, l) -> - (* Lalias-bound variables are never assigned, so don't increase - v's refcount *) - count bv l - | Lsend(_, m, o, ll, _) -> List.iter (count bv) (m::o::ll) - | Levent(l, _) -> count bv l - | Lifused(v, l) -> - if count_var v > 0 then count bv l - - and count_default bv sw = match sw.sw_failaction with - | None -> () - | Some al -> - let nconsts = List.length sw.sw_consts - and nblocks = List.length sw.sw_blocks in - if - nconsts < sw.sw_numconsts && nblocks < sw.sw_numblocks - then begin (* default action will occur twice in native code *) - count bv al ; count bv al - end else begin (* default action will occur once *) - assert (nconsts < sw.sw_numconsts || nblocks < sw.sw_numblocks) ; - count bv al - end - in - count Ident.Map.empty lam; - - (* Second pass: remove Lalias bindings of unused variables, - and substitute the bindings of variables used exactly once. *) - - let subst = Hashtbl.create 83 in - -(* This (small) optimisation is always legal, it may uncover some - tail call later on. *) - - let mklet str kind v e1 e2 = match e2 with - | Lvar w when optimize && Ident.same v w -> e1 - | _ -> Llet (str, kind,v,e1,e2) in - - - let rec simplif = function - Lvar v as l -> - begin try - Hashtbl.find subst v - with Not_found -> - l - end - | Lconst _ as l -> l - | Lapply{ap_func = Lfunction{kind = Curried; params; body}; ap_args = args} - when optimize && List.length params = List.length args -> - simplif (beta_reduce params body args) - | Lapply{ap_func = Lfunction{kind = Tupled; params; body}; - ap_args = [Lprim(Pmakeblock _, args, _)]} - when optimize && List.length params = List.length args -> - simplif (beta_reduce params body args) - | Lapply ap -> Lapply {ap with ap_func = simplif ap.ap_func; - ap_args = List.map simplif ap.ap_args} - | Lfunction{kind; params; return=return1; body = l; attr; loc} -> - begin match simplif l with - Lfunction{kind=Curried; params=params'; return=return2; body; attr; loc} - when kind = Curried && optimize -> - (* The return type is the type of the value returned after - applying all the parameters to the function. The return - type of the merged function taking [params @ params'] as - parameters is the type returned after applying [params']. *) - let return = return2 in - Lfunction{kind; params = params @ params'; return; body; attr; loc} - | body -> - Lfunction{kind; params; return = return1; body; attr; loc} - end - | Llet(_str, _k, v, Lvar w, l2) when optimize -> - Hashtbl.add subst v (simplif (Lvar w)); - simplif l2 - | Llet(Strict, kind, v, - Lprim(Pmakeblock(0, Mutable, kind_ref) as prim, [linit], loc), lbody) - when optimize -> - let slinit = simplif linit in - let slbody = simplif lbody in - begin try - let kind = match kind_ref with - | None -> Pgenval - | Some [field_kind] -> field_kind - | Some _ -> assert false - in - mklet Variable kind v slinit (eliminate_ref v slbody) - with Real_reference -> - mklet Strict kind v (Lprim(prim, [slinit], loc)) slbody - end - | Llet(Alias, kind, v, l1, l2) -> - begin match count_var v with - 0 -> simplif l2 - | 1 when optimize -> Hashtbl.add subst v (simplif l1); simplif l2 - | _ -> Llet(Alias, kind, v, simplif l1, simplif l2) - end - | Llet(StrictOpt, kind, v, l1, l2) -> - begin match count_var v with - 0 -> simplif l2 - | _ -> mklet StrictOpt kind v (simplif l1) (simplif l2) - end - | Llet(str, kind, v, l1, l2) -> mklet str kind v (simplif l1) (simplif l2) - | Lletrec(bindings, body) -> - Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body) - | Lprim(p, ll, loc) -> Lprim(p, List.map simplif ll, loc) - | Lswitch(l, sw, loc) -> - let new_l = simplif l - and new_consts = List.map (fun (n, e) -> (n, simplif e)) sw.sw_consts - and new_blocks = List.map (fun (n, e) -> (n, simplif e)) sw.sw_blocks - and new_fail = Misc.may_map simplif sw.sw_failaction in - Lswitch - (new_l, - {sw with sw_consts = new_consts ; sw_blocks = new_blocks; - sw_failaction = new_fail}, - loc) - | Lstringswitch (l,sw,d,loc) -> - Lstringswitch - (simplif l,List.map (fun (s,l) -> s,simplif l) sw, - Misc.may_map simplif d,loc) - | Lstaticraise (i,ls) -> - Lstaticraise (i, List.map simplif ls) - | Lstaticcatch(l1, (i,args), l2) -> - Lstaticcatch (simplif l1, (i,args), simplif l2) - | Ltrywith(l1, v, l2) -> Ltrywith(simplif l1, v, simplif l2) - | Lifthenelse(l1, l2, l3) -> Lifthenelse(simplif l1, simplif l2, simplif l3) - | Lsequence(Lifused(v, l1), l2) -> - if count_var v > 0 - then Lsequence(simplif l1, simplif l2) - else simplif l2 - | Lsequence(l1, l2) -> Lsequence(simplif l1, simplif l2) - | Lwhile(l1, l2) -> Lwhile(simplif l1, simplif l2) - | Lfor(v, l1, l2, dir, l3) -> - Lfor(v, simplif l1, simplif l2, dir, simplif l3) - | Lassign(v, l) -> Lassign(v, simplif l) - | Lsend(k, m, o, ll, loc) -> - Lsend(k, simplif m, simplif o, List.map simplif ll, loc) - | Levent(l, ev) -> Levent(simplif l, ev) - | Lifused(v, l) -> - if count_var v > 0 then simplif l else lambda_unit - in - simplif lam - -(* Tail call info in annotation files *) - -let is_tail_native_heuristic : (int -> bool) ref = - ref (fun _ -> true) - -let rec emit_tail_infos is_tail lambda = - let call_kind args = - if is_tail - && ((not !Clflags.native_code) - || (!is_tail_native_heuristic (List.length args))) - then Annot.Tail - else Annot.Stack in - match lambda with - | Lvar _ -> () - | Lconst _ -> () - | Lapply ap -> - if ap.ap_should_be_tailcall - && not is_tail - && Warnings.is_active Warnings.Expect_tailcall - then Location.prerr_warning ap.ap_loc Warnings.Expect_tailcall; - emit_tail_infos false ap.ap_func; - list_emit_tail_infos false ap.ap_args; - if !Clflags.annotations then - Stypes.record (Stypes.An_call (ap.ap_loc, call_kind ap.ap_args)) - | Lfunction {body = lam} -> - emit_tail_infos true lam - | Llet (_str, _k, _, lam, body) -> - emit_tail_infos false lam; - emit_tail_infos is_tail body - | Lletrec (bindings, body) -> - List.iter (fun (_, lam) -> emit_tail_infos false lam) bindings; - emit_tail_infos is_tail body - | Lprim (Pidentity, [arg], _) -> - emit_tail_infos is_tail arg - | Lprim ((Pbytes_to_string | Pbytes_of_string), [arg], _) -> - emit_tail_infos is_tail arg - | Lprim (Psequand, [arg1; arg2], _) - | Lprim (Psequor, [arg1; arg2], _) -> - emit_tail_infos false arg1; - emit_tail_infos is_tail arg2 - | Lprim (_, l, _) -> - list_emit_tail_infos false l - | Lswitch (lam, sw, _loc) -> - emit_tail_infos false lam; - list_emit_tail_infos_fun snd is_tail sw.sw_consts; - list_emit_tail_infos_fun snd is_tail sw.sw_blocks; - Misc.may (emit_tail_infos is_tail) sw.sw_failaction - | Lstringswitch (lam, sw, d, _) -> - emit_tail_infos false lam; - List.iter - (fun (_,lam) -> emit_tail_infos is_tail lam) - sw ; - Misc.may (emit_tail_infos is_tail) d - | Lstaticraise (_, l) -> - list_emit_tail_infos false l - | Lstaticcatch (body, _, handler) -> - emit_tail_infos is_tail body; - emit_tail_infos is_tail handler - | Ltrywith (body, _, handler) -> - emit_tail_infos false body; - emit_tail_infos is_tail handler - | Lifthenelse (cond, ifso, ifno) -> - emit_tail_infos false cond; - emit_tail_infos is_tail ifso; - emit_tail_infos is_tail ifno - | Lsequence (lam1, lam2) -> - emit_tail_infos false lam1; - emit_tail_infos is_tail lam2 - | Lwhile (cond, body) -> - emit_tail_infos false cond; - emit_tail_infos false body - | Lfor (_, low, high, _, body) -> - emit_tail_infos false low; - emit_tail_infos false high; - emit_tail_infos false body - | Lassign (_, lam) -> - emit_tail_infos false lam - | Lsend (_, meth, obj, args, loc) -> - emit_tail_infos false meth; - emit_tail_infos false obj; - list_emit_tail_infos false args; - if !Clflags.annotations then - Stypes.record (Stypes.An_call (loc, call_kind (obj :: args))); - | Levent (lam, _) -> - emit_tail_infos is_tail lam - | Lifused (_, lam) -> - emit_tail_infos is_tail lam -and list_emit_tail_infos_fun f is_tail = - List.iter (fun x -> emit_tail_infos is_tail (f x)) -and list_emit_tail_infos is_tail = - List.iter (emit_tail_infos is_tail) - -(* Split a function with default parameters into a wrapper and an - inner function. The wrapper fills in missing optional parameters - with their default value and tail-calls the inner function. The - wrapper can then hopefully be inlined on most call sites to avoid - the overhead associated with boxing an optional argument with a - 'Some' constructor, only to deconstruct it immediately in the - function's body. *) - -let split_default_wrapper ~id:fun_id ~kind ~params ~return ~body ~attr ~loc = - let rec aux map = function - | Llet(Strict, k, id, (Lifthenelse(Lvar optparam, _, _) as def), rest) when - Ident.name optparam = "*opt*" && List.mem_assoc optparam params - && not (List.mem_assoc optparam map) - -> - let wrapper_body, inner = aux ((optparam, id) :: map) rest in - Llet(Strict, k, id, def, wrapper_body), inner - | _ when map = [] -> raise Exit - | body -> - (* Check that those *opt* identifiers don't appear in the remaining - body. This should not appear, but let's be on the safe side. *) - let fv = Lambda.free_variables body in - List.iter (fun (id, _) -> if Ident.Set.mem id fv then raise Exit) map; - - let inner_id = Ident.create_local (Ident.name fun_id ^ "_inner") in - let map_param p = try List.assoc p map with Not_found -> p in - let args = List.map (fun (p, _) -> Lvar (map_param p)) params in - let wrapper_body = - Lapply { - ap_func = Lvar inner_id; - ap_args = args; - ap_loc = Location.none; - ap_should_be_tailcall = false; - ap_inlined = Default_inline; - ap_specialised = Default_specialise; - } - in - let inner_params = List.map map_param (List.map fst params) in - let new_ids = List.map Ident.rename inner_params in - let subst = - List.fold_left2 (fun s id new_id -> - Ident.Map.add id new_id s - ) Ident.Map.empty inner_params new_ids - in - let body = Lambda.rename subst body in - let inner_fun = - Lfunction { kind = Curried; - params = List.map (fun id -> id, Pgenval) new_ids; - return; body; attr; loc; } - in - (wrapper_body, (inner_id, inner_fun)) - in - try - let body, inner = aux [] body in - let attr = default_stub_attribute in - [(fun_id, Lfunction{kind; params; return; body; attr; loc}); inner] - with Exit -> - [(fun_id, Lfunction{kind; params; return; body; attr; loc})] - -(* Simplify local let-bound functions: if all occurrences are - fully-applied function calls in the same "tail scope", replace the - function by a staticcatch handler (on that scope). - - This handles as a special case functions used exactly once (in any - scope) for a full application. -*) - -type slot = - { - nargs: int; - mutable scope: lambda option; - } - -module LamTbl = Hashtbl.Make(struct - type t = lambda - let equal = (==) - let hash = Hashtbl.hash - end) - -let simplify_local_functions lam = - let slots = Hashtbl.create 16 in - let static_id = Hashtbl.create 16 in (* function id -> static id *) - let static = LamTbl.create 16 in (* scope -> static function on that scope *) - (* We keep track of the current "tail scope", identified - by the outermost lambda for which the the current lambda - is in tail position. *) - let current_scope = ref lam in - let check_static lf = - if lf.attr.local = Always_local then - Location.prerr_warning lf.loc - (Warnings.Inlining_impossible - "This function cannot be compiled into a static continuation") - in - let enabled = function - | {local = Always_local; _} - | {local = Default_local; inline = (Never_inline | Default_inline); _} - -> true - | {local = Default_local; inline = (Always_inline | Unroll _); _} - | {local = Never_local; _} - -> false - in - let rec tail = function - | Llet (_str, _kind, id, Lfunction lf, cont) when enabled lf.attr -> - let r = {nargs=List.length lf.params; scope=None} in - Hashtbl.add slots id r; - tail cont; - begin match Hashtbl.find_opt slots id with - | Some {scope = Some scope; _} -> - let st = next_raise_count () in - let sc = - (* Do not move higher than current lambda *) - if scope == !current_scope then cont - else scope - in - Hashtbl.add static_id id st; - LamTbl.add static sc (st, lf); - (* The body of the function will become an handler - in that "scope". *) - with_scope ~scope lf.body - | _ -> - check_static lf; - (* note: if scope = None, the function is unused *) - non_tail lf.body - end - | Lapply {ap_func = Lvar id; ap_args; _} -> - begin match Hashtbl.find_opt slots id with - | Some {nargs; _} when nargs <> List.length ap_args -> - (* Wrong arity *) - Hashtbl.remove slots id - | Some {scope = Some scope; _} when scope != !current_scope -> - (* Different "tail scope" *) - Hashtbl.remove slots id - | Some ({scope = None; _} as slot) -> - (* First use of the function: remember the current tail scope *) - slot.scope <- Some !current_scope - | _ -> - () - end; - List.iter non_tail ap_args - | Lvar id -> - Hashtbl.remove slots id - | Lfunction lf as lam -> - check_static lf; - Lambda.shallow_iter ~tail ~non_tail lam - | lam -> - Lambda.shallow_iter ~tail ~non_tail lam - and non_tail lam = - with_scope ~scope:lam lam - and with_scope ~scope lam = - let old_scope = !current_scope in - current_scope := scope; - tail lam; - current_scope := old_scope - in - tail lam; - let rec rewrite lam0 = - let lam = - match lam0 with - | Llet (_, _, id, _, cont) when Hashtbl.mem static_id id -> - rewrite cont - | Lapply {ap_func = Lvar id; ap_args; _} when Hashtbl.mem static_id id -> - Lstaticraise (Hashtbl.find static_id id, List.map rewrite ap_args) - | lam -> - Lambda.shallow_map rewrite lam - in - List.fold_right - (fun (st, lf) lam -> - Lstaticcatch (lam, (st, lf.params), rewrite lf.body) - ) - (LamTbl.find_all static lam0) - lam - in - if LamTbl.length static = 0 then - lam - else - rewrite lam - -(* The entry point: - simplification + emission of tailcall annotations, if needed. *) - -let simplify_lambda lam = - let lam = - lam - |> (if !Clflags.native_code || not !Clflags.debug - then simplify_local_functions else Fun.id - ) - |> simplify_exits - |> simplify_lets - in - if !Clflags.annotations || Warnings.is_active Warnings.Expect_tailcall - then emit_tail_infos true lam; - lam diff --git a/bytecomp/simplif.mli b/bytecomp/simplif.mli deleted file mode 100644 index d5ca210e5a..0000000000 --- a/bytecomp/simplif.mli +++ /dev/null @@ -1,44 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Lambda simplification. - - {b Warning:} this module is unstable and part of - {{!Compiler_libs}compiler-libs}. - -*) - -(* Elimination of useless Llet(Alias) bindings. - Transformation of let-bound references into variables. - Simplification over staticraise/staticcatch constructs. - Generation of tail-call annotations if -annot is set. *) - -open Lambda - -val simplify_lambda: lambda -> lambda - -val split_default_wrapper - : id:Ident.t - -> kind:function_kind - -> params:(Ident.t * Lambda.value_kind) list - -> return:Lambda.value_kind - -> body:lambda - -> attr:function_attribute - -> loc:Location.t - -> (Ident.t * lambda) list - -(* To be filled by asmcomp/selectgen.ml *) -val is_tail_native_heuristic: (int -> bool) ref - (* # arguments -> can tailcall *) diff --git a/bytecomp/switch.ml b/bytecomp/switch.ml deleted file mode 100644 index 89bfe83a07..0000000000 --- a/bytecomp/switch.ml +++ /dev/null @@ -1,877 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Luc Maranget, projet Moscova, INRIA Rocquencourt *) -(* *) -(* Copyright 2000 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 'a shared = Shared of 'a | Single of 'a - -type ('a, 'ctx) t_store = - {act_get : unit -> 'a array ; - act_get_shared : unit -> 'a shared array ; - act_store : 'ctx -> 'a -> int ; - act_store_shared : 'ctx -> 'a -> int ; } - -exception Not_simple - -module type Stored = sig - type t - type key - val compare_key : key -> key -> int - val make_key : t -> key option -end - -module type CtxStored = sig - include Stored - type context - val make_key : context -> t -> key option -end - -module CtxStore(A:CtxStored) = struct - module AMap = - Map.Make(struct type t = A.key let compare = A.compare_key end) - - type intern = - { mutable map : (bool * int) AMap.t ; - mutable next : int ; - mutable acts : (bool * A.t) list; } - - let mk_store () = - let st = - { map = AMap.empty ; - next = 0 ; - acts = [] ; } in - - let add mustshare act = - let i = st.next in - st.acts <- (mustshare,act) :: st.acts ; - st.next <- i+1 ; - i in - - let store mustshare ctx act = match A.make_key ctx act with - | Some key -> - begin try - let (shared,i) = AMap.find key st.map in - if not shared then st.map <- AMap.add key (true,i) st.map ; - i - with Not_found -> - let i = add mustshare act in - st.map <- AMap.add key (mustshare,i) st.map ; - i - end - | None -> - add mustshare act - - and get () = Array.of_list (List.rev_map (fun (_,act) -> act) st.acts) - - and get_shared () = - let acts = - Array.of_list - (List.rev_map - (fun (shared,act) -> - if shared then Shared act else Single act) - st.acts) in - AMap.iter - (fun _ (shared,i) -> - if shared then match acts.(i) with - | Single act -> acts.(i) <- Shared act - | Shared _ -> ()) - st.map ; - acts in - {act_store = store false ; act_store_shared = store true ; - act_get = get; act_get_shared = get_shared; } -end - -module Store(A:Stored) = struct - module Me = - CtxStore - (struct - include A - type context = unit - let make_key () = A.make_key - end) - - let mk_store = Me.mk_store -end - - - -module type S = -sig - type primitive - val eqint : primitive - val neint : primitive - val leint : primitive - val ltint : primitive - val geint : primitive - val gtint : primitive - type act - - val bind : act -> (act -> act) -> act - val make_const : int -> act - val make_offset : act -> int -> act - val make_prim : primitive -> act list -> act - val make_isout : act -> act -> act - val make_isin : act -> act -> act - val make_if : act -> act -> act -> act - val make_switch : Location.t -> act -> int array -> act array -> act - val make_catch : act -> int * (act -> act) - val make_exit : int -> act -end - -(* The module will ``produce good code for the case statement'' *) -(* - Adaptation of - R.L. Berstein - ``Producing good code for the case statement'' - Software Practice and Experience, 15(10) (1985) - and - D.L. Spuler - ``Two-Way Comparison Search Trees, a Generalisation of Binary Search Trees - and Split Trees'' - ``Compiler Code Generation for Multiway Branch Statement as - a Static Search Problem'' - Technical Reports, James Cook University -*) -(* - Main adaptation is considering interval tests - (implemented as one addition + one unsigned test and branch) - which leads to exhaustive search for finding the optimal - test sequence in small cases and heuristics otherwise. -*) -module Make (Arg : S) = -struct - - type 'a inter = - {cases : (int * int * int) array ; - actions : 'a array} - - type 'a t_ctx = {off : int ; arg : 'a} - - let cut = ref 8 - and more_cut = ref 16 - -(* -let pint chan i = - if i = min_int then Printf.fprintf chan "-oo" - else if i=max_int then Printf.fprintf chan "oo" - else Printf.fprintf chan "%d" i - -let pcases chan cases = - for i =0 to Array.length cases-1 do - let l,h,act = cases.(i) in - if l=h then - Printf.fprintf chan "%d:%d " l act - else - Printf.fprintf chan "%a..%a:%d " pint l pint h act - done - -let prerr_inter i = Printf.fprintf stderr - "cases=%a" pcases i.cases -*) - - let get_act cases i = - let _,_,r = cases.(i) in - r - and get_low cases i = - let r,_,_ = cases.(i) in - r - - type ctests = { - mutable n : int ; - mutable ni : int ; - } - - let too_much = {n=max_int ; ni=max_int} - -(* -let ptests chan {n=n ; ni=ni} = - Printf.fprintf chan "{n=%d ; ni=%d}" n ni - -let pta chan t = - for i =0 to Array.length t-1 do - Printf.fprintf chan "%d: %a\n" i ptests t.(i) - done -*) - - let less_tests c1 c2 = - if c1.n < c2.n then - true - else if c1.n = c2.n then begin - if c1.ni < c2.ni then - true - else - false - end else - false - - and eq_tests c1 c2 = c1.n = c2.n && c1.ni=c2.ni - - let less2tests (c1,d1) (c2,d2) = - if eq_tests c1 c2 then - less_tests d1 d2 - else - less_tests c1 c2 - - let add_test t1 t2 = - t1.n <- t1.n + t2.n ; - t1.ni <- t1.ni + t2.ni ; - - type t_ret = Inter of int * int | Sep of int | No - -(* -let pret chan = function - | Inter (i,j)-> Printf.fprintf chan "Inter %d %d" i j - | Sep i -> Printf.fprintf chan "Sep %d" i - | No -> Printf.fprintf chan "No" -*) - - let coupe cases i = - let l,_,_ = cases.(i) in - l, - Array.sub cases 0 i, - Array.sub cases i (Array.length cases-i) - - - let case_append c1 c2 = - let len1 = Array.length c1 - and len2 = Array.length c2 in - match len1,len2 with - | 0,_ -> c2 - | _,0 -> c1 - | _,_ -> - let l1,h1,act1 = c1.(Array.length c1-1) - and l2,h2,act2 = c2.(0) in - if act1 = act2 then - let r = Array.make (len1+len2-1) c1.(0) in - for i = 0 to len1-2 do - r.(i) <- c1.(i) - done ; - - let l = - if len1-2 >= 0 then begin - let _,h,_ = r.(len1-2) in - if h+1 < l1 then - h+1 - else - l1 - end else - l1 - and h = - if 1 < len2-1 then begin - let l,_,_ = c2.(1) in - if h2+1 < l then - l-1 - else - h2 - end else - h2 in - r.(len1-1) <- (l,h,act1) ; - for i=1 to len2-1 do - r.(len1-1+i) <- c2.(i) - done ; - r - else if h1 > l1 then - let r = Array.make (len1+len2) c1.(0) in - for i = 0 to len1-2 do - r.(i) <- c1.(i) - done ; - r.(len1-1) <- (l1,l2-1,act1) ; - for i=0 to len2-1 do - r.(len1+i) <- c2.(i) - done ; - r - else if h2 > l2 then - let r = Array.make (len1+len2) c1.(0) in - for i = 0 to len1-1 do - r.(i) <- c1.(i) - done ; - r.(len1) <- (h1+1,h2,act2) ; - for i=1 to len2-1 do - r.(len1+i) <- c2.(i) - done ; - r - else - Array.append c1 c2 - - - let coupe_inter i j cases = - let lcases = Array.length cases in - let low,_,_ = cases.(i) - and _,high,_ = cases.(j) in - low,high, - Array.sub cases i (j-i+1), - case_append (Array.sub cases 0 i) (Array.sub cases (j+1) (lcases-(j+1))) - - type kind = Kvalue of int | Kinter of int | Kempty - -(* -let pkind chan = function - | Kvalue i ->Printf.fprintf chan "V%d" i - | Kinter i -> Printf.fprintf chan "I%d" i - | Kempty -> Printf.fprintf chan "E" - -let rec pkey chan = function - | [] -> () - | [k] -> pkind chan k - | k::rem -> - Printf.fprintf chan "%a %a" pkey rem pkind k -*) - - let t = Hashtbl.create 17 - - let make_key cases = - let seen = ref [] - and count = ref 0 in - let rec got_it act = function - | [] -> - seen := (act,!count):: !seen ; - let r = !count in - incr count ; - r - | (act0,index) :: rem -> - if act0 = act then - index - else - got_it act rem in - - let make_one l h act = - if l=h then - Kvalue (got_it act !seen) - else - Kinter (got_it act !seen) in - - let rec make_rec i pl = - if i < 0 then - [] - else - let l,h,act = cases.(i) in - if pl = h+1 then - make_one l h act::make_rec (i-1) l - else - Kempty::make_one l h act::make_rec (i-1) l in - - let l,h,act = cases.(Array.length cases-1) in - make_one l h act::make_rec (Array.length cases-2) l - - - let same_act t = - let len = Array.length t in - let a = get_act t (len-1) in - let rec do_rec i = - if i < 0 then true - else - let b = get_act t i in - b=a && do_rec (i-1) in - do_rec (len-2) - - -(* - Interval test x in [l,h] works by checking x-l in [0,h-l] - * This may be false for arithmetic modulo 2^31 - * Subtracting l may change the relative ordering of values - and invalid the invariant that matched values are given in - increasing order - - To avoid this, interval check is allowed only when the - integers indeed present in the whole case interval are - in [-2^16 ; 2^16] - - This condition is checked by zyva -*) - - let inter_limit = 1 lsl 16 - - let ok_inter = ref false - - let rec opt_count top cases = - let key = make_key cases in - try - Hashtbl.find t key - with - | Not_found -> - let r = - let lcases = Array.length cases in - match lcases with - | 0 -> assert false - | _ when same_act cases -> No, ({n=0; ni=0},{n=0; ni=0}) - | _ -> - if lcases < !cut then - enum top cases - else if lcases < !more_cut then - heuristic cases - else - divide cases in - Hashtbl.add t key r ; - r - - and divide cases = - let lcases = Array.length cases in - let m = lcases/2 in - let _,left,right = coupe cases m in - let ci = {n=1 ; ni=0} - and cm = {n=1 ; ni=0} - and _,(cml,cleft) = opt_count false left - and _,(cmr,cright) = opt_count false right in - add_test ci cleft ; - add_test ci cright ; - if less_tests cml cmr then - add_test cm cmr - else - add_test cm cml ; - Sep m,(cm, ci) - - and heuristic cases = - let lcases = Array.length cases in - - let sep,csep = divide cases - - and inter,cinter = - if !ok_inter then begin - let _,_,act0 = cases.(0) - and _,_,act1 = cases.(lcases-1) in - if act0 = act1 then begin - let low, high, inside, outside = coupe_inter 1 (lcases-2) cases in - let _,(cmi,cinside) = opt_count false inside - and _,(cmo,coutside) = opt_count false outside - and cmij = {n=1 ; ni=(if low=high then 0 else 1)} - and cij = {n=1 ; ni=(if low=high then 0 else 1)} in - add_test cij cinside ; - add_test cij coutside ; - if less_tests cmi cmo then - add_test cmij cmo - else - add_test cmij cmi ; - Inter (1,lcases-2),(cmij,cij) - end else - Inter (-1,-1),(too_much, too_much) - end else - Inter (-1,-1),(too_much, too_much) in - if less2tests csep cinter then - sep,csep - else - inter,cinter - - - and enum top cases = - let lcases = Array.length cases in - let lim, with_sep = - let best = ref (-1) and best_cost = ref (too_much,too_much) in - - for i = 1 to lcases-(1) do - let _,left,right = coupe cases i in - let ci = {n=1 ; ni=0} - and cm = {n=1 ; ni=0} - and _,(cml,cleft) = opt_count false left - and _,(cmr,cright) = opt_count false right in - add_test ci cleft ; - add_test ci cright ; - if less_tests cml cmr then - add_test cm cmr - else - add_test cm cml ; - - if - less2tests (cm,ci) !best_cost - then begin - if top then - Printf.fprintf stderr "Get it: %d\n" i ; - best := i ; - best_cost := (cm,ci) - end - done ; - !best, !best_cost in - - let ilow, ihigh, with_inter = - if not !ok_inter then - let rlow = ref (-1) and rhigh = ref (-1) - and best_cost= ref (too_much,too_much) in - for i=1 to lcases-2 do - let low, high, inside, outside = coupe_inter i i cases in - if low=high then begin - let _,(cmi,cinside) = opt_count false inside - and _,(cmo,coutside) = opt_count false outside - and cmij = {n=1 ; ni=0} - and cij = {n=1 ; ni=0} in - add_test cij cinside ; - add_test cij coutside ; - if less_tests cmi cmo then - add_test cmij cmo - else - add_test cmij cmi ; - if less2tests (cmij,cij) !best_cost then begin - rlow := i ; - rhigh := i ; - best_cost := (cmij,cij) - end - end - done ; - !rlow, !rhigh, !best_cost - else - let rlow = ref (-1) and rhigh = ref (-1) - and best_cost= ref (too_much,too_much) in - for i=1 to lcases-2 do - for j=i to lcases-2 do - let low, high, inside, outside = coupe_inter i j cases in - let _,(cmi,cinside) = opt_count false inside - and _,(cmo,coutside) = opt_count false outside - and cmij = {n=1 ; ni=(if low=high then 0 else 1)} - and cij = {n=1 ; ni=(if low=high then 0 else 1)} in - add_test cij cinside ; - add_test cij coutside ; - if less_tests cmi cmo then - add_test cmij cmo - else - add_test cmij cmi ; - if less2tests (cmij,cij) !best_cost then begin - rlow := i ; - rhigh := j ; - best_cost := (cmij,cij) - end - done - done ; - !rlow, !rhigh, !best_cost in - let r = ref (Inter (ilow,ihigh)) and rc = ref with_inter in - if less2tests with_sep !rc then begin - r := Sep lim ; rc := with_sep - end ; - !r, !rc - - let make_if_test test arg i ifso ifnot = - Arg.make_if - (Arg.make_prim test [arg ; Arg.make_const i]) - ifso ifnot - - let make_if_lt arg i ifso ifnot = match i with - | 1 -> - make_if_test Arg.leint arg 0 ifso ifnot - | _ -> - make_if_test Arg.ltint arg i ifso ifnot - - and make_if_ge arg i ifso ifnot = match i with - | 1 -> - make_if_test Arg.gtint arg 0 ifso ifnot - | _ -> - make_if_test Arg.geint arg i ifso ifnot - - and make_if_eq arg i ifso ifnot = - make_if_test Arg.eqint arg i ifso ifnot - - and make_if_ne arg i ifso ifnot = - make_if_test Arg.neint arg i ifso ifnot - - let do_make_if_out h arg ifso ifno = - Arg.make_if (Arg.make_isout h arg) ifso ifno - - let make_if_out ctx l d mk_ifso mk_ifno = match l with - | 0 -> - do_make_if_out - (Arg.make_const d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) - | _ -> - Arg.bind - (Arg.make_offset ctx.arg (-l)) - (fun arg -> - let ctx = {off= (-l+ctx.off) ; arg=arg} in - do_make_if_out - (Arg.make_const d) arg (mk_ifso ctx) (mk_ifno ctx)) - - let do_make_if_in h arg ifso ifno = - Arg.make_if (Arg.make_isin h arg) ifso ifno - - let make_if_in ctx l d mk_ifso mk_ifno = match l with - | 0 -> - do_make_if_in - (Arg.make_const d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) - | _ -> - Arg.bind - (Arg.make_offset ctx.arg (-l)) - (fun arg -> - let ctx = {off= (-l+ctx.off) ; arg=arg} in - do_make_if_in - (Arg.make_const d) arg (mk_ifso ctx) (mk_ifno ctx)) - - let rec c_test ctx ({cases=cases ; actions=actions} as s) = - let lcases = Array.length cases in - assert(lcases > 0) ; - if lcases = 1 then - actions.(get_act cases 0) ctx - - else begin - - let w,_c = opt_count false cases in -(* - Printf.fprintf stderr - "off=%d tactic=%a for %a\n" - ctx.off pret w pcases cases ; - *) - match w with - | No -> actions.(get_act cases 0) ctx - | Inter (i,j) -> - let low,high,inside, outside = coupe_inter i j cases in - let _,(cinside,_) = opt_count false inside - and _,(coutside,_) = opt_count false outside in - (* Costs are retrieved to put the code with more remaining tests - in the privileged (positive) branch of ``if'' *) - if low=high then begin - if less_tests coutside cinside then - make_if_eq - ctx.arg - (low+ctx.off) - (c_test ctx {s with cases=inside}) - (c_test ctx {s with cases=outside}) - else - make_if_ne - ctx.arg - (low+ctx.off) - (c_test ctx {s with cases=outside}) - (c_test ctx {s with cases=inside}) - end else begin - if less_tests coutside cinside then - make_if_in - ctx - (low+ctx.off) - (high-low) - (fun ctx -> c_test ctx {s with cases=inside}) - (fun ctx -> c_test ctx {s with cases=outside}) - else - make_if_out - ctx - (low+ctx.off) - (high-low) - (fun ctx -> c_test ctx {s with cases=outside}) - (fun ctx -> c_test ctx {s with cases=inside}) - end - | Sep i -> - let lim,left,right = coupe cases i in - let _,(cleft,_) = opt_count false left - and _,(cright,_) = opt_count false right in - let left = {s with cases=left} - and right = {s with cases=right} in - - if i=1 && (lim+ctx.off)=1 && get_low cases 0+ctx.off=0 then - make_if_ne - ctx.arg 0 - (c_test ctx right) (c_test ctx left) - else if less_tests cright cleft then - make_if_lt - ctx.arg (lim+ctx.off) - (c_test ctx left) (c_test ctx right) - else - make_if_ge - ctx.arg (lim+ctx.off) - (c_test ctx right) (c_test ctx left) - - end - - - (* Minimal density of switches *) - let theta = ref 0.33333 - - (* Minimal number of tests to make a switch *) - let switch_min = ref 3 - - (* Particular case 0, 1, 2 *) - let particular_case cases i j = - j-i = 2 && - (let l1,_h1,act1 = cases.(i) - and l2,_h2,_act2 = cases.(i+1) - and l3,h3,act3 = cases.(i+2) in - l1+1=l2 && l2+1=l3 && l3=h3 && - act1 <> act3) - - let approx_count cases i j = - let l = j-i+1 in - if l < !cut then - let _,(_,{n=ntests}) = opt_count false (Array.sub cases i l) in - ntests - else - l-1 - - (* Sends back a boolean that says whether is switch is worth or not *) - - let dense {cases} i j = - if i=j then true - else - let l,_,_ = cases.(i) - and _,h,_ = cases.(j) in - let ntests = approx_count cases i j in -(* - (ntests+1) >= theta * (h-l+1) -*) - particular_case cases i j || - (ntests >= !switch_min && - float_of_int ntests +. 1.0 >= - !theta *. (float_of_int h -. float_of_int l +. 1.0)) - - (* Compute clusters by dynamic programming - Adaptation of the correction to Bernstein - ``Correction to `Producing Good Code for the Case Statement' '' - S.K. Kannan and T.A. Proebsting - Software Practice and Experience Vol. 24(2) 233 (Feb 1994) - *) - - let comp_clusters s = - let len = Array.length s.cases in - let min_clusters = Array.make len max_int - and k = Array.make len 0 in - let get_min i = if i < 0 then 0 else min_clusters.(i) in - - for i = 0 to len-1 do - for j = 0 to i do - if - dense s j i && - get_min (j-1) + 1 < min_clusters.(i) - then begin - k.(i) <- j ; - min_clusters.(i) <- get_min (j-1) + 1 - end - done ; - done ; - min_clusters.(len-1),k - - (* Assume j > i *) - let make_switch loc {cases=cases ; actions=actions} i j = - let ll,_,_ = cases.(i) - and _,hh,_ = cases.(j) in - let tbl = Array.make (hh-ll+1) 0 - and t = Hashtbl.create 17 - and index = ref 0 in - let get_index act = - try - Hashtbl.find t act - with - | Not_found -> - let i = !index in - incr index ; - Hashtbl.add t act i ; - i in - - for k=i to j do - let l,h,act = cases.(k) in - let index = get_index act in - for kk=l-ll to h-ll do - tbl.(kk) <- index - done - done ; - let acts = Array.make !index actions.(0) in - Hashtbl.iter - (fun act i -> acts.(i) <- actions.(act)) - t ; - (fun ctx -> - match -ll-ctx.off with - | 0 -> Arg.make_switch loc ctx.arg tbl acts - | _ -> - Arg.bind - (Arg.make_offset ctx.arg (-ll-ctx.off)) - (fun arg -> Arg.make_switch loc arg tbl acts)) - - - let make_clusters loc ({cases=cases ; actions=actions} as s) n_clusters k = - let len = Array.length cases in - let r = Array.make n_clusters (0,0,0) - and t = Hashtbl.create 17 - and index = ref 0 - and bidon = ref (Array.length actions) in - let get_index act = - try - let i,_ = Hashtbl.find t act in - i - with - | Not_found -> - let i = !index in - incr index ; - Hashtbl.add - t act - (i,(fun _ -> actions.(act))) ; - i - and add_index act = - let i = !index in - incr index ; - incr bidon ; - Hashtbl.add t !bidon (i,act) ; - i in - - let rec zyva j ir = - let i = k.(j) in - begin if i=j then - let l,h,act = cases.(i) in - r.(ir) <- (l,h,get_index act) - else (* assert i < j *) - let l,_,_ = cases.(i) - and _,h,_ = cases.(j) in - r.(ir) <- (l,h,add_index (make_switch loc s i j)) - end ; - if i > 0 then zyva (i-1) (ir-1) in - - zyva (len-1) (n_clusters-1) ; - let acts = Array.make !index (fun _ -> assert false) in - Hashtbl.iter (fun _ (i,act) -> acts.(i) <- act) t ; - {cases = r ; actions = acts} - ;; - - - let do_zyva loc (low,high) arg cases actions = - let old_ok = !ok_inter in - ok_inter := (abs low <= inter_limit && abs high <= inter_limit) ; - if !ok_inter <> old_ok then Hashtbl.clear t ; - - let s = {cases=cases ; actions=actions} in - -(* - Printf.eprintf "ZYVA: %B [low=%i,high=%i]\n" !ok_inter low high ; - pcases stderr cases ; - prerr_endline "" ; -*) - let n_clusters,k = comp_clusters s in - let clusters = make_clusters loc s n_clusters k in - c_test {arg=arg ; off=0} clusters - - let abstract_shared actions = - let handlers = ref (fun x -> x) in - let actions = - Array.map - (fun act -> match act with - | Single act -> act - | Shared act -> - let i,h = Arg.make_catch act in - let oh = !handlers in - handlers := (fun act -> h (oh act)) ; - Arg.make_exit i) - actions in - !handlers,actions - - let zyva loc lh arg cases actions = - assert (Array.length cases > 0) ; - let actions = actions.act_get_shared () in - let hs,actions = abstract_shared actions in - hs (do_zyva loc lh arg cases actions) - - and test_sequence arg cases actions = - assert (Array.length cases > 0) ; - let actions = actions.act_get_shared () in - let hs,actions = abstract_shared actions in - let old_ok = !ok_inter in - ok_inter := false ; - if !ok_inter <> old_ok then Hashtbl.clear t ; - let s = - {cases=cases ; - actions=Array.map (fun act -> (fun _ -> act)) actions} in -(* - Printf.eprintf "SEQUENCE: %B\n" !ok_inter ; - pcases stderr cases ; - prerr_endline "" ; -*) - hs (c_test {arg=arg ; off=0} s) - ;; - -end diff --git a/bytecomp/switch.mli b/bytecomp/switch.mli deleted file mode 100644 index b4058c1784..0000000000 --- a/bytecomp/switch.mli +++ /dev/null @@ -1,129 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Luc Maranget, projet Moscova, INRIA Rocquencourt *) -(* *) -(* Copyright 2000 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. *) -(* *) -(**************************************************************************) - -(* - This module transforms generic switches in combinations - of if tests and switches. -*) - -(* For detecting action sharing, object style *) - -(* Store for actions in object style: - act_store : store an action, returns index in table - In case an action with equal key exists, returns index - of the stored action. Otherwise add entry in table. - act_store_shared : This stored action will always be shared. - act_get : retrieve table - act_get_shared : retrieve table, with sharing explicit -*) - -type 'a shared = Shared of 'a | Single of 'a - -type ('a, 'ctx) t_store = - {act_get : unit -> 'a array ; - act_get_shared : unit -> 'a shared array ; - act_store : 'ctx -> 'a -> int ; - act_store_shared : 'ctx -> 'a -> int ; } - -exception Not_simple - -module type Stored = sig - type t - type key - val compare_key : key -> key -> int - val make_key : t -> key option -end - -module type CtxStored = sig - include Stored - type context - val make_key : context -> t -> key option -end - -module CtxStore(A:CtxStored) : - sig - val mk_store : unit -> (A.t, A.context) t_store - end - -module Store(A:Stored) : - sig - val mk_store : unit -> (A.t, unit) t_store - end - -(* Arguments to the Make functor *) -module type S = - sig - (* type of basic tests *) - type primitive - (* basic tests themselves *) - val eqint : primitive - val neint : primitive - val leint : primitive - val ltint : primitive - val geint : primitive - val gtint : primitive - (* type of actions *) - type act - - (* Various constructors, for making a binder, - adding one integer, etc. *) - val bind : act -> (act -> act) -> act - val make_const : int -> act - val make_offset : act -> int -> act - val make_prim : primitive -> act list -> act - val make_isout : act -> act -> act - val make_isin : act -> act -> act - val make_if : act -> act -> act -> act - (* construct an actual switch : - make_switch arg cases acts - NB: cases is in the value form *) - val make_switch : - Location.t -> act -> int array -> act array -> act - (* Build last minute sharing of action stuff *) - val make_catch : act -> int * (act -> act) - val make_exit : int -> act - - end - - -(* - Make.zyva arg low high cases actions where - - arg is the argument of the switch. - - low, high are the interval limits. - - cases is a list of sub-interval and action indices - - actions is an array of actions. - - All these arguments specify a switch construct and zyva - returns an action that performs the switch. -*) -module Make : - functor (Arg : S) -> - sig -(* Standard entry point, sharing is tracked *) - val zyva : - Location.t -> - (int * int) -> - Arg.act -> - (int * int * int) array -> - (Arg.act, _) t_store -> - Arg.act - -(* Output test sequence, sharing tracked *) - val test_sequence : - Arg.act -> - (int * int * int) array -> - (Arg.act, _) t_store -> - Arg.act - end diff --git a/bytecomp/translattribute.ml b/bytecomp/translattribute.ml deleted file mode 100644 index 1520a3b41f..0000000000 --- a/bytecomp/translattribute.ml +++ /dev/null @@ -1,332 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* *) -(* Copyright 2015 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 Typedtree -open Lambda -open Location - -let is_inline_attribute = function - | {txt=("inline"|"ocaml.inline")} -> true - | _ -> false - -let is_inlined_attribute = function - | {txt=("inlined"|"ocaml.inlined")} -> true - | {txt=("unrolled"|"ocaml.unrolled")} when Config.flambda -> true - | _ -> false - -let is_specialise_attribute = function - | {txt=("specialise"|"ocaml.specialise")} when Config.flambda -> true - | _ -> false - -let is_specialised_attribute = function - | {txt=("specialised"|"ocaml.specialised")} when Config.flambda -> true - | _ -> false - -let is_local_attribute = function - | {txt=("local"|"ocaml.local")} -> true - | _ -> false - -let find_attribute p attributes = - let inline_attribute, other_attributes = - List.partition (fun a -> p a.Parsetree.attr_name) attributes - in - let attr = - match inline_attribute with - | [] -> None - | [attr] -> Some attr - | _ :: {Parsetree.attr_name = {txt;loc}; _} :: _ -> - Location.prerr_warning loc (Warnings.Duplicated_attribute txt); - None - in - attr, other_attributes - -let is_unrolled = function - | {txt="unrolled"|"ocaml.unrolled"} -> true - | {txt="inline"|"ocaml.inline"|"inlined"|"ocaml.inlined"} -> false - | _ -> assert false - -let get_id_payload = - let open Parsetree in - function - | PStr [] -> Some "" - | PStr [{pstr_desc = Pstr_eval ({pexp_desc},[])}] -> - begin match pexp_desc with - | Pexp_ident { txt = Longident.Lident id } -> Some id - | _ -> None - end - | _ -> None - -let parse_id_payload txt loc ~default ~empty cases payload = - let[@local] warn () = - let ( %> ) f g x = g (f x) in - let msg = - cases - |> List.map (fst %> Printf.sprintf "'%s'") - |> String.concat ", " - |> Printf.sprintf "It must be either %s or empty" - in - Location.prerr_warning loc (Warnings.Attribute_payload (txt, msg)); - default - in - match get_id_payload payload with - | Some "" -> empty - | None -> warn () - | Some id -> - match List.assoc_opt id cases with - | Some r -> r - | None -> warn () - -let parse_inline_attribute attr = - match attr with - | None -> Default_inline - | Some {Parsetree.attr_name = {txt;loc} as id; attr_payload = payload} -> - let open Parsetree in - if is_unrolled id then begin - (* the 'unrolled' attributes must be used as [@unrolled n]. *) - let warning txt = Warnings.Attribute_payload - (txt, "It must be an integer literal") - in - match payload with - | PStr [{pstr_desc = Pstr_eval ({pexp_desc},[])}] -> begin - match pexp_desc with - | Pexp_constant (Pconst_integer(s, None)) -> begin - try - Unroll (Misc.Int_literal_converter.int s) - with Failure _ -> - Location.prerr_warning loc (warning txt); - Default_inline - end - | _ -> - Location.prerr_warning loc (warning txt); - Default_inline - end - | _ -> - Location.prerr_warning loc (warning txt); - Default_inline - end else - parse_id_payload txt loc - ~default:Default_inline - ~empty:Always_inline - [ - "never", Never_inline; - "always", Always_inline; - ] - payload - -let parse_specialise_attribute attr = - match attr with - | None -> Default_specialise - | Some {Parsetree.attr_name = {txt; loc}; attr_payload = payload} -> - parse_id_payload txt loc - ~default:Default_specialise - ~empty:Always_specialise - [ - "never", Never_specialise; - "always", Always_specialise; - ] - payload - -let parse_local_attribute attr = - match attr with - | None -> Default_local - | Some {Parsetree.attr_name = {txt; loc}; attr_payload = payload} -> - parse_id_payload txt loc - ~default:Default_local - ~empty:Always_local - [ - "never", Never_local; - "always", Always_local; - "maybe", Default_local; - ] - payload - -let get_inline_attribute l = - let attr, _ = find_attribute is_inline_attribute l in - parse_inline_attribute attr - -let get_specialise_attribute l = - let attr, _ = find_attribute is_specialise_attribute l in - parse_specialise_attribute attr - -let get_local_attribute l = - let attr, _ = find_attribute is_local_attribute l in - parse_local_attribute attr - -let check_local_inline loc attr = - match attr.local, attr.inline with - | Always_local, (Always_inline | Unroll _) -> - Location.prerr_warning loc - (Warnings.Duplicated_attribute "local/inline") - | _ -> - () - -let add_inline_attribute expr loc attributes = - match expr, get_inline_attribute attributes with - | expr, Default_inline -> expr - | Lfunction({ attr = { stub = false } as attr } as funct), inline -> - begin match attr.inline with - | Default_inline -> () - | Always_inline | Never_inline | Unroll _ -> - Location.prerr_warning loc - (Warnings.Duplicated_attribute "inline") - end; - let attr = { attr with inline } in - check_local_inline loc attr; - Lfunction { funct with attr = attr } - | expr, (Always_inline | Never_inline | Unroll _) -> - Location.prerr_warning loc - (Warnings.Misplaced_attribute "inline"); - expr - -let add_specialise_attribute expr loc attributes = - match expr, get_specialise_attribute attributes with - | expr, Default_specialise -> expr - | Lfunction({ attr = { stub = false } as attr } as funct), specialise -> - begin match attr.specialise with - | Default_specialise -> () - | Always_specialise | Never_specialise -> - Location.prerr_warning loc - (Warnings.Duplicated_attribute "specialise") - end; - let attr = { attr with specialise } in - Lfunction { funct with attr } - | expr, (Always_specialise | Never_specialise) -> - Location.prerr_warning loc - (Warnings.Misplaced_attribute "specialise"); - expr - -let add_local_attribute expr loc attributes = - match expr, get_local_attribute attributes with - | expr, Default_local -> expr - | Lfunction({ attr = { stub = false } as attr } as funct), local -> - begin match attr.local with - | Default_local -> () - | Always_local | Never_local -> - Location.prerr_warning loc - (Warnings.Duplicated_attribute "local") - end; - let attr = { attr with local } in - check_local_inline loc attr; - Lfunction { funct with attr } - | expr, (Always_local | Never_local) -> - Location.prerr_warning loc - (Warnings.Misplaced_attribute "local"); - expr - -(* Get the [@inlined] attribute payload (or default if not present). - It also returns the expression without this attribute. This is - used to ensure that this attribute is not misplaced: If it - appears on any expression, it is an error, otherwise it would - have been removed by this function *) -let get_and_remove_inlined_attribute e = - let attr, exp_attributes = - find_attribute is_inlined_attribute e.exp_attributes - in - let inlined = parse_inline_attribute attr in - inlined, { e with exp_attributes } - -let get_and_remove_inlined_attribute_on_module e = - let rec get_and_remove mod_expr = - let attr, mod_attributes = - find_attribute is_inlined_attribute mod_expr.mod_attributes - in - let attr = parse_inline_attribute attr in - let attr, mod_desc = - match mod_expr.Typedtree.mod_desc with - | Tmod_constraint (me, mt, mtc, mc) -> - let inner_attr, me = get_and_remove me in - let attr = - match attr with - | Always_inline | Never_inline | Unroll _ -> attr - | Default_inline -> inner_attr - in - attr, Tmod_constraint (me, mt, mtc, mc) - | md -> attr, md - in - attr, { mod_expr with mod_desc; mod_attributes } - in - get_and_remove e - -let get_and_remove_specialised_attribute e = - let attr, exp_attributes = - find_attribute is_specialised_attribute e.exp_attributes - in - let specialised = parse_specialise_attribute attr in - specialised, { e with exp_attributes } - -(* It also removes the attribute from the expression, like - get_inlined_attribute *) -let get_tailcall_attribute e = - let is_tailcall_attribute = function - | {Parsetree.attr_name = {txt=("tailcall"|"ocaml.tailcall")}; _} -> true - | _ -> false - in - let tailcalls, exp_attributes = - List.partition is_tailcall_attribute e.exp_attributes - in - match tailcalls with - | [] -> false, e - | _ :: r -> - begin match r with - | [] -> () - | {Parsetree.attr_name = {txt;loc}; _} :: _ -> - Location.prerr_warning loc (Warnings.Duplicated_attribute txt) - end; - true, { e with exp_attributes } - -let check_attribute e {Parsetree.attr_name = { txt; loc }; _} = - match txt with - | "inline" | "ocaml.inline" - | "specialise" | "ocaml.specialise" -> begin - match e.exp_desc with - | Texp_function _ -> () - | _ -> - Location.prerr_warning loc - (Warnings.Misplaced_attribute txt) - end - | "inlined" | "ocaml.inlined" - | "specialised" | "ocaml.specialised" - | "tailcall" | "ocaml.tailcall" -> - (* Removed by the Texp_apply cases *) - Location.prerr_warning loc - (Warnings.Misplaced_attribute txt) - | _ -> () - -let check_attribute_on_module e {Parsetree.attr_name = { txt; loc }; _} = - match txt with - | "inline" | "ocaml.inline" -> begin - match e.mod_desc with - | Tmod_functor _ -> () - | _ -> - Location.prerr_warning loc - (Warnings.Misplaced_attribute txt) - end - | "inlined" | "ocaml.inlined" -> - (* Removed by the Texp_apply cases *) - Location.prerr_warning loc - (Warnings.Misplaced_attribute txt) - | _ -> () - -let add_function_attributes lam loc attr = - let lam = - add_inline_attribute lam loc attr - in - let lam = - add_specialise_attribute lam loc attr - in - let lam = - add_local_attribute lam loc attr - in - lam diff --git a/bytecomp/translattribute.mli b/bytecomp/translattribute.mli deleted file mode 100644 index bf22fd1c5d..0000000000 --- a/bytecomp/translattribute.mli +++ /dev/null @@ -1,76 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* *) -(* Copyright 2015 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. *) -(* *) -(**************************************************************************) - -val check_attribute - : Typedtree.expression - -> Parsetree.attribute - -> unit - -val check_attribute_on_module - : Typedtree.module_expr - -> Parsetree.attribute - -> unit - -val add_inline_attribute - : Lambda.lambda - -> Location.t - -> Parsetree.attributes - -> Lambda.lambda - -val get_inline_attribute - : Parsetree.attributes - -> Lambda.inline_attribute - -val add_specialise_attribute - : Lambda.lambda - -> Location.t - -> Parsetree.attributes - -> Lambda.lambda - -val get_specialise_attribute - : Parsetree.attributes - -> Lambda.specialise_attribute - -val add_local_attribute - : Lambda.lambda - -> Location.t - -> Parsetree.attributes - -> Lambda.lambda - -val get_local_attribute - : Parsetree.attributes - -> Lambda.local_attribute - -val get_and_remove_inlined_attribute - : Typedtree.expression - -> Lambda.inline_attribute * Typedtree.expression - -val get_and_remove_inlined_attribute_on_module - : Typedtree.module_expr - -> Lambda.inline_attribute * Typedtree.module_expr - -val get_and_remove_specialised_attribute - : Typedtree.expression - -> Lambda.specialise_attribute * Typedtree.expression - -val get_tailcall_attribute - : Typedtree.expression - -> bool * Typedtree.expression - -val add_function_attributes - : Lambda.lambda - -> Location.t - -> Parsetree.attributes - -> Lambda.lambda diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml deleted file mode 100644 index 10b09066d7..0000000000 --- a/bytecomp/translclass.ml +++ /dev/null @@ -1,946 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Jerome Vouillon, 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 Asttypes -open Types -open Typedtree -open Lambda -open Translobj -open Translcore - -(* XXX Rajouter des evenements... | Add more events... *) - -type error = Tags of label * label - -exception Error of Location.t * error - -let lfunction params body = - if params = [] then body else - match body with - | Lfunction {kind = Curried; params = params'; body = body'; attr; loc} -> - Lfunction {kind = Curried; params = params @ params'; - return = Pgenval; - body = body'; attr; - loc} - | _ -> - Lfunction {kind = Curried; params; return = Pgenval; - body; - attr = default_function_attribute; - loc = Location.none} - -let lapply ap = - match ap.ap_func with - Lapply ap' -> - Lapply {ap with ap_func = ap'.ap_func; ap_args = ap'.ap_args @ ap.ap_args} - | _ -> - Lapply ap - -let mkappl (func, args) = - Lapply {ap_should_be_tailcall=false; - ap_loc=Location.none; - ap_func=func; - ap_args=args; - ap_inlined=Default_inline; - ap_specialised=Default_specialise};; - -let lsequence l1 l2 = - if l2 = lambda_unit then l1 else Lsequence(l1, l2) - -let lfield v i = Lprim(Pfield i, [Lvar v], Location.none) - -let transl_label l = share (Const_immstring l) - -let transl_meth_list lst = - if lst = [] then Lconst (Const_pointer 0) else - share (Const_block - (0, List.map (fun lab -> Const_immstring lab) lst)) - -let set_inst_var obj id expr = - Lprim(Psetfield_computed (Typeopt.maybe_pointer expr, Assignment), - [Lvar obj; Lvar id; transl_exp expr], Location.none) - -let transl_val tbl create name = - mkappl (oo_prim (if create then "new_variable" else "get_variable"), - [Lvar tbl; transl_label name]) - -let transl_vals tbl create strict vals rem = - List.fold_right - (fun (name, id) rem -> - Llet(strict, Pgenval, id, transl_val tbl create name, rem)) - vals rem - -let meths_super tbl meths inh_meths = - List.fold_right - (fun (nm, id) rem -> - try - (nm, id, - mkappl(oo_prim "get_method", [Lvar tbl; Lvar (Meths.find nm meths)])) - :: rem - with Not_found -> rem) - inh_meths [] - -let bind_super tbl (vals, meths) cl_init = - transl_vals tbl false StrictOpt vals - (List.fold_right (fun (_nm, id, def) rem -> - Llet(StrictOpt, Pgenval, id, def, rem)) - meths cl_init) - -let create_object cl obj init = - let obj' = Ident.create_local "self" in - let (inh_init, obj_init, has_init) = init obj' in - if obj_init = lambda_unit then - (inh_init, - mkappl (oo_prim (if has_init then "create_object_and_run_initializers" - else"create_object_opt"), - [obj; Lvar cl])) - else begin - (inh_init, - Llet(Strict, Pgenval, obj', - mkappl (oo_prim "create_object_opt", [obj; Lvar cl]), - Lsequence(obj_init, - if not has_init then Lvar obj' else - mkappl (oo_prim "run_initializers_opt", - [obj; Lvar obj'; Lvar cl])))) - end - -let name_pattern default p = - match p.pat_desc with - | Tpat_var (id, _) -> id - | Tpat_alias(_, id, _) -> id - | _ -> Ident.create_local default - -let rec build_object_init cl_table obj params inh_init obj_init cl = - match cl.cl_desc with - Tcl_ident (path, _, _) -> - let obj_init = Ident.create_local "obj_init" in - let envs, inh_init = inh_init in - let env = - match envs with None -> [] - | Some envs -> - [Lprim(Pfield (List.length inh_init + 1), - [Lvar envs], - Location.none)] - in - let path_lam = transl_class_path cl.cl_loc cl.cl_env path in - ((envs, (path, path_lam, obj_init) :: inh_init), - mkappl(Lvar obj_init, env @ [obj])) - | Tcl_structure str -> - create_object cl_table obj (fun obj -> - let (inh_init, obj_init, has_init) = - List.fold_right - (fun field (inh_init, obj_init, has_init) -> - match field.cf_desc with - Tcf_inherit (_, cl, _, _, _) -> - let (inh_init, obj_init') = - build_object_init cl_table (Lvar obj) [] inh_init - (fun _ -> lambda_unit) cl - in - (inh_init, lsequence obj_init' obj_init, true) - | Tcf_val (_, _, id, Tcfk_concrete (_, exp), _) -> - (inh_init, lsequence (set_inst_var obj id exp) obj_init, - has_init) - | Tcf_method _ | Tcf_val _ | Tcf_constraint _ | Tcf_attribute _-> - (inh_init, obj_init, has_init) - | Tcf_initializer _ -> - (inh_init, obj_init, true) - ) - str.cstr_fields - (inh_init, obj_init obj, false) - in - (inh_init, - List.fold_right - (fun (id, expr) rem -> - lsequence (Lifused (id, set_inst_var obj id expr)) rem) - params obj_init, - has_init)) - | Tcl_fun (_, pat, vals, cl, partial) -> - let (inh_init, obj_init) = - build_object_init cl_table obj (vals @ params) inh_init obj_init cl - in - (inh_init, - let build params rem = - let param = name_pattern "param" pat in - Lfunction {kind = Curried; params = (param, Pgenval)::params; - return = Pgenval; - attr = default_function_attribute; - loc = pat.pat_loc; - body = Matching.for_function - pat.pat_loc None (Lvar param) [pat, rem] partial} - in - begin match obj_init with - Lfunction {kind = Curried; params; body = rem} -> build params rem - | rem -> build [] rem - end) - | Tcl_apply (cl, oexprs) -> - let (inh_init, obj_init) = - build_object_init cl_table obj params inh_init obj_init cl - in - (inh_init, transl_apply obj_init oexprs Location.none) - | Tcl_let (rec_flag, defs, vals, cl) -> - let (inh_init, obj_init) = - build_object_init cl_table obj (vals @ params) inh_init obj_init cl - in - (inh_init, Translcore.transl_let rec_flag defs obj_init) - | Tcl_open (_, cl) - | Tcl_constraint (cl, _, _, _, _) -> - build_object_init cl_table obj params inh_init obj_init cl - -let rec build_object_init_0 cl_table params cl copy_env subst_env top ids = - match cl.cl_desc with - Tcl_let (_rec_flag, _defs, vals, cl) -> - build_object_init_0 cl_table (vals@params) cl copy_env subst_env top ids - | _ -> - let self = Ident.create_local "self" in - let env = Ident.create_local "env" in - let obj = if ids = [] then lambda_unit else Lvar self in - let envs = if top then None else Some env in - let ((_,inh_init), obj_init) = - build_object_init cl_table obj params (envs,[]) copy_env cl in - let obj_init = - if ids = [] then obj_init else lfunction [self, Pgenval] obj_init in - (inh_init, lfunction [env, Pgenval] (subst_env env inh_init obj_init)) - - -let bind_method tbl lab id cl_init = - Llet(Strict, Pgenval, id, mkappl (oo_prim "get_method_label", - [Lvar tbl; transl_label lab]), - cl_init) - -let bind_methods tbl meths vals cl_init = - let methl = Meths.fold (fun lab id tl -> (lab,id) :: tl) meths [] in - let len = List.length methl and nvals = List.length vals in - if len < 2 && nvals = 0 then Meths.fold (bind_method tbl) meths cl_init else - if len = 0 && nvals < 2 then transl_vals tbl true Strict vals cl_init else - let ids = Ident.create_local "ids" in - let i = ref (len + nvals) in - let getter, names = - if nvals = 0 then "get_method_labels", [] else - "new_methods_variables", [transl_meth_list (List.map fst vals)] - in - Llet(Strict, Pgenval, ids, - mkappl (oo_prim getter, - [Lvar tbl; transl_meth_list (List.map fst methl)] @ names), - List.fold_right - (fun (_lab,id) lam -> decr i; Llet(StrictOpt, Pgenval, id, - lfield ids !i, lam)) - (methl @ vals) cl_init) - -let output_methods tbl methods lam = - match methods with - [] -> lam - | [lab; code] -> - lsequence (mkappl(oo_prim "set_method", [Lvar tbl; lab; code])) lam - | _ -> - lsequence (mkappl(oo_prim "set_methods", - [Lvar tbl; Lprim(Pmakeblock(0,Immutable,None), - methods, Location.none)])) - lam - -let rec ignore_cstrs cl = - match cl.cl_desc with - Tcl_constraint (cl, _, _, _, _) -> ignore_cstrs cl - | Tcl_apply (cl, _) -> ignore_cstrs cl - | _ -> cl - -let rec index a = function - [] -> raise Not_found - | b :: l -> - if b = a then 0 else 1 + index a l - -let bind_id_as_val (id, _) = ("", id) - -let rec build_class_init cla cstr super inh_init cl_init msubst top cl = - match cl.cl_desc with - | Tcl_ident _ -> - begin match inh_init with - | (_, path_lam, obj_init)::inh_init -> - (inh_init, - Llet (Strict, Pgenval, obj_init, - mkappl(Lprim(Pfield 1, [path_lam], Location.none), Lvar cla :: - if top then [Lprim(Pfield 3, [path_lam], Location.none)] - else []), - bind_super cla super cl_init)) - | _ -> - assert false - end - | Tcl_structure str -> - let cl_init = bind_super cla super cl_init in - let (inh_init, cl_init, methods, values) = - List.fold_right - (fun field (inh_init, cl_init, methods, values) -> - match field.cf_desc with - Tcf_inherit (_, cl, _, vals, meths) -> - let cl_init = output_methods cla methods cl_init in - let inh_init, cl_init = - build_class_init cla false - (vals, meths_super cla str.cstr_meths meths) - inh_init cl_init msubst top cl in - (inh_init, cl_init, [], values) - | Tcf_val (name, _, id, _, over) -> - let values = - if over then values else (name.txt, id) :: values - in - (inh_init, cl_init, methods, values) - | Tcf_method (_, _, Tcfk_virtual _) - | Tcf_constraint _ - -> - (inh_init, cl_init, methods, values) - | Tcf_method (name, _, Tcfk_concrete (_, exp)) -> - let met_code = msubst true (transl_exp exp) in - let met_code = - if !Clflags.native_code && List.length met_code = 1 then - (* Force correct naming of method for profiles *) - let met = Ident.create_local ("method_" ^ name.txt) in - [Llet(Strict, Pgenval, met, List.hd met_code, Lvar met)] - else met_code - in - (inh_init, cl_init, - Lvar(Meths.find name.txt str.cstr_meths) :: met_code @ methods, - values) - | Tcf_initializer exp -> - (inh_init, - Lsequence(mkappl (oo_prim "add_initializer", - Lvar cla :: msubst false (transl_exp exp)), - cl_init), - methods, values) - | Tcf_attribute _ -> - (inh_init, cl_init, methods, values)) - str.cstr_fields - (inh_init, cl_init, [], []) - in - let cl_init = output_methods cla methods cl_init in - (inh_init, bind_methods cla str.cstr_meths values cl_init) - | Tcl_fun (_, _pat, vals, cl, _) -> - let (inh_init, cl_init) = - build_class_init cla cstr super inh_init cl_init msubst top cl - in - let vals = List.map bind_id_as_val vals in - (inh_init, transl_vals cla true StrictOpt vals cl_init) - | Tcl_apply (cl, _exprs) -> - build_class_init cla cstr super inh_init cl_init msubst top cl - | Tcl_let (_rec_flag, _defs, vals, cl) -> - let (inh_init, cl_init) = - build_class_init cla cstr super inh_init cl_init msubst top cl - in - let vals = List.map bind_id_as_val vals in - (inh_init, transl_vals cla true StrictOpt vals cl_init) - | Tcl_constraint (cl, _, vals, meths, concr_meths) -> - let virt_meths = - List.filter (fun lab -> not (Concr.mem lab concr_meths)) meths in - let concr_meths = Concr.elements concr_meths in - let narrow_args = - [Lvar cla; - transl_meth_list vals; - transl_meth_list virt_meths; - transl_meth_list concr_meths] in - let cl = ignore_cstrs cl in - begin match cl.cl_desc, inh_init with - | Tcl_ident (path, _, _), (path', path_lam, obj_init)::inh_init -> - assert (Path.same path path'); - let inh = Ident.create_local "inh" - and ofs = List.length vals + 1 - and valids, methids = super in - let cl_init = - List.fold_left - (fun init (nm, id, _) -> - Llet(StrictOpt, Pgenval, id, - lfield inh (index nm concr_meths + ofs), - init)) - cl_init methids in - let cl_init = - List.fold_left - (fun init (nm, id) -> - Llet(StrictOpt, Pgenval, id, - lfield inh (index nm vals + 1), init)) - cl_init valids in - (inh_init, - Llet (Strict, Pgenval, inh, - mkappl(oo_prim "inherits", narrow_args @ - [path_lam; - Lconst(Const_pointer(if top then 1 else 0))]), - Llet(StrictOpt, Pgenval, obj_init, lfield inh 0, cl_init))) - | _ -> - let core cl_init = - build_class_init cla true super inh_init cl_init msubst top cl - in - if cstr then core cl_init else - let (inh_init, cl_init) = - core (Lsequence (mkappl (oo_prim "widen", [Lvar cla]), cl_init)) - in - (inh_init, - Lsequence(mkappl (oo_prim "narrow", narrow_args), - cl_init)) - end - | Tcl_open (_, cl) -> - build_class_init cla cstr super inh_init cl_init msubst top cl - -let rec build_class_lets cl = - match cl.cl_desc with - Tcl_let (rec_flag, defs, _vals, cl') -> - let env, wrap = build_class_lets cl' in - (env, fun x -> - Translcore.transl_let rec_flag defs (wrap x)) - | _ -> - (cl.cl_env, fun x -> x) - -let rec get_class_meths cl = - match cl.cl_desc with - Tcl_structure cl -> - Meths.fold (fun _ -> Ident.Set.add) cl.cstr_meths Ident.Set.empty - | Tcl_ident _ -> Ident.Set.empty - | Tcl_fun (_, _, _, cl, _) - | Tcl_let (_, _, _, cl) - | Tcl_apply (cl, _) - | Tcl_open (_, cl) - | Tcl_constraint (cl, _, _, _, _) -> get_class_meths cl - -(* - XXX Il devrait etre peu couteux d'ecrire des classes : - | Writing classes should be cheap - class c x y = d e f -*) -let rec transl_class_rebind obj_init cl vf = - match cl.cl_desc with - Tcl_ident (path, _, _) -> - if vf = Concrete then begin - try if (Env.find_class path cl.cl_env).cty_new = None then raise Exit - with Not_found -> raise Exit - end; - let path_lam = transl_class_path cl.cl_loc cl.cl_env path in - (path, path_lam, obj_init) - | Tcl_fun (_, pat, _, cl, partial) -> - let path, path_lam, obj_init = transl_class_rebind obj_init cl vf in - let build params rem = - let param = name_pattern "param" pat in - Lfunction {kind = Curried; params = (param, Pgenval)::params; - return = Pgenval; - attr = default_function_attribute; - loc = pat.pat_loc; - body = Matching.for_function - pat.pat_loc None (Lvar param) [pat, rem] partial} - in - (path, path_lam, - match obj_init with - Lfunction {kind = Curried; params; body} -> build params body - | rem -> build [] rem) - | Tcl_apply (cl, oexprs) -> - let path, path_lam, obj_init = transl_class_rebind obj_init cl vf in - (path, path_lam, transl_apply obj_init oexprs Location.none) - | Tcl_let (rec_flag, defs, _vals, cl) -> - let path, path_lam, obj_init = transl_class_rebind obj_init cl vf in - (path, path_lam, Translcore.transl_let rec_flag defs obj_init) - | Tcl_structure _ -> raise Exit - | Tcl_constraint (cl', _, _, _, _) -> - let path, path_lam, obj_init = transl_class_rebind obj_init cl' vf in - let rec check_constraint = function - Cty_constr(path', _, _) when Path.same path path' -> () - | Cty_arrow (_, _, cty) -> check_constraint cty - | _ -> raise Exit - in - check_constraint cl.cl_type; - (path, path_lam, obj_init) - | Tcl_open (_, cl) -> - transl_class_rebind obj_init cl vf - -let rec transl_class_rebind_0 (self:Ident.t) obj_init cl vf = - match cl.cl_desc with - Tcl_let (rec_flag, defs, _vals, cl) -> - let path, path_lam, obj_init = - transl_class_rebind_0 self obj_init cl vf - in - (path, path_lam, Translcore.transl_let rec_flag defs obj_init) - | _ -> - let path, path_lam, obj_init = transl_class_rebind obj_init cl vf in - (path, path_lam, lfunction [self, Pgenval] obj_init) - -let transl_class_rebind cl vf = - try - let obj_init = Ident.create_local "obj_init" - and self = Ident.create_local "self" in - let obj_init0 = - lapply {ap_should_be_tailcall=false; - ap_loc=Location.none; - ap_func=Lvar obj_init; - ap_args=[Lvar self]; - ap_inlined=Default_inline; - ap_specialised=Default_specialise} - in - let _, path_lam, obj_init' = transl_class_rebind_0 self obj_init0 cl vf in - let id = (obj_init' = lfunction [self, Pgenval] obj_init0) in - if id then path_lam else - - let cla = Ident.create_local "class" - and new_init = Ident.create_local "new_init" - and env_init = Ident.create_local "env_init" - and table = Ident.create_local "table" - and envs = Ident.create_local "envs" in - Llet( - Strict, Pgenval, new_init, lfunction [obj_init, Pgenval] obj_init', - Llet( - Alias, Pgenval, cla, path_lam, - Lprim(Pmakeblock(0, Immutable, None), - [mkappl(Lvar new_init, [lfield cla 0]); - lfunction [table, Pgenval] - (Llet(Strict, Pgenval, env_init, - mkappl(lfield cla 1, [Lvar table]), - lfunction [envs, Pgenval] - (mkappl(Lvar new_init, - [mkappl(Lvar env_init, [Lvar envs])])))); - lfield cla 2; - lfield cla 3], - Location.none))) - with Exit -> - lambda_unit - -(* Rewrite a closure using builtins. Improves native code size. *) - -let rec module_path = function - Lvar id -> - let s = Ident.name id in s <> "" && s.[0] >= 'A' && s.[0] <= 'Z' - | Lprim(Pfield _, [p], _) -> module_path p - | Lprim(Pgetglobal _, [], _) -> true - | _ -> false - -let const_path local = function - Lvar id -> not (List.mem id local) - | Lconst _ -> true - | Lfunction {kind = Curried; body} -> - let fv = free_variables body in - List.for_all (fun x -> not (Ident.Set.mem x fv)) local - | p -> module_path p - -let rec builtin_meths self env env2 body = - let const_path = const_path (env::self) in - let conv = function - (* Lvar s when List.mem s self -> "_self", [] *) - | p when const_path p -> "const", [p] - | Lprim(Parrayrefu _, [Lvar s; Lvar n], _) when List.mem s self -> - "var", [Lvar n] - | Lprim(Pfield n, [Lvar e], _) when Ident.same e env -> - "env", [Lvar env2; Lconst(Const_pointer n)] - | Lsend(Self, met, Lvar s, [], _) when List.mem s self -> - "meth", [met] - | _ -> raise Not_found - in - match body with - | Llet(_str, _k, s', Lvar s, body) when List.mem s self -> - builtin_meths (s'::self) env env2 body - | Lapply{ap_func = f; ap_args = [arg]} when const_path f -> - let s, args = conv arg in ("app_"^s, f :: args) - | Lapply{ap_func = f; ap_args = [arg; p]} when const_path f && const_path p -> - let s, args = conv arg in - ("app_"^s^"_const", f :: args @ [p]) - | Lapply{ap_func = f; ap_args = [p; arg]} when const_path f && const_path p -> - let s, args = conv arg in - ("app_const_"^s, f :: p :: args) - | Lsend(Self, Lvar n, Lvar s, [arg], _) when List.mem s self -> - let s, args = conv arg in - ("meth_app_"^s, Lvar n :: args) - | Lsend(Self, met, Lvar s, [], _) when List.mem s self -> - ("get_meth", [met]) - | Lsend(Public, met, arg, [], _) -> - let s, args = conv arg in - ("send_"^s, met :: args) - | Lsend(Cached, met, arg, [_;_], _) -> - let s, args = conv arg in - ("send_"^s, met :: args) - | Lfunction {kind = Curried; params = [x, _]; body} -> - let rec enter self = function - | Lprim(Parraysetu _, [Lvar s; Lvar n; Lvar x'], _) - when Ident.same x x' && List.mem s self -> - ("set_var", [Lvar n]) - | Llet(_str, _k, s', Lvar s, body) when List.mem s self -> - enter (s'::self) body - | _ -> raise Not_found - in enter self body - | Lfunction _ -> raise Not_found - | _ -> - let s, args = conv body in ("get_"^s, args) - -module M = struct - open CamlinternalOO - let builtin_meths self env env2 body = - let builtin, args = builtin_meths self env env2 body in - (* if not arr then [mkappl(oo_prim builtin, args)] else *) - let tag = match builtin with - "get_const" -> GetConst - | "get_var" -> GetVar - | "get_env" -> GetEnv - | "get_meth" -> GetMeth - | "set_var" -> SetVar - | "app_const" -> AppConst - | "app_var" -> AppVar - | "app_env" -> AppEnv - | "app_meth" -> AppMeth - | "app_const_const" -> AppConstConst - | "app_const_var" -> AppConstVar - | "app_const_env" -> AppConstEnv - | "app_const_meth" -> AppConstMeth - | "app_var_const" -> AppVarConst - | "app_env_const" -> AppEnvConst - | "app_meth_const" -> AppMethConst - | "meth_app_const" -> MethAppConst - | "meth_app_var" -> MethAppVar - | "meth_app_env" -> MethAppEnv - | "meth_app_meth" -> MethAppMeth - | "send_const" -> SendConst - | "send_var" -> SendVar - | "send_env" -> SendEnv - | "send_meth" -> SendMeth - | _ -> assert false - in Lconst(Const_pointer(Obj.magic tag)) :: args -end -open M - - -(* - Class translation. - Three subcases: - * reapplication of a known class -> transl_class_rebind - * class without local dependencies -> direct translation - * with local dependencies -> generate a stubs tree, - with a node for every local classes inherited - A class is a 4-tuple: - (obj_init, class_init, env_init, env) - obj_init: creation function (unit -> obj) - class_init: inheritance function (table -> env_init) - (one by source code) - env_init: parameterisation by the local environment - (env -> params -> obj_init) - (one for each combination of inherited class_init ) - env: local environment - If ids=0 (immediate object), then only env_init is conserved. -*) - -(* -let prerr_ids msg ids = - let names = List.map Ident.unique_toplevel_name ids in - prerr_endline (String.concat " " (msg :: names)) -*) - -let free_methods l = - let fv = ref Ident.Set.empty in - let rec free l = - Lambda.iter_head_constructor free l; - match l with - | Lsend(Self, Lvar meth, _, _, _) -> - fv := Ident.Set.add meth !fv - | Lsend _ -> () - | Lfunction{params} -> - List.iter (fun (param, _) -> fv := Ident.Set.remove param !fv) params - | Llet(_str, _k, id, _arg, _body) -> - fv := Ident.Set.remove id !fv - | Lletrec(decl, _body) -> - List.iter (fun (id, _exp) -> fv := Ident.Set.remove id !fv) decl - | Lstaticcatch(_e1, (_,vars), _e2) -> - List.iter (fun (id, _) -> fv := Ident.Set.remove id !fv) vars - | Ltrywith(_e1, exn, _e2) -> - fv := Ident.Set.remove exn !fv - | Lfor(v, _e1, _e2, _dir, _e3) -> - fv := Ident.Set.remove v !fv - | Lassign _ - | Lvar _ | Lconst _ | Lapply _ - | Lprim _ | Lswitch _ | Lstringswitch _ | Lstaticraise _ - | Lifthenelse _ | Lsequence _ | Lwhile _ - | Levent _ | Lifused _ -> () - in free l; !fv - -let transl_class ids cl_id pub_meths cl vflag = - (* First check if it is not only a rebind *) - let rebind = transl_class_rebind cl vflag in - if rebind <> lambda_unit then rebind else - - (* Prepare for heavy environment handling *) - let tables = Ident.create_local (Ident.name cl_id ^ "_tables") in - let (top_env, req) = oo_add_class tables in - let top = not req in - let cl_env, llets = build_class_lets cl in - let new_ids = if top then [] else Env.diff top_env cl_env in - let env2 = Ident.create_local "env" in - let meth_ids = get_class_meths cl in - let subst env lam i0 new_ids' = - let fv = free_variables lam in - (* prerr_ids "cl_id =" [cl_id]; prerr_ids "fv =" (Ident.Set.elements fv); *) - let fv = List.fold_right Ident.Set.remove !new_ids' fv in - (* We need to handle method ids specially, as they do not appear - in the typing environment (PR#3576, PR#4560) *) - (* very hacky: we add and remove free method ids on the fly, - depending on the visit order... *) - method_ids := - Ident.Set.diff (Ident.Set.union (free_methods lam) !method_ids) meth_ids; - (* prerr_ids "meth_ids =" (Ident.Set.elements meth_ids); - prerr_ids "method_ids =" (Ident.Set.elements !method_ids); *) - let new_ids = List.fold_right Ident.Set.add new_ids !method_ids in - let fv = Ident.Set.inter fv new_ids in - new_ids' := !new_ids' @ Ident.Set.elements fv; - (* prerr_ids "new_ids' =" !new_ids'; *) - let i = ref (i0-1) in - List.fold_left - (fun subst id -> - incr i; Ident.Map.add id (lfield env !i) subst) - Ident.Map.empty !new_ids' - in - let new_ids_meths = ref [] in - let no_env_update _ _ env = env in - let msubst arr = function - Lfunction {kind = Curried; params = (self, Pgenval) :: args; body} -> - let env = Ident.create_local "env" in - let body' = - if new_ids = [] then body else - Lambda.subst no_env_update (subst env body 0 new_ids_meths) body in - begin try - (* Doesn't seem to improve size for bytecode *) - (* if not !Clflags.native_code then raise Not_found; *) - if not arr || !Clflags.debug then raise Not_found; - builtin_meths [self] env env2 (lfunction args body') - with Not_found -> - [lfunction ((self, Pgenval) :: args) - (if not (Ident.Set.mem env (free_variables body')) then body' else - Llet(Alias, Pgenval, env, - Lprim(Pfield_computed, - [Lvar self; Lvar env2], - Location.none), - body'))] - end - | _ -> assert false - in - let new_ids_init = ref [] in - let env1 = Ident.create_local "env" and env1' = Ident.create_local "env'" in - let copy_env self = - if top then lambda_unit else - Lifused(env2, Lprim(Psetfield_computed (Pointer, Assignment), - [Lvar self; Lvar env2; Lvar env1'], - Location.none)) - and subst_env envs l lam = - if top then lam else - (* must be called only once! *) - let lam = Lambda.subst no_env_update (subst env1 lam 1 new_ids_init) lam in - Llet(Alias, Pgenval, env1, (if l = [] then Lvar envs else lfield envs 0), - Llet(Alias, Pgenval, env1', - (if !new_ids_init = [] then Lvar env1 else lfield env1 0), - lam)) - in - - (* Now we start compiling the class *) - let cla = Ident.create_local "class" in - let (inh_init, obj_init) = - build_object_init_0 cla [] cl copy_env subst_env top ids in - let inh_init' = List.rev inh_init in - let (inh_init', cl_init) = - build_class_init cla true ([],[]) inh_init' obj_init msubst top cl - in - assert (inh_init' = []); - let table = Ident.create_local "table" - and class_init = Ident.create_local (Ident.name cl_id ^ "_init") - and env_init = Ident.create_local "env_init" - and obj_init = Ident.create_local "obj_init" in - let pub_meths = - List.sort - (fun s s' -> compare (Btype.hash_variant s) (Btype.hash_variant s')) - pub_meths in - let tags = List.map Btype.hash_variant pub_meths in - let rev_map = List.combine tags pub_meths in - List.iter2 - (fun tag name -> - let name' = List.assoc tag rev_map in - if name' <> name then raise(Error(cl.cl_loc, Tags(name, name')))) - tags pub_meths; - let ltable table lam = - Llet(Strict, Pgenval, table, - mkappl (oo_prim "create_table", [transl_meth_list pub_meths]), lam) - and ldirect obj_init = - Llet(Strict, Pgenval, obj_init, cl_init, - Lsequence(mkappl (oo_prim "init_class", [Lvar cla]), - mkappl (Lvar obj_init, [lambda_unit]))) - in - (* Simplest case: an object defined at toplevel (ids=[]) *) - if top && ids = [] then llets (ltable cla (ldirect obj_init)) else - - let concrete = (vflag = Concrete) - and lclass lam = - let cl_init = llets (Lfunction{kind = Curried; - attr = default_function_attribute; - loc = Location.none; - return = Pgenval; - params = [cla, Pgenval]; body = cl_init}) in - Llet(Strict, Pgenval, class_init, cl_init, lam (free_variables cl_init)) - and lbody fv = - if List.for_all (fun id -> not (Ident.Set.mem id fv)) ids then - mkappl (oo_prim "make_class",[transl_meth_list pub_meths; - Lvar class_init]) - else - ltable table ( - Llet( - Strict, Pgenval, env_init, mkappl (Lvar class_init, [Lvar table]), - Lsequence( - mkappl (oo_prim "init_class", [Lvar table]), - Lprim(Pmakeblock(0, Immutable, None), - [mkappl (Lvar env_init, [lambda_unit]); - Lvar class_init; Lvar env_init; lambda_unit], - Location.none)))) - and lbody_virt lenvs = - Lprim(Pmakeblock(0, Immutable, None), - [lambda_unit; Lfunction{kind = Curried; - attr = default_function_attribute; - loc = Location.none; - return = Pgenval; - params = [cla, Pgenval]; body = cl_init}; - lambda_unit; lenvs], - Location.none) - in - (* Still easy: a class defined at toplevel *) - if top && concrete then lclass lbody else - if top then llets (lbody_virt lambda_unit) else - - (* Now for the hard stuff: prepare for table caching *) - let envs = Ident.create_local "envs" - and cached = Ident.create_local "cached" in - let lenvs = - if !new_ids_meths = [] && !new_ids_init = [] && inh_init = [] - then lambda_unit - else Lvar envs in - let lenv = - let menv = - if !new_ids_meths = [] then lambda_unit else - Lprim(Pmakeblock(0, Immutable, None), - List.map (fun id -> Lvar id) !new_ids_meths, - Location.none) in - if !new_ids_init = [] then menv else - Lprim(Pmakeblock(0, Immutable, None), - menv :: List.map (fun id -> Lvar id) !new_ids_init, - Location.none) - and linh_envs = - List.map - (fun (_, path_lam, _) -> Lprim(Pfield 3, [path_lam], Location.none)) - (List.rev inh_init) - in - let make_envs lam = - Llet(StrictOpt, Pgenval, envs, - (if linh_envs = [] then lenv else - Lprim(Pmakeblock(0, Immutable, None), - lenv :: linh_envs, Location.none)), - lam) - and def_ids cla lam = - Llet(StrictOpt, Pgenval, env2, - mkappl (oo_prim "new_variable", [Lvar cla; transl_label ""]), - lam) - in - let inh_paths = - List.filter - (fun (path, _, _) -> List.mem (Path.head path) new_ids) inh_init - in - let inh_keys = - List.map - (fun (_, path_lam, _) -> Lprim(Pfield 1, [path_lam], Location.none)) - inh_paths - in - let lclass lam = - Llet(Strict, Pgenval, class_init, - Lfunction{kind = Curried; params = [cla, Pgenval]; - return = Pgenval; - attr = default_function_attribute; - loc = Location.none; - body = def_ids cla cl_init}, lam) - and lcache lam = - if inh_keys = [] then Llet(Alias, Pgenval, cached, Lvar tables, lam) else - Llet(Strict, Pgenval, cached, - mkappl (oo_prim "lookup_tables", - [Lvar tables; Lprim(Pmakeblock(0, Immutable, None), - inh_keys, Location.none)]), - lam) - and lset cached i lam = - Lprim(Psetfield(i, Pointer, Assignment), - [Lvar cached; lam], Location.none) - in - let ldirect () = - ltable cla - (Llet(Strict, Pgenval, env_init, def_ids cla cl_init, - Lsequence(mkappl (oo_prim "init_class", [Lvar cla]), - lset cached 0 (Lvar env_init)))) - and lclass_virt () = - lset cached 0 - (Lfunction - { - kind = Curried; - attr = default_function_attribute; - loc = Location.none; - return = Pgenval; - params = [cla, Pgenval]; - body = def_ids cla cl_init; - } - ) - in - let lupdate_cache = - if ids = [] then ldirect () else - if not concrete then lclass_virt () else - lclass ( - mkappl (oo_prim "make_class_store", - [transl_meth_list pub_meths; - Lvar class_init; Lvar cached])) in - let lcheck_cache = - if !Clflags.native_code && !Clflags.afl_instrument then - (* When afl-fuzz instrumentation is enabled, ignore the cache - so that the program's behaviour does not change between runs *) - lupdate_cache - else - Lifthenelse(lfield cached 0, lambda_unit, lupdate_cache) in - llets ( - lcache ( - Lsequence(lcheck_cache, - make_envs ( - if ids = [] then mkappl (lfield cached 0, [lenvs]) else - Lprim(Pmakeblock(0, Immutable, None), - (if concrete then - [mkappl (lfield cached 0, [lenvs]); - lfield cached 1; - lfield cached 0; - lenvs] - else [lambda_unit; lfield cached 0; lambda_unit; lenvs]), - Location.none - ))))) - -(* Wrapper for class compilation *) -(* - let cl_id = ci.ci_id_class in -(* TODO: cl_id is used somewhere else as typesharp ? *) - let _arity = List.length ci.ci_params in - let pub_meths = m in - let cl = ci.ci_expr in - let vflag = vf in -*) - -let transl_class ids id pub_meths cl vf = - oo_wrap cl.cl_env false (transl_class ids id pub_meths cl) vf - -let () = - transl_object := (fun id meths cl -> transl_class [] id meths cl Concrete) - -(* Error report *) - -open Format - -let report_error ppf = function - | Tags (lab1, lab2) -> - fprintf ppf "Method labels `%s' and `%s' are incompatible.@ %s" - lab1 lab2 "Change one of them." - -let () = - Location.register_error_of_exn - (function - | Error (loc, err) -> - Some (Location.error_of_printer ~loc report_error err) - | _ -> - None - ) diff --git a/bytecomp/translclass.mli b/bytecomp/translclass.mli deleted file mode 100644 index 4c4bed0f63..0000000000 --- a/bytecomp/translclass.mli +++ /dev/null @@ -1,29 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Jerome Vouillon, 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 Typedtree -open Lambda - -val transl_class : - Ident.t list -> Ident.t -> - string list -> class_expr -> Asttypes.virtual_flag -> lambda;; - -type error = Tags of string * string - -exception Error of Location.t * error - -open Format - -val report_error: formatter -> error -> unit diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml deleted file mode 100644 index 6fe2dcbbb9..0000000000 --- a/bytecomp/translcore.ml +++ /dev/null @@ -1,1048 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Translation from typed abstract syntax to lambda terms, - for the core language *) - -open Misc -open Asttypes -open Primitive -open Types -open Typedtree -open Typeopt -open Lambda - -type error = - Free_super_var - | Unreachable_reached - -exception Error of Location.t * error - -let use_dup_for_constant_arrays_bigger_than = 4 - -(* Forward declaration -- to be filled in by Translmod.transl_module *) -let transl_module = - ref((fun _cc _rootpath _modl -> assert false) : - module_coercion -> Path.t option -> module_expr -> lambda) - -let transl_object = - ref (fun _id _s _cl -> assert false : - Ident.t -> string list -> class_expr -> lambda) - -(* Compile an exception/extension definition *) - -let prim_fresh_oo_id = - Pccall (Primitive.simple ~name:"caml_fresh_oo_id" ~arity:1 ~alloc:false) - -let transl_extension_constructor env path ext = - let path = - Printtyp.wrap_printing_env env ~error:true (fun () -> - Option.map (Printtyp.rewrite_double_underscore_paths env) path) - in - let name = - match path, !Clflags.for_package with - None, _ -> Ident.name ext.ext_id - | Some p, None -> Path.name p - | Some p, Some pack -> Printf.sprintf "%s.%s" pack (Path.name p) - in - let loc = ext.ext_loc in - match ext.ext_kind with - Text_decl _ -> - Lprim (Pmakeblock (Obj.object_tag, Immutable, None), - [Lconst (Const_base (Const_string (name, None))); - Lprim (prim_fresh_oo_id, [Lconst (Const_base (Const_int 0))], loc)], - loc) - | Text_rebind(path, _lid) -> - transl_extension_path loc env path - -(* To propagate structured constants *) - -exception Not_constant - -let extract_constant = function - Lconst sc -> sc - | _ -> raise Not_constant - -let extract_float = function - Const_base(Const_float f) -> f - | _ -> fatal_error "Translcore.extract_float" - -(* Push the default values under the functional abstractions *) -(* Also push bindings of module patterns, since this sound *) - -type binding = - | Bind_value of value_binding list - | Bind_module of Ident.t * string loc * module_presence * module_expr - -let rec push_defaults loc bindings cases partial = - match cases with - [{c_lhs=pat; c_guard=None; - c_rhs={exp_desc = Texp_function { arg_label; param; cases; partial; } } - as exp}] -> - let cases = push_defaults exp.exp_loc bindings cases partial in - [{c_lhs=pat; c_guard=None; - c_rhs={exp with exp_desc = Texp_function { arg_label; param; cases; - partial; }}}] - | [{c_lhs=pat; c_guard=None; - c_rhs={exp_attributes=[{Parsetree.attr_name = {txt="#default"};_}]; - exp_desc = Texp_let - (Nonrecursive, binds, ({exp_desc = Texp_function _} as e2))}}] -> - push_defaults loc (Bind_value binds :: bindings) - [{c_lhs=pat;c_guard=None;c_rhs=e2}] - partial - | [{c_lhs=pat; c_guard=None; - c_rhs={exp_attributes=[{Parsetree.attr_name = {txt="#modulepat"};_}]; - exp_desc = Texp_letmodule - (id, name, pres, mexpr, - ({exp_desc = Texp_function _} as e2))}}] -> - push_defaults loc (Bind_module (id, name, pres, mexpr) :: bindings) - [{c_lhs=pat;c_guard=None;c_rhs=e2}] - partial - | [case] -> - let exp = - List.fold_left - (fun exp binds -> - {exp with exp_desc = - match binds with - | Bind_value binds -> Texp_let(Nonrecursive, binds, exp) - | Bind_module (id, name, pres, mexpr) -> - Texp_letmodule (id, name, pres, mexpr, exp)}) - case.c_rhs bindings - in - [{case with c_rhs=exp}] - | {c_lhs=pat; c_rhs=exp; c_guard=_} :: _ when bindings <> [] -> - let param = Typecore.name_cases "param" cases in - let desc = - {val_type = pat.pat_type; val_kind = Val_reg; - val_attributes = []; Types.val_loc = Location.none; } - in - let env = Env.add_value param desc exp.exp_env in - let name = Ident.name param in - let exp = - { exp with exp_loc = loc; exp_env = env; exp_desc = - Texp_match - ({exp with exp_type = pat.pat_type; exp_env = env; exp_desc = - Texp_ident - (Path.Pident param, mknoloc (Longident.Lident name), desc)}, - cases, partial) } - in - push_defaults loc bindings - [{c_lhs={pat with pat_desc = Tpat_var (param, mknoloc name)}; - c_guard=None; c_rhs=exp}] - Total - | _ -> - cases - -(* Insertion of debugging events *) - -let event_before = Translprim.event_before - -let event_after = Translprim.event_after - -let event_function exp lam = - if !Clflags.debug && not !Clflags.native_code then - let repr = Some (ref 0) in - let (info, body) = lam repr in - (info, - Levent(body, {lev_loc = exp.exp_loc; - lev_kind = Lev_function; - lev_repr = repr; - lev_env = exp.exp_env})) - else - lam None - -(* Assertions *) - -let assert_failed exp = - let slot = - transl_extension_path Location.none - Env.initial_safe_string Predef.path_assert_failure - in - let (fname, line, char) = - Location.get_pos_info exp.exp_loc.Location.loc_start - in - Lprim(Praise Raise_regular, [event_after exp - (Lprim(Pmakeblock(0, Immutable, None), - [slot; - Lconst(Const_block(0, - [Const_base(Const_string (fname, None)); - Const_base(Const_int line); - Const_base(Const_int char)]))], exp.exp_loc))], exp.exp_loc) -;; - -let rec cut n l = - if n = 0 then ([],l) else - match l with [] -> failwith "Translcore.cut" - | a::l -> let (l1,l2) = cut (n-1) l in (a::l1,l2) - -(* Translation of expressions *) - -let rec iter_exn_names f pat = - match pat.pat_desc with - | Tpat_var (id, _) -> f id - | Tpat_alias (p, id, _) -> - f id; - iter_exn_names f p - | _ -> () - -let transl_ident loc env ty path desc = - match desc.val_kind with - | Val_prim p -> - Translprim.transl_primitive loc p env ty (Some path) - | Val_anc _ -> - raise(Error(loc, Free_super_var)) - | Val_reg | Val_self _ -> - transl_value_path loc env path - | _ -> fatal_error "Translcore.transl_exp: bad Texp_ident" - -let rec transl_exp e = - List.iter (Translattribute.check_attribute e) e.exp_attributes; - let eval_once = - (* Whether classes for immediate objects must be cached *) - match e.exp_desc with - Texp_function _ | Texp_for _ | Texp_while _ -> false - | _ -> true - in - if eval_once then transl_exp0 e else - Translobj.oo_wrap e.exp_env true transl_exp0 e - -and transl_exp0 e = - match e.exp_desc with - | Texp_ident(path, _, desc) -> - transl_ident e.exp_loc e.exp_env e.exp_type path desc - | Texp_constant cst -> - Lconst(Const_base cst) - | Texp_let(rec_flag, pat_expr_list, body) -> - transl_let rec_flag pat_expr_list (event_before body (transl_exp body)) - | Texp_function { arg_label = _; param; cases; partial; } -> - let ((kind, params, return), body) = - event_function e - (function repr -> - let pl = push_defaults e.exp_loc [] cases partial in - let return_kind = function_return_value_kind e.exp_env e.exp_type in - transl_function e.exp_loc return_kind !Clflags.native_code repr - partial param pl) - in - let attr = default_function_attribute in - let loc = e.exp_loc in - let lam = Lfunction{kind; params; return; body; attr; loc} in - Translattribute.add_function_attributes lam loc e.exp_attributes - | Texp_apply({ exp_desc = Texp_ident(path, _, {val_kind = Val_prim p}); - exp_type = prim_type } as funct, oargs) - when List.length oargs >= p.prim_arity - && List.for_all (fun (_, arg) -> arg <> None) oargs -> - let argl, extra_args = cut p.prim_arity oargs in - let arg_exps = - List.map (function _, Some x -> x | _ -> assert false) argl - in - let args = transl_list arg_exps in - let prim_exp = if extra_args = [] then Some e else None in - let lam = - Translprim.transl_primitive_application - e.exp_loc p e.exp_env prim_type path - prim_exp args arg_exps - in - if extra_args = [] then lam - else begin - let should_be_tailcall, funct = - Translattribute.get_tailcall_attribute funct - in - let inlined, funct = - Translattribute.get_and_remove_inlined_attribute funct - in - let specialised, funct = - Translattribute.get_and_remove_specialised_attribute funct - in - let e = { e with exp_desc = Texp_apply(funct, oargs) } in - event_after e - (transl_apply ~should_be_tailcall ~inlined ~specialised - lam extra_args e.exp_loc) - end - | Texp_apply(funct, oargs) -> - let should_be_tailcall, funct = - Translattribute.get_tailcall_attribute funct - in - let inlined, funct = - Translattribute.get_and_remove_inlined_attribute funct - in - let specialised, funct = - Translattribute.get_and_remove_specialised_attribute funct - in - let e = { e with exp_desc = Texp_apply(funct, oargs) } in - event_after e - (transl_apply ~should_be_tailcall ~inlined ~specialised - (transl_exp funct) oargs e.exp_loc) - | Texp_match(arg, pat_expr_list, partial) -> - transl_match e arg pat_expr_list partial - | Texp_try(body, pat_expr_list) -> - let id = Typecore.name_cases "exn" pat_expr_list in - Ltrywith(transl_exp body, id, - Matching.for_trywith (Lvar id) (transl_cases_try pat_expr_list)) - | Texp_tuple el -> - let ll, shape = transl_list_with_shape el in - begin try - Lconst(Const_block(0, List.map extract_constant ll)) - with Not_constant -> - Lprim(Pmakeblock(0, Immutable, Some shape), ll, e.exp_loc) - end - | Texp_construct(_, cstr, args) -> - let ll, shape = transl_list_with_shape args in - if cstr.cstr_inlined <> None then begin match ll with - | [x] -> x - | _ -> assert false - end else begin match cstr.cstr_tag with - Cstr_constant n -> - Lconst(Const_pointer n) - | Cstr_unboxed -> - (match ll with [v] -> v | _ -> assert false) - | Cstr_block n -> - begin try - Lconst(Const_block(n, List.map extract_constant ll)) - with Not_constant -> - Lprim(Pmakeblock(n, Immutable, Some shape), ll, e.exp_loc) - end - | Cstr_extension(path, is_const) -> - let lam = transl_extension_path e.exp_loc e.exp_env path in - if is_const then lam - else - Lprim(Pmakeblock(0, Immutable, Some (Pgenval :: shape)), - lam :: ll, e.exp_loc) - end - | Texp_extension_constructor (_, path) -> - transl_extension_path e.exp_loc e.exp_env path - | Texp_variant(l, arg) -> - let tag = Btype.hash_variant l in - begin match arg with - None -> Lconst(Const_pointer tag) - | Some arg -> - let lam = transl_exp arg in - try - Lconst(Const_block(0, [Const_base(Const_int tag); - extract_constant lam])) - with Not_constant -> - Lprim(Pmakeblock(0, Immutable, None), - [Lconst(Const_base(Const_int tag)); lam], e.exp_loc) - end - | Texp_record {fields; representation; extended_expression} -> - transl_record e.exp_loc e.exp_env fields representation - extended_expression - | Texp_field(arg, _, lbl) -> - let targ = transl_exp arg in - begin match lbl.lbl_repres with - Record_regular | Record_inlined _ -> - Lprim (Pfield lbl.lbl_pos, [targ], e.exp_loc) - | Record_unboxed _ -> targ - | Record_float -> Lprim (Pfloatfield lbl.lbl_pos, [targ], e.exp_loc) - | Record_extension _ -> - Lprim (Pfield (lbl.lbl_pos + 1), [targ], e.exp_loc) - end - | Texp_setfield(arg, _, lbl, newval) -> - let access = - match lbl.lbl_repres with - Record_regular - | Record_inlined _ -> - Psetfield(lbl.lbl_pos, maybe_pointer newval, Assignment) - | Record_unboxed _ -> assert false - | Record_float -> Psetfloatfield (lbl.lbl_pos, Assignment) - | Record_extension _ -> - Psetfield (lbl.lbl_pos + 1, maybe_pointer newval, Assignment) - in - Lprim(access, [transl_exp arg; transl_exp newval], e.exp_loc) - | Texp_array expr_list -> - let kind = array_kind e in - let ll = transl_list expr_list in - begin try - (* For native code the decision as to which compilation strategy to - use is made later. This enables the Flambda passes to lift certain - kinds of array definitions to symbols. *) - (* Deactivate constant optimization if array is small enough *) - if List.length ll <= use_dup_for_constant_arrays_bigger_than - then begin - raise Not_constant - end; - begin match List.map extract_constant ll with - | exception Not_constant when kind = Pfloatarray -> - (* We cannot currently lift [Pintarray] arrays safely in Flambda - because [caml_modify] might be called upon them (e.g. from - code operating on polymorphic arrays, or functions such as - [caml_array_blit]. - To avoid having different Lambda code for - bytecode/Closure vs. Flambda, we always generate - [Pduparray] here, and deal with it in [Bytegen] (or in - the case of Closure, in [Cmmgen], which already has to - handle [Pduparray Pmakearray Pfloatarray] in the case - where the array turned out to be inconstant). - When not [Pfloatarray], the exception propagates to the handler - below. *) - let imm_array = - Lprim (Pmakearray (kind, Immutable), ll, e.exp_loc) - in - Lprim (Pduparray (kind, Mutable), [imm_array], e.exp_loc) - | cl -> - let imm_array = - match kind with - | Paddrarray | Pintarray -> - Lconst(Const_block(0, cl)) - | Pfloatarray -> - Lconst(Const_float_array(List.map extract_float cl)) - | Pgenarray -> - raise Not_constant (* can this really happen? *) - in - Lprim (Pduparray (kind, Mutable), [imm_array], e.exp_loc) - end - with Not_constant -> - Lprim(Pmakearray (kind, Mutable), ll, e.exp_loc) - end - | Texp_ifthenelse(cond, ifso, Some ifnot) -> - Lifthenelse(transl_exp cond, - event_before ifso (transl_exp ifso), - event_before ifnot (transl_exp ifnot)) - | Texp_ifthenelse(cond, ifso, None) -> - Lifthenelse(transl_exp cond, - event_before ifso (transl_exp ifso), - lambda_unit) - | Texp_sequence(expr1, expr2) -> - Lsequence(transl_exp expr1, event_before expr2 (transl_exp expr2)) - | Texp_while(cond, body) -> - Lwhile(transl_exp cond, event_before body (transl_exp body)) - | Texp_for(param, _, low, high, dir, body) -> - Lfor(param, transl_exp low, transl_exp high, dir, - event_before body (transl_exp body)) - | Texp_send(_, _, Some exp) -> transl_exp exp - | Texp_send(expr, met, None) -> - let obj = transl_exp expr in - let lam = - match met with - Tmeth_val id -> Lsend (Self, Lvar id, obj, [], e.exp_loc) - | Tmeth_name nm -> - let (tag, cache) = Translobj.meth obj nm in - let kind = if cache = [] then Public else Cached in - Lsend (kind, tag, obj, cache, e.exp_loc) - in - event_after e lam - | Texp_new (cl, {Location.loc=loc}, _) -> - Lapply{ap_should_be_tailcall=false; - ap_loc=loc; - ap_func= - Lprim(Pfield 0, [transl_class_path loc e.exp_env cl], loc); - ap_args=[lambda_unit]; - ap_inlined=Default_inline; - ap_specialised=Default_specialise} - | Texp_instvar(path_self, path, _) -> - let self = transl_value_path e.exp_loc e.exp_env path_self in - let var = transl_value_path e.exp_loc e.exp_env path in - Lprim(Pfield_computed, [self; var], e.exp_loc) - | Texp_setinstvar(path_self, path, _, expr) -> - let self = transl_value_path e.exp_loc e.exp_env path_self in - let var = transl_value_path e.exp_loc e.exp_env path in - transl_setinstvar e.exp_loc self var expr - | Texp_override(path_self, modifs) -> - let self = transl_value_path e.exp_loc e.exp_env path_self in - let cpy = Ident.create_local "copy" in - Llet(Strict, Pgenval, cpy, - Lapply{ap_should_be_tailcall=false; - ap_loc=Location.none; - ap_func=Translobj.oo_prim "copy"; - ap_args=[self]; - ap_inlined=Default_inline; - ap_specialised=Default_specialise}, - List.fold_right - (fun (path, _, expr) rem -> - let var = transl_value_path e.exp_loc e.exp_env path in - Lsequence(transl_setinstvar Location.none - (Lvar cpy) var expr, rem)) - modifs - (Lvar cpy)) - | Texp_letmodule(id, loc, Mp_present, modl, body) -> - let defining_expr = - Levent (!transl_module Tcoerce_none None modl, { - lev_loc = loc.loc; - lev_kind = Lev_module_definition id; - lev_repr = None; - lev_env = Env.empty; - }) - in - Llet(Strict, Pgenval, id, defining_expr, transl_exp body) - | Texp_letmodule(_, _, Mp_absent, _, body) -> - transl_exp body - | Texp_letexception(cd, body) -> - Llet(Strict, Pgenval, - cd.ext_id, transl_extension_constructor e.exp_env None cd, - transl_exp body) - | Texp_pack modl -> - !transl_module Tcoerce_none None modl - | Texp_assert {exp_desc=Texp_construct(_, {cstr_name="false"}, _)} -> - assert_failed e - | Texp_assert (cond) -> - if !Clflags.noassert - then lambda_unit - else Lifthenelse (transl_exp cond, lambda_unit, assert_failed e) - | Texp_lazy e -> - (* when e needs no computation (constants, identifiers, ...), we - optimize the translation just as Lazy.lazy_from_val would - do *) - begin match Typeopt.classify_lazy_argument e with - | `Constant_or_function -> - (* A constant expr (of type <> float if [Config.flat_float_array] is - true) gets compiled as itself. *) - transl_exp e - | `Float_that_cannot_be_shortcut -> - (* We don't need to wrap with Popaque: this forward - block will never be shortcutted since it points to a float - and Config.flat_float_array is true. *) - Lprim(Pmakeblock(Obj.forward_tag, Immutable, None), - [transl_exp e], e.exp_loc) - | `Identifier `Forward_value -> - (* CR-someday mshinwell: Consider adding a new primitive - that expresses the construction of forward_tag blocks. - We need to use [Popaque] here to prevent unsound - optimisation in Flambda, but the concept of a mutable - block doesn't really match what is going on here. This - value may subsequently turn into an immediate... *) - Lprim (Popaque, - [Lprim(Pmakeblock(Obj.forward_tag, Immutable, None), - [transl_exp e], e.exp_loc)], - e.exp_loc) - | `Identifier `Other -> - transl_exp e - | `Other -> - (* other cases compile to a lazy block holding a function *) - let fn = Lfunction {kind = Curried; - params= [Ident.create_local "param", Pgenval]; - return = Pgenval; - attr = default_function_attribute; - loc = e.exp_loc; - body = transl_exp e} in - Lprim(Pmakeblock(Config.lazy_tag, Mutable, None), [fn], e.exp_loc) - end - | Texp_object (cs, meths) -> - let cty = cs.cstr_type in - let cl = Ident.create_local "class" in - !transl_object cl meths - { cl_desc = Tcl_structure cs; - cl_loc = e.exp_loc; - cl_type = Cty_signature cty; - cl_env = e.exp_env; - cl_attributes = []; - } - | Texp_letop{let_; ands; param; body; partial} -> - event_after e - (transl_letop e.exp_loc e.exp_env let_ ands param body partial) - | Texp_unreachable -> - raise (Error (e.exp_loc, Unreachable_reached)) - | Texp_open (od, e) -> - let pure = pure_module od.open_expr in - (* this optimization shouldn't be needed because Simplif would - actually remove the [Llet] when it's not used. - But since [scan_used_globals] runs before Simplif, we need to - do it. *) - begin match od.open_bound_items with - | [] when pure = Alias -> transl_exp e - | _ -> - let oid = Ident.create_local "open" in - let body, _ = - List.fold_left (fun (body, pos) id -> - Llet(Alias, Pgenval, id, - Lprim(Pfield pos, [Lvar oid], od.open_loc), body), - pos + 1 - ) (transl_exp e, 0) (bound_value_identifiers od.open_bound_items) - in - Llet(pure, Pgenval, oid, - !transl_module Tcoerce_none None od.open_expr, body) - end - -and pure_module m = - match m.mod_desc with - Tmod_ident _ -> Alias - | Tmod_constraint (m,_,_,_) -> pure_module m - | _ -> Strict - -and transl_list expr_list = - List.map transl_exp expr_list - -and transl_list_with_shape expr_list = - let transl_with_shape e = - let shape = Typeopt.value_kind e.exp_env e.exp_type in - transl_exp e, shape - in - List.split (List.map transl_with_shape expr_list) - -and transl_guard guard rhs = - let expr = event_before rhs (transl_exp rhs) in - match guard with - | None -> expr - | Some cond -> - event_before cond (Lifthenelse(transl_exp cond, expr, staticfail)) - -and transl_case {c_lhs; c_guard; c_rhs} = - c_lhs, transl_guard c_guard c_rhs - -and transl_cases cases = - let cases = - List.filter (fun c -> c.c_rhs.exp_desc <> Texp_unreachable) cases in - List.map transl_case cases - -and transl_case_try {c_lhs; c_guard; c_rhs} = - iter_exn_names Translprim.add_exception_ident c_lhs; - Misc.try_finally - (fun () -> c_lhs, transl_guard c_guard c_rhs) - ~always:(fun () -> - iter_exn_names Translprim.remove_exception_ident c_lhs) - -and transl_cases_try cases = - let cases = - List.filter (fun c -> c.c_rhs.exp_desc <> Texp_unreachable) cases in - List.map transl_case_try cases - -and transl_tupled_cases patl_expr_list = - let patl_expr_list = - List.filter (fun (_,_,e) -> e.exp_desc <> Texp_unreachable) - patl_expr_list in - List.map (fun (patl, guard, expr) -> (patl, transl_guard guard expr)) - patl_expr_list - -and transl_apply ?(should_be_tailcall=false) ?(inlined = Default_inline) - ?(specialised = Default_specialise) lam sargs loc = - let lapply funct args = - match funct with - Lsend(k, lmet, lobj, largs, loc) -> - Lsend(k, lmet, lobj, largs @ args, loc) - | Levent(Lsend(k, lmet, lobj, largs, loc), _) -> - Lsend(k, lmet, lobj, largs @ args, loc) - | Lapply ap -> - Lapply {ap with ap_args = ap.ap_args @ args; ap_loc = loc} - | lexp -> - Lapply {ap_should_be_tailcall=should_be_tailcall; - ap_loc=loc; - ap_func=lexp; - ap_args=args; - ap_inlined=inlined; - ap_specialised=specialised;} - in - let rec build_apply lam args = function - (None, optional) :: l -> - let defs = ref [] in - let protect name lam = - match lam with - Lvar _ | Lconst _ -> lam - | _ -> - let id = Ident.create_local name in - defs := (id, lam) :: !defs; - Lvar id - in - let args, args' = - if List.for_all (fun (_,opt) -> opt) args then [], args - else args, [] in - let lam = - if args = [] then lam else lapply lam (List.rev_map fst args) in - let handle = protect "func" lam - and l = List.map (fun (arg, opt) -> may_map (protect "arg") arg, opt) l - and id_arg = Ident.create_local "param" in - let body = - match build_apply handle ((Lvar id_arg, optional)::args') l with - Lfunction{kind = Curried; params = ids; return; - body = lam; attr; loc} -> - Lfunction{kind = Curried; - params = (id_arg, Pgenval)::ids; - return; - body = lam; attr; - loc} - | Levent(Lfunction{kind = Curried; params = ids; return; - body = lam; attr; loc}, _) -> - Lfunction{kind = Curried; params = (id_arg, Pgenval)::ids; - return; - body = lam; attr; - loc} - | lam -> - Lfunction{kind = Curried; params = [id_arg, Pgenval]; - return = Pgenval; body = lam; - attr = default_stub_attribute; loc = loc} - in - List.fold_left - (fun body (id, lam) -> Llet(Strict, Pgenval, id, lam, body)) - body !defs - | (Some arg, optional) :: l -> - build_apply lam ((arg, optional) :: args) l - | [] -> - lapply lam (List.rev_map fst args) - in - (build_apply lam [] (List.map (fun (l, x) -> - may_map transl_exp x, Btype.is_optional l) - sargs) - : Lambda.lambda) - -and transl_function loc return untuplify_fn repr partial (param:Ident.t) cases = - match cases with - [{c_lhs=pat; c_guard=None; - c_rhs={exp_desc = Texp_function { arg_label = _; param = param'; cases; - partial = partial'; }; exp_env; exp_type} as exp}] - when Parmatch.inactive ~partial pat -> - let kind = value_kind pat.pat_env pat.pat_type in - let return_kind = function_return_value_kind exp_env exp_type in - let ((_, params, return), body) = - transl_function exp.exp_loc return_kind false repr partial' param' cases - in - ((Curried, (param, kind) :: params, return), - Matching.for_function loc None (Lvar param) [pat, body] partial) - | {c_lhs={pat_desc = Tpat_tuple pl}} :: _ when untuplify_fn -> - begin try - let size = List.length pl in - let pats_expr_list = - List.map - (fun {c_lhs; c_guard; c_rhs} -> - (Matching.flatten_pattern size c_lhs, c_guard, c_rhs)) - cases in - let kinds = - (* All the patterns might not share the same types. We must take the - union of the patterns types *) - match pats_expr_list with - | [] -> assert false - | (pats, _, _) :: cases -> - let first_case_kinds = - List.map (fun pat -> value_kind pat.pat_env pat.pat_type) pats - in - List.fold_left - (fun kinds (pats, _, _) -> - List.map2 (fun kind pat -> - value_kind_union kind - (value_kind pat.pat_env pat.pat_type)) - kinds pats) - first_case_kinds cases - in - let tparams = - List.map (fun kind -> Ident.create_local "param", kind) kinds - in - let params = List.map fst tparams in - ((Tupled, tparams, return), - Matching.for_tupled_function loc params - (transl_tupled_cases pats_expr_list) partial) - with Matching.Cannot_flatten -> - ((Curried, [param, Pgenval], return), - Matching.for_function loc repr (Lvar param) - (transl_cases cases) partial) - end - | {c_lhs=pat} :: other_cases -> - let kind = - (* All the patterns might not share the same types. We must take the - union of the patterns types *) - List.fold_left (fun k {c_lhs=pat} -> - Typeopt.value_kind_union k - (value_kind pat.pat_env pat.pat_type)) - (value_kind pat.pat_env pat.pat_type) other_cases - in - ((Curried, [param, kind], return), - Matching.for_function loc repr (Lvar param) - (transl_cases cases) partial) - | [] -> - (* With Camlp4, a pattern matching might be empty *) - ((Curried, [param, Pgenval], return), - Matching.for_function loc repr (Lvar param) - (transl_cases cases) partial) - -(* - Notice: transl_let consumes (ie compiles) its pat_expr_list argument, - and returns a function that will take the body of the lambda-let construct. - This complication allows choosing any compilation order for the - bindings and body of let constructs. -*) -and transl_let rec_flag pat_expr_list = - match rec_flag with - Nonrecursive -> - let rec transl = function - [] -> - fun body -> body - | {vb_pat=pat; vb_expr=expr; vb_attributes=attr; vb_loc} :: rem -> - let lam = transl_exp expr in - let lam = Translattribute.add_function_attributes lam vb_loc attr in - let mk_body = transl rem in - fun body -> Matching.for_let pat.pat_loc lam pat (mk_body body) - in transl pat_expr_list - | Recursive -> - let idlist = - List.map - (fun {vb_pat=pat} -> match pat.pat_desc with - Tpat_var (id,_) -> id - | Tpat_alias ({pat_desc=Tpat_any}, id,_) -> id - | _ -> assert false) - pat_expr_list in - let transl_case {vb_expr=expr; vb_attributes; vb_loc} id = - let lam = transl_exp expr in - let lam = - Translattribute.add_function_attributes lam vb_loc vb_attributes - in - (id, lam) in - let lam_bds = List.map2 transl_case pat_expr_list idlist in - fun body -> Lletrec(lam_bds, body) - -and transl_setinstvar loc self var expr = - Lprim(Psetfield_computed (maybe_pointer expr, Assignment), - [self; var; transl_exp expr], loc) - -and transl_record loc env fields repres opt_init_expr = - let size = Array.length fields in - (* Determine if there are "enough" fields (only relevant if this is a - functional-style record update *) - let no_init = match opt_init_expr with None -> true | _ -> false in - if no_init || size < Config.max_young_wosize - then begin - (* Allocate new record with given fields (and remaining fields - taken from init_expr if any *) - let init_id = Ident.create_local "init" in - let lv = - Array.mapi - (fun i (_, definition) -> - match definition with - | Kept typ -> - let field_kind = value_kind env typ in - let access = - match repres with - Record_regular | Record_inlined _ -> Pfield i - | Record_unboxed _ -> assert false - | Record_extension _ -> Pfield (i + 1) - | Record_float -> Pfloatfield i in - Lprim(access, [Lvar init_id], loc), field_kind - | Overridden (_lid, expr) -> - let field_kind = value_kind expr.exp_env expr.exp_type in - transl_exp expr, field_kind) - fields - in - let ll, shape = List.split (Array.to_list lv) in - let mut = - if Array.exists (fun (lbl, _) -> lbl.lbl_mut = Mutable) fields - then Mutable - else Immutable in - let lam = - try - if mut = Mutable then raise Not_constant; - let cl = List.map extract_constant ll in - match repres with - | Record_regular -> Lconst(Const_block(0, cl)) - | Record_inlined tag -> Lconst(Const_block(tag, cl)) - | Record_unboxed _ -> Lconst(match cl with [v] -> v | _ -> assert false) - | Record_float -> - Lconst(Const_float_array(List.map extract_float cl)) - | Record_extension _ -> - raise Not_constant - with Not_constant -> - match repres with - Record_regular -> - Lprim(Pmakeblock(0, mut, Some shape), ll, loc) - | Record_inlined tag -> - Lprim(Pmakeblock(tag, mut, Some shape), ll, loc) - | Record_unboxed _ -> (match ll with [v] -> v | _ -> assert false) - | Record_float -> - Lprim(Pmakearray (Pfloatarray, mut), ll, loc) - | Record_extension path -> - let slot = transl_extension_path loc env path in - Lprim(Pmakeblock(0, mut, Some (Pgenval :: shape)), slot :: ll, loc) - in - begin match opt_init_expr with - None -> lam - | Some init_expr -> Llet(Strict, Pgenval, init_id, - transl_exp init_expr, lam) - end - end else begin - (* Take a shallow copy of the init record, then mutate the fields - of the copy *) - let copy_id = Ident.create_local "newrecord" in - let update_field cont (lbl, definition) = - match definition with - | Kept _type -> cont - | Overridden (_lid, expr) -> - let upd = - match repres with - Record_regular - | Record_inlined _ -> - Psetfield(lbl.lbl_pos, maybe_pointer expr, Assignment) - | Record_unboxed _ -> assert false - | Record_float -> Psetfloatfield (lbl.lbl_pos, Assignment) - | Record_extension _ -> - Psetfield(lbl.lbl_pos + 1, maybe_pointer expr, Assignment) - in - Lsequence(Lprim(upd, [Lvar copy_id; transl_exp expr], loc), cont) - in - begin match opt_init_expr with - None -> assert false - | Some init_expr -> - Llet(Strict, Pgenval, copy_id, - Lprim(Pduprecord (repres, size), [transl_exp init_expr], loc), - Array.fold_left update_field (Lvar copy_id) fields) - end - end - -and transl_match e arg pat_expr_list partial = - let rewrite_case (val_cases, exn_cases, static_handlers as acc) - ({ c_lhs; c_guard; c_rhs } as case) = - if c_rhs.exp_desc = Texp_unreachable then acc else - let val_pat, exn_pat = split_pattern c_lhs in - match val_pat, exn_pat with - | None, None -> assert false - | Some pv, None -> - let val_case = - transl_case { case with c_lhs = pv } - in - val_case :: val_cases, exn_cases, static_handlers - | None, Some pe -> - let exn_case = transl_case_try { case with c_lhs = pe } in - val_cases, exn_case :: exn_cases, static_handlers - | Some pv, Some pe -> - assert (c_guard = None); - let lbl = next_raise_count () in - let static_raise ids = - Lstaticraise (lbl, List.map (fun id -> Lvar id) ids) - in - (* Simplif doesn't like it if binders are not uniq, so we make sure to - use different names in the value and the exception branches. *) - let ids_full = Typedtree.pat_bound_idents_full pv in - let ids = List.map (fun (id, _, _) -> id) ids_full in - let ids_kinds = - List.map (fun (id, _, ty) -> id, Typeopt.value_kind pv.pat_env ty) - ids_full - in - let vids = List.map Ident.rename ids in - let pv = alpha_pat (List.combine ids vids) pv in - (* Also register the names of the exception so Re-raise happens. *) - iter_exn_names Translprim.add_exception_ident pe; - let rhs = - Misc.try_finally - (fun () -> event_before c_rhs (transl_exp c_rhs)) - ~always:(fun () -> - iter_exn_names Translprim.remove_exception_ident pe) - in - (pv, static_raise vids) :: val_cases, - (pe, static_raise ids) :: exn_cases, - (lbl, ids_kinds, rhs) :: static_handlers - in - let val_cases, exn_cases, static_handlers = - let x, y, z = List.fold_left rewrite_case ([], [], []) pat_expr_list in - List.rev x, List.rev y, List.rev z - in - let static_catch body val_ids handler = - let id = Typecore.name_pattern "exn" (List.map fst exn_cases) in - let static_exception_id = next_raise_count () in - Lstaticcatch - (Ltrywith (Lstaticraise (static_exception_id, body), id, - Matching.for_trywith (Lvar id) exn_cases), - (static_exception_id, val_ids), - handler) - in - let classic = - match arg, exn_cases with - | {exp_desc = Texp_tuple argl}, [] -> - assert (static_handlers = []); - Matching.for_multiple_match e.exp_loc (transl_list argl) val_cases partial - | {exp_desc = Texp_tuple argl}, _ :: _ -> - let val_ids = - List.map - (fun arg -> - Typecore.name_pattern "val" [], - Typeopt.value_kind arg.exp_env arg.exp_type - ) - argl - in - let lvars = List.map (fun (id, _) -> Lvar id) val_ids in - static_catch (transl_list argl) val_ids - (Matching.for_multiple_match e.exp_loc lvars val_cases partial) - | arg, [] -> - assert (static_handlers = []); - Matching.for_function e.exp_loc None (transl_exp arg) val_cases partial - | arg, _ :: _ -> - let val_id = Typecore.name_cases "val" pat_expr_list in - let k = Typeopt.value_kind arg.exp_env arg.exp_type in - static_catch [transl_exp arg] [val_id, k] - (Matching.for_function e.exp_loc None (Lvar val_id) val_cases partial) - in - List.fold_left (fun body (static_exception_id, val_ids, handler) -> - Lstaticcatch (body, (static_exception_id, val_ids), handler) - ) classic static_handlers - -and transl_letop loc env let_ ands param case partial = - let rec loop prev_lam = function - | [] -> prev_lam - | and_ :: rest -> - let left_id = Ident.create_local "left" in - let right_id = Ident.create_local "right" in - let op = - transl_ident and_.bop_op_name.loc env - and_.bop_op_type and_.bop_op_path and_.bop_op_val - in - let exp = transl_exp and_.bop_exp in - let lam = - bind Strict right_id exp - (Lapply{ap_should_be_tailcall = false; - ap_loc = and_.bop_loc; - ap_func = op; - ap_args=[Lvar left_id; Lvar right_id]; - ap_inlined=Default_inline; - ap_specialised=Default_specialise}) - in - bind Strict left_id prev_lam (loop lam rest) - in - let op = - transl_ident let_.bop_op_name.loc env - let_.bop_op_type let_.bop_op_path let_.bop_op_val - in - let exp = loop (transl_exp let_.bop_exp) ands in - let func = - let return_kind = value_kind case.c_rhs.exp_env case.c_rhs.exp_type in - let (kind, params, return), body = - event_function case.c_rhs - (function repr -> - transl_function case.c_rhs.exp_loc return_kind - !Clflags.native_code repr partial param [case]) - in - let attr = default_function_attribute in - let loc = case.c_rhs.exp_loc in - Lfunction{kind; params; return; body; attr; loc} - in - Lapply{ap_should_be_tailcall = false; - ap_loc = loc; - ap_func = op; - ap_args=[exp; func]; - ap_inlined=Default_inline; - ap_specialised=Default_specialise} - -(* Wrapper for class compilation *) - -(* -let transl_exp = transl_exp_wrap - -let transl_let rec_flag pat_expr_list body = - match pat_expr_list with - [] -> body - | (_, expr) :: _ -> - Translobj.oo_wrap expr.exp_env false - (transl_let rec_flag pat_expr_list) body -*) - -(* Error report *) - -open Format - -let report_error ppf = function - | Free_super_var -> - fprintf ppf - "Ancestor names can only be used to select inherited methods" - | Unreachable_reached -> - fprintf ppf "Unreachable expression was reached" - -let () = - Location.register_error_of_exn - (function - | Error (loc, err) -> - Some (Location.error_of_printer ~loc report_error err) - | _ -> - None - ) diff --git a/bytecomp/translcore.mli b/bytecomp/translcore.mli deleted file mode 100644 index 7a27dbcb39..0000000000 --- a/bytecomp/translcore.mli +++ /dev/null @@ -1,50 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Translation from typed abstract syntax to lambda terms, - for the core language *) - -open Asttypes -open Typedtree -open Lambda - -val pure_module : module_expr -> let_kind - -val transl_exp: expression -> lambda -val transl_apply: ?should_be_tailcall:bool - -> ?inlined:inline_attribute - -> ?specialised:specialise_attribute - -> lambda -> (arg_label * expression option) list - -> Location.t -> lambda -val transl_let: rec_flag -> value_binding list -> lambda -> lambda - -val transl_extension_constructor: Env.t -> Path.t option -> - extension_constructor -> lambda - -type error = - Free_super_var - | Unreachable_reached - -exception Error of Location.t * error - -open Format - -val report_error: formatter -> error -> unit - -(* Forward declaration -- to be filled in by Translmod.transl_module *) -val transl_module : - (module_coercion -> Path.t option -> module_expr -> lambda) ref -val transl_object : - (Ident.t -> string list -> class_expr -> lambda) ref diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml deleted file mode 100644 index bf111693be..0000000000 --- a/bytecomp/translmod.ml +++ /dev/null @@ -1,1556 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Translation from typed abstract syntax to lambda terms, - for the module language *) - -open Misc -open Asttypes -open Path -open Types -open Typedtree -open Lambda -open Translobj -open Translcore -open Translclass - -type unsafe_component = - | Unsafe_module_binding - | Unsafe_functor - | Unsafe_non_function - | Unsafe_typext - -type unsafe_info = { reason:unsafe_component; loc:Location.t; subid:Ident.t } -type error = - Circular_dependency of (Ident.t * unsafe_info) list -| Conflicting_inline_attributes - -exception Error of Location.t * error - -(* Keep track of the root path (from the root of the namespace to the - currently compiled module expression). Useful for naming extensions. *) - -let global_path glob = Some(Pident glob) -let functor_path path param = - match path with - None -> None - | Some p -> Some(Papply(p, Pident param)) -let field_path path field = - match path with - None -> None - | Some p -> Some(Pdot(p, Ident.name field)) - -(* Compile type extensions *) - -let transl_type_extension env rootpath tyext body = - List.fold_right - (fun ext body -> - let lam = - transl_extension_constructor env (field_path rootpath ext.ext_id) ext - in - Llet(Strict, Pgenval, ext.ext_id, lam, body)) - tyext.tyext_constructors - body - -(* Compile a coercion *) - -let rec apply_coercion loc strict restr arg = - match restr with - Tcoerce_none -> - arg - | Tcoerce_structure(pos_cc_list, id_pos_list) -> - name_lambda strict arg (fun id -> - let get_field pos = Lprim(Pfield pos,[Lvar id], loc) in - let lam = - Lprim(Pmakeblock(0, Immutable, None), - List.map (apply_coercion_field loc get_field) pos_cc_list, - loc) - in - wrap_id_pos_list loc id_pos_list get_field lam) - | Tcoerce_functor(cc_arg, cc_res) -> - let param = Ident.create_local "funarg" in - let carg = apply_coercion loc Alias cc_arg (Lvar param) in - apply_coercion_result loc strict arg [param, Pgenval] [carg] cc_res - | Tcoerce_primitive { pc_loc; pc_desc; pc_env; pc_type; } -> - Translprim.transl_primitive pc_loc pc_desc pc_env pc_type None - | Tcoerce_alias (env, path, cc) -> - let lam = transl_module_path loc env path in - name_lambda strict arg - (fun _ -> apply_coercion loc Alias cc lam) - -and apply_coercion_field loc get_field (pos, cc) = - apply_coercion loc Alias cc (get_field pos) - -and apply_coercion_result loc strict funct params args cc_res = - match cc_res with - | Tcoerce_functor(cc_arg, cc_res) -> - let param = Ident.create_local "funarg" in - let arg = apply_coercion loc Alias cc_arg (Lvar param) in - apply_coercion_result loc strict funct - ((param, Pgenval) :: params) (arg :: args) cc_res - | _ -> - name_lambda strict funct - (fun id -> - Lfunction - { - kind = Curried; - params = List.rev params; - return = Pgenval; - attr = { default_function_attribute with - is_a_functor = true; - stub = true; }; - loc = loc; - body = apply_coercion - loc Strict cc_res - (Lapply{ap_should_be_tailcall=false; - ap_loc=loc; - ap_func=Lvar id; - ap_args=List.rev args; - ap_inlined=Default_inline; - ap_specialised=Default_specialise})}) - -and wrap_id_pos_list loc id_pos_list get_field lam = - let fv = free_variables lam in - (*Format.eprintf "%a@." Printlambda.lambda lam; - Ident.Set.iter (fun id -> Format.eprintf "%a " Ident.print id) fv; - Format.eprintf "@.";*) - let (lam,s) = - List.fold_left (fun (lam, s) (id',pos,c) -> - if Ident.Set.mem id' fv then - let id'' = Ident.create_local (Ident.name id') in - (Llet(Alias, Pgenval, id'', - apply_coercion loc Alias c (get_field pos),lam), - Ident.Map.add id' id'' s) - else (lam, s)) - (lam, Ident.Map.empty) id_pos_list - in - if s == Ident.Map.empty then lam else Lambda.rename s lam - - -(* Compose two coercions - apply_coercion c1 (apply_coercion c2 e) behaves like - apply_coercion (compose_coercions c1 c2) e. *) - -let rec compose_coercions c1 c2 = - match (c1, c2) with - (Tcoerce_none, c2) -> c2 - | (c1, Tcoerce_none) -> c1 - | (Tcoerce_structure (pc1, ids1), Tcoerce_structure (pc2, ids2)) -> - let v2 = Array.of_list pc2 in - let ids1 = - List.map (fun (id,pos1,c1) -> - let (pos2,c2) = v2.(pos1) in (id, pos2, compose_coercions c1 c2)) - ids1 - in - Tcoerce_structure - (List.map - (fun pc -> - match pc with - | _, (Tcoerce_primitive _ | Tcoerce_alias _) -> - (* These cases do not take an argument (the position is -1), - so they do not need adjusting. *) - pc - | (p1, c1) -> - let (p2, c2) = v2.(p1) in - (p2, compose_coercions c1 c2)) - pc1, - ids1 @ ids2) - | (Tcoerce_functor(arg1, res1), Tcoerce_functor(arg2, res2)) -> - Tcoerce_functor(compose_coercions arg2 arg1, - compose_coercions res1 res2) - | (c1, Tcoerce_alias (env, path, c2)) -> - Tcoerce_alias (env, path, compose_coercions c1 c2) - | (_, _) -> - fatal_error "Translmod.compose_coercions" - -(* -let apply_coercion a b c = - Format.eprintf "@[<2>apply_coercion@ %a@]@." Includemod.print_coercion b; - apply_coercion a b c - -let compose_coercions c1 c2 = - let c3 = compose_coercions c1 c2 in - let open Includemod in - Format.eprintf "@[<2>compose_coercions@ (%a)@ (%a) =@ %a@]@." - print_coercion c1 print_coercion c2 print_coercion c3; - c3 -*) - -(* Record the primitive declarations occurring in the module compiled *) - -let primitive_declarations = ref ([] : Primitive.description list) -let record_primitive = function - | {val_kind=Val_prim p;val_loc} -> - Translprim.check_primitive_arity val_loc p; - primitive_declarations := p :: !primitive_declarations - | _ -> () - -(* Utilities for compiling "module rec" definitions *) - -let mod_prim = Lambda.transl_prim "CamlinternalMod" - -let undefined_location loc = - let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in - Lconst(Const_block(0, - [Const_base(Const_string (fname, None)); - Const_base(Const_int line); - Const_base(Const_int char)])) - -exception Initialization_failure of unsafe_info - -let init_shape id modl = - let rec init_shape_mod subid loc env mty = - match Mtype.scrape env mty with - Mty_ident _ - | Mty_alias _ -> - raise (Initialization_failure {reason=Unsafe_module_binding;loc;subid}) - | Mty_signature sg -> - Const_block(0, [Const_block(0, init_shape_struct env sg)]) - | Mty_functor _ -> - (* can we do better? *) - raise (Initialization_failure {reason=Unsafe_functor;loc;subid}) - and init_shape_struct env sg = - match sg with - [] -> [] - | Sig_value(subid, {val_kind=Val_reg; val_type=ty; val_loc=loc},_) :: rem -> - let init_v = - match Ctype.expand_head env ty with - {desc = Tarrow(_,_,_,_)} -> - Const_pointer 0 (* camlinternalMod.Function *) - | {desc = Tconstr(p, _, _)} when Path.same p Predef.path_lazy_t -> - Const_pointer 1 (* camlinternalMod.Lazy *) - | _ -> - let not_a_function = {reason=Unsafe_non_function; loc; subid } in - raise (Initialization_failure not_a_function) in - init_v :: init_shape_struct env rem - | Sig_value(_, {val_kind=Val_prim _}, _) :: rem -> - init_shape_struct env rem - | Sig_value _ :: _rem -> - assert false - | Sig_type(id, tdecl, _, _) :: rem -> - init_shape_struct (Env.add_type ~check:false id tdecl env) rem - | Sig_typext (subid, {ext_loc=loc},_,_) :: _ -> - raise (Initialization_failure {reason=Unsafe_typext; loc; subid}) - | Sig_module(id, Mp_present, md, _, _) :: rem -> - init_shape_mod id md.md_loc env md.md_type :: - init_shape_struct (Env.add_module_declaration ~check:false - id Mp_present md env) rem - | Sig_module(id, Mp_absent, md, _, _) :: rem -> - init_shape_struct - (Env.add_module_declaration ~check:false - id Mp_absent md env) rem - | Sig_modtype(id, minfo, _) :: rem -> - init_shape_struct (Env.add_modtype id minfo env) rem - | Sig_class _ :: rem -> - Const_pointer 2 (* camlinternalMod.Class *) - :: init_shape_struct env rem - | Sig_class_type _ :: rem -> - init_shape_struct env rem - in - try - Ok(undefined_location modl.mod_loc, - Lconst(init_shape_mod id modl.mod_loc modl.mod_env modl.mod_type)) - with Initialization_failure reason -> Result.Error(reason) - -(* Reorder bindings to honor dependencies. *) - -type binding_status = - | Undefined - | Inprogress of int option (** parent node *) - | Defined - -let extract_unsafe_cycle id status init cycle_start = - let info i = match init.(i) with - | Result.Error r -> id.(i), r - | Ok _ -> assert false in - let rec collect stop l i = match status.(i) with - | Inprogress None | Undefined | Defined -> assert false - | Inprogress Some i when i = stop -> info i :: l - | Inprogress Some i -> collect stop (info i::l) i in - collect cycle_start [] cycle_start - -let reorder_rec_bindings bindings = - let id = Array.of_list (List.map (fun (id,_,_,_) -> id) bindings) - and loc = Array.of_list (List.map (fun (_,loc,_,_) -> loc) bindings) - and init = Array.of_list (List.map (fun (_,_,init,_) -> init) bindings) - and rhs = Array.of_list (List.map (fun (_,_,_,rhs) -> rhs) bindings) in - let fv = Array.map Lambda.free_variables rhs in - let num_bindings = Array.length id in - let status = Array.make num_bindings Undefined in - let res = ref [] in - let is_unsafe i = match init.(i) with - | Ok _ -> false - | Result.Error _ -> true in - let init_res i = match init.(i) with - | Result.Error _ -> None - | Ok(a,b) -> Some(a,b) in - let rec emit_binding parent i = - match status.(i) with - Defined -> () - | Inprogress _ -> - status.(i) <- Inprogress parent; - let cycle = extract_unsafe_cycle id status init i in - raise(Error(loc.(i), Circular_dependency cycle)) - | Undefined -> - if is_unsafe i then begin - status.(i) <- Inprogress parent; - for j = 0 to num_bindings - 1 do - if Ident.Set.mem id.(j) fv.(i) then emit_binding (Some i) j - done - end; - res := (id.(i), init_res i, rhs.(i)) :: !res; - status.(i) <- Defined in - for i = 0 to num_bindings - 1 do - match status.(i) with - Undefined -> emit_binding None i - | Inprogress _ -> assert false - | Defined -> () - done; - List.rev !res - -(* Generate lambda-code for a reordered list of bindings *) - -let eval_rec_bindings bindings cont = - let rec bind_inits = function - [] -> - bind_strict bindings - | (_id, None, _rhs) :: rem -> - bind_inits rem - | (id, Some(loc, shape), _rhs) :: rem -> - Llet(Strict, Pgenval, id, - Lapply{ap_should_be_tailcall=false; - ap_loc=Location.none; - ap_func=mod_prim "init_mod"; - ap_args=[loc; shape]; - ap_inlined=Default_inline; - ap_specialised=Default_specialise}, - bind_inits rem) - and bind_strict = function - [] -> - patch_forwards bindings - | (id, None, rhs) :: rem -> - Llet(Strict, Pgenval, id, rhs, bind_strict rem) - | (_id, Some _, _rhs) :: rem -> - bind_strict rem - and patch_forwards = function - [] -> - cont - | (_id, None, _rhs) :: rem -> - patch_forwards rem - | (id, Some(_loc, shape), rhs) :: rem -> - Lsequence(Lapply{ap_should_be_tailcall=false; - ap_loc=Location.none; - ap_func=mod_prim "update_mod"; - ap_args=[shape; Lvar id; rhs]; - ap_inlined=Default_inline; - ap_specialised=Default_specialise}, - patch_forwards rem) - in - bind_inits bindings - -let compile_recmodule compile_rhs bindings cont = - eval_rec_bindings - (reorder_rec_bindings - (List.map - (fun {mb_id=id; mb_expr=modl; mb_loc=loc; _} -> - (id, modl.mod_loc, init_shape id modl, compile_rhs id modl loc)) - bindings)) - cont - -(* Code to translate class entries in a structure *) - -let transl_class_bindings cl_list = - let ids = List.map (fun (ci, _) -> ci.ci_id_class) cl_list in - (ids, - List.map - (fun ({ci_id_class=id; ci_expr=cl; ci_virt=vf}, meths) -> - (id, transl_class ids id meths cl vf)) - cl_list) - -(* Compile one or more functors, merging curried functors to produce - multi-argument functors. Any [@inline] attribute on a functor that is - merged must be consistent with any other [@inline] attribute(s) on the - functor(s) being merged with. Such an attribute will be placed on the - resulting merged functor. *) - -let merge_inline_attributes attr1 attr2 loc = - match Lambda.merge_inline_attributes attr1 attr2 with - | Some attr -> attr - | None -> raise (Error (loc, Conflicting_inline_attributes)) - -let merge_functors mexp coercion root_path = - let rec merge mexp coercion path acc inline_attribute = - let finished = acc, mexp, path, coercion, inline_attribute in - match mexp.mod_desc with - | Tmod_functor (param, _, _, body) -> - let inline_attribute' = - Translattribute.get_inline_attribute mexp.mod_attributes - in - let arg_coercion, res_coercion = - match coercion with - | Tcoerce_none -> Tcoerce_none, Tcoerce_none - | Tcoerce_functor (arg_coercion, res_coercion) -> - arg_coercion, res_coercion - | _ -> fatal_error "Translmod.merge_functors: bad coercion" - in - let loc = mexp.mod_loc in - let path = functor_path path param in - let inline_attribute = - merge_inline_attributes inline_attribute inline_attribute' loc - in - merge body res_coercion path ((param, loc, arg_coercion) :: acc) - inline_attribute - | _ -> finished - in - merge mexp coercion root_path [] Default_inline - -let rec compile_functor mexp coercion root_path loc = - let functor_params_rev, body, body_path, res_coercion, inline_attribute = - merge_functors mexp coercion root_path - in - assert (List.length functor_params_rev >= 1); (* cf. [transl_module] *) - let params, body = - List.fold_left (fun (params, body) (param, loc, arg_coercion) -> - let param' = Ident.rename param in - let arg = apply_coercion loc Alias arg_coercion (Lvar param') in - let params = (param', Pgenval) :: params in - let body = Llet (Alias, Pgenval, param, arg, body) in - params, body) - ([], transl_module res_coercion body_path body) - functor_params_rev - in - Lfunction { - kind = Curried; - params; - return = Pgenval; - attr = { - inline = inline_attribute; - specialise = Default_specialise; - local = Default_local; - is_a_functor = true; - stub = false; - }; - loc; - body; - } - -(* Compile a module expression *) - -and transl_module cc rootpath mexp = - List.iter (Translattribute.check_attribute_on_module mexp) - mexp.mod_attributes; - let loc = mexp.mod_loc in - match mexp.mod_desc with - | Tmod_ident (path,_) -> - apply_coercion loc Strict cc - (transl_module_path loc mexp.mod_env path) - | Tmod_structure str -> - fst (transl_struct loc [] cc rootpath str) - | Tmod_functor _ -> - oo_wrap mexp.mod_env true (fun () -> - compile_functor mexp cc rootpath loc) () - | Tmod_apply(funct, arg, ccarg) -> - let inlined_attribute, funct = - Translattribute.get_and_remove_inlined_attribute_on_module funct - in - oo_wrap mexp.mod_env true - (apply_coercion loc Strict cc) - (Lapply{ap_should_be_tailcall=false; - ap_loc=loc; - ap_func=transl_module Tcoerce_none None funct; - ap_args=[transl_module ccarg None arg]; - ap_inlined=inlined_attribute; - ap_specialised=Default_specialise}) - | Tmod_constraint(arg, _, _, ccarg) -> - transl_module (compose_coercions cc ccarg) rootpath arg - | Tmod_unpack(arg, _) -> - apply_coercion loc Strict cc (Translcore.transl_exp arg) - -and transl_struct loc fields cc rootpath str = - transl_structure loc fields cc rootpath str.str_final_env str.str_items - -(* The function transl_structure is called by the bytecode compiler. - Some effort is made to compile in top to bottom order, in order to display - warning by increasing locations. *) -and transl_structure loc fields cc rootpath final_env = function - [] -> - let body, size = - match cc with - Tcoerce_none -> - Lprim(Pmakeblock(0, Immutable, None), - List.map (fun id -> Lvar id) (List.rev fields), loc), - List.length fields - | Tcoerce_structure(pos_cc_list, id_pos_list) -> - (* Do not ignore id_pos_list ! *) - (*Format.eprintf "%a@.@[" Includemod.print_coercion cc; - List.iter (fun l -> Format.eprintf "%a@ " Ident.print l) - fields; - Format.eprintf "@]@.";*) - let v = Array.of_list (List.rev fields) in - let get_field pos = - if pos < 0 then lambda_unit - else Lvar v.(pos) - in - let ids = List.fold_right Ident.Set.add fields Ident.Set.empty in - let lam = - Lprim(Pmakeblock(0, Immutable, None), - List.map - (fun (pos, cc) -> - match cc with - Tcoerce_primitive p -> - Translprim.transl_primitive p.pc_loc - p.pc_desc p.pc_env p.pc_type None - | _ -> apply_coercion loc Strict cc (get_field pos)) - pos_cc_list, loc) - and id_pos_list = - List.filter (fun (id,_,_) -> not (Ident.Set.mem id ids)) - id_pos_list - in - wrap_id_pos_list loc id_pos_list get_field lam, - List.length pos_cc_list - | _ -> - fatal_error "Translmod.transl_structure" - in - (* This debugging event provides information regarding the structure - items. It is ignored by the OCaml debugger but is used by - Js_of_ocaml to preserve variable names. *) - (if !Clflags.debug && not !Clflags.native_code then - Levent(body, - {lev_loc = loc; - lev_kind = Lev_pseudo; - lev_repr = None; - lev_env = final_env}) - else - body), - size - | item :: rem -> - match item.str_desc with - | Tstr_eval (expr, _) -> - let body, size = - transl_structure loc fields cc rootpath final_env rem - in - Lsequence(transl_exp expr, body), size - | Tstr_value(rec_flag, pat_expr_list) -> - (* Translate bindings first *) - let mk_lam_let = transl_let rec_flag pat_expr_list in - let ext_fields = rev_let_bound_idents pat_expr_list @ fields in - (* Then, translate remainder of struct *) - let body, size = - transl_structure loc ext_fields cc rootpath final_env rem - in - mk_lam_let body, size - | Tstr_primitive descr -> - record_primitive descr.val_val; - transl_structure loc fields cc rootpath final_env rem - | Tstr_type _ -> - transl_structure loc fields cc rootpath final_env rem - | Tstr_typext(tyext) -> - let ids = List.map (fun ext -> ext.ext_id) tyext.tyext_constructors in - let body, size = - transl_structure loc (List.rev_append ids fields) - cc rootpath final_env rem - in - transl_type_extension item.str_env rootpath tyext body, size - | Tstr_exception ext -> - let id = ext.tyexn_constructor.ext_id in - let path = field_path rootpath id in - let body, size = - transl_structure loc (id :: fields) cc rootpath final_env rem - in - Llet(Strict, Pgenval, id, - transl_extension_constructor item.str_env - path - ext.tyexn_constructor, body), - size - | Tstr_module ({mb_presence=Mp_present} as mb) -> - let id = mb.mb_id in - (* Translate module first *) - let module_body = - transl_module Tcoerce_none (field_path rootpath id) mb.mb_expr - in - let module_body = - Translattribute.add_inline_attribute module_body mb.mb_loc - mb.mb_attributes - in - (* Translate remainder second *) - let body, size = - transl_structure loc (id :: fields) cc rootpath final_env rem - in - let module_body = - Levent (module_body, { - lev_loc = mb.mb_loc; - lev_kind = Lev_module_definition id; - lev_repr = None; - lev_env = Env.empty; - }) - in - Llet(pure_module mb.mb_expr, Pgenval, id, - module_body, - body), size - | Tstr_module {mb_presence=Mp_absent} -> - transl_structure loc fields cc rootpath final_env rem - | Tstr_recmodule bindings -> - let ext_fields = - List.rev_append (List.map (fun mb -> mb.mb_id) bindings) fields - in - let body, size = - transl_structure loc ext_fields cc rootpath final_env rem - in - let lam = - compile_recmodule - (fun id modl loc -> - let module_body = - transl_module Tcoerce_none (field_path rootpath id) modl - in - Levent (module_body, { - lev_loc = loc; - lev_kind = Lev_module_definition id; - lev_repr = None; - lev_env = Env.empty; - })) - bindings - body - in - lam, size - | Tstr_class cl_list -> - let (ids, class_bindings) = transl_class_bindings cl_list in - let body, size = - transl_structure loc (List.rev_append ids fields) - cc rootpath final_env rem - in - Lletrec(class_bindings, body), size - | Tstr_include incl -> - let ids = bound_value_identifiers incl.incl_type in - let modl = incl.incl_mod in - let mid = Ident.create_local "include" in - let rec rebind_idents pos newfields = function - [] -> - transl_structure loc newfields cc rootpath final_env rem - | id :: ids -> - let body, size = - rebind_idents (pos + 1) (id :: newfields) ids - in - Llet(Alias, Pgenval, id, - Lprim(Pfield pos, [Lvar mid], incl.incl_loc), body), - size - in - let body, size = rebind_idents 0 fields ids in - Llet(pure_module modl, Pgenval, mid, - transl_module Tcoerce_none None modl, body), - size - - | Tstr_open od -> - let pure = pure_module od.open_expr in - (* this optimization shouldn't be needed because Simplif would - actually remove the [Llet] when it's not used. - But since [scan_used_globals] runs before Simplif, we need to do - it. *) - begin match od.open_bound_items with - | [] when pure = Alias -> - transl_structure loc fields cc rootpath final_env rem - | _ -> - let ids = bound_value_identifiers od.open_bound_items in - let mid = Ident.create_local "open" in - let rec rebind_idents pos newfields = function - [] -> - transl_structure loc newfields cc rootpath final_env rem - | id :: ids -> - let body, size = - rebind_idents (pos + 1) (id :: newfields) ids - in - Llet(Alias, Pgenval, id, - Lprim(Pfield pos, [Lvar mid], od.open_loc), body), - size - in - let body, size = rebind_idents 0 fields ids in - Llet(pure, Pgenval, mid, - transl_module Tcoerce_none None od.open_expr, body), size - end - | Tstr_modtype _ - | Tstr_class_type _ - | Tstr_attribute _ -> - transl_structure loc fields cc rootpath final_env rem - -(* Update forward declaration in Translcore *) -let _ = - Translcore.transl_module := transl_module - -(* Introduce dependencies on modules referenced only by "external". *) - -let scan_used_globals lam = - let globals = ref Ident.Set.empty in - let rec scan lam = - Lambda.iter_head_constructor scan lam; - match lam with - Lprim ((Pgetglobal id | Psetglobal id), _, _) -> - globals := Ident.Set.add id !globals - | _ -> () - in - scan lam; !globals - -let required_globals ~flambda body = - let globals = scan_used_globals body in - let add_global id req = - if not flambda && Ident.Set.mem id globals then - req - else - Ident.Set.add id req - in - let required = - List.fold_left - (fun acc path -> add_global (Path.head path) acc) - (if flambda then globals else Ident.Set.empty) - (Translprim.get_used_primitives ()) - in - let required = - List.fold_right add_global (Env.get_required_globals ()) required - in - Env.reset_required_globals (); - Translprim.clear_used_primitives (); - required - -(* Compile an implementation *) - -let transl_implementation_flambda module_name (str, cc) = - reset_labels (); - primitive_declarations := []; - Translprim.clear_used_primitives (); - let module_id = Ident.create_persistent module_name in - let body, size = - Translobj.transl_label_init - (fun () -> transl_struct Location.none [] cc - (global_path module_id) str) - in - { module_ident = module_id; - main_module_block_size = size; - required_globals = required_globals ~flambda:true body; - code = body } - -let transl_implementation module_name (str, cc) = - let implementation = - transl_implementation_flambda module_name (str, cc) - in - let code = - Lprim (Psetglobal implementation.module_ident, [implementation.code], - Location.none) - in - { implementation with code } - -(* Build the list of value identifiers defined by a toplevel structure - (excluding primitive declarations). *) - -let rec defined_idents = function - [] -> [] - | item :: rem -> - match item.str_desc with - | Tstr_eval _ -> defined_idents rem - | Tstr_value(_rec_flag, pat_expr_list) -> - let_bound_idents pat_expr_list @ defined_idents rem - | Tstr_primitive _ -> defined_idents rem - | Tstr_type _ -> defined_idents rem - | Tstr_typext tyext -> - List.map (fun ext -> ext.ext_id) tyext.tyext_constructors - @ defined_idents rem - | Tstr_exception ext -> ext.tyexn_constructor.ext_id :: defined_idents rem - | Tstr_module {mb_id; mb_presence=Mp_present} -> mb_id :: defined_idents rem - | Tstr_module {mb_presence=Mp_absent} -> defined_idents rem - | Tstr_recmodule decls -> - List.map (fun mb -> mb.mb_id) decls @ defined_idents rem - | Tstr_modtype _ -> defined_idents rem - | Tstr_open od -> - bound_value_identifiers od.open_bound_items @ defined_idents rem - | Tstr_class cl_list -> - List.map (fun (ci, _) -> ci.ci_id_class) cl_list @ defined_idents rem - | Tstr_class_type _ -> defined_idents rem - | Tstr_include incl -> - bound_value_identifiers incl.incl_type @ defined_idents rem - | Tstr_attribute _ -> defined_idents rem - -(* second level idents (module M = struct ... let id = ... end), - and all sub-levels idents *) -let rec more_idents = function - [] -> [] - | item :: rem -> - match item.str_desc with - | Tstr_eval _ -> more_idents rem - | Tstr_value _ -> more_idents rem - | Tstr_primitive _ -> more_idents rem - | Tstr_type _ -> more_idents rem - | Tstr_typext _ -> more_idents rem - | Tstr_exception _ -> more_idents rem - | Tstr_recmodule _ -> more_idents rem - | Tstr_modtype _ -> more_idents rem - | Tstr_open od -> - let rest = more_idents rem in - begin match od.open_expr.mod_desc with - | Tmod_structure str -> all_idents str.str_items @ rest - | _ -> rest - end - | Tstr_class _ -> more_idents rem - | Tstr_class_type _ -> more_idents rem - | Tstr_include{incl_mod={mod_desc = - Tmod_constraint ({mod_desc = Tmod_structure str}, - _, _, _)}} -> - all_idents str.str_items @ more_idents rem - | Tstr_include _ -> more_idents rem - | Tstr_module - {mb_presence=Mp_present; mb_expr={mod_desc = Tmod_structure str}} - | Tstr_module - {mb_presence=Mp_present; - mb_expr={mod_desc= - Tmod_constraint ({mod_desc = Tmod_structure str}, _, _, _)}} -> - all_idents str.str_items @ more_idents rem - | Tstr_module _ -> more_idents rem - | Tstr_attribute _ -> more_idents rem - -and all_idents = function - [] -> [] - | item :: rem -> - match item.str_desc with - | Tstr_eval _ -> all_idents rem - | Tstr_value(_rec_flag, pat_expr_list) -> - let_bound_idents pat_expr_list @ all_idents rem - | Tstr_primitive _ -> all_idents rem - | Tstr_type _ -> all_idents rem - | Tstr_typext tyext -> - List.map (fun ext -> ext.ext_id) tyext.tyext_constructors - @ all_idents rem - | Tstr_exception ext -> ext.tyexn_constructor.ext_id :: all_idents rem - | Tstr_recmodule decls -> - List.map (fun mb -> mb.mb_id) decls @ all_idents rem - | Tstr_modtype _ -> all_idents rem - | Tstr_open od -> - let rest = all_idents rem in - begin match od.open_expr.mod_desc with - | Tmod_structure str -> - bound_value_identifiers od.open_bound_items - @ all_idents str.str_items - @ rest - | _ -> bound_value_identifiers od.open_bound_items @ rest - end - | Tstr_class cl_list -> - List.map (fun (ci, _) -> ci.ci_id_class) cl_list @ all_idents rem - | Tstr_class_type _ -> all_idents rem - - | Tstr_include{incl_type; incl_mod={mod_desc = - Tmod_constraint ({mod_desc = Tmod_structure str}, - _, _, _)}} -> - bound_value_identifiers incl_type - @ all_idents str.str_items - @ all_idents rem - | Tstr_include incl -> - bound_value_identifiers incl.incl_type @ all_idents rem - - | Tstr_module - {mb_id;mb_presence=Mp_present;mb_expr={mod_desc = Tmod_structure str}} - | Tstr_module - {mb_id;mb_presence=Mp_present; - mb_expr= - {mod_desc = - Tmod_constraint ({mod_desc = Tmod_structure str}, _, _, _)}} -> - mb_id :: all_idents str.str_items @ all_idents rem - | Tstr_module {mb_id;mb_presence=Mp_present} -> mb_id :: all_idents rem - | Tstr_module {mb_presence=Mp_absent} -> all_idents rem - | Tstr_attribute _ -> all_idents rem - - -(* A variant of transl_structure used to compile toplevel structure definitions - for the native-code compiler. Store the defined values in the fields - of the global as soon as they are defined, in order to reduce register - pressure. Also rewrites the defining expressions so that they - refer to earlier fields of the structure through the fields of - the global, not by their names. - "map" is a table from defined idents to (pos in global block, coercion). - "prim" is a list of (pos in global block, primitive declaration). *) - -let transl_store_subst = ref Ident.Map.empty - (** In the native toplevel, this reference is threaded through successive - calls of transl_store_structure *) - -let nat_toplevel_name id = - try match Ident.Map.find id !transl_store_subst with - | Lprim(Pfield pos, [Lprim(Pgetglobal glob, [], _)], _) -> (glob,pos) - | _ -> raise Not_found - with Not_found -> - fatal_error("Translmod.nat_toplevel_name: " ^ Ident.unique_name id) - -let field_of_str loc str = - let ids = Array.of_list (defined_idents str.str_items) in - fun (pos, cc) -> - match cc with - | Tcoerce_primitive { pc_loc; pc_desc; pc_env; pc_type; } -> - Translprim.transl_primitive pc_loc pc_desc pc_env pc_type None - | Tcoerce_alias (env, path, cc) -> - let lam = transl_module_path loc env path in - apply_coercion loc Alias cc lam - | _ -> apply_coercion loc Strict cc (Lvar ids.(pos)) - - -let transl_store_structure glob map prims aliases str = - let no_env_update _ _ env = env in - let rec transl_store rootpath subst cont = function - [] -> - transl_store_subst := subst; - Lambda.subst no_env_update subst cont - | item :: rem -> - match item.str_desc with - | Tstr_eval (expr, _attrs) -> - Lsequence(Lambda.subst no_env_update subst (transl_exp expr), - transl_store rootpath subst cont rem) - | Tstr_value(rec_flag, pat_expr_list) -> - let ids = let_bound_idents pat_expr_list in - let lam = - transl_let rec_flag pat_expr_list - (store_idents Location.none ids) - in - Lsequence(Lambda.subst no_env_update subst lam, - transl_store rootpath - (add_idents false ids subst) cont rem) - | Tstr_primitive descr -> - record_primitive descr.val_val; - transl_store rootpath subst cont rem - | Tstr_type _ -> - transl_store rootpath subst cont rem - | Tstr_typext(tyext) -> - let ids = - List.map (fun ext -> ext.ext_id) tyext.tyext_constructors - in - let lam = - transl_type_extension item.str_env rootpath tyext - (store_idents Location.none ids) - in - Lsequence(Lambda.subst no_env_update subst lam, - transl_store rootpath - (add_idents false ids subst) cont rem) - | Tstr_exception ext -> - let id = ext.tyexn_constructor.ext_id in - let path = field_path rootpath id in - let lam = - transl_extension_constructor item.str_env - path - ext.tyexn_constructor - in - Lsequence(Llet(Strict, Pgenval, id, - Lambda.subst no_env_update subst lam, - store_ident ext.tyexn_constructor.ext_loc id), - transl_store rootpath - (add_ident false id subst) cont rem) - | Tstr_module{mb_id=id;mb_loc=loc;mb_presence=Mp_present; - mb_expr={mod_desc = Tmod_structure str} as mexp; - mb_attributes} -> - List.iter (Translattribute.check_attribute_on_module mexp) - mb_attributes; - let lam = - transl_store (field_path rootpath id) subst - lambda_unit str.str_items - in - (* Careful: see next case *) - let subst = !transl_store_subst in - Lsequence(lam, - Llet(Strict, Pgenval, id, - Lambda.subst no_env_update subst - (Lprim(Pmakeblock(0, Immutable, None), - List.map (fun id -> Lvar id) - (defined_idents str.str_items), loc)), - Lsequence(store_ident loc id, - transl_store rootpath - (add_ident true id subst) - cont rem))) - | Tstr_module{ - mb_id=id;mb_loc=loc;mb_presence=Mp_present; - mb_expr= { - mod_desc = Tmod_constraint ( - {mod_desc = Tmod_structure str} as mexp, _, _, - (Tcoerce_structure (map, _) as _cc))}; - mb_attributes - } -> - (* Format.printf "coerc id %s: %a@." (Ident.unique_name id) - Includemod.print_coercion cc; *) - List.iter (Translattribute.check_attribute_on_module mexp) - mb_attributes; - let lam = - transl_store (field_path rootpath id) subst - lambda_unit str.str_items - in - (* Careful: see next case *) - let subst = !transl_store_subst in - let field = field_of_str loc str in - Lsequence(lam, - Llet(Strict, Pgenval, id, - Lambda.subst no_env_update subst - (Lprim(Pmakeblock(0, Immutable, None), - List.map field map, loc)), - Lsequence(store_ident loc id, - transl_store rootpath - (add_ident true id subst) - cont rem))) - | Tstr_module - {mb_id=id; mb_presence=Mp_present; mb_expr=modl; - mb_loc=loc; mb_attributes} -> - let lam = - Translattribute.add_inline_attribute - (transl_module Tcoerce_none (field_path rootpath id) modl) - loc mb_attributes - in - (* Careful: the module value stored in the global may be different - from the local module value, in case a coercion is applied. - If so, keep using the local module value (id) in the remainder of - the compilation unit (add_ident true returns subst unchanged). - If not, we can use the value from the global - (add_ident true adds id -> Pgetglobal... to subst). *) - Llet(Strict, Pgenval, id, Lambda.subst no_env_update subst lam, - Lsequence(store_ident loc id, - transl_store rootpath (add_ident true id subst) - cont rem)) - | Tstr_module {mb_presence=Mp_absent} -> - transl_store rootpath subst cont rem - | Tstr_recmodule bindings -> - let ids = List.map (fun mb -> mb.mb_id) bindings in - compile_recmodule - (fun id modl _loc -> - Lambda.subst no_env_update subst - (transl_module Tcoerce_none - (field_path rootpath id) modl)) - bindings - (Lsequence(store_idents Location.none ids, - transl_store rootpath (add_idents true ids subst) - cont rem)) - | Tstr_class cl_list -> - let (ids, class_bindings) = transl_class_bindings cl_list in - let lam = - Lletrec(class_bindings, store_idents Location.none ids) - in - Lsequence(Lambda.subst no_env_update subst lam, - transl_store rootpath (add_idents false ids subst) - cont rem) - - | Tstr_include{ - incl_loc=loc; - incl_mod= { - mod_desc = Tmod_constraint ( - ({mod_desc = Tmod_structure str} as mexp), _, _, - (Tcoerce_structure (map, _)))}; - incl_attributes; - incl_type; - } -> - List.iter (Translattribute.check_attribute_on_module mexp) - incl_attributes; - (* Shouldn't we use mod_attributes instead of incl_attributes? - Same question for the Tstr_module cases above, btw. *) - let lam = - transl_store None subst lambda_unit str.str_items - (* It is tempting to pass rootpath instead of None - in order to give a more precise name to exceptions - in the included structured, but this would introduce - a difference of behavior compared to bytecode. *) - in - let subst = !transl_store_subst in - let field = field_of_str loc str in - let ids0 = bound_value_identifiers incl_type in - let rec loop ids args = - match ids, args with - | [], [] -> - transl_store rootpath (add_idents true ids0 subst) - cont rem - | id :: ids, arg :: args -> - Llet(Alias, Pgenval, id, - Lambda.subst no_env_update subst (field arg), - Lsequence(store_ident loc id, - loop ids args)) - | _ -> assert false - in - Lsequence(lam, loop ids0 map) - - - | Tstr_include incl -> - let ids = bound_value_identifiers incl.incl_type in - let modl = incl.incl_mod in - let mid = Ident.create_local "include" in - let loc = incl.incl_loc in - let rec store_idents pos = function - | [] -> - transl_store rootpath (add_idents true ids subst) cont rem - | id :: idl -> - Llet(Alias, Pgenval, id, Lprim(Pfield pos, [Lvar mid], loc), - Lsequence(store_ident loc id, - store_idents (pos + 1) idl)) - in - Llet(Strict, Pgenval, mid, - Lambda.subst no_env_update subst - (transl_module Tcoerce_none None modl), - store_idents 0 ids) - | Tstr_open od -> - begin match od.open_expr.mod_desc with - | Tmod_structure str -> - let lam = - transl_store rootpath subst lambda_unit str.str_items - in - let ids = Array.of_list (defined_idents str.str_items) in - let ids0 = bound_value_identifiers od.open_bound_items in - let subst = !transl_store_subst in - let rec store_idents pos = function - | [] -> transl_store rootpath subst cont rem - | id :: idl -> - Llet(Alias, Pgenval, id, Lvar ids.(pos), - Lsequence(store_ident od.open_loc id, - store_idents (pos + 1) idl)) - in - Lsequence(lam, Lambda.subst no_env_update subst - (store_idents 0 ids0)) - | _ -> - let pure = pure_module od.open_expr in - (* this optimization shouldn't be needed because Simplif would - actually remove the [Llet] when it's not used. - But since [scan_used_globals] runs before Simplif, we need to - do it. *) - match od.open_bound_items with - | [] when pure = Alias -> transl_store rootpath subst cont rem - | _ -> - let ids = bound_value_identifiers od.open_bound_items in - let mid = Ident.create_local "open" in - let loc = od.open_loc in - let rec store_idents pos = function - [] -> - transl_store rootpath (add_idents true ids subst) cont - rem - | id :: idl -> - Llet(Alias, Pgenval, id, Lprim(Pfield pos, [Lvar mid], - loc), - Lsequence(store_ident loc id, - store_idents (pos + 1) idl)) - in - Llet(pure, Pgenval, mid, - Lambda.subst no_env_update subst - (transl_module Tcoerce_none None od.open_expr), - store_idents 0 ids) - end - | Tstr_modtype _ - | Tstr_class_type _ - | Tstr_attribute _ -> - transl_store rootpath subst cont rem - - and store_ident loc id = - try - let (pos, cc) = Ident.find_same id map in - let init_val = apply_coercion loc Alias cc (Lvar id) in - Lprim(Psetfield(pos, Pointer, Root_initialization), - [Lprim(Pgetglobal glob, [], loc); init_val], - loc) - with Not_found -> - fatal_error("Translmod.store_ident: " ^ Ident.unique_name id) - - and store_idents loc idlist = - make_sequence (store_ident loc) idlist - - and add_ident may_coerce id subst = - try - let (pos, cc) = Ident.find_same id map in - match cc with - Tcoerce_none -> - Ident.Map.add id - (Lprim(Pfield pos, - [Lprim(Pgetglobal glob, [], Location.none)], - Location.none)) - subst - | _ -> - if may_coerce then subst else assert false - with Not_found -> - assert false - - and add_idents may_coerce idlist subst = - List.fold_right (add_ident may_coerce) idlist subst - - and store_primitive (pos, prim) cont = - Lsequence(Lprim(Psetfield(pos, Pointer, Root_initialization), - [Lprim(Pgetglobal glob, [], Location.none); - Translprim.transl_primitive Location.none - prim.pc_desc prim.pc_env prim.pc_type None], - Location.none), - cont) - - and store_alias (pos, env, path, cc) = - let path_lam = transl_module_path Location.none env path in - let init_val = apply_coercion Location.none Strict cc path_lam in - Lprim(Psetfield(pos, Pointer, Root_initialization), - [Lprim(Pgetglobal glob, [], Location.none); - init_val], - Location.none) - in - let aliases = make_sequence store_alias aliases in - List.fold_right store_primitive prims - (transl_store (global_path glob) !transl_store_subst aliases str) - -(* Transform a coercion and the list of value identifiers defined by - a toplevel structure into a table [id -> (pos, coercion)], - with [pos] being the position in the global block where the value of - [id] must be stored, and [coercion] the coercion to be applied to it. - A given identifier may appear several times - in the coercion (if it occurs several times in the signature); remember - to assign it the position of its last occurrence. - Identifiers that are not exported are assigned positions at the - end of the block (beyond the positions of all exported idents). - Also compute the total size of the global block, - and the list of all primitives exported as values. *) - -let build_ident_map restr idlist more_ids = - let rec natural_map pos map prims aliases = function - | [] -> - (map, prims, aliases, pos) - | id :: rem -> - natural_map (pos+1) - (Ident.add id (pos, Tcoerce_none) map) prims aliases rem - in - let (map, prims, aliases, pos) = - match restr with - | Tcoerce_none -> - natural_map 0 Ident.empty [] [] idlist - | Tcoerce_structure (pos_cc_list, _id_pos_list) -> - (* ignore _id_pos_list as the ids are already bound *) - let idarray = Array.of_list idlist in - let rec export_map pos map prims aliases undef = function - | [] -> - natural_map pos map prims aliases undef - | (_source_pos, Tcoerce_primitive p) :: rem -> - export_map (pos + 1) map - ((pos, p) :: prims) aliases undef rem - | (_source_pos, Tcoerce_alias(env, path, cc)) :: rem -> - export_map (pos + 1) map prims - ((pos, env, path, cc) :: aliases) undef rem - | (source_pos, cc) :: rem -> - let id = idarray.(source_pos) in - export_map (pos + 1) (Ident.add id (pos, cc) map) - prims aliases (list_remove id undef) rem - in - export_map 0 Ident.empty [] [] idlist pos_cc_list - | _ -> - fatal_error "Translmod.build_ident_map" - in - natural_map pos map prims aliases more_ids - -(* Compile an implementation using transl_store_structure - (for the native-code compiler). *) - -let transl_store_gen module_name ({ str_items = str }, restr) topl = - reset_labels (); - primitive_declarations := []; - Translprim.clear_used_primitives (); - let module_id = Ident.create_persistent module_name in - let (map, prims, aliases, size) = - build_ident_map restr (defined_idents str) (more_idents str) in - let f = function - | [ { str_desc = Tstr_eval (expr, _attrs) } ] when topl -> - assert (size = 0); - Lambda.subst (fun _ _ env -> env) !transl_store_subst (transl_exp expr) - | str -> transl_store_structure module_id map prims aliases str - in - transl_store_label_init module_id size f str - (*size, transl_label_init (transl_store_structure module_id map prims str)*) - -let transl_store_phrases module_name str = - transl_store_gen module_name (str,Tcoerce_none) true - -let transl_store_implementation module_name (str, restr) = - let s = !transl_store_subst in - transl_store_subst := Ident.Map.empty; - let (i, code) = transl_store_gen module_name (str, restr) false in - transl_store_subst := s; - { Lambda.main_module_block_size = i; - code; - (* module_ident is not used by closure, but this allow to share - the type with the flambda version *) - module_ident = Ident.create_persistent module_name; - required_globals = required_globals ~flambda:true code } - -(* Compile a toplevel phrase *) - -let toploop_ident = Ident.create_persistent "Toploop" -let toploop_getvalue_pos = 0 (* position of getvalue in module Toploop *) -let toploop_setvalue_pos = 1 (* position of setvalue in module Toploop *) - -let aliased_idents = ref Ident.empty - -let set_toplevel_unique_name id = - aliased_idents := - Ident.add id (Ident.unique_toplevel_name id) !aliased_idents - -let toplevel_name id = - try Ident.find_same id !aliased_idents - with Not_found -> Ident.name id - -let toploop_getvalue id = - Lapply{ap_should_be_tailcall=false; - ap_loc=Location.none; - ap_func=Lprim(Pfield toploop_getvalue_pos, - [Lprim(Pgetglobal toploop_ident, [], Location.none)], - Location.none); - ap_args=[Lconst(Const_base(Const_string (toplevel_name id, None)))]; - ap_inlined=Default_inline; - ap_specialised=Default_specialise} - -let toploop_setvalue id lam = - Lapply{ap_should_be_tailcall=false; - ap_loc=Location.none; - ap_func=Lprim(Pfield toploop_setvalue_pos, - [Lprim(Pgetglobal toploop_ident, [], Location.none)], - Location.none); - ap_args=[Lconst(Const_base(Const_string (toplevel_name id, None))); - lam]; - ap_inlined=Default_inline; - ap_specialised=Default_specialise} - -let toploop_setvalue_id id = toploop_setvalue id (Lvar id) - -let close_toplevel_term (lam, ()) = - Ident.Set.fold (fun id l -> Llet(Strict, Pgenval, id, - toploop_getvalue id, l)) - (free_variables lam) lam - -let transl_toplevel_item item = - match item.str_desc with - Tstr_eval (expr, _) - | Tstr_value(Nonrecursive, - [{vb_pat = {pat_desc=Tpat_any};vb_expr = expr}]) -> - (* special compilation for toplevel "let _ = expr", so - that Toploop can display the result of the expression. - Otherwise, the normal compilation would result - in a Lsequence returning unit. *) - transl_exp expr - | Tstr_value(rec_flag, pat_expr_list) -> - let idents = let_bound_idents pat_expr_list in - transl_let rec_flag pat_expr_list - (make_sequence toploop_setvalue_id idents) - | Tstr_typext(tyext) -> - let idents = - List.map (fun ext -> ext.ext_id) tyext.tyext_constructors - in - (* we need to use unique name in case of multiple - definitions of the same extension constructor in the toplevel *) - List.iter set_toplevel_unique_name idents; - transl_type_extension item.str_env None tyext - (make_sequence toploop_setvalue_id idents) - | Tstr_exception ext -> - set_toplevel_unique_name ext.tyexn_constructor.ext_id; - toploop_setvalue ext.tyexn_constructor.ext_id - (transl_extension_constructor item.str_env None ext.tyexn_constructor) - | Tstr_module {mb_id=id; mb_presence=Mp_present; mb_expr=modl} -> - (* we need to use the unique name for the module because of issues - with "open" (PR#8133) *) - set_toplevel_unique_name id; - let lam = transl_module Tcoerce_none (Some(Pident id)) modl in - toploop_setvalue id lam - | Tstr_recmodule bindings -> - let idents = List.map (fun mb -> mb.mb_id) bindings in - compile_recmodule - (fun id modl _loc -> transl_module Tcoerce_none (Some(Pident id)) modl) - bindings - (make_sequence toploop_setvalue_id idents) - | Tstr_class cl_list -> - (* we need to use unique names for the classes because there might - be a value named identically *) - let (ids, class_bindings) = transl_class_bindings cl_list in - List.iter set_toplevel_unique_name ids; - Lletrec(class_bindings, make_sequence toploop_setvalue_id ids) - | Tstr_include incl -> - let ids = bound_value_identifiers incl.incl_type in - let modl = incl.incl_mod in - let mid = Ident.create_local "include" in - let rec set_idents pos = function - [] -> - lambda_unit - | id :: ids -> - Lsequence(toploop_setvalue id - (Lprim(Pfield pos, [Lvar mid], Location.none)), - set_idents (pos + 1) ids) in - Llet(Strict, Pgenval, mid, - transl_module Tcoerce_none None modl, set_idents 0 ids) - | Tstr_primitive descr -> - record_primitive descr.val_val; - lambda_unit - | Tstr_open od -> - let pure = pure_module od.open_expr in - (* this optimization shouldn't be needed because Simplif would - actually remove the [Llet] when it's not used. - But since [scan_used_globals] runs before Simplif, we need to do - it. *) - begin match od.open_bound_items with - | [] when pure = Alias -> lambda_unit - | _ -> - let ids = bound_value_identifiers od.open_bound_items in - let mid = Ident.create_local "open" in - let rec set_idents pos = function - [] -> - lambda_unit - | id :: ids -> - Lsequence(toploop_setvalue id - (Lprim(Pfield pos, [Lvar mid], Location.none)), - set_idents (pos + 1) ids) - in - Llet(pure, Pgenval, mid, - transl_module Tcoerce_none None od.open_expr, set_idents 0 ids) - end - | Tstr_modtype _ - | Tstr_module {mb_presence=Mp_absent} - | Tstr_type _ - | Tstr_class_type _ - | Tstr_attribute _ -> - lambda_unit - -let transl_toplevel_item_and_close itm = - close_toplevel_term - (transl_label_init (fun () -> transl_toplevel_item itm, ())) - -let transl_toplevel_definition str = - reset_labels (); - Translprim.clear_used_primitives (); - make_sequence transl_toplevel_item_and_close str.str_items - -(* Compile the initialization code for a packed library *) - -let get_component = function - None -> Lconst const_unit - | Some id -> Lprim(Pgetglobal id, [], Location.none) - -let transl_package_flambda component_names coercion = - let size = - match coercion with - | Tcoerce_none -> List.length component_names - | Tcoerce_structure (l, _) -> List.length l - | Tcoerce_functor _ - | Tcoerce_primitive _ - | Tcoerce_alias _ -> assert false - in - size, - apply_coercion Location.none Strict coercion - (Lprim(Pmakeblock(0, Immutable, None), - List.map get_component component_names, - Location.none)) - -let transl_package component_names target_name coercion = - let components = - Lprim(Pmakeblock(0, Immutable, None), - List.map get_component component_names, Location.none) in - Lprim(Psetglobal target_name, - [apply_coercion Location.none Strict coercion components], - Location.none) - (* - let components = - match coercion with - Tcoerce_none -> - List.map get_component component_names - | Tcoerce_structure (pos_cc_list, id_pos_list) -> - (* ignore id_pos_list as the ids are already bound *) - let g = Array.of_list component_names in - List.map - (fun (pos, cc) -> apply_coercion Strict cc (get_component g.(pos))) - pos_cc_list - | _ -> - assert false in - Lprim(Psetglobal target_name, [Lprim(Pmakeblock(0, Immutable), components)]) - *) - -let transl_store_package component_names target_name coercion = - let rec make_sequence fn pos arg = - match arg with - [] -> lambda_unit - | hd :: tl -> Lsequence(fn pos hd, make_sequence fn (pos + 1) tl) in - match coercion with - Tcoerce_none -> - (List.length component_names, - make_sequence - (fun pos id -> - Lprim(Psetfield(pos, Pointer, Root_initialization), - [Lprim(Pgetglobal target_name, [], Location.none); - get_component id], - Location.none)) - 0 component_names) - | Tcoerce_structure (pos_cc_list, _id_pos_list) -> - let components = - Lprim(Pmakeblock(0, Immutable, None), - List.map get_component component_names, - Location.none) - in - let blk = Ident.create_local "block" in - (List.length pos_cc_list, - Llet (Strict, Pgenval, blk, - apply_coercion Location.none Strict coercion components, - make_sequence - (fun pos _id -> - Lprim(Psetfield(pos, Pointer, Root_initialization), - [Lprim(Pgetglobal target_name, [], Location.none); - Lprim(Pfield pos, [Lvar blk], Location.none)], - Location.none)) - 0 pos_cc_list)) - (* - (* ignore id_pos_list as the ids are already bound *) - let id = Array.of_list component_names in - (List.length pos_cc_list, - make_sequence - (fun dst (src, cc) -> - Lprim(Psetfield(dst, false), - [Lprim(Pgetglobal target_name, []); - apply_coercion Strict cc (get_component id.(src))])) - 0 pos_cc_list) - *) - | _ -> assert false - -(* Error report *) - -open Format - -let print_cycle ppf cycle = - let print_ident ppf (x,_) = Format.pp_print_string ppf (Ident.name x) in - let pp_sep ppf () = fprintf ppf "@ -> " in - Format.fprintf ppf "%a%a%s" - (Format.pp_print_list ~pp_sep print_ident) cycle - pp_sep () - (Ident.name @@ fst @@ List.hd cycle) -(* we repeat the first element to make the cycle more apparent *) - -let explanation_submsg (id, {reason;loc;subid}) = - let print fmt = - let printer = Format.dprintf fmt (Ident.name id) (Ident.name subid) in - Location.mkloc printer loc in - match reason with - | Unsafe_module_binding -> print "Module %s defines an unsafe module, %s ." - | Unsafe_functor -> print "Module %s defines an unsafe functor, %s ." - | Unsafe_typext -> - print "Module %s defines an unsafe extension constructor, %s ." - | Unsafe_non_function -> print "Module %s defines an unsafe value, %s ." - -let report_error loc = function - | Circular_dependency cycle -> - let[@manual.ref "s-recursive-modules"] chapter, section = 8, 2 in - Location.errorf ~loc ~sub:(List.map explanation_submsg cycle) - "Cannot safely evaluate the definition of the following cycle@ \ - of recursively-defined modules:@ %a.@ \ - There are no safe modules in this cycle@ (see manual section %d.%d)." - print_cycle cycle chapter section - | Conflicting_inline_attributes -> - Location.errorf "@[Conflicting 'inline' attributes@]" - -let () = - Location.register_error_of_exn - (function - | Error (loc, err) -> Some (report_error loc err) - | _ -> - None - ) - -let reset () = - primitive_declarations := []; - transl_store_subst := Ident.Map.empty; - aliased_idents := Ident.empty; - Env.reset_required_globals (); - Translprim.clear_used_primitives () diff --git a/bytecomp/translmod.mli b/bytecomp/translmod.mli deleted file mode 100644 index d0898c769a..0000000000 --- a/bytecomp/translmod.mli +++ /dev/null @@ -1,61 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Translation from typed abstract syntax to lambda terms, - for the module language *) - -open Typedtree -open Lambda - -val transl_implementation: - string -> structure * module_coercion -> Lambda.program -val transl_store_phrases: string -> structure -> int * lambda -val transl_store_implementation: - string -> structure * module_coercion -> Lambda.program - -val transl_implementation_flambda: - string -> structure * module_coercion -> Lambda.program - -val transl_toplevel_definition: structure -> lambda -val transl_package: - Ident.t option list -> Ident.t -> module_coercion -> lambda -val transl_store_package: - Ident.t option list -> Ident.t -> module_coercion -> int * lambda - -val transl_package_flambda: - Ident.t option list -> module_coercion -> int * lambda - -val toplevel_name: Ident.t -> string -val nat_toplevel_name: Ident.t -> Ident.t * int - -val primitive_declarations: Primitive.description list ref - -type unsafe_component = - | Unsafe_module_binding - | Unsafe_functor - | Unsafe_non_function - | Unsafe_typext - -type unsafe_info = { reason:unsafe_component; loc:Location.t; subid:Ident.t } - -type error = - Circular_dependency of (Ident.t * unsafe_info) list -| Conflicting_inline_attributes - -exception Error of Location.t * error - -val report_error: Location.t -> error -> Location.error - -val reset: unit -> unit diff --git a/bytecomp/translobj.ml b/bytecomp/translobj.ml deleted file mode 100644 index ce06353879..0000000000 --- a/bytecomp/translobj.ml +++ /dev/null @@ -1,199 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Jerome Vouillon, 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 Asttypes -open Lambda - -(* Get oo primitives identifiers *) - -let oo_prim = Lambda.transl_prim "CamlinternalOO" - -(* Share blocks *) - -let consts : (structured_constant, Ident.t) Hashtbl.t = Hashtbl.create 17 - -let share c = - match c with - Const_block (_n, l) when l <> [] -> - begin try - Lvar (Hashtbl.find consts c) - with Not_found -> - let id = Ident.create_local "shared" in - Hashtbl.add consts c id; - Lvar id - end - | _ -> Lconst c - -(* Collect labels *) - -let cache_required = ref false -let method_cache = ref lambda_unit -let method_count = ref 0 -let method_table = ref [] - -let meth_tag s = Lconst(Const_base(Const_int(Btype.hash_variant s))) - -let next_cache tag = - let n = !method_count in - incr method_count; - (tag, [!method_cache; Lconst(Const_base(Const_int n))]) - -let rec is_path = function - Lvar _ | Lprim (Pgetglobal _, [], _) | Lconst _ -> true - | Lprim (Pfield _, [lam], _) -> is_path lam - | Lprim ((Parrayrefu _ | Parrayrefs _), [lam1; lam2], _) -> - is_path lam1 && is_path lam2 - | _ -> false - -let meth obj lab = - let tag = meth_tag lab in - if not (!cache_required && !Clflags.native_code) then (tag, []) else - if not (is_path obj) then next_cache tag else - try - let r = List.assoc obj !method_table in - try - (tag, List.assoc tag !r) - with Not_found -> - let p = next_cache tag in - r := p :: !r; - p - with Not_found -> - let p = next_cache tag in - method_table := (obj, ref [p]) :: !method_table; - p - -let reset_labels () = - Hashtbl.clear consts; - method_count := 0; - method_table := [] - -(* Insert labels *) - -let int n = Lconst (Const_base (Const_int n)) - -let prim_makearray = - Primitive.simple ~name:"caml_make_vect" ~arity:2 ~alloc:true - -(* Also use it for required globals *) -let transl_label_init_general f = - let expr, size = f () in - let expr = - Hashtbl.fold - (fun c id expr -> Llet(Alias, Pgenval, id, Lconst c, expr)) - consts expr - in - (*let expr = - List.fold_right - (fun id expr -> Lsequence(Lprim(Pgetglobal id, [], Location.none), expr)) - (Env.get_required_globals ()) expr - in - Env.reset_required_globals ();*) - reset_labels (); - expr, size - -let transl_label_init_flambda f = - assert(Config.flambda); - let method_cache_id = Ident.create_local "method_cache" in - method_cache := Lvar method_cache_id; - (* Calling f (usually Translmod.transl_struct) requires the - method_cache variable to be initialised to be able to generate - method accesses. *) - let expr, size = f () in - let expr = - if !method_count = 0 then expr - else - Llet (Strict, Pgenval, method_cache_id, - Lprim (Pccall prim_makearray, - [int !method_count; int 0], - Location.none), - expr) - in - transl_label_init_general (fun () -> expr, size) - -let transl_store_label_init glob size f arg = - assert(not Config.flambda); - assert(!Clflags.native_code); - method_cache := Lprim(Pfield size, - [Lprim(Pgetglobal glob, [], Location.none)], - Location.none); - let expr = f arg in - let (size, expr) = - if !method_count = 0 then (size, expr) else - (size+1, - Lsequence( - Lprim(Psetfield(size, Pointer, Root_initialization), - [Lprim(Pgetglobal glob, [], Location.none); - Lprim (Pccall prim_makearray, - [int !method_count; int 0], - Location.none)], - Location.none), - expr)) - in - let lam, size = transl_label_init_general (fun () -> (expr, size)) in - size, lam - -let transl_label_init f = - if !Clflags.native_code then - transl_label_init_flambda f - else - transl_label_init_general f - -(* Share classes *) - -let wrapping = ref false -let top_env = ref Env.empty -let classes = ref [] -let method_ids = ref Ident.Set.empty - -let oo_add_class id = - classes := id :: !classes; - (!top_env, !cache_required) - -let oo_wrap env req f x = - if !wrapping then - if !cache_required then f x else - Misc.protect_refs [Misc.R (cache_required, true)] (fun () -> - f x - ) - else - Misc.protect_refs [Misc.R (wrapping, true); Misc.R (top_env, env)] - (fun () -> - cache_required := req; - classes := []; - method_ids := Ident.Set.empty; - let lambda = f x in - let lambda = - List.fold_left - (fun lambda id -> - Llet(StrictOpt, Pgenval, id, - Lprim(Pmakeblock(0, Mutable, None), - [lambda_unit; lambda_unit; lambda_unit], - Location.none), - lambda)) - lambda !classes - in - lambda - ) - -let reset () = - Hashtbl.clear consts; - cache_required := false; - method_cache := lambda_unit; - method_count := 0; - method_table := []; - wrapping := false; - top_env := Env.empty; - classes := []; - method_ids := Ident.Set.empty diff --git a/bytecomp/translobj.mli b/bytecomp/translobj.mli deleted file mode 100644 index c27053e961..0000000000 --- a/bytecomp/translobj.mli +++ /dev/null @@ -1,33 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Jerome Vouillon, 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 Lambda - -val oo_prim: string -> lambda - -val share: structured_constant -> lambda -val meth: lambda -> string -> lambda * lambda list - -val reset_labels: unit -> unit -val transl_label_init: (unit -> lambda * 'a) -> lambda * 'a -val transl_store_label_init: - Ident.t -> int -> ('a -> lambda) -> 'a -> int * lambda - -val method_ids: Ident.Set.t ref (* reset when starting a new wrapper *) - -val oo_wrap: Env.t -> bool -> ('a -> lambda) -> 'a -> lambda -val oo_add_class: Ident.t -> Env.t * bool - -val reset: unit -> unit diff --git a/bytecomp/translprim.ml b/bytecomp/translprim.ml deleted file mode 100644 index d56002b70c..0000000000 --- a/bytecomp/translprim.ml +++ /dev/null @@ -1,811 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Translation of primitives *) - -open Misc -open Asttypes -open Primitive -open Types -open Typedtree -open Typeopt -open Lambda - -type error = - | Unknown_builtin_primitive of string - | Wrong_arity_builtin_primitive of string - -exception Error of Location.t * error - -(* Insertion of debugging events *) - -let event_before exp lam = match lam with -| Lstaticraise (_,_) -> lam -| _ -> - if !Clflags.debug && not !Clflags.native_code - then Levent(lam, {lev_loc = exp.exp_loc; - lev_kind = Lev_before; - lev_repr = None; - lev_env = exp.exp_env}) - else lam - -let event_after exp lam = - if !Clflags.debug && not !Clflags.native_code - then Levent(lam, {lev_loc = exp.exp_loc; - lev_kind = Lev_after exp.exp_type; - lev_repr = None; - lev_env = exp.exp_env}) - else lam - -type comparison = - | Equal - | Not_equal - | Less_equal - | Less_than - | Greater_equal - | Greater_than - | Compare - -type comparison_kind = - | Compare_generic - | Compare_ints - | Compare_floats - | Compare_strings - | Compare_bytes - | Compare_nativeints - | Compare_int32s - | Compare_int64s - -type loc_kind = - | Loc_FILE - | Loc_LINE - | Loc_MODULE - | Loc_LOC - | Loc_POS - -type prim = - | Primitive of Lambda.primitive * int - | External of Primitive.description - | Comparison of comparison * comparison_kind - | Raise of Lambda.raise_kind - | Raise_with_backtrace - | Lazy_force - | Loc of loc_kind - | Send - | Send_self - | Send_cache - -let used_primitives = Hashtbl.create 7 -let add_used_primitive loc env path = - match path with - Some (Path.Pdot _ as path) -> - let path = Env.normalize_path_prefix (Some loc) env path in - let unit = Path.head path in - if Ident.global unit && not (Hashtbl.mem used_primitives path) - then Hashtbl.add used_primitives path loc - | _ -> () - -let clear_used_primitives () = Hashtbl.clear used_primitives -let get_used_primitives () = - Hashtbl.fold (fun path _ acc -> path :: acc) used_primitives [] - -let gen_array_kind = - if Config.flat_float_array then Pgenarray else Paddrarray - -let prim_sys_argv = - Primitive.simple ~name:"caml_sys_argv" ~arity:1 ~alloc:true - -let primitives_table = - create_hashtable 57 [ - "%identity", Primitive (Pidentity, 1); - "%bytes_to_string", Primitive (Pbytes_to_string, 1); - "%bytes_of_string", Primitive (Pbytes_of_string, 1); - "%ignore", Primitive (Pignore, 1); - "%revapply", Primitive (Prevapply, 2); - "%apply", Primitive (Pdirapply, 2); - "%loc_LOC", Loc Loc_LOC; - "%loc_FILE", Loc Loc_FILE; - "%loc_LINE", Loc Loc_LINE; - "%loc_POS", Loc Loc_POS; - "%loc_MODULE", Loc Loc_MODULE; - "%field0", Primitive ((Pfield 0), 1); - "%field1", Primitive ((Pfield 1), 1); - "%setfield0", Primitive ((Psetfield(0, Pointer, Assignment)), 2); - "%makeblock", Primitive ((Pmakeblock(0, Immutable, None)), 1); - "%makemutable", Primitive ((Pmakeblock(0, Mutable, None)), 1); - "%raise", Raise Raise_regular; - "%reraise", Raise Raise_reraise; - "%raise_notrace", Raise Raise_notrace; - "%raise_with_backtrace", Raise_with_backtrace; - "%sequand", Primitive (Psequand, 2); - "%sequor", Primitive (Psequor, 2); - "%boolnot", Primitive (Pnot, 1); - "%big_endian", Primitive ((Pctconst Big_endian), 1); - "%backend_type", Primitive ((Pctconst Backend_type), 1); - "%word_size", Primitive ((Pctconst Word_size), 1); - "%int_size", Primitive ((Pctconst Int_size), 1); - "%max_wosize", Primitive ((Pctconst Max_wosize), 1); - "%ostype_unix", Primitive ((Pctconst Ostype_unix), 1); - "%ostype_win32", Primitive ((Pctconst Ostype_win32), 1); - "%ostype_cygwin", Primitive ((Pctconst Ostype_cygwin), 1); - "%negint", Primitive (Pnegint, 1); - "%succint", Primitive ((Poffsetint 1), 1); - "%predint", Primitive ((Poffsetint(-1)), 1); - "%addint", Primitive (Paddint, 2); - "%subint", Primitive (Psubint, 2); - "%mulint", Primitive (Pmulint, 2); - "%divint", Primitive ((Pdivint Safe), 2); - "%modint", Primitive ((Pmodint Safe), 2); - "%andint", Primitive (Pandint, 2); - "%orint", Primitive (Porint, 2); - "%xorint", Primitive (Pxorint, 2); - "%lslint", Primitive (Plslint, 2); - "%lsrint", Primitive (Plsrint, 2); - "%asrint", Primitive (Pasrint, 2); - "%eq", Primitive ((Pintcomp Ceq), 2); - "%noteq", Primitive ((Pintcomp Cne), 2); - "%ltint", Primitive ((Pintcomp Clt), 2); - "%leint", Primitive ((Pintcomp Cle), 2); - "%gtint", Primitive ((Pintcomp Cgt), 2); - "%geint", Primitive ((Pintcomp Cge), 2); - "%incr", Primitive ((Poffsetref(1)), 1); - "%decr", Primitive ((Poffsetref(-1)), 1); - "%intoffloat", Primitive (Pintoffloat, 1); - "%floatofint", Primitive (Pfloatofint, 1); - "%negfloat", Primitive (Pnegfloat, 1); - "%absfloat", Primitive (Pabsfloat, 1); - "%addfloat", Primitive (Paddfloat, 2); - "%subfloat", Primitive (Psubfloat, 2); - "%mulfloat", Primitive (Pmulfloat, 2); - "%divfloat", Primitive (Pdivfloat, 2); - "%eqfloat", Primitive ((Pfloatcomp CFeq), 2); - "%noteqfloat", Primitive ((Pfloatcomp CFneq), 2); - "%ltfloat", Primitive ((Pfloatcomp CFlt), 2); - "%lefloat", Primitive ((Pfloatcomp CFle), 2); - "%gtfloat", Primitive ((Pfloatcomp CFgt), 2); - "%gefloat", Primitive ((Pfloatcomp CFge), 2); - "%string_length", Primitive (Pstringlength, 1); - "%string_safe_get", Primitive (Pstringrefs, 2); - "%string_safe_set", Primitive (Pbytessets, 3); - "%string_unsafe_get", Primitive (Pstringrefu, 2); - "%string_unsafe_set", Primitive (Pbytessetu, 3); - "%bytes_length", Primitive (Pbyteslength, 1); - "%bytes_safe_get", Primitive (Pbytesrefs, 2); - "%bytes_safe_set", Primitive (Pbytessets, 3); - "%bytes_unsafe_get", Primitive (Pbytesrefu, 2); - "%bytes_unsafe_set", Primitive (Pbytessetu, 3); - "%array_length", Primitive ((Parraylength gen_array_kind), 1); - "%array_safe_get", Primitive ((Parrayrefs gen_array_kind), 2); - "%array_safe_set", Primitive ((Parraysets gen_array_kind), 3); - "%array_unsafe_get", Primitive ((Parrayrefu gen_array_kind), 2); - "%array_unsafe_set", Primitive ((Parraysetu gen_array_kind), 3); - "%obj_size", Primitive ((Parraylength gen_array_kind), 1); - "%obj_field", Primitive ((Parrayrefu gen_array_kind), 2); - "%obj_set_field", Primitive ((Parraysetu gen_array_kind), 3); - "%floatarray_length", Primitive ((Parraylength Pfloatarray), 1); - "%floatarray_safe_get", Primitive ((Parrayrefs Pfloatarray), 2); - "%floatarray_safe_set", Primitive ((Parraysets Pfloatarray), 3); - "%floatarray_unsafe_get", Primitive ((Parrayrefu Pfloatarray), 2); - "%floatarray_unsafe_set", Primitive ((Parraysetu Pfloatarray), 3); - "%obj_is_int", Primitive (Pisint, 1); - "%lazy_force", Lazy_force; - "%nativeint_of_int", Primitive ((Pbintofint Pnativeint), 1); - "%nativeint_to_int", Primitive ((Pintofbint Pnativeint), 1); - "%nativeint_neg", Primitive ((Pnegbint Pnativeint), 1); - "%nativeint_add", Primitive ((Paddbint Pnativeint), 2); - "%nativeint_sub", Primitive ((Psubbint Pnativeint), 2); - "%nativeint_mul", Primitive ((Pmulbint Pnativeint), 2); - "%nativeint_div", - Primitive ((Pdivbint { size = Pnativeint; is_safe = Safe }), 2); - "%nativeint_mod", - Primitive ((Pmodbint { size = Pnativeint; is_safe = Safe }), 2); - "%nativeint_and", Primitive ((Pandbint Pnativeint), 2); - "%nativeint_or", Primitive ( (Porbint Pnativeint), 2); - "%nativeint_xor", Primitive ((Pxorbint Pnativeint), 2); - "%nativeint_lsl", Primitive ((Plslbint Pnativeint), 2); - "%nativeint_lsr", Primitive ((Plsrbint Pnativeint), 2); - "%nativeint_asr", Primitive ((Pasrbint Pnativeint), 2); - "%int32_of_int", Primitive ((Pbintofint Pint32), 1); - "%int32_to_int", Primitive ((Pintofbint Pint32), 1); - "%int32_neg", Primitive ((Pnegbint Pint32), 1); - "%int32_add", Primitive ((Paddbint Pint32), 2); - "%int32_sub", Primitive ((Psubbint Pint32), 2); - "%int32_mul", Primitive ((Pmulbint Pint32), 2); - "%int32_div", Primitive ((Pdivbint { size = Pint32; is_safe = Safe }), 2); - "%int32_mod", Primitive ((Pmodbint { size = Pint32; is_safe = Safe }), 2); - "%int32_and", Primitive ((Pandbint Pint32), 2); - "%int32_or", Primitive ( (Porbint Pint32), 2); - "%int32_xor", Primitive ((Pxorbint Pint32), 2); - "%int32_lsl", Primitive ((Plslbint Pint32), 2); - "%int32_lsr", Primitive ((Plsrbint Pint32), 2); - "%int32_asr", Primitive ((Pasrbint Pint32), 2); - "%int64_of_int", Primitive ((Pbintofint Pint64), 1); - "%int64_to_int", Primitive ((Pintofbint Pint64), 1); - "%int64_neg", Primitive ((Pnegbint Pint64), 1); - "%int64_add", Primitive ((Paddbint Pint64), 2); - "%int64_sub", Primitive ((Psubbint Pint64), 2); - "%int64_mul", Primitive ((Pmulbint Pint64), 2); - "%int64_div", Primitive ((Pdivbint { size = Pint64; is_safe = Safe }), 2); - "%int64_mod", Primitive ((Pmodbint { size = Pint64; is_safe = Safe }), 2); - "%int64_and", Primitive ((Pandbint Pint64), 2); - "%int64_or", Primitive ( (Porbint Pint64), 2); - "%int64_xor", Primitive ((Pxorbint Pint64), 2); - "%int64_lsl", Primitive ((Plslbint Pint64), 2); - "%int64_lsr", Primitive ((Plsrbint Pint64), 2); - "%int64_asr", Primitive ((Pasrbint Pint64), 2); - "%nativeint_of_int32", Primitive ((Pcvtbint(Pint32, Pnativeint)), 1); - "%nativeint_to_int32", Primitive ((Pcvtbint(Pnativeint, Pint32)), 1); - "%int64_of_int32", Primitive ((Pcvtbint(Pint32, Pint64)), 1); - "%int64_to_int32", Primitive ((Pcvtbint(Pint64, Pint32)), 1); - "%int64_of_nativeint", Primitive ((Pcvtbint(Pnativeint, Pint64)), 1); - "%int64_to_nativeint", Primitive ((Pcvtbint(Pint64, Pnativeint)), 1); - "%caml_ba_ref_1", - Primitive - ((Pbigarrayref(false, 1, Pbigarray_unknown, Pbigarray_unknown_layout)), - 2); - "%caml_ba_ref_2", - Primitive - ((Pbigarrayref(false, 2, Pbigarray_unknown, Pbigarray_unknown_layout)), - 3); - "%caml_ba_ref_3", - Primitive - ((Pbigarrayref(false, 3, Pbigarray_unknown, Pbigarray_unknown_layout)), - 4); - "%caml_ba_set_1", - Primitive - ((Pbigarrayset(false, 1, Pbigarray_unknown, Pbigarray_unknown_layout)), - 3); - "%caml_ba_set_2", - Primitive - ((Pbigarrayset(false, 2, Pbigarray_unknown, Pbigarray_unknown_layout)), - 4); - "%caml_ba_set_3", - Primitive - ((Pbigarrayset(false, 3, Pbigarray_unknown, Pbigarray_unknown_layout)), - 5); - "%caml_ba_unsafe_ref_1", - Primitive - ((Pbigarrayref(true, 1, Pbigarray_unknown, Pbigarray_unknown_layout)), - 2); - "%caml_ba_unsafe_ref_2", - Primitive - ((Pbigarrayref(true, 2, Pbigarray_unknown, Pbigarray_unknown_layout)), - 3); - "%caml_ba_unsafe_ref_3", - Primitive - ((Pbigarrayref(true, 3, Pbigarray_unknown, Pbigarray_unknown_layout)), - 4); - "%caml_ba_unsafe_set_1", - Primitive - ((Pbigarrayset(true, 1, Pbigarray_unknown, Pbigarray_unknown_layout)), - 3); - "%caml_ba_unsafe_set_2", - Primitive - ((Pbigarrayset(true, 2, Pbigarray_unknown, Pbigarray_unknown_layout)), - 4); - "%caml_ba_unsafe_set_3", - Primitive - ((Pbigarrayset(true, 3, Pbigarray_unknown, Pbigarray_unknown_layout)), - 5); - "%caml_ba_dim_1", Primitive ((Pbigarraydim(1)), 1); - "%caml_ba_dim_2", Primitive ((Pbigarraydim(2)), 1); - "%caml_ba_dim_3", Primitive ((Pbigarraydim(3)), 1); - "%caml_string_get16", Primitive ((Pstring_load_16(false)), 2); - "%caml_string_get16u", Primitive ((Pstring_load_16(true)), 2); - "%caml_string_get32", Primitive ((Pstring_load_32(false)), 2); - "%caml_string_get32u", Primitive ((Pstring_load_32(true)), 2); - "%caml_string_get64", Primitive ((Pstring_load_64(false)), 2); - "%caml_string_get64u", Primitive ((Pstring_load_64(true)), 2); - "%caml_string_set16", Primitive ((Pbytes_set_16(false)), 3); - "%caml_string_set16u", Primitive ((Pbytes_set_16(true)), 3); - "%caml_string_set32", Primitive ((Pbytes_set_32(false)), 3); - "%caml_string_set32u", Primitive ((Pbytes_set_32(true)), 3); - "%caml_string_set64", Primitive ((Pbytes_set_64(false)), 3); - "%caml_string_set64u", Primitive ((Pbytes_set_64(true)), 3); - "%caml_bytes_get16", Primitive ((Pbytes_load_16(false)), 2); - "%caml_bytes_get16u", Primitive ((Pbytes_load_16(true)), 2); - "%caml_bytes_get32", Primitive ((Pbytes_load_32(false)), 2); - "%caml_bytes_get32u", Primitive ((Pbytes_load_32(true)), 2); - "%caml_bytes_get64", Primitive ((Pbytes_load_64(false)), 2); - "%caml_bytes_get64u", Primitive ((Pbytes_load_64(true)), 2); - "%caml_bytes_set16", Primitive ((Pbytes_set_16(false)), 3); - "%caml_bytes_set16u", Primitive ((Pbytes_set_16(true)), 3); - "%caml_bytes_set32", Primitive ((Pbytes_set_32(false)), 3); - "%caml_bytes_set32u", Primitive ((Pbytes_set_32(true)), 3); - "%caml_bytes_set64", Primitive ((Pbytes_set_64(false)), 3); - "%caml_bytes_set64u", Primitive ((Pbytes_set_64(true)), 3); - "%caml_bigstring_get16", Primitive ((Pbigstring_load_16(false)), 2); - "%caml_bigstring_get16u", Primitive ((Pbigstring_load_16(true)), 2); - "%caml_bigstring_get32", Primitive ((Pbigstring_load_32(false)), 2); - "%caml_bigstring_get32u", Primitive ((Pbigstring_load_32(true)), 2); - "%caml_bigstring_get64", Primitive ((Pbigstring_load_64(false)), 2); - "%caml_bigstring_get64u", Primitive ((Pbigstring_load_64(true)), 2); - "%caml_bigstring_set16", Primitive ((Pbigstring_set_16(false)), 3); - "%caml_bigstring_set16u", Primitive ((Pbigstring_set_16(true)), 3); - "%caml_bigstring_set32", Primitive ((Pbigstring_set_32(false)), 3); - "%caml_bigstring_set32u", Primitive ((Pbigstring_set_32(true)), 3); - "%caml_bigstring_set64", Primitive ((Pbigstring_set_64(false)), 3); - "%caml_bigstring_set64u", Primitive ((Pbigstring_set_64(true)), 3); - "%bswap16", Primitive (Pbswap16, 1); - "%bswap_int32", Primitive ((Pbbswap(Pint32)), 1); - "%bswap_int64", Primitive ((Pbbswap(Pint64)), 1); - "%bswap_native", Primitive ((Pbbswap(Pnativeint)), 1); - "%int_as_pointer", Primitive (Pint_as_pointer, 1); - "%opaque", Primitive (Popaque, 1); - "%sys_argv", External prim_sys_argv; - "%send", Send; - "%sendself", Send_self; - "%sendcache", Send_cache; - "%equal", Comparison(Equal, Compare_generic); - "%notequal", Comparison(Not_equal, Compare_generic); - "%lessequal", Comparison(Less_equal, Compare_generic); - "%lessthan", Comparison(Less_than, Compare_generic); - "%greaterequal", Comparison(Greater_equal, Compare_generic); - "%greaterthan", Comparison(Greater_than, Compare_generic); - "%compare", Comparison(Compare, Compare_generic); - ] - - -let lookup_primitive loc p = - match Hashtbl.find primitives_table p.prim_name with - | prim -> prim - | exception Not_found -> - if String.length p.prim_name > 0 && p.prim_name.[0] = '%' then - raise(Error(loc, Unknown_builtin_primitive p.prim_name)); - External p - -let lookup_primitive_and_mark_used loc p env path = - match lookup_primitive loc p with - | External _ as e -> add_used_primitive loc env path; e - | x -> x - -let simplify_constant_constructor = function - | Equal -> true - | Not_equal -> true - | Less_equal -> false - | Less_than -> false - | Greater_equal -> false - | Greater_than -> false - | Compare -> false - -(* The following function computes the greatest lower bound in the - semilattice of array kinds: - gen - / \ - addr float - | - int - Note that the GLB is not guaranteed to exist, in which case we return - our first argument instead of raising a fatal error because, although - it cannot happen in a well-typed program, (ab)use of Obj.magic can - probably trigger it. -*) -let glb_array_type t1 t2 = - match t1, t2 with - | Pfloatarray, (Paddrarray | Pintarray) - | (Paddrarray | Pintarray), Pfloatarray -> t1 - - | Pgenarray, x | x, Pgenarray -> x - | Paddrarray, x | x, Paddrarray -> x - | Pintarray, Pintarray -> Pintarray - | Pfloatarray, Pfloatarray -> Pfloatarray - -(* Specialize a primitive from available type information. *) - -let specialize_primitive env ty ~has_constant_constructor prim = - let param_tys = - match is_function_type env ty with - | None -> [] - | Some (p1, rhs) -> - match is_function_type env rhs with - | None -> [p1] - | Some (p2, _) -> [p1;p2] - in - match prim, param_tys with - | Primitive (Psetfield(n, Pointer, init), arity), [_; p2] -> begin - match maybe_pointer_type env p2 with - | Pointer -> None - | Immediate -> Some (Primitive (Psetfield(n, Immediate, init), arity)) - end - | Primitive (Parraylength t, arity), [p] -> begin - let array_type = glb_array_type t (array_type_kind env p) in - if t = array_type then None - else Some (Primitive (Parraylength array_type, arity)) - end - | Primitive (Parrayrefu t, arity), p1 :: _ -> begin - let array_type = glb_array_type t (array_type_kind env p1) in - if t = array_type then None - else Some (Primitive (Parrayrefu array_type, arity)) - end - | Primitive (Parraysetu t, arity), p1 :: _ -> begin - let array_type = glb_array_type t (array_type_kind env p1) in - if t = array_type then None - else Some (Primitive (Parraysetu array_type, arity)) - end - | Primitive (Parrayrefs t, arity), p1 :: _ -> begin - let array_type = glb_array_type t (array_type_kind env p1) in - if t = array_type then None - else Some (Primitive (Parrayrefs array_type, arity)) - end - | Primitive (Parraysets t, arity), p1 :: _ -> begin - let array_type = glb_array_type t (array_type_kind env p1) in - if t = array_type then None - else Some (Primitive (Parraysets array_type, arity)) - end - | Primitive (Pbigarrayref(unsafe, n, Pbigarray_unknown, - Pbigarray_unknown_layout), arity), p1 :: _ -> begin - let (k, l) = bigarray_type_kind_and_layout env p1 in - match k, l with - | Pbigarray_unknown, Pbigarray_unknown_layout -> None - | _, _ -> Some (Primitive (Pbigarrayref(unsafe, n, k, l), arity)) - end - | Primitive (Pbigarrayset(unsafe, n, Pbigarray_unknown, - Pbigarray_unknown_layout), arity), p1 :: _ -> begin - let (k, l) = bigarray_type_kind_and_layout env p1 in - match k, l with - | Pbigarray_unknown, Pbigarray_unknown_layout -> None - | _, _ -> Some (Primitive (Pbigarrayset(unsafe, n, k, l), arity)) - end - | Primitive (Pmakeblock(tag, mut, None), arity), fields -> begin - let shape = List.map (Typeopt.value_kind env) fields in - let useful = List.exists (fun knd -> knd <> Pgenval) shape in - if useful then Some (Primitive (Pmakeblock(tag, mut, Some shape), arity)) - else None - end - | Comparison(comp, Compare_generic), p1 :: _ -> - if (has_constant_constructor - && simplify_constant_constructor comp) then begin - Some (Comparison(comp, Compare_ints)) - end else if (is_base_type env p1 Predef.path_int - || is_base_type env p1 Predef.path_char - || (maybe_pointer_type env p1 = Immediate)) then begin - Some (Comparison(comp, Compare_ints)) - end else if is_base_type env p1 Predef.path_float then begin - Some (Comparison(comp, Compare_floats)) - end else if is_base_type env p1 Predef.path_string then begin - Some (Comparison(comp, Compare_strings)) - end else if is_base_type env p1 Predef.path_bytes then begin - Some (Comparison(comp, Compare_bytes)) - end else if is_base_type env p1 Predef.path_nativeint then begin - Some (Comparison(comp, Compare_nativeints)) - end else if is_base_type env p1 Predef.path_int32 then begin - Some (Comparison(comp, Compare_int32s)) - end else if is_base_type env p1 Predef.path_int64 then begin - Some (Comparison(comp, Compare_int64s)) - end else begin - None - end - | _ -> None - -let unboxed_compare name native_repr = - Primitive.make ~name ~alloc:false ~native_name:(name^"_unboxed") - ~native_repr_args:[native_repr;native_repr] ~native_repr_res:Untagged_int - -let caml_equal = - Primitive.simple ~name:"caml_equal" ~arity:2 ~alloc:true -let caml_string_equal = - Primitive.simple ~name:"caml_string_equal" ~arity:2 ~alloc:false -let caml_bytes_equal = - Primitive.simple ~name:"caml_bytes_equal" ~arity:2 ~alloc:false -let caml_notequal = - Primitive.simple ~name:"caml_notequal" ~arity:2 ~alloc:true -let caml_string_notequal = - Primitive.simple ~name:"caml_string_notequal" ~arity:2 ~alloc:false -let caml_bytes_notequal = - Primitive.simple ~name:"caml_bytes_notequal" ~arity:2 ~alloc:false -let caml_lessequal = - Primitive.simple ~name:"caml_lessequal" ~arity:2 ~alloc:true -let caml_string_lessequal = - Primitive.simple ~name:"caml_string_lessequal" ~arity:2 ~alloc:false -let caml_bytes_lessequal = - Primitive.simple ~name:"caml_bytes_lessequal" ~arity:2 ~alloc:false -let caml_lessthan = - Primitive.simple ~name:"caml_lessthan" ~arity:2 ~alloc:true -let caml_string_lessthan = - Primitive.simple ~name:"caml_string_lessthan" ~arity:2 ~alloc:false -let caml_bytes_lessthan = - Primitive.simple ~name:"caml_bytes_lessthan" ~arity:2 ~alloc:false -let caml_greaterequal = - Primitive.simple ~name:"caml_greaterequal" ~arity:2 ~alloc:true -let caml_string_greaterequal = - Primitive.simple ~name:"caml_string_greaterequal" ~arity:2 ~alloc:false -let caml_bytes_greaterequal = - Primitive.simple ~name:"caml_bytes_greaterequal" ~arity:2 ~alloc:false -let caml_greaterthan = - Primitive.simple ~name:"caml_greaterthan" ~arity:2 ~alloc:true -let caml_string_greaterthan = - Primitive.simple ~name:"caml_string_greaterthan" ~arity:2 ~alloc: false -let caml_bytes_greaterthan = - Primitive.simple ~name:"caml_bytes_greaterthan" ~arity:2 ~alloc: false -let caml_compare = - Primitive.simple ~name:"caml_compare" ~arity:2 ~alloc:true -let caml_int_compare = - (* Not unboxed since the comparison is done directly on tagged int *) - Primitive.simple ~name:"caml_int_compare" ~arity:2 ~alloc:false -let caml_float_compare = - unboxed_compare "caml_float_compare" Unboxed_float -let caml_string_compare = - Primitive.simple ~name:"caml_string_compare" ~arity:2 ~alloc:false -let caml_bytes_compare = - Primitive.simple ~name:"caml_bytes_compare" ~arity:2 ~alloc:false -let caml_nativeint_compare = - unboxed_compare "caml_nativeint_compare" (Unboxed_integer Pnativeint) -let caml_int32_compare = - unboxed_compare "caml_int32_compare" (Unboxed_integer Pint32) -let caml_int64_compare = - unboxed_compare "caml_int64_compare" (Unboxed_integer Pint64) - -let comparison_primitive comparison comparison_kind = - match comparison, comparison_kind with - | Equal, Compare_generic -> Pccall caml_equal - | Equal, Compare_ints -> Pintcomp Ceq - | Equal, Compare_floats -> Pfloatcomp CFeq - | Equal, Compare_strings -> Pccall caml_string_equal - | Equal, Compare_bytes -> Pccall caml_bytes_equal - | Equal, Compare_nativeints -> Pbintcomp(Pnativeint, Ceq) - | Equal, Compare_int32s -> Pbintcomp(Pint32, Ceq) - | Equal, Compare_int64s -> Pbintcomp(Pint64, Ceq) - | Not_equal, Compare_generic -> Pccall caml_notequal - | Not_equal, Compare_ints -> Pintcomp Cne - | Not_equal, Compare_floats -> Pfloatcomp CFneq - | Not_equal, Compare_strings -> Pccall caml_string_notequal - | Not_equal, Compare_bytes -> Pccall caml_bytes_notequal - | Not_equal, Compare_nativeints -> Pbintcomp(Pnativeint, Cne) - | Not_equal, Compare_int32s -> Pbintcomp(Pint32, Cne) - | Not_equal, Compare_int64s -> Pbintcomp(Pint64, Cne) - | Less_equal, Compare_generic -> Pccall caml_lessequal - | Less_equal, Compare_ints -> Pintcomp Cle - | Less_equal, Compare_floats -> Pfloatcomp CFle - | Less_equal, Compare_strings -> Pccall caml_string_lessequal - | Less_equal, Compare_bytes -> Pccall caml_bytes_lessequal - | Less_equal, Compare_nativeints -> Pbintcomp(Pnativeint, Cle) - | Less_equal, Compare_int32s -> Pbintcomp(Pint32, Cle) - | Less_equal, Compare_int64s -> Pbintcomp(Pint64, Cle) - | Less_than, Compare_generic -> Pccall caml_lessthan - | Less_than, Compare_ints -> Pintcomp Clt - | Less_than, Compare_floats -> Pfloatcomp CFlt - | Less_than, Compare_strings -> Pccall caml_string_lessthan - | Less_than, Compare_bytes -> Pccall caml_bytes_lessthan - | Less_than, Compare_nativeints -> Pbintcomp(Pnativeint, Clt) - | Less_than, Compare_int32s -> Pbintcomp(Pint32, Clt) - | Less_than, Compare_int64s -> Pbintcomp(Pint64, Clt) - | Greater_equal, Compare_generic -> Pccall caml_greaterequal - | Greater_equal, Compare_ints -> Pintcomp Cge - | Greater_equal, Compare_floats -> Pfloatcomp CFge - | Greater_equal, Compare_strings -> Pccall caml_string_greaterequal - | Greater_equal, Compare_bytes -> Pccall caml_bytes_greaterequal - | Greater_equal, Compare_nativeints -> Pbintcomp(Pnativeint, Cge) - | Greater_equal, Compare_int32s -> Pbintcomp(Pint32, Cge) - | Greater_equal, Compare_int64s -> Pbintcomp(Pint64, Cge) - | Greater_than, Compare_generic -> Pccall caml_greaterthan - | Greater_than, Compare_ints -> Pintcomp Cgt - | Greater_than, Compare_floats -> Pfloatcomp CFgt - | Greater_than, Compare_strings -> Pccall caml_string_greaterthan - | Greater_than, Compare_bytes -> Pccall caml_bytes_greaterthan - | Greater_than, Compare_nativeints -> Pbintcomp(Pnativeint, Cgt) - | Greater_than, Compare_int32s -> Pbintcomp(Pint32, Cgt) - | Greater_than, Compare_int64s -> Pbintcomp(Pint64, Cgt) - | Compare, Compare_generic -> Pccall caml_compare - | Compare, Compare_ints -> Pccall caml_int_compare - | Compare, Compare_floats -> Pccall caml_float_compare - | Compare, Compare_strings -> Pccall caml_string_compare - | Compare, Compare_bytes -> Pccall caml_bytes_compare - | Compare, Compare_nativeints -> Pccall caml_nativeint_compare - | Compare, Compare_int32s -> Pccall caml_int32_compare - | Compare, Compare_int64s -> Pccall caml_int64_compare - -let lambda_of_loc kind loc = - let loc_start = loc.Location.loc_start in - let (file, lnum, cnum) = Location.get_pos_info loc_start in - let file = - if Filename.is_relative file then - file - else - Location.rewrite_absolute_path file in - let enum = loc.Location.loc_end.Lexing.pos_cnum - - loc_start.Lexing.pos_cnum + cnum in - match kind with - | Loc_POS -> - Lconst (Const_block (0, [ - Const_immstring file; - Const_base (Const_int lnum); - Const_base (Const_int cnum); - Const_base (Const_int enum); - ])) - | Loc_FILE -> Lconst (Const_immstring file) - | Loc_MODULE -> - let filename = Filename.basename file in - let name = Env.get_unit_name () in - let module_name = if name = "" then "//"^filename^"//" else name in - Lconst (Const_immstring module_name) - | Loc_LOC -> - let loc = Printf.sprintf "File %S, line %d, characters %d-%d" - file lnum cnum enum in - Lconst (Const_immstring loc) - | Loc_LINE -> Lconst (Const_base (Const_int lnum)) - -let caml_restore_raw_backtrace = - Primitive.simple ~name:"caml_restore_raw_backtrace" ~arity:2 ~alloc:false - -let try_ids = Hashtbl.create 8 - -let add_exception_ident id = - Hashtbl.replace try_ids id () - -let remove_exception_ident id = - Hashtbl.remove try_ids id - -let lambda_of_prim prim_name prim loc args arg_exps = - match prim, args with - | Primitive (prim, arity), args when arity = List.length args -> - Lprim(prim, args, loc) - | External prim, args when prim = prim_sys_argv -> - Lprim(Pccall prim, Lconst (Const_pointer 0) :: args, loc) - | External prim, args -> - Lprim(Pccall prim, args, loc) - | Comparison(comp, knd), ([_;_] as args) -> - let prim = comparison_primitive comp knd in - Lprim(prim, args, loc) - | Raise kind, [arg] -> - let kind = - match kind, arg with - | Raise_regular, Lvar argv when Hashtbl.mem try_ids argv -> - Raise_reraise - | _, _ -> - kind - in - let arg = - match arg_exps with - | None -> arg - | Some [arg_exp] -> event_after arg_exp arg - | Some _ -> assert false - in - Lprim(Praise kind, [arg], loc) - | Raise_with_backtrace, [exn; bt] -> - let vexn = Ident.create_local "exn" in - let raise_arg = - match arg_exps with - | None -> Lvar vexn - | Some [exn_exp; _] -> event_after exn_exp (Lvar vexn) - | Some _ -> assert false - in - Llet(Strict, Pgenval, vexn, exn, - Lsequence(Lprim(Pccall caml_restore_raw_backtrace, - [Lvar vexn; bt], - loc), - Lprim(Praise Raise_reraise, [raise_arg], loc))) - | Lazy_force, [arg] -> - Matching.inline_lazy_force arg Location.none - | Loc kind, [] -> - lambda_of_loc kind loc - | Loc kind, [arg] -> - let lam = lambda_of_loc kind loc in - Lprim(Pmakeblock(0, Immutable, None), [lam; arg], loc) - | Send, [obj; meth] -> - Lsend(Public, meth, obj, [], loc) - | Send_self, [obj; meth] -> - Lsend(Self, meth, obj, [], loc) - | Send_cache, [obj; meth; cache; pos] -> - Lsend(Cached, meth, obj, [cache; pos], loc) - | (Raise _ | Raise_with_backtrace - | Lazy_force | Loc _ | Primitive _ | Comparison _ - | Send | Send_self | Send_cache), _ -> - raise(Error(loc, Wrong_arity_builtin_primitive prim_name)) - -let check_primitive_arity loc p = - let prim = lookup_primitive loc p in - let ok = - match prim with - | Primitive (_,arity) -> arity = p.prim_arity - | External _ -> true - | Comparison _ -> p.prim_arity = 2 - | Raise _ -> p.prim_arity = 1 - | Raise_with_backtrace -> p.prim_arity = 2 - | Lazy_force -> p.prim_arity = 1 - | Loc _ -> p.prim_arity = 1 || p.prim_arity = 0 - | Send | Send_self -> p.prim_arity = 2 - | Send_cache -> p.prim_arity = 4 - in - if not ok then raise(Error(loc, Wrong_arity_builtin_primitive p.prim_name)) - -(* Eta-expand a primitive *) - -let transl_primitive loc p env ty path = - let prim = lookup_primitive_and_mark_used loc p env path in - let has_constant_constructor = false in - let prim = - match specialize_primitive env ty ~has_constant_constructor prim with - | None -> prim - | Some prim -> prim - in - let rec make_params n = - if n <= 0 then [] - else (Ident.create_local "prim", Pgenval) :: make_params (n-1) - in - let params = make_params p.prim_arity in - let args = List.map (fun (id, _) -> Lvar id) params in - let body = lambda_of_prim p.prim_name prim loc args None in - match params with - | [] -> body - | _ -> - Lfunction{ kind = Curried; - params; - return = Pgenval; - attr = default_stub_attribute; - loc = loc; - body = body; } - -(* Determine if a primitive is a Pccall or will be turned later into - a C function call that may raise an exception *) -let primitive_is_ccall = function - | Pccall _ | Pstringrefs | Pbytesrefs | Pbytessets | Parrayrefs _ | - Parraysets _ | Pbigarrayref _ | Pbigarrayset _ | Pduprecord _ | Pdirapply | - Prevapply -> true - | _ -> false - -(* Determine if a primitive should be surrounded by an "after" debug event *) -let primitive_needs_event_after = function - | Primitive (prim,_) -> primitive_is_ccall prim - | External _ -> true - | Comparison(comp, knd) -> - primitive_is_ccall (comparison_primitive comp knd) - | Lazy_force | Send | Send_self | Send_cache -> true - | Raise _ | Raise_with_backtrace | Loc _ -> false - -let transl_primitive_application loc p env ty path exp args arg_exps = - let prim = lookup_primitive_and_mark_used loc p env (Some path) in - let has_constant_constructor = - match arg_exps with - | [_; {exp_desc = Texp_construct(_, {cstr_tag = Cstr_constant _}, _)}] - | [{exp_desc = Texp_construct(_, {cstr_tag = Cstr_constant _}, _)}; _] - | [_; {exp_desc = Texp_variant(_, None)}] - | [{exp_desc = Texp_variant(_, None)}; _] -> true - | _ -> false - in - let prim = - match specialize_primitive env ty ~has_constant_constructor prim with - | None -> prim - | Some prim -> prim - in - let lam = lambda_of_prim p.prim_name prim loc args (Some arg_exps) in - let lam = - if primitive_needs_event_after prim then begin - match exp with - | None -> lam - | Some exp -> event_after exp lam - end else begin - lam - end - in - lam - -(* Error report *) - -open Format - -let report_error ppf = function - | Unknown_builtin_primitive prim_name -> - fprintf ppf "Unknown builtin primitive \"%s\"" prim_name - | Wrong_arity_builtin_primitive prim_name -> - fprintf ppf "Wrong arity for builtin primitive \"%s\"" prim_name - -let () = - Location.register_error_of_exn - (function - | Error (loc, err) -> - Some (Location.error_of_printer ~loc report_error err) - | _ -> - None - ) diff --git a/bytecomp/translprim.mli b/bytecomp/translprim.mli deleted file mode 100644 index abf0f7d589..0000000000 --- a/bytecomp/translprim.mli +++ /dev/null @@ -1,51 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Insertion of debugging events *) - -val event_before : Typedtree.expression -> Lambda.lambda -> Lambda.lambda - -val event_after : Typedtree.expression -> Lambda.lambda -> Lambda.lambda - -(* Translation of primitives *) - -val add_exception_ident : Ident.t -> unit -val remove_exception_ident : Ident.t -> unit - -val clear_used_primitives : unit -> unit -val get_used_primitives: unit -> Path.t list - -val check_primitive_arity : Location.t -> Primitive.description -> unit - -val transl_primitive : - Location.t -> Primitive.description -> Env.t -> - Types.type_expr -> Path.t option -> Lambda.lambda - -val transl_primitive_application : - Location.t -> Primitive.description -> Env.t -> - Types.type_expr -> Path.t -> Typedtree.expression option -> - Lambda.lambda list -> Typedtree.expression list -> Lambda.lambda - -(* Errors *) - -type error = - | Unknown_builtin_primitive of string - | Wrong_arity_builtin_primitive of string - -exception Error of Location.t * error - -open Format - -val report_error : formatter -> error -> unit diff --git a/debugger/.depend b/debugger/.depend index bfbac13596..114bd380e3 100644 --- a/debugger/.depend +++ b/debugger/.depend @@ -286,6 +286,7 @@ main.cmo : \ question.cmi \ program_management.cmi \ primitives.cmi \ + ../typing/persistent_env.cmi \ parameters.cmi \ ../utils/misc.cmi \ loadprinter.cmi \ @@ -293,11 +294,10 @@ main.cmo : \ input_handling.cmi \ frames.cmi \ exec.cmi \ - ../typing/env.cmi \ debugger_config.cmi \ ../utils/config.cmi \ command_line.cmi \ - ../typing/cmi_format.cmi \ + ../file_formats/cmi_format.cmi \ ../utils/clflags.cmi \ checkpoints.cmi main.cmx : \ @@ -308,6 +308,7 @@ main.cmx : \ question.cmx \ program_management.cmx \ primitives.cmx \ + ../typing/persistent_env.cmx \ parameters.cmx \ ../utils/misc.cmx \ loadprinter.cmx \ @@ -315,11 +316,10 @@ main.cmx : \ input_handling.cmx \ frames.cmx \ exec.cmx \ - ../typing/env.cmx \ debugger_config.cmx \ ../utils/config.cmx \ command_line.cmx \ - ../typing/cmi_format.cmx \ + ../file_formats/cmi_format.cmx \ ../utils/clflags.cmx \ checkpoints.cmx parameters.cmo : \ diff --git a/debugger/Makefile b/debugger/Makefile index 5b4b550c4a..1ff7fc25f0 100644 --- a/debugger/Makefile +++ b/debugger/Makefile @@ -34,7 +34,7 @@ DEPFLAGS=-slash DEPINCLUDES=$(INCLUDES) DIRECTORIES=$(UNIXDIR) $(DYNLINKDIR) $(addprefix $(ROOTDIR)/,\ - utils parsing typing bytecomp toplevel) + utils parsing typing bytecomp toplevel driver file_formats lambda) INCLUDES=$(addprefix -I ,$(DIRECTORIES)) @@ -48,16 +48,23 @@ parsing_modules := $(addprefix parsing/,\ typing_modules := $(addprefix typing/,\ ident path types btype primitive typedtree subst predef datarepr \ - cmi_format persistent_env env oprint ctype printtyp mtype envaux) + persistent_env env oprint ctype printtyp mtype envaux) + +file_formats_modules := $(addprefix file_formats/,\ + cmi_format) + +lambda_modules := $(addprefix lambda/,\ + runtimedef) bytecomp_modules := $(addprefix bytecomp/,\ - runtimedef bytesections dll meta symtable opcodes) + bytesections dll meta symtable opcodes) other_compiler_modules := toplevel/genprintval compiler_modules := $(addprefix $(ROOTDIR)/,\ - $(utils_modules) $(parsing_modules) $(typing_modules) \ - $(bytecomp_modules) $(other_compiler_modules)) + $(utils_modules) $(parsing_modules) $(file_formats_modules) \ + $(lambda_modules) \ + $(typing_modules) $(bytecomp_modules) $(other_compiler_modules)) debugger_modules := \ int64ops primitives unix_tools debugger_config parameters lexer \ diff --git a/debugger/dune b/debugger/dune index 9756094370..60813e0c8c 100644 --- a/debugger/dune +++ b/debugger/dune @@ -12,14 +12,16 @@ ;* * ;************************************************************************** -(ocamllex lexer) -(ocamlyacc parser) +; mshinwell: Disabled for now -- otherlibs/dynlink/dune needs fixing first. -(executable - (name main) - (modes byte) - (flags (:standard -w -9)) - (modules_without_implementation parser_aux) - (libraries ocamlcommon ocamltoplevel runtime stdlib unix)) - -(rule (copy main.exe ocamldebug.byte)) +;(ocamllex lexer) +;(ocamlyacc parser) +; +;(executable +; (name main) +; (modes byte) +; (flags (:standard -w -9)) +; (modules_without_implementation parser_aux) +; (libraries ocamlcommon ocamltoplevel runtime stdlib unix)) +; +;(rule (copy main.exe ocamldebug.byte)) diff --git a/driver/optcompile.ml b/driver/optcompile.ml index 3e82b12922..0af391cc5d 100644 --- a/driver/optcompile.ml +++ b/driver/optcompile.ml @@ -49,7 +49,7 @@ let flambda i backend typed = |>> Simplif.simplify_lambda |>> print_if i.ppf_dump Clflags.dump_lambda Printlambda.lambda |> (fun ((module_ident, size), lam) -> - Middle_end.middle_end + Flambda_middle_end.middle_end ~ppf_dump:i.ppf_dump ~prefixname:i.output_prefix ~size @@ -61,7 +61,7 @@ let flambda i backend typed = i.output_prefix ~required_globals ~backend ~ppf_dump:i.ppf_dump; Compilenv.save_unit_info (cmx i)) -let clambda i typed = +let clambda i backend typed = Clflags.use_inlining_arguments_set Clflags.classic_arguments; typed |> Profile.(record transl) @@ -73,7 +73,7 @@ let clambda i typed = { program with Lambda.code } |> print_if i.ppf_dump Clflags.dump_lambda Printlambda.program |> Asmgen.compile_implementation_clambda - i.output_prefix ~ppf_dump:i.ppf_dump; + i.output_prefix ~backend ~ppf_dump:i.ppf_dump; Compilenv.save_unit_info (cmx i)) let implementation ~backend ~source_file ~output_prefix = @@ -81,7 +81,7 @@ let implementation ~backend ~source_file ~output_prefix = Compilenv.reset ?packname:!Clflags.for_package info.module_name; if Config.flambda then flambda info backend typed - else clambda info typed + else clambda info backend typed in with_info ~source_file ~output_prefix ~dump_ext:"cmx" @@ fun info -> Compile_common.implementation info ~backend diff --git a/driver/optcompile.mli b/driver/optcompile.mli index 27cd1e0d6f..9a23b8b239 100644 --- a/driver/optcompile.mli +++ b/driver/optcompile.mli @@ -25,6 +25,7 @@ val implementation: val clambda : Compile_common.info -> + (module Backend_intf.S) -> Typedtree.structure * Typedtree.module_coercion -> unit (** [clambda info typed] applies the regular compilation pipeline to the given typechecked implementation and outputs the resulting files. diff --git a/dune b/dune index 8f3bf409a2..278240475b 100644 --- a/dune +++ b/dune @@ -27,8 +27,12 @@ (copy_files# driver/*.ml{,i}) (copy_files# asmcomp/*.ml{,i}) (copy_files# asmcomp/debug/*.ml{,i}) +(copy_files# file_formats/*.ml{,i}) +(copy_files# lambda/*.ml{,i}) (copy_files# middle_end/*.ml{,i}) -(copy_files# middle_end/base_types/*.ml{,i}) +(copy_files# middle_end/closure/*.ml{,i}) +(copy_files# middle_end/flambda/*.ml{,i}) +(copy_files# middle_end/flambda/base_types/*.ml{,i}) (library (name ocamlcommon) @@ -41,7 +45,7 @@ ;; UTILS config build_path_prefix_map misc identifiable numbers arg_helper clflags profile terminfo ccomp warnings consistbl strongly_connected_components - targetint load_path + targetint load_path int_replace_polymorphic_compare ;; PARSING location longident docstrings syntaxerr ast_helper camlinternalMenhirLib @@ -61,17 +65,20 @@ ; manual update: mli only files annot outcometree - ;; COMP - lambda printlambda semantics_of_primitives switch matching translobj - translattribute translprim translcore translclass translmod simplif - runtimedef meta opcodes bytesections dll symtable pparse main_args compenv - compmisc makedepend compile_common clambda_primitives - printclambda_primitives + ;; lambda/ + debuginfo lambda matching printlambda runtimedef simplif switch + translattribute translclass translcore translmod translobj translprim + + ;; bytecomp/ + meta opcodes bytesections dll symtable + + ;; some of COMP + pparse main_args compenv compmisc makedepend compile_common ; manual update: mli only files cmo_format ; manual update: this is required. instruct - )) + )) (library (name ocamlbytecomp) @@ -79,58 +86,79 @@ (flags (:standard -principal -nostdlib)) (libraries stdlib ocamlcommon) (modules - bytegen printinstr emitcode bytelink bytelibrarian bytepackager errors - compile)) + ;; bytecomp/ + bytegen bytelibrarian bytelink bytepackager emitcode printinstr + + ;; driver/ + errors compile + )) (library - (name ocamloptcomp) + (name ocamlmiddleend) (wrapped false) (flags (:standard -principal -nostdlib)) (libraries stdlib ocamlcommon) (modules_without_implementation - cmxs_format cmx_format x86_ast backend_intf inlining_decision_intf + cmx_format cmxs_format backend_intf inlining_decision_intf simplify_boxed_integer_ops_intf) (modules - ;; ASMCOMP - arch backend_var cmm printcmm reg reg_with_debug_info reg_availability_set - mach proc clambda printclambda export_info export_info_for_pack compilenv - closure traverse_for_exported_symbols build_export_info closure_offsets - flambda_to_clambda import_approx un_anf afl_instrument strmatch cmmgen_state - cmmgen interval printmach selectgen spacetime_profiling selection comballoc - CSEgen CSE liveness spill split interf coloring linscan reloadgen reload - deadcode printlinear linearize available_regs schedgen scheduling - branch_relaxation_intf branch_relaxation emitaux emit asmgen asmlink - asmlibrarian asmpackager opterrors optcompile - ; manual update: mli only files - cmxs_format cmx_format - - ; arch specific files: we always include them even though depending on the - ; target architecture they might not be used. - x86_ast - x86_proc - x86_dsl - x86_gas - x86_masm - - ;; MIDDLE_END - int_replace_polymorphic_compare debuginfo tag linkage_name compilation_unit - internal_variable_names variable mutable_variable id_types set_of_closures_id - set_of_closures_origin closure_element closure_id closure_origin - var_within_closure static_exception export_id symbol pass_wrapper - allocated_const parameter projection flambda flambda_iterators flambda_utils - inlining_cost effect_analysis freshening simple_value_approx lift_code - closure_conversion_aux closure_conversion initialize_symbol_to_let_symbol - lift_let_to_initialize_symbol find_recursive_functions invariant_params - inconstant_idents alias_analysis lift_constants share_constants - simplify_common remove_unused_arguments remove_unused_closure_vars - remove_unused_program_constructs simplify_boxed_integer_ops - simplify_primitives inlining_stats_types inlining_stats - inline_and_simplify_aux remove_free_vars_equal_to_args extract_projections - augment_specialised_args unbox_free_vars_of_closures unbox_specialised_args - unbox_closures inlining_transforms inlining_decision inline_and_simplify - ref_to_variables flambda_invariants middle_end convert_primitives - ; manual update: mli only files - backend_intf inlining_decision_intf simplify_boxed_integer_ops_intf + ;; file_formats/ + cmx_format cmxs_format + + ;; middle_end/ + backend_intf backend_var backend_var clambda clambda_primitives + compilation_unit compilenv convert_primitives internal_variable_names + linkage_name printclambda printclambda_primitives semantics_of_primitives + symbol variable + + ;; middle_end/closure/ + closure + + ;; middle_end/flambda/base_types/ + closure_element closure_id closure_origin export_id id_types mutable_variable + set_of_closures_id set_of_closures_origin static_exception tag + var_within_closure + + ;; middle_end/flambda/ + alias_analysis allocated_const augment_specialised_args build_export_info + closure_conversion closure_conversion_aux closure_offsets effect_analysis + export_info export_info_for_pack extract_projections find_recursive_functions + flambda flambda_invariants flambda_iterators flambda_middle_end + flambda_to_clambda flambda_utils freshening import_approx inconstant_idents + initialize_symbol_to_let_symbol inline_and_simplify inline_and_simplify_aux + inlining_cost inlining_decision inlining_decision_intf inlining_stats + inlining_stats_types inlining_transforms invariant_params lift_code + lift_constants lift_let_to_initialize_symbol parameter pass_wrapper + projection ref_to_variables remove_free_vars_equal_to_args + remove_unused_arguments remove_unused_closure_vars + remove_unused_program_constructs share_constants simple_value_approx + simplify_boxed_integer_ops simplify_boxed_integer_ops_intf simplify_common + simplify_primitives traverse_for_exported_symbols un_anf unbox_closures + unbox_free_vars_of_closures unbox_specialised_args + ) +) + +(library + (name ocamloptcomp) + (wrapped false) + (flags (:standard -principal -nostdlib)) + (libraries stdlib ocamlcommon ocamlmiddleend) + (modules_without_implementation x86_ast) + (modules + ;; asmcomp/ + afl_instrument arch asmgen asmlibrarian asmlink asmpackager branch_relaxation + branch_relaxation_intf cmm cmmgen cmmgen_state coloring comballoc CSE CSEgen + deadcode emit emitaux interf interval linearize linscan liveness mach + printcmm printlinear printmach proc reg reload reloadgen schedgen scheduling + selectgen selection spacetime_profiling spill split strmatch x86_ast + x86_dsl x86_gas x86_masm x86_proc + + ;; asmcomp/debug/ + reg_availability_set compute_ranges_intf available_regs reg_with_debug_info + compute_ranges + + ;; driver/ + optcompile opterrors ) ) @@ -156,7 +184,7 @@ (name optmain) (modes byte) (flags (:standard -principal -nostdlib)) - (libraries ocamloptcomp ocamlcommon runtime stdlib) + (libraries ocamloptcomp ocamlmiddleend ocamlcommon runtime stdlib) (modules optmain)) (rule @@ -166,12 +194,14 @@ ;;; aliases ;;; ;;;;;;;;;;;;;;; +; mshinwell: The debugger and ocamldoc are currently disabled as Dynlink is +; not built correctly. (alias (name world) (deps ocamlc.byte ocamlopt.byte - debugger/ocamldebug.byte - ocamldoc/ocamldoc.byte +; debugger/ocamldebug.byte +; ocamldoc/ocamldoc.byte ocamltest/ocamltest.byte toplevel/ocaml.byte toplevel/expunge.exe diff --git a/file_formats/cmi_format.ml b/file_formats/cmi_format.ml new file mode 100644 index 0000000000..a98520a8a6 --- /dev/null +++ b/file_formats/cmi_format.ml @@ -0,0 +1,111 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* *) +(* Copyright 2012 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 Misc + +type pers_flags = + | Rectypes + | Alerts of alerts + | Opaque + | Unsafe_string + +type error = + | Not_an_interface of filepath + | Wrong_version_interface of filepath * string + | Corrupted_interface of filepath + +exception Error of error + +type cmi_infos = { + cmi_name : Misc.modname; + cmi_sign : Types.signature_item list; + cmi_crcs : crcs; + cmi_flags : pers_flags list; +} + +let input_cmi ic = + let (name, sign) = input_value ic in + let crcs = input_value ic in + let flags = input_value ic in + { + cmi_name = name; + cmi_sign = sign; + cmi_crcs = crcs; + cmi_flags = flags; + } + +let read_cmi filename = + let ic = open_in_bin filename in + try + let buffer = + really_input_string ic (String.length Config.cmi_magic_number) + in + if buffer <> Config.cmi_magic_number then begin + close_in ic; + let pre_len = String.length Config.cmi_magic_number - 3 in + if String.sub buffer 0 pre_len + = String.sub Config.cmi_magic_number 0 pre_len then + begin + let msg = + if buffer < Config.cmi_magic_number then "an older" else "a newer" in + raise (Error (Wrong_version_interface (filename, msg))) + end else begin + raise(Error(Not_an_interface filename)) + end + end; + let cmi = input_cmi ic in + close_in ic; + cmi + with End_of_file | Failure _ -> + close_in ic; + raise(Error(Corrupted_interface(filename))) + | Error e -> + close_in ic; + raise (Error e) + +let output_cmi filename oc cmi = +(* beware: the provided signature must have been substituted for saving *) + output_string oc Config.cmi_magic_number; + output_value oc (cmi.cmi_name, cmi.cmi_sign); + flush oc; + let crc = Digest.file filename in + let crcs = (cmi.cmi_name, Some crc) :: cmi.cmi_crcs in + output_value oc crcs; + output_value oc cmi.cmi_flags; + crc + +(* Error report *) + +open Format + +let report_error ppf = function + | Not_an_interface filename -> + fprintf ppf "%a@ is not a compiled interface" + Location.print_filename filename + | Wrong_version_interface (filename, older_newer) -> + fprintf ppf + "%a@ is not a compiled interface for this version of OCaml.@.\ + It seems to be for %s version of OCaml." + Location.print_filename filename older_newer + | Corrupted_interface filename -> + fprintf ppf "Corrupted compiled interface@ %a" + Location.print_filename filename + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) diff --git a/file_formats/cmi_format.mli b/file_formats/cmi_format.mli new file mode 100644 index 0000000000..d4d665fdf5 --- /dev/null +++ b/file_formats/cmi_format.mli @@ -0,0 +1,51 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* *) +(* Copyright 2012 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 Misc + +type pers_flags = + | Rectypes + | Alerts of alerts + | Opaque + | Unsafe_string + +type cmi_infos = { + cmi_name : modname; + cmi_sign : Types.signature_item list; + cmi_crcs : crcs; + cmi_flags : pers_flags list; +} + +(* write the magic + the cmi information *) +val output_cmi : string -> out_channel -> cmi_infos -> Digest.t + +(* read the cmi information (the magic is supposed to have already been read) *) +val input_cmi : in_channel -> cmi_infos + +(* read a cmi from a filename, checking the magic *) +val read_cmi : string -> cmi_infos + +(* Error report *) + +type error = + | Not_an_interface of filepath + | Wrong_version_interface of filepath * string + | Corrupted_interface of filepath + +exception Error of error + +open Format + +val report_error: formatter -> error -> unit diff --git a/file_formats/cmo_format.mli b/file_formats/cmo_format.mli new file mode 100644 index 0000000000..d953a8817a --- /dev/null +++ b/file_formats/cmo_format.mli @@ -0,0 +1,66 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, 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. *) +(* *) +(**************************************************************************) + +(* Symbol table information for .cmo and .cma files *) + +open Misc + +(* Relocation information *) + +type reloc_info = + Reloc_literal of Lambda.structured_constant (* structured constant *) + | Reloc_getglobal of Ident.t (* reference to a global *) + | Reloc_setglobal of Ident.t (* definition of a global *) + | Reloc_primitive of string (* C primitive number *) + +(* Descriptor for compilation units *) + +type compilation_unit = + { cu_name: modname; (* Name of compilation unit *) + mutable cu_pos: int; (* Absolute position in file *) + cu_codesize: int; (* Size of code block *) + cu_reloc: (reloc_info * int) list; (* Relocation information *) + cu_imports: crcs; (* Names and CRC of intfs imported *) + cu_required_globals: Ident.t list; (* Compilation units whose + initialization side effects + must occur before this one. *) + cu_primitives: string list; (* Primitives declared inside *) + mutable cu_force_link: bool; (* Must be linked even if unref'ed *) + mutable cu_debug: int; (* Position of debugging info, or 0 *) + cu_debugsize: int } (* Length of debugging info *) + +(* Format of a .cmo file: + magic number (Config.cmo_magic_number) + absolute offset of compilation unit descriptor + block of relocatable bytecode + debugging information if any + compilation unit descriptor *) + +(* Descriptor for libraries *) + +type library = + { lib_units: compilation_unit list; (* List of compilation units *) + lib_custom: bool; (* Requires custom mode linking? *) + lib_ccobjs: string list; (* C object files needed for -custom *) + lib_ccopts: string list; (* Extra opts to C compiler *) + lib_dllibs: string list } (* DLLs needed *) + +(* Format of a .cma file: + magic number (Config.cma_magic_number) + absolute offset of library descriptor + object code for first library member + ... + object code for last library member + library descriptor *) diff --git a/file_formats/cmt_format.ml b/file_formats/cmt_format.ml new file mode 100644 index 0000000000..09c787d966 --- /dev/null +++ b/file_formats/cmt_format.ml @@ -0,0 +1,194 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* *) +(* Copyright 2012 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 Cmi_format +open Typedtree + +(* Note that in Typerex, there is an awful hack to save a cmt file + together with the interface file that was generated by ocaml (this + is because the installed version of ocaml might differ from the one + integrated in Typerex). +*) + + + +let read_magic_number ic = + let len_magic_number = String.length Config.cmt_magic_number in + really_input_string ic len_magic_number + +type binary_annots = + | Packed of Types.signature * string list + | Implementation of structure + | Interface of signature + | Partial_implementation of binary_part array + | Partial_interface of binary_part array + +and binary_part = +| Partial_structure of structure +| Partial_structure_item of structure_item +| Partial_expression of expression +| Partial_pattern of pattern +| Partial_class_expr of class_expr +| Partial_signature of signature +| Partial_signature_item of signature_item +| Partial_module_type of module_type + +type cmt_infos = { + cmt_modname : string; + cmt_annots : binary_annots; + cmt_value_dependencies : + (Types.value_description * Types.value_description) list; + cmt_comments : (string * Location.t) list; + cmt_args : string array; + cmt_sourcefile : string option; + cmt_builddir : string; + cmt_loadpath : string list; + cmt_source_digest : Digest.t option; + cmt_initial_env : Env.t; + cmt_imports : (string * Digest.t option) list; + cmt_interface_digest : Digest.t option; + cmt_use_summaries : bool; +} + +type error = + Not_a_typedtree of string + +let need_to_clear_env = + try ignore (Sys.getenv "OCAML_BINANNOT_WITHENV"); false + with Not_found -> true + +let keep_only_summary = Env.keep_only_summary + +open Tast_mapper + +let cenv = + {Tast_mapper.default with env = fun _sub env -> keep_only_summary env} + +let clear_part = function + | Partial_structure s -> Partial_structure (cenv.structure cenv s) + | Partial_structure_item s -> + Partial_structure_item (cenv.structure_item cenv s) + | Partial_expression e -> Partial_expression (cenv.expr cenv e) + | Partial_pattern p -> Partial_pattern (cenv.pat cenv p) + | Partial_class_expr ce -> Partial_class_expr (cenv.class_expr cenv ce) + | Partial_signature s -> Partial_signature (cenv.signature cenv s) + | Partial_signature_item s -> + Partial_signature_item (cenv.signature_item cenv s) + | Partial_module_type s -> Partial_module_type (cenv.module_type cenv s) + +let clear_env binary_annots = + if need_to_clear_env then + match binary_annots with + | Implementation s -> Implementation (cenv.structure cenv s) + | Interface s -> Interface (cenv.signature cenv s) + | Packed _ -> binary_annots + | Partial_implementation array -> + Partial_implementation (Array.map clear_part array) + | Partial_interface array -> + Partial_interface (Array.map clear_part array) + + else binary_annots + +exception Error of error + +let input_cmt ic = (input_value ic : cmt_infos) + +let output_cmt oc cmt = + output_string oc Config.cmt_magic_number; + output_value oc (cmt : cmt_infos) + +let read filename = +(* Printf.fprintf stderr "Cmt_format.read %s\n%!" filename; *) + let ic = open_in_bin filename in + Misc.try_finally + ~always:(fun () -> close_in ic) + (fun () -> + let magic_number = read_magic_number ic in + let cmi, cmt = + if magic_number = Config.cmt_magic_number then + None, Some (input_cmt ic) + else if magic_number = Config.cmi_magic_number then + let cmi = Cmi_format.input_cmi ic in + let cmt = try + let magic_number = read_magic_number ic in + if magic_number = Config.cmt_magic_number then + let cmt = input_cmt ic in + Some cmt + else None + with _ -> None + in + Some cmi, cmt + else + raise(Cmi_format.Error(Cmi_format.Not_an_interface filename)) + in + cmi, cmt + ) + +let read_cmt filename = + match read filename with + _, None -> raise (Error (Not_a_typedtree filename)) + | _, Some cmt -> cmt + +let read_cmi filename = + match read filename with + None, _ -> + raise (Cmi_format.Error (Cmi_format.Not_an_interface filename)) + | Some cmi, _ -> cmi + +let saved_types = ref [] +let value_deps = ref [] + +let clear () = + saved_types := []; + value_deps := [] + +let add_saved_type b = saved_types := b :: !saved_types +let get_saved_types () = !saved_types +let set_saved_types l = saved_types := l + +let record_value_dependency vd1 vd2 = + if vd1.Types.val_loc <> vd2.Types.val_loc then + value_deps := (vd1, vd2) :: !value_deps + +let save_cmt filename modname binary_annots sourcefile initial_env cmi = + if !Clflags.binary_annotations && not !Clflags.print_types then begin + Misc.output_to_file_via_temporary + ~mode:[Open_binary] filename + (fun temp_file_name oc -> + let this_crc = + match cmi with + | None -> None + | Some cmi -> Some (output_cmi temp_file_name oc cmi) + in + let source_digest = Misc.may_map Digest.file sourcefile in + let cmt = { + cmt_modname = modname; + cmt_annots = clear_env binary_annots; + cmt_value_dependencies = !value_deps; + cmt_comments = Lexer.comments (); + cmt_args = Sys.argv; + cmt_sourcefile = sourcefile; + cmt_builddir = Location.rewrite_absolute_path (Sys.getcwd ()); + cmt_loadpath = Load_path.get_paths (); + cmt_source_digest = source_digest; + cmt_initial_env = if need_to_clear_env then + keep_only_summary initial_env else initial_env; + cmt_imports = List.sort compare (Env.imports ()); + cmt_interface_digest = this_crc; + cmt_use_summaries = need_to_clear_env; + } in + output_cmt oc cmt) + end; + clear () diff --git a/file_formats/cmt_format.mli b/file_formats/cmt_format.mli new file mode 100644 index 0000000000..7649de7b6e --- /dev/null +++ b/file_formats/cmt_format.mli @@ -0,0 +1,123 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* *) +(* Copyright 2012 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. *) +(* *) +(**************************************************************************) + +(** cmt and cmti files format. *) + +open Misc + +(** The layout of a cmt file is as follows: + := \{\} \{cmt infos\} \{\} + where is the cmi file format: + := . + More precisely, the optional part must be present if and only if + the file is: + - a cmti, or + - a cmt, for a ml file which has no corresponding mli (hence no + corresponding cmti). + + Thus, we provide a common reading function for cmi and cmt(i) + files which returns an option for each of the three parts: cmi + info, cmt info, source info. *) + +open Typedtree + +type binary_annots = + | Packed of Types.signature * string list + | Implementation of structure + | Interface of signature + | Partial_implementation of binary_part array + | Partial_interface of binary_part array + +and binary_part = + | Partial_structure of structure + | Partial_structure_item of structure_item + | Partial_expression of expression + | Partial_pattern of pattern + | Partial_class_expr of class_expr + | Partial_signature of signature + | Partial_signature_item of signature_item + | Partial_module_type of module_type + +type cmt_infos = { + cmt_modname : modname; + cmt_annots : binary_annots; + cmt_value_dependencies : + (Types.value_description * Types.value_description) list; + cmt_comments : (string * Location.t) list; + cmt_args : string array; + cmt_sourcefile : string option; + cmt_builddir : string; + cmt_loadpath : string list; + cmt_source_digest : string option; + cmt_initial_env : Env.t; + cmt_imports : crcs; + cmt_interface_digest : Digest.t option; + cmt_use_summaries : bool; +} + +type error = + Not_a_typedtree of string + +exception Error of error + +(** [read filename] opens filename, and extract both the cmi_infos, if + it exists, and the cmt_infos, if it exists. Thus, it can be used + with .cmi, .cmt and .cmti files. + + .cmti files always contain a cmi_infos at the beginning. .cmt files + only contain a cmi_infos at the beginning if there is no associated + .cmti file. +*) +val read : string -> Cmi_format.cmi_infos option * cmt_infos option + +val read_cmt : string -> cmt_infos +val read_cmi : string -> Cmi_format.cmi_infos + +(** [save_cmt filename modname binary_annots sourcefile initial_env cmi] + writes a cmt(i) file. *) +val save_cmt : + string -> (* filename.cmt to generate *) + string -> (* module name *) + binary_annots -> + string option -> (* source file *) + Env.t -> (* initial env *) + Cmi_format.cmi_infos option -> (* if a .cmi was generated *) + unit + +(* Miscellaneous functions *) + +val read_magic_number : in_channel -> string + +val clear: unit -> unit + +val add_saved_type : binary_part -> unit +val get_saved_types : unit -> binary_part list +val set_saved_types : binary_part list -> unit + +val record_value_dependency: + Types.value_description -> Types.value_description -> unit + + +(* + + val is_magic_number : string -> bool + val read : in_channel -> Env.cmi_infos option * t + val write_magic_number : out_channel -> unit + val write : out_channel -> t -> unit + + val find : string list -> string -> string + val read_signature : 'a -> string -> Types.signature * 'b list * 'c list + +*) diff --git a/file_formats/cmx_format.mli b/file_formats/cmx_format.mli new file mode 100644 index 0000000000..0efa32eec3 --- /dev/null +++ b/file_formats/cmx_format.mli @@ -0,0 +1,56 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Format of .cmx, .cmxa and .cmxs files *) + +open Misc + +(* Each .o file has a matching .cmx file that provides the following infos + on the compilation unit: + - list of other units imported, with MD5s of their .cmx files + - approximation of the structure implemented + (includes descriptions of known functions: arity and direct entry + points) + - list of currying functions and application functions needed + The .cmx file contains these infos (as an externed record) plus a MD5 + of these infos *) + +type export_info = + | Clambda of Clambda.value_approximation + | Flambda of Export_info.t + +type unit_infos = + { mutable ui_name: modname; (* Name of unit implemented *) + mutable ui_symbol: string; (* Prefix for symbols *) + mutable ui_defines: string list; (* Unit and sub-units implemented *) + mutable ui_imports_cmi: crcs; (* Interfaces imported *) + mutable ui_imports_cmx: crcs; (* Infos imported *) + mutable ui_curry_fun: int list; (* Currying functions needed *) + mutable ui_apply_fun: int list; (* Apply functions needed *) + mutable ui_send_fun: int list; (* Send functions needed *) + mutable ui_export_info: export_info; + mutable ui_force_link: bool } (* Always linked *) + +(* Each .a library has a matching .cmxa file that provides the following + infos on the library: *) + +type library_infos = + { lib_units: (unit_infos * Digest.t) list; (* List of unit infos w/ MD5s *) + lib_ccobjs: string list; (* C object files needed *) + lib_ccopts: string list } (* Extra opts to C compiler *) diff --git a/file_formats/cmxs_format.mli b/file_formats/cmxs_format.mli new file mode 100644 index 0000000000..c670024f92 --- /dev/null +++ b/file_formats/cmxs_format.mli @@ -0,0 +1,35 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2010 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. *) +(* *) +(**************************************************************************) + +(* Format of .cmxs files *) + +open Misc + +(* Each .cmxs dynamically-loaded plugin contains a symbol + "caml_plugin_header" containing the following info + (as an externed record) *) + +type dynunit = { + dynu_name: modname; + dynu_crc: Digest.t; + dynu_imports_cmi: crcs; + dynu_imports_cmx: crcs; + dynu_defines: string list; +} + +type dynheader = { + dynu_magic: string; + dynu_units: dynunit list; +} diff --git a/lambda/debuginfo.ml b/lambda/debuginfo.ml new file mode 100644 index 0000000000..7a33902222 --- /dev/null +++ b/lambda/debuginfo.ml @@ -0,0 +1,145 @@ +(**************************************************************************) +(* *) +(* 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/lambda/debuginfo.mli b/lambda/debuginfo.mli new file mode 100644 index 0000000000..4dc5e59906 --- /dev/null +++ b/lambda/debuginfo.mli @@ -0,0 +1,46 @@ +(**************************************************************************) +(* *) +(* 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/lambda/dune b/lambda/dune new file mode 100644 index 0000000000..034cdc3bd4 --- /dev/null +++ b/lambda/dune @@ -0,0 +1,21 @@ +;************************************************************************** +;* * +;* OCaml * +;* * +;* Thomas Refis, 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. * +;* * +;************************************************************************** + +(rule + (targets runtimedef.ml) + (mode fallback) + (deps (:fail (file ../runtime/caml/fail.h)) + (:prim (file ../runtime/primitives))) + (action (with-stdout-to %{targets} + (run ./generate_runtimedef.sh %{fail} %{prim})))) diff --git a/lambda/generate_runtimedef.sh b/lambda/generate_runtimedef.sh new file mode 100755 index 0000000000..66ccf3ce5d --- /dev/null +++ b/lambda/generate_runtimedef.sh @@ -0,0 +1,25 @@ +#!/bin/sh + +#************************************************************************** +#* * +#* OCaml * +#* * +#* Xavier Leroy, projet Cristal, INRIA Rocquencourt * +#* * +#* Copyright 1999 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. * +#* * +#************************************************************************** + +echo 'let builtin_exceptions = [|' +cat "$1" | tr -d '\r' | \ + sed -n -e 's|.*/\* \("[A-Za-z_]*"\) \*/$| \1;|p' +echo '|]' + +echo 'let builtin_primitives = [|' +sed -e 's/.*/ "&";/' "$2" +echo '|]' diff --git a/lambda/lambda.ml b/lambda/lambda.ml new file mode 100644 index 0000000000..f06d9a820d --- /dev/null +++ b/lambda/lambda.ml @@ -0,0 +1,886 @@ +(**************************************************************************) +(* *) +(* 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 Misc +open Asttypes + +type compile_time_constant = + | Big_endian + | Word_size + | Int_size + | Max_wosize + | Ostype_unix + | Ostype_win32 + | Ostype_cygwin + | Backend_type + +type immediate_or_pointer = + | Immediate + | Pointer + +type initialization_or_assignment = + | Assignment + | Heap_initialization + | Root_initialization + +type is_safe = + | Safe + | Unsafe + +type primitive = + | Pidentity + | Pbytes_to_string + | Pbytes_of_string + | Pignore + | Prevapply + | Pdirapply + (* Globals *) + | Pgetglobal of Ident.t + | Psetglobal of Ident.t + (* 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 + (* Force lazy values *) + (* 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 + | 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 Bigarrays: (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 Bigarray *) + | Pbigarraydim of int + (* load/set 16,32,64 bits from a string: (unsafe)*) + | Pstring_load_16 of bool + | Pstring_load_32 of bool + | Pstring_load_64 of bool + | Pbytes_load_16 of bool + | Pbytes_load_32 of bool + | Pbytes_load_64 of bool + | Pbytes_set_16 of bool + | Pbytes_set_32 of bool + | Pbytes_set_64 of bool + (* load/set 16,32,64 bits from a + (char, int8_unsigned_elt, c_layout) Bigarray.Array1.t : (unsafe) *) + | Pbigstring_load_16 of bool + | Pbigstring_load_32 of bool + | Pbigstring_load_64 of bool + | Pbigstring_set_16 of bool + | Pbigstring_set_32 of bool + | Pbigstring_set_64 of bool + (* Compile time constants *) + | Pctconst of compile_time_constant + (* byte swap *) + | Pbswap16 + | Pbbswap of boxed_integer + (* Integer to external pointer *) + | Pint_as_pointer + (* Inhibition of optimisation *) + | Popaque + +and integer_comparison = + Ceq | Cne | Clt | Cgt | Cle | Cge + +and float_comparison = + CFeq | CFneq | CFlt | CFnlt | CFgt | CFngt | CFle | CFnle | CFge | CFnge + +and value_kind = + Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval + +and block_shape = + value_kind list option + +and array_kind = + Pgenarray | Paddrarray | Pintarray | Pfloatarray + +and boxed_integer = Primitive.boxed_integer = + Pnativeint | Pint32 | Pint64 + +and 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 = + Pbigarray_unknown_layout + | Pbigarray_c_layout + | Pbigarray_fortran_layout + +and raise_kind = + | Raise_regular + | Raise_reraise + | Raise_notrace + +let equal_boxed_integer x y = + match x, y with + | Pnativeint, Pnativeint + | Pint32, Pint32 + | Pint64, Pint64 -> + true + | (Pnativeint | Pint32 | Pint64), _ -> + false + +let equal_primitive = + (* Should be implemented like [equal_value_kind] of [equal_boxed_integer], + i.e. by matching over the various constructors but the type has more + than 100 constructors... *) + (=) + +let equal_value_kind x y = + match x, y with + | Pgenval, Pgenval -> true + | Pfloatval, Pfloatval -> true + | Pboxedintval bi1, Pboxedintval bi2 -> equal_boxed_integer bi1 bi2 + | Pintval, Pintval -> true + | (Pgenval | Pfloatval | Pboxedintval _ | Pintval), _ -> false + + +type structured_constant = + Const_base of constant + | Const_pointer of int + | Const_block of int * structured_constant list + | Const_float_array of string list + | Const_immstring of string + +type inline_attribute = + | Always_inline (* [@inline] or [@inline always] *) + | Never_inline (* [@inline never] *) + | Unroll of int (* [@unroll x] *) + | Default_inline (* no [@inline] attribute *) + +let equal_inline_attribute x y = + match x, y with + | Always_inline, Always_inline + | Never_inline, Never_inline + | Default_inline, Default_inline + -> + true + | Unroll u, Unroll v -> + u = v + | (Always_inline | Never_inline | Unroll _ | Default_inline), _ -> + false + +type specialise_attribute = + | Always_specialise (* [@specialise] or [@specialise always] *) + | Never_specialise (* [@specialise never] *) + | Default_specialise (* no [@specialise] attribute *) + +let equal_specialise_attribute x y = + match x, y with + | Always_specialise, Always_specialise + | Never_specialise, Never_specialise + | Default_specialise, Default_specialise -> + true + | (Always_specialise | Never_specialise | Default_specialise), _ -> + false + +type local_attribute = + | Always_local (* [@local] or [@local always] *) + | Never_local (* [@local never] *) + | Default_local (* [@local maybe] or no [@local] attribute *) + +type function_kind = Curried | Tupled + +type let_kind = Strict | Alias | StrictOpt | Variable + +type meth_kind = Self | Public | Cached + +let equal_meth_kind x y = + match x, y with + | Self, Self -> true + | Public, Public -> true + | Cached, Cached -> true + | (Self | Public | Cached), _ -> false + +type shared_code = (int * int) list + +type function_attribute = { + inline : inline_attribute; + specialise : specialise_attribute; + local: local_attribute; + is_a_functor: bool; + stub: bool; +} + +type lambda = + Lvar of Ident.t + | Lconst of structured_constant + | Lapply of lambda_apply + | Lfunction of lfunction + | Llet of let_kind * value_kind * Ident.t * lambda * lambda + | Lletrec of (Ident.t * lambda) list * lambda + | Lprim of primitive * lambda list * Location.t + | Lswitch of lambda * lambda_switch * Location.t + | Lstringswitch of + lambda * (string * lambda) list * lambda option * Location.t + | Lstaticraise of int * lambda list + | Lstaticcatch of lambda * (int * (Ident.t * value_kind) list) * lambda + | Ltrywith of lambda * Ident.t * lambda + | Lifthenelse of lambda * lambda * lambda + | Lsequence of lambda * lambda + | Lwhile of lambda * lambda + | Lfor of Ident.t * lambda * lambda * direction_flag * lambda + | Lassign of Ident.t * lambda + | Lsend of meth_kind * lambda * lambda * lambda list * Location.t + | Levent of lambda * lambda_event + | Lifused of Ident.t * lambda + +and lfunction = + { kind: function_kind; + params: (Ident.t * value_kind) list; + return: value_kind; + body: lambda; + attr: function_attribute; (* specified with [@inline] attribute *) + loc: Location.t; } + +and lambda_apply = + { ap_func : lambda; + ap_args : lambda list; + ap_loc : Location.t; + ap_should_be_tailcall : bool; + ap_inlined : inline_attribute; + ap_specialised : specialise_attribute; } + +and lambda_switch = + { sw_numconsts: int; + sw_consts: (int * lambda) list; + sw_numblocks: int; + sw_blocks: (int * lambda) list; + sw_failaction : lambda option} + +and lambda_event = + { lev_loc: Location.t; + lev_kind: lambda_event_kind; + lev_repr: int ref option; + lev_env: Env.t } + +and lambda_event_kind = + Lev_before + | Lev_after of Types.type_expr + | Lev_function + | Lev_pseudo + | Lev_module_definition of Ident.t + +type program = + { module_ident : Ident.t; + main_module_block_size : int; + required_globals : Ident.Set.t; + code : lambda } + +let const_unit = Const_pointer 0 + +let lambda_unit = Lconst const_unit + +let default_function_attribute = { + inline = Default_inline; + specialise = Default_specialise; + local = Default_local; + is_a_functor = false; + stub = false; +} + +let default_stub_attribute = + { default_function_attribute with stub = true } + +(* Build sharing keys *) +(* + Those keys are later compared with Stdlib.compare. + For that reason, they should not include cycles. +*) + +exception Not_simple + +let max_raw = 32 + +let make_key e = + let count = ref 0 (* Used for controlling size *) + and make_key = Ident.make_key_generator () in + (* make_key is used for normalizing let-bound variables *) + let rec tr_rec env e = + incr count ; + if !count > max_raw then raise Not_simple ; (* Too big ! *) + match e with + | Lvar id -> + begin + try Ident.find_same id env + with Not_found -> e + end + | Lconst (Const_base (Const_string _)) -> + (* Mutable constants are not shared *) + raise Not_simple + | Lconst _ -> e + | Lapply ap -> + Lapply {ap with ap_func = tr_rec env ap.ap_func; + ap_args = tr_recs env ap.ap_args; + ap_loc = Location.none} + | Llet (Alias,_k,x,ex,e) -> (* Ignore aliases -> substitute *) + let ex = tr_rec env ex in + tr_rec (Ident.add x ex env) e + | Llet ((Strict | StrictOpt),_k,x,ex,Lvar v) when Ident.same v x -> + tr_rec env ex + | Llet (str,k,x,ex,e) -> + (* Because of side effects, keep other lets with normalized names *) + let ex = tr_rec env ex in + let y = make_key x in + Llet (str,k,y,ex,tr_rec (Ident.add x (Lvar y) env) e) + | Lprim (p,es,_) -> + Lprim (p,tr_recs env es, Location.none) + | Lswitch (e,sw,loc) -> + Lswitch (tr_rec env e,tr_sw env sw,loc) + | Lstringswitch (e,sw,d,_) -> + Lstringswitch + (tr_rec env e, + List.map (fun (s,e) -> s,tr_rec env e) sw, + tr_opt env d, + Location.none) + | Lstaticraise (i,es) -> + Lstaticraise (i,tr_recs env es) + | Lstaticcatch (e1,xs,e2) -> + Lstaticcatch (tr_rec env e1,xs,tr_rec env e2) + | Ltrywith (e1,x,e2) -> + Ltrywith (tr_rec env e1,x,tr_rec env e2) + | Lifthenelse (cond,ifso,ifnot) -> + Lifthenelse (tr_rec env cond,tr_rec env ifso,tr_rec env ifnot) + | Lsequence (e1,e2) -> + Lsequence (tr_rec env e1,tr_rec env e2) + | Lassign (x,e) -> + Lassign (x,tr_rec env e) + | Lsend (m,e1,e2,es,_loc) -> + Lsend (m,tr_rec env e1,tr_rec env e2,tr_recs env es,Location.none) + | Lifused (id,e) -> Lifused (id,tr_rec env e) + | Lletrec _|Lfunction _ + | Lfor _ | Lwhile _ +(* Beware: (PR#6412) the event argument to Levent + may include cyclic structure of type Type.typexpr *) + | Levent _ -> + raise Not_simple + + and tr_recs env es = List.map (tr_rec env) es + + and tr_sw env sw = + { sw with + sw_consts = List.map (fun (i,e) -> i,tr_rec env e) sw.sw_consts ; + sw_blocks = List.map (fun (i,e) -> i,tr_rec env e) sw.sw_blocks ; + sw_failaction = tr_opt env sw.sw_failaction ; } + + and tr_opt env = function + | None -> None + | Some e -> Some (tr_rec env e) in + + try + Some (tr_rec Ident.empty e) + with Not_simple -> None + +(***************) + +let name_lambda strict arg fn = + match arg with + Lvar id -> fn id + | _ -> + let id = Ident.create_local "let" in + Llet(strict, Pgenval, id, arg, fn id) + +let name_lambda_list args fn = + let rec name_list names = function + [] -> fn (List.rev names) + | (Lvar _ as arg) :: rem -> + name_list (arg :: names) rem + | arg :: rem -> + let id = Ident.create_local "let" in + Llet(Strict, Pgenval, id, arg, name_list (Lvar id :: names) rem) in + name_list [] args + + +let iter_opt f = function + | None -> () + | Some e -> f e + +let shallow_iter ~tail ~non_tail:f = function + Lvar _ + | Lconst _ -> () + | Lapply{ap_func = fn; ap_args = args} -> + f fn; List.iter f args + | Lfunction{body} -> + f body + | Llet(_str, _k, _id, arg, body) -> + f arg; tail body + | Lletrec(decl, body) -> + tail body; + List.iter (fun (_id, exp) -> f exp) decl + | Lprim (Pidentity, [l], _) -> + tail l + | Lprim (Psequand, [l1; l2], _) + | Lprim (Psequor, [l1; l2], _) -> + f l1; + tail l2 + | Lprim(_p, args, _loc) -> + List.iter f args + | Lswitch(arg, sw,_) -> + f arg; + List.iter (fun (_key, case) -> tail case) sw.sw_consts; + List.iter (fun (_key, case) -> tail case) sw.sw_blocks; + iter_opt tail sw.sw_failaction + | Lstringswitch (arg,cases,default,_) -> + f arg ; + List.iter (fun (_,act) -> tail act) cases ; + iter_opt tail default + | Lstaticraise (_,args) -> + List.iter f args + | Lstaticcatch(e1, _, e2) -> + tail e1; tail e2 + | Ltrywith(e1, _, e2) -> + f e1; tail e2 + | Lifthenelse(e1, e2, e3) -> + f e1; tail e2; tail e3 + | Lsequence(e1, e2) -> + f e1; tail e2 + | Lwhile(e1, e2) -> + f e1; f e2 + | Lfor(_v, e1, e2, _dir, e3) -> + f e1; f e2; f e3 + | Lassign(_, e) -> + f e + | Lsend (_k, met, obj, args, _) -> + List.iter f (met::obj::args) + | Levent (e, _evt) -> + tail e + | Lifused (_v, e) -> + tail e + +let iter_head_constructor f l = + shallow_iter ~tail:f ~non_tail:f l + +let rec free_variables = function + | Lvar id -> Ident.Set.singleton id + | Lconst _ -> Ident.Set.empty + | Lapply{ap_func = fn; ap_args = args} -> + free_variables_list (free_variables fn) args + | Lfunction{body; params} -> + Ident.Set.diff (free_variables body) + (Ident.Set.of_list (List.map fst params)) + | Llet(_str, _k, id, arg, body) -> + Ident.Set.union + (free_variables arg) + (Ident.Set.remove id (free_variables body)) + | Lletrec(decl, body) -> + let set = free_variables_list (free_variables body) (List.map snd decl) in + Ident.Set.diff set (Ident.Set.of_list (List.map fst decl)) + | Lprim(_p, args, _loc) -> + free_variables_list Ident.Set.empty args + | Lswitch(arg, sw,_) -> + let set = + free_variables_list + (free_variables_list (free_variables arg) + (List.map snd sw.sw_consts)) + (List.map snd sw.sw_blocks) + in + begin match sw.sw_failaction with + | None -> set + | Some failaction -> Ident.Set.union set (free_variables failaction) + end + | Lstringswitch (arg,cases,default,_) -> + let set = + free_variables_list (free_variables arg) + (List.map snd cases) + in + begin match default with + | None -> set + | Some default -> Ident.Set.union set (free_variables default) + end + | Lstaticraise (_,args) -> + free_variables_list Ident.Set.empty args + | Lstaticcatch(body, (_, params), handler) -> + Ident.Set.union + (Ident.Set.diff + (free_variables handler) + (Ident.Set.of_list (List.map fst params))) + (free_variables body) + | Ltrywith(body, param, handler) -> + Ident.Set.union + (Ident.Set.remove + param + (free_variables handler)) + (free_variables body) + | Lifthenelse(e1, e2, e3) -> + Ident.Set.union + (Ident.Set.union (free_variables e1) (free_variables e2)) + (free_variables e3) + | Lsequence(e1, e2) -> + Ident.Set.union (free_variables e1) (free_variables e2) + | Lwhile(e1, e2) -> + Ident.Set.union (free_variables e1) (free_variables e2) + | Lfor(v, lo, hi, _dir, body) -> + let set = Ident.Set.union (free_variables lo) (free_variables hi) in + Ident.Set.union set (Ident.Set.remove v (free_variables body)) + | Lassign(id, e) -> + Ident.Set.add id (free_variables e) + | Lsend (_k, met, obj, args, _) -> + free_variables_list + (Ident.Set.union (free_variables met) (free_variables obj)) + args + | Levent (lam, _evt) -> + free_variables lam + | Lifused (_v, e) -> + (* Shouldn't v be considered a free variable ? *) + free_variables e + +and free_variables_list set exprs = + List.fold_left (fun set expr -> Ident.Set.union (free_variables expr) set) + set exprs + +(* Check if an action has a "when" guard *) +let raise_count = ref 0 + +let next_raise_count () = + incr raise_count ; + !raise_count + +(* Anticipated staticraise, for guards *) +let staticfail = Lstaticraise (0,[]) + +let rec is_guarded = function + | Lifthenelse(_cond, _body, Lstaticraise (0,[])) -> true + | Llet(_str, _k, _id, _lam, body) -> is_guarded body + | Levent(lam, _ev) -> is_guarded lam + | _ -> false + +let rec patch_guarded patch = function + | Lifthenelse (cond, body, Lstaticraise (0,[])) -> + Lifthenelse (cond, body, patch) + | Llet(str, k, id, lam, body) -> + Llet (str, k, id, lam, patch_guarded patch body) + | Levent(lam, ev) -> + Levent (patch_guarded patch lam, ev) + | _ -> fatal_error "Lambda.patch_guarded" + +(* Translate an access path *) + +let rec transl_address loc = function + | Env.Aident id -> + if Ident.global id + then Lprim(Pgetglobal id, [], loc) + else Lvar id + | Env.Adot(addr, pos) -> + Lprim(Pfield pos, [transl_address loc addr], loc) + +let transl_path find loc env path = + match find path env with + | exception Not_found -> + fatal_error ("Cannot find address for: " ^ (Path.name path)) + | addr -> transl_address loc addr + +(* Translation of identifiers *) + +let transl_module_path loc env path = + transl_path Env.find_module_address loc env path + +let transl_value_path loc env path = + transl_path Env.find_value_address loc env path + +let transl_extension_path loc env path = + transl_path Env.find_constructor_address loc env path + +let transl_class_path loc env path = + transl_path Env.find_class_address loc env path + +let transl_prim mod_name name = + let pers = Ident.create_persistent mod_name in + let env = Env.add_persistent_structure pers Env.empty in + let lid = Longident.Ldot (Longident.Lident mod_name, name) in + match Env.lookup_value lid env with + | path, _ -> transl_value_path Location.none env path + | exception Not_found -> + fatal_error ("Primitive " ^ name ^ " not found.") + +(* Compile a sequence of expressions *) + +let rec make_sequence fn = function + [] -> lambda_unit + | [x] -> fn x + | x::rem -> + let lam = fn x in Lsequence(lam, make_sequence fn rem) + +(* Apply a substitution to a lambda-term. + Assumes that the image of the substitution is out of reach + of the bound variables of the lambda-term (no capture). *) + +let subst update_env s lam = + let rec subst s lam = + let remove_list l s = + List.fold_left (fun s (id, _kind) -> Ident.Map.remove id s) s l + in + let module M = Ident.Map in + match lam with + | Lvar id as l -> + begin try Ident.Map.find id s with Not_found -> l end + | Lconst _ as l -> l + | Lapply ap -> + Lapply{ap with ap_func = subst s ap.ap_func; + ap_args = subst_list s ap.ap_args} + | Lfunction lf -> + let s = + List.fold_right + (fun (id, _) s -> Ident.Map.remove id s) + lf.params s + in + Lfunction {lf with body = subst s lf.body} + | Llet(str, k, id, arg, body) -> + Llet(str, k, id, subst s arg, subst (Ident.Map.remove id s) body) + | Lletrec(decl, body) -> + let s = + List.fold_left (fun s (id, _) -> Ident.Map.remove id s) + s decl + in + Lletrec(List.map (subst_decl s) decl, subst s body) + | Lprim(p, args, loc) -> Lprim(p, subst_list s args, loc) + | Lswitch(arg, sw, loc) -> + Lswitch(subst s arg, + {sw with sw_consts = List.map (subst_case s) sw.sw_consts; + sw_blocks = List.map (subst_case s) sw.sw_blocks; + sw_failaction = subst_opt s sw.sw_failaction; }, + loc) + | Lstringswitch (arg,cases,default,loc) -> + Lstringswitch + (subst s arg,List.map (subst_strcase s) cases,subst_opt s default,loc) + | Lstaticraise (i,args) -> Lstaticraise (i, subst_list s args) + | Lstaticcatch(body, (id, params), handler) -> + Lstaticcatch(subst s body, (id, params), + subst (remove_list params s) handler) + | Ltrywith(body, exn, handler) -> + Ltrywith(subst s body, exn, subst (Ident.Map.remove exn s) handler) + | Lifthenelse(e1, e2, e3) -> Lifthenelse(subst s e1, subst s e2, subst s e3) + | Lsequence(e1, e2) -> Lsequence(subst s e1, subst s e2) + | Lwhile(e1, e2) -> Lwhile(subst s e1, subst s e2) + | Lfor(v, lo, hi, dir, body) -> + Lfor(v, subst s lo, subst s hi, dir, + subst (Ident.Map.remove v s) body) + | Lassign(id, e) -> + assert(not (Ident.Map.mem id s)); + Lassign(id, subst s e) + | Lsend (k, met, obj, args, loc) -> + Lsend (k, subst s met, subst s obj, subst_list s args, loc) + | Levent (lam, evt) -> + let lev_env = + Ident.Map.fold (fun id _ env -> + match Env.find_value (Path.Pident id) evt.lev_env with + | exception Not_found -> env + | vd -> update_env id vd env + ) s evt.lev_env + in + Levent (subst s lam, { evt with lev_env }) + | Lifused (v, e) -> Lifused (v, subst s e) + and subst_list s l = List.map (subst s) l + and subst_decl s (id, exp) = (id, subst s exp) + and subst_case s (key, case) = (key, subst s case) + and subst_strcase s (key, case) = (key, subst s case) + and subst_opt s = function + | None -> None + | Some e -> Some (subst s e) + in + subst s lam + +let rename idmap lam = + let update_env oldid vd env = + let newid = Ident.Map.find oldid idmap in + Env.add_value newid vd env + in + let s = Ident.Map.map (fun new_id -> Lvar new_id) idmap in + subst update_env s lam + +let shallow_map f = function + | Lvar _ + | Lconst _ as lam -> lam + | Lapply { ap_func; ap_args; ap_loc; ap_should_be_tailcall; + ap_inlined; ap_specialised } -> + Lapply { + ap_func = f ap_func; + ap_args = List.map f ap_args; + ap_loc; + ap_should_be_tailcall; + ap_inlined; + ap_specialised; + } + | Lfunction { kind; params; return; body; attr; loc; } -> + Lfunction { kind; params; return; body = f body; attr; loc; } + | Llet (str, k, v, e1, e2) -> + Llet (str, k, v, f e1, f e2) + | Lletrec (idel, e2) -> + Lletrec (List.map (fun (v, e) -> (v, f e)) idel, f e2) + | Lprim (p, el, loc) -> + Lprim (p, List.map f el, loc) + | Lswitch (e, sw, loc) -> + Lswitch (f e, + { sw_numconsts = sw.sw_numconsts; + sw_consts = List.map (fun (n, e) -> (n, f e)) sw.sw_consts; + sw_numblocks = sw.sw_numblocks; + sw_blocks = List.map (fun (n, e) -> (n, f e)) sw.sw_blocks; + sw_failaction = Misc.may_map f sw.sw_failaction; + }, + loc) + | Lstringswitch (e, sw, default, loc) -> + Lstringswitch ( + f e, + List.map (fun (s, e) -> (s, f e)) sw, + Misc.may_map f default, + loc) + | Lstaticraise (i, args) -> + Lstaticraise (i, List.map f args) + | Lstaticcatch (body, id, handler) -> + Lstaticcatch (f body, id, f handler) + | Ltrywith (e1, v, e2) -> + Ltrywith (f e1, v, f e2) + | Lifthenelse (e1, e2, e3) -> + Lifthenelse (f e1, f e2, f e3) + | Lsequence (e1, e2) -> + Lsequence (f e1, f e2) + | Lwhile (e1, e2) -> + Lwhile (f e1, f e2) + | Lfor (v, e1, e2, dir, e3) -> + Lfor (v, f e1, f e2, dir, f e3) + | Lassign (v, e) -> + Lassign (v, f e) + | Lsend (k, m, o, el, loc) -> + Lsend (k, f m, f o, List.map f el, loc) + | Levent (l, ev) -> + Levent (f l, ev) + | Lifused (v, e) -> + Lifused (v, f e) + +let map f = + let rec g lam = f (shallow_map g lam) in + g + +(* To let-bind expressions to variables *) + +let bind_with_value_kind str (var, kind) exp body = + match exp with + Lvar var' when Ident.same var var' -> body + | _ -> Llet(str, kind, var, exp, body) + +let bind str var exp body = + bind_with_value_kind str (var, Pgenval) exp body + +let negate_integer_comparison = function + | Ceq -> Cne + | Cne -> Ceq + | Clt -> Cge + | Cle -> Cgt + | Cgt -> Cle + | Cge -> Clt + +let swap_integer_comparison = function + | Ceq -> Ceq + | Cne -> Cne + | Clt -> Cgt + | Cle -> Cge + | Cgt -> Clt + | Cge -> Cle + +let negate_float_comparison = function + | CFeq -> CFneq + | CFneq -> CFeq + | CFlt -> CFnlt + | CFnlt -> CFlt + | CFgt -> CFngt + | CFngt -> CFgt + | CFle -> CFnle + | CFnle -> CFle + | CFge -> CFnge + | CFnge -> CFge + +let swap_float_comparison = function + | CFeq -> CFeq + | CFneq -> CFneq + | CFlt -> CFgt + | CFnlt -> CFngt + | CFle -> CFge + | CFnle -> CFnge + | CFgt -> CFlt + | CFngt -> CFnlt + | CFge -> CFle + | CFnge -> CFnle + +let raise_kind = function + | Raise_regular -> "raise" + | Raise_reraise -> "reraise" + | Raise_notrace -> "raise_notrace" + +let merge_inline_attributes attr1 attr2 = + match attr1, attr2 with + | Default_inline, _ -> Some attr2 + | _, Default_inline -> Some attr1 + | _, _ -> + if attr1 = attr2 then Some attr1 + else None + +let reset () = + raise_count := 0 diff --git a/lambda/lambda.mli b/lambda/lambda.mli new file mode 100644 index 0000000000..39c7f265ca --- /dev/null +++ b/lambda/lambda.mli @@ -0,0 +1,426 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* The "lambda" intermediate code *) + +open Asttypes + +type compile_time_constant = + | Big_endian + | Word_size + | Int_size + | Max_wosize + | Ostype_unix + | Ostype_win32 + | Ostype_cygwin + | Backend_type + +type immediate_or_pointer = + | Immediate + | Pointer + +type initialization_or_assignment = + | Assignment + (* Initialization of in heap values, like [caml_initialize] C primitive. The + field should not have been read before and initialization should happen + only once. *) + | Heap_initialization + (* Initialization of roots only. Compiles to a simple store. + No checks are done to preserve GC invariants. *) + | Root_initialization + +type is_safe = + | Safe + | Unsafe + +type primitive = + | Pidentity + | Pbytes_to_string + | Pbytes_of_string + | Pignore + | Prevapply + | Pdirapply + (* Globals *) + | Pgetglobal of Ident.t + | Psetglobal of Ident.t + (* 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 Bigarrays: (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 Bigarray *) + | Pbigarraydim of int + (* load/set 16,32,64 bits from a string: (unsafe)*) + | Pstring_load_16 of bool + | Pstring_load_32 of bool + | Pstring_load_64 of bool + | Pbytes_load_16 of bool + | Pbytes_load_32 of bool + | Pbytes_load_64 of bool + | Pbytes_set_16 of bool + | Pbytes_set_32 of bool + | Pbytes_set_64 of bool + (* load/set 16,32,64 bits from a + (char, int8_unsigned_elt, c_layout) Bigarray.Array1.t : (unsafe) *) + | Pbigstring_load_16 of bool + | Pbigstring_load_32 of bool + | Pbigstring_load_64 of bool + | Pbigstring_set_16 of bool + | Pbigstring_set_32 of bool + | Pbigstring_set_64 of bool + (* Compile time constants *) + | Pctconst of compile_time_constant + (* byte swap *) + | Pbswap16 + | Pbbswap of boxed_integer + (* Integer to external pointer *) + | Pint_as_pointer + (* Inhibition of optimisation *) + | Popaque + +and integer_comparison = + Ceq | Cne | Clt | Cgt | Cle | Cge + +and float_comparison = + CFeq | CFneq | CFlt | CFnlt | CFgt | CFngt | CFle | CFnle | CFge | CFnge + +and array_kind = + Pgenarray | Paddrarray | Pintarray | Pfloatarray + +and value_kind = + Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval + +and block_shape = + value_kind list option + +and boxed_integer = Primitive.boxed_integer = + Pnativeint | Pint32 | Pint64 + +and 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 = + Pbigarray_unknown_layout + | Pbigarray_c_layout + | Pbigarray_fortran_layout + +and raise_kind = + | Raise_regular + | Raise_reraise + | Raise_notrace + +val equal_primitive : primitive -> primitive -> bool + +val equal_value_kind : value_kind -> value_kind -> bool + +val equal_boxed_integer : boxed_integer -> boxed_integer -> bool + +type structured_constant = + Const_base of constant + | Const_pointer of int + | Const_block of int * structured_constant list + | Const_float_array of string list + | Const_immstring of string + +type inline_attribute = + | Always_inline (* [@inline] or [@inline always] *) + | Never_inline (* [@inline never] *) + | Unroll of int (* [@unroll x] *) + | Default_inline (* no [@inline] attribute *) + +val equal_inline_attribute : inline_attribute -> inline_attribute -> bool + +type specialise_attribute = + | Always_specialise (* [@specialise] or [@specialise always] *) + | Never_specialise (* [@specialise never] *) + | Default_specialise (* no [@specialise] attribute *) + +val equal_specialise_attribute + : specialise_attribute + -> specialise_attribute + -> bool + +type local_attribute = + | Always_local (* [@local] or [@local always] *) + | Never_local (* [@local never] *) + | Default_local (* [@local maybe] or no [@local] attribute *) + +type function_kind = Curried | Tupled + +type let_kind = Strict | Alias | StrictOpt | Variable +(* Meaning of kinds for let x = e in e': + Strict: e may have side-effects; always evaluate e first + (If e is a simple expression, e.g. a variable or constant, + we may still substitute e'[x/e].) + Alias: e is pure, we can substitute e'[x/e] if x has 0 or 1 occurrences + in e' + StrictOpt: e does not have side-effects, but depend on the store; + we can discard e if x does not appear in e' + Variable: the variable x is assigned later in e' + *) + +type meth_kind = Self | Public | Cached + +val equal_meth_kind : meth_kind -> meth_kind -> bool + +type shared_code = (int * int) list (* stack size -> code label *) + +type function_attribute = { + inline : inline_attribute; + specialise : specialise_attribute; + local: local_attribute; + is_a_functor: bool; + stub: bool; +} + +type lambda = + Lvar of Ident.t + | Lconst of structured_constant + | Lapply of lambda_apply + | Lfunction of lfunction + | Llet of let_kind * value_kind * Ident.t * lambda * lambda + | Lletrec of (Ident.t * lambda) list * lambda + | Lprim of primitive * lambda list * Location.t + | Lswitch of lambda * lambda_switch * Location.t +(* switch on strings, clauses are sorted by string order, + strings are pairwise distinct *) + | Lstringswitch of + lambda * (string * lambda) list * lambda option * Location.t + | Lstaticraise of int * lambda list + | Lstaticcatch of lambda * (int * (Ident.t * value_kind) list) * lambda + | Ltrywith of lambda * Ident.t * lambda + | Lifthenelse of lambda * lambda * lambda + | Lsequence of lambda * lambda + | Lwhile of lambda * lambda + | Lfor of Ident.t * lambda * lambda * direction_flag * lambda + | Lassign of Ident.t * lambda + | Lsend of meth_kind * lambda * lambda * lambda list * Location.t + | Levent of lambda * lambda_event + | Lifused of Ident.t * lambda + +and lfunction = + { kind: function_kind; + params: (Ident.t * value_kind) list; + return: value_kind; + body: lambda; + attr: function_attribute; (* specified with [@inline] attribute *) + loc : Location.t; } + +and lambda_apply = + { ap_func : lambda; + ap_args : lambda list; + ap_loc : Location.t; + ap_should_be_tailcall : bool; (* true if [@tailcall] was specified *) + ap_inlined : inline_attribute; (* specified with the [@inlined] attribute *) + ap_specialised : specialise_attribute; } + +and lambda_switch = + { sw_numconsts: int; (* Number of integer cases *) + sw_consts: (int * lambda) list; (* Integer cases *) + sw_numblocks: int; (* Number of tag block cases *) + sw_blocks: (int * lambda) list; (* Tag block cases *) + sw_failaction : lambda option} (* Action to take if failure *) +and lambda_event = + { lev_loc: Location.t; + lev_kind: lambda_event_kind; + lev_repr: int ref option; + lev_env: Env.t } + +and lambda_event_kind = + Lev_before + | Lev_after of Types.type_expr + | Lev_function + | Lev_pseudo + | Lev_module_definition of Ident.t + +type program = + { module_ident : Ident.t; + main_module_block_size : int; + required_globals : Ident.Set.t; (* Modules whose initializer side effects + must occur before [code]. *) + code : lambda } +(* Lambda code for the middle-end. + * In the closure case the code is a sequence of assignments to a + preallocated block of size [main_module_block_size] using + (Setfield(Getglobal(module_ident))). The size is used to preallocate + the block. + * In the flambda case the code is an expression returning a block + value of size [main_module_block_size]. The size is used to build + the module root as an initialize_symbol + Initialize_symbol(module_name, 0, + [getfield 0; ...; getfield (main_module_block_size - 1)]) +*) + +(* Sharing key *) +val make_key: lambda -> lambda option + +val const_unit: structured_constant +val lambda_unit: lambda +val name_lambda: let_kind -> lambda -> (Ident.t -> lambda) -> lambda +val name_lambda_list: lambda list -> (lambda list -> lambda) -> lambda + +val iter_head_constructor: (lambda -> unit) -> lambda -> unit +(** [iter_head_constructor f lam] apply [f] to only the first level of + sub expressions of [lam]. It does not recursively traverse the + expression. +*) + +val shallow_iter: + tail:(lambda -> unit) -> + non_tail:(lambda -> unit) -> + lambda -> unit +(** Same as [iter_head_constructor], but use a different callback for + sub-terms which are in tail position or not. *) + +val transl_prim: string -> string -> lambda +(** Translate a value from a persistent module. For instance: + + {[ + transl_internal_value "CamlinternalLazy" "force" + ]} +*) + +val free_variables: lambda -> Ident.Set.t + +val transl_module_path: Location.t -> Env.t -> Path.t -> lambda +val transl_value_path: Location.t -> Env.t -> Path.t -> lambda +val transl_extension_path: Location.t -> Env.t -> Path.t -> lambda +val transl_class_path: Location.t -> Env.t -> Path.t -> lambda + +val make_sequence: ('a -> lambda) -> 'a list -> lambda + +val subst: (Ident.t -> Types.value_description -> Env.t -> Env.t) -> + lambda Ident.Map.t -> lambda -> lambda +(** [subst env_update_fun s lt] applies a substitution [s] to the lambda-term + [lt]. + + Assumes that the image of the substitution is out of reach + of the bound variables of the lambda-term (no capture). + + [env_update_fun] is used to refresh the environment contained in debug + events. *) + +val rename : Ident.t Ident.Map.t -> lambda -> lambda +(** A version of [subst] specialized for the case where we're just renaming + idents. *) + +val map : (lambda -> lambda) -> lambda -> lambda + (** Bottom-up rewriting, applying the function on + each node from the leaves to the root. *) + +val shallow_map : (lambda -> lambda) -> lambda -> lambda + (** Rewrite each immediate sub-term with the function. *) + +val bind : let_kind -> Ident.t -> lambda -> lambda -> lambda +val bind_with_value_kind: + let_kind -> (Ident.t * value_kind) -> lambda -> lambda -> lambda + +val negate_integer_comparison : integer_comparison -> integer_comparison +val swap_integer_comparison : integer_comparison -> integer_comparison + +val negate_float_comparison : float_comparison -> float_comparison +val swap_float_comparison : float_comparison -> float_comparison + +val default_function_attribute : function_attribute +val default_stub_attribute : function_attribute + +(***********************) +(* For static failures *) +(***********************) + +(* Get a new static failure ident *) +val next_raise_count : unit -> int + +val staticfail : lambda (* Anticipated static failure *) + +(* Check anticipated failure, substitute its final value *) +val is_guarded: lambda -> bool +val patch_guarded : lambda -> lambda -> lambda + +val raise_kind: raise_kind -> string + +val merge_inline_attributes + : inline_attribute + -> inline_attribute + -> inline_attribute option + +val reset: unit -> unit diff --git a/lambda/matching.ml b/lambda/matching.ml new file mode 100644 index 0000000000..0b31ecbc1e --- /dev/null +++ b/lambda/matching.ml @@ -0,0 +1,3240 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Compilation of pattern matching *) + +open Misc +open Asttypes +open Types +open Typedtree +open Lambda +open Parmatch +open Printf +open Printpat + + +let dbg = false + +(* See Peyton-Jones, ``The Implementation of functional programming + languages'', chapter 5. *) +(* + Well, it was true at the beginning of the world. + Now, see Lefessant-Maranget ``Optimizing Pattern-Matching'' ICFP'2001 +*) + +(* + Compatibility predicate that considers potential rebindings of constructors + of an extension type. + + "may_compat p q" returns false when p and q never admit a common instance; + returns true when they may have a common instance. +*) + +module MayCompat = + Parmatch.Compat (struct let equal = Types.may_equal_constr end) +let may_compat = MayCompat.compat +and may_compats = MayCompat.compats + +(* + Many functions on the various data structures of the algorithm : + - Pattern matrices. + - Default environments: mapping from matrices to exit numbers. + - Contexts: matrices whose column are partitioned into + left and right. + - Jump summaries: mapping from exit numbers to contexts +*) + + +let string_of_lam lam = + Printlambda.lambda Format.str_formatter lam ; + Format.flush_str_formatter () + +let all_record_args lbls = match lbls with +| (_,{lbl_all=lbl_all},_)::_ -> + let t = + Array.map + (fun lbl -> mknoloc (Longident.Lident "?temp?"), lbl,omega) + lbl_all in + List.iter + (fun ((_, lbl,_) as x) -> t.(lbl.lbl_pos) <- x) + lbls ; + Array.to_list t +| _ -> fatal_error "Parmatch.all_record_args" + +type matrix = pattern list list + +let add_omega_column pss = List.map (fun ps -> omega::ps) pss + +type ctx = {left:pattern list ; right:pattern list} + +let pretty_ctx ctx = + List.iter + (fun {left=left ; right=right} -> + Format.eprintf "LEFT:%a RIGHT:%a\n" pretty_line left pretty_line right) + ctx + +let le_ctx c1 c2 = + le_pats c1.left c2.left && + le_pats c1.right c2.right + +let lshift {left=left ; right=right} = match right with +| x::xs -> {left=x::left ; right=xs} +| _ -> assert false + +let lforget {left=left ; right=right} = match right with +| _::xs -> {left=omega::left ; right=xs} +| _ -> assert false + +let rec small_enough n = function + | [] -> true + | _::rem -> + if n <= 0 then false + else small_enough (n-1) rem + +let ctx_lshift ctx = + if small_enough (!Clflags.match_context_rows - 1) ctx then + List.map lshift ctx + else (* Context pruning *) begin + get_mins le_ctx (List.map lforget ctx) + end + +let rshift {left=left ; right=right} = match left with +| p::ps -> {left=ps ; right=p::right} +| _ -> assert false + +let ctx_rshift ctx = List.map rshift ctx + +let rec nchars n ps = + if n <= 0 then [],ps + else match ps with + | p::rem -> + let chars, cdrs = nchars (n-1) rem in + p::chars,cdrs + | _ -> assert false + +let rshift_num n {left=left ; right=right} = + let shifted,left = nchars n left in + {left=left ; right = shifted@right} + +let ctx_rshift_num n ctx = List.map (rshift_num n) ctx + +(* Recombination of contexts (eg: (_,_)::p1::p2::rem -> (p1,p2)::rem) + All mutable fields are replaced by '_', since side-effects in + guards can alter these fields *) + +let combine {left=left ; right=right} = match left with +| p::ps -> {left=ps ; right=set_args_erase_mutable p right} +| _ -> assert false + +let ctx_combine ctx = List.map combine ctx + +let ncols = function + | [] -> 0 + | ps::_ -> List.length ps + + +exception NoMatch +exception OrPat + +let filter_matrix matcher pss = + + let rec filter_rec = function + | (p::ps)::rem -> + begin match p.pat_desc with + | Tpat_alias (p,_,_) -> + filter_rec ((p::ps)::rem) + | Tpat_var _ -> + filter_rec ((omega::ps)::rem) + | _ -> + begin + let rem = filter_rec rem in + try + matcher p ps::rem + with + | NoMatch -> rem + | OrPat -> + match p.pat_desc with + | Tpat_or (p1,p2,_) -> filter_rec [(p1::ps) ;(p2::ps)]@rem + | _ -> assert false + end + end + | [] -> [] + | _ -> + pretty_matrix Format.err_formatter pss ; + fatal_error "Matching.filter_matrix" in + filter_rec pss + +let make_default matcher env = + let rec make_rec = function + | [] -> [] + | ([[]],i)::_ -> [[[]],i] + | (pss,i)::rem -> + let rem = make_rec rem in + match filter_matrix matcher pss with + | [] -> rem + | ([]::_) -> ([[]],i)::rem + | pss -> (pss,i)::rem in + make_rec env + +let ctx_matcher p = + let p = normalize_pat p in + match p.pat_desc with + | Tpat_construct (_, cstr,omegas) -> + (fun q rem -> match q.pat_desc with + | Tpat_construct (_, cstr',args) +(* NB: may_constr_equal considers (potential) constructor rebinding *) + when Types.may_equal_constr cstr cstr' -> + p,args@rem + | Tpat_any -> p,omegas @ rem + | _ -> raise NoMatch) + | Tpat_constant cst -> + (fun q rem -> match q.pat_desc with + | Tpat_constant cst' when const_compare cst cst' = 0 -> + p,rem + | Tpat_any -> p,rem + | _ -> raise NoMatch) + | Tpat_variant (lab,Some omega,_) -> + (fun q rem -> match q.pat_desc with + | Tpat_variant (lab',Some arg,_) when lab=lab' -> + p,arg::rem + | Tpat_any -> p,omega::rem + | _ -> raise NoMatch) + | Tpat_variant (lab,None,_) -> + (fun q rem -> match q.pat_desc with + | Tpat_variant (lab',None,_) when lab=lab' -> + p,rem + | Tpat_any -> p,rem + | _ -> raise NoMatch) + | Tpat_array omegas -> + let len = List.length omegas in + (fun q rem -> match q.pat_desc with + | Tpat_array args when List.length args = len -> p,args @ rem + | Tpat_any -> p, omegas @ rem + | _ -> raise NoMatch) + | Tpat_tuple omegas -> + let len = List.length omegas in + (fun q rem -> match q.pat_desc with + | Tpat_tuple args when List.length args = len -> p,args @ rem + | Tpat_any -> p, omegas @ rem + | _ -> raise NoMatch) + | Tpat_record (((_, lbl, _) :: _) as l,_) -> (* Records are normalized *) + let len = Array.length lbl.lbl_all in + (fun q rem -> match q.pat_desc with + | Tpat_record (((_, lbl', _) :: _) as l',_) + when Array.length lbl'.lbl_all = len -> + let l' = all_record_args l' in + p, List.fold_right (fun (_, _,p) r -> p::r) l' rem + | Tpat_any -> p,List.fold_right (fun (_, _,p) r -> p::r) l rem + | _ -> raise NoMatch) + | Tpat_lazy omega -> + (fun q rem -> match q.pat_desc with + | Tpat_lazy arg -> p, (arg::rem) + | Tpat_any -> p, (omega::rem) + | _ -> raise NoMatch) + | _ -> fatal_error "Matching.ctx_matcher" + + + + +let filter_ctx q ctx = + + let matcher = ctx_matcher q in + + let rec filter_rec = function + | ({right=p::ps} as l)::rem -> + begin match p.pat_desc with + | Tpat_or (p1,p2,_) -> + filter_rec ({l with right=p1::ps}::{l with right=p2::ps}::rem) + | Tpat_alias (p,_,_) -> + filter_rec ({l with right=p::ps}::rem) + | Tpat_var _ -> + filter_rec ({l with right=omega::ps}::rem) + | _ -> + begin let rem = filter_rec rem in + try + let to_left, right = matcher p ps in + {left=to_left::l.left ; right=right}::rem + with + | NoMatch -> rem + end + end + | [] -> [] + | _ -> fatal_error "Matching.filter_ctx" in + + filter_rec ctx + +let select_columns pss ctx = + let n = ncols pss in + List.fold_right + (fun ps r -> + List.fold_right + (fun {left=left ; right=right} r -> + let transfert, right = nchars n right in + try + {left = lubs transfert ps @ left ; right=right}::r + with + | Empty -> r) + ctx r) + pss [] + +let ctx_lub p ctx = + List.fold_right + (fun {left=left ; right=right} r -> + match right with + | q::rem -> + begin try + {left=left ; right = lub p q::rem}::r + with + | Empty -> r + end + | _ -> fatal_error "Matching.ctx_lub") + ctx [] + +let ctx_match ctx pss = + List.exists + (fun {right=qs} -> List.exists (fun ps -> may_compats qs ps) pss) + ctx + +type jumps = (int * ctx list) list + +let pretty_jumps (env : jumps) = match env with +| [] -> () +| _ -> + List.iter + (fun (i,ctx) -> + Printf.fprintf stderr "jump for %d\n" i ; + pretty_ctx ctx) + env + + +let rec jumps_extract i = function + | [] -> [],[] + | (j,pss) as x::rem as all -> + if i=j then pss,rem + else if j < i then [],all + else + let r,rem = jumps_extract i rem in + r,(x::rem) + +let rec jumps_remove i = function + | [] -> [] + | (j,_)::rem when i=j -> rem + | x::rem -> x::jumps_remove i rem + +let jumps_empty = [] +and jumps_is_empty = function + | [] -> true + | _ -> false + +let jumps_singleton i = function + | [] -> [] + | ctx -> [i,ctx] + +let jumps_add i pss jumps = match pss with +| [] -> jumps +| _ -> + let rec add = function + | [] -> [i,pss] + | (j,qss) as x::rem as all -> + if j > i then x::add rem + else if j < i then (i,pss)::all + else (i,(get_mins le_ctx (pss@qss)))::rem in + add jumps + + +let rec jumps_union (env1:(int*ctx list)list) env2 = match env1,env2 with +| [],_ -> env2 +| _,[] -> env1 +| ((i1,pss1) as x1::rem1), ((i2,pss2) as x2::rem2) -> + if i1=i2 then + (i1,get_mins le_ctx (pss1@pss2))::jumps_union rem1 rem2 + else if i1 > i2 then + x1::jumps_union rem1 env2 + else + x2::jumps_union env1 rem2 + + +let rec merge = function + | env1::env2::rem -> jumps_union env1 env2::merge rem + | envs -> envs + +let rec jumps_unions envs = match envs with + | [] -> [] + | [env] -> env + | _ -> jumps_unions (merge envs) + +let jumps_map f env = + List.map + (fun (i,pss) -> i,f pss) + env + +(* Pattern matching before any compilation *) + +type pattern_matching = + { mutable cases : (pattern list * lambda) list; + args : (lambda * let_kind) list ; + default : (matrix * int) list} + +(* Pattern matching after application of both the or-pat rule and the + mixture rule *) + +type pm_or_compiled = + {body : pattern_matching ; + handlers : + (matrix * int * (Ident.t * Lambda.value_kind) list * pattern_matching) + list; + or_matrix : matrix ; } + +type pm_half_compiled = + | PmOr of pm_or_compiled + | PmVar of pm_var_compiled + | Pm of pattern_matching + +and pm_var_compiled = + {inside : pm_half_compiled ; var_arg : lambda ; } + +type pm_half_compiled_info = + {me : pm_half_compiled ; + matrix : matrix ; + top_default : (matrix * int) list ; } + +let pretty_cases cases = + List.iter + (fun (ps,_l) -> + List.iter + (fun p -> Format.eprintf " %a%!" top_pretty p) + ps ; + Format.eprintf "\n") + cases + +let pretty_def def = + Format.eprintf "+++++ Defaults +++++\n" ; + List.iter + (fun (pss,i) -> Format.eprintf "Matrix for %d\n%a" i pretty_matrix pss) + def ; + Format.eprintf "+++++++++++++++++++++\n" + +let pretty_pm pm = + pretty_cases pm.cases ; + if pm.default <> [] then + pretty_def pm.default + + +let rec pretty_precompiled = function + | Pm pm -> + Format.eprintf "++++ PM ++++\n" ; + pretty_pm pm + | PmVar x -> + Format.eprintf "++++ VAR ++++\n" ; + pretty_precompiled x.inside + | PmOr x -> + Format.eprintf "++++ OR ++++\n" ; + pretty_pm x.body ; + pretty_matrix Format.err_formatter x.or_matrix ; + List.iter + (fun (_,i,_,pm) -> + eprintf "++ Handler %d ++\n" i ; + pretty_pm pm) + x.handlers + +let pretty_precompiled_res first nexts = + pretty_precompiled first ; + List.iter + (fun (e, pmh) -> + eprintf "** DEFAULT %d **\n" e ; + pretty_precompiled pmh) + nexts + + + +(* Identifying some semantically equivalent lambda-expressions, + Our goal here is also to + find alpha-equivalent (simple) terms *) + +(* However, as shown by PR#6359 such sharing may hinders the + lambda-code invariant that all bound idents are unique, + when switches are compiled to test sequences. + The definitive fix is the systematic introduction of exit/catch + in case action sharing is present. +*) + + +module StoreExp = + Switch.Store + (struct + type t = lambda + type key = lambda + let compare_key = Stdlib.compare + let make_key = Lambda.make_key + end) + + +let make_exit i = Lstaticraise (i,[]) + +(* Introduce a catch, if worth it *) +let make_catch d k = match d with +| Lstaticraise (_,[]) -> k d +| _ -> + let e = next_raise_count () in + Lstaticcatch (k (make_exit e),(e,[]),d) + +(* Introduce a catch, if worth it, delayed version *) +let rec as_simple_exit = function + | Lstaticraise (i,[]) -> Some i + | Llet (Alias,_k,_,_,e) -> as_simple_exit e + | _ -> None + + +let make_catch_delayed handler = match as_simple_exit handler with +| Some i -> i,(fun act -> act) +| None -> + let i = next_raise_count () in +(* + Printf.eprintf "SHARE LAMBDA: %i\n%s\n" i (string_of_lam handler); +*) + i, + (fun body -> match body with + | Lstaticraise (j,_) -> + if i=j then handler else body + | _ -> Lstaticcatch (body,(i,[]),handler)) + + +let raw_action l = + match make_key l with | Some l -> l | None -> l + + +let tr_raw act = match make_key act with +| Some act -> act +| None -> raise Exit + +let same_actions = function + | [] -> None + | [_,act] -> Some act + | (_,act0) :: rem -> + try + let raw_act0 = tr_raw act0 in + let rec s_rec = function + | [] -> Some act0 + | (_,act)::rem -> + if raw_act0 = tr_raw act then + s_rec rem + else + None in + s_rec rem + with + | Exit -> None + + +(* Test for swapping two clauses *) + +let up_ok_action act1 act2 = + try + let raw1 = tr_raw act1 + and raw2 = tr_raw act2 in + raw1 = raw2 + with + | Exit -> false + +let up_ok (ps,act_p) l = + List.for_all + (fun (qs,act_q) -> + up_ok_action act_p act_q || not (may_compats ps qs)) + l + +(* + The simplify function normalizes the first column of the match + - records are expanded so that they possess all fields + - aliases are removed and replaced by bindings in actions. + However or-patterns are simplified differently, + - aliases are not removed + - or-patterns (_|p) are changed into _ +*) + +exception Var of pattern + +let simplify_or p = + let rec simpl_rec p = match p with + | {pat_desc = Tpat_any|Tpat_var _} -> raise (Var p) + | {pat_desc = Tpat_alias (q,id,s)} -> + begin try + {p with pat_desc = Tpat_alias (simpl_rec q,id,s)} + with + | Var q -> raise (Var {p with pat_desc = Tpat_alias (q,id,s)}) + end + | {pat_desc = Tpat_or (p1,p2,o)} -> + let q1 = simpl_rec p1 in + begin try + let q2 = simpl_rec p2 in + {p with pat_desc = Tpat_or (q1, q2, o)} + with + | Var q2 -> raise (Var {p with pat_desc = Tpat_or (q1, q2, o)}) + end + | {pat_desc = Tpat_record (lbls,closed)} -> + let all_lbls = all_record_args lbls in + {p with pat_desc=Tpat_record (all_lbls, closed)} + | _ -> p in + try + simpl_rec p + with + | Var p -> p + +let simplify_cases args cls = match args with +| [] -> assert false +| (arg,_)::_ -> + let rec simplify = function + | [] -> [] + | ((pat :: patl, action) as cl) :: rem -> + begin match pat.pat_desc with + | Tpat_var (id, _) -> + let k = Typeopt.value_kind pat.pat_env pat.pat_type in + (omega :: patl, bind_with_value_kind Alias (id, k) arg action) :: + simplify rem + | Tpat_any -> + cl :: simplify rem + | Tpat_alias(p, id,_) -> + let k = Typeopt.value_kind pat.pat_env pat.pat_type in + simplify ((p :: patl, + bind_with_value_kind Alias (id, k) arg action) :: rem) + | Tpat_record ([],_) -> + (omega :: patl, action):: + simplify rem + | Tpat_record (lbls, closed) -> + let all_lbls = all_record_args lbls in + let full_pat = + {pat with pat_desc=Tpat_record (all_lbls, closed)} in + (full_pat::patl,action):: + simplify rem + | Tpat_or _ -> + let pat_simple = simplify_or pat in + begin match pat_simple.pat_desc with + | Tpat_or _ -> + (pat_simple :: patl, action) :: + simplify rem + | _ -> + simplify ((pat_simple::patl,action) :: rem) + end + | _ -> cl :: simplify rem + end + | _ -> assert false in + + simplify cls + + + +(* Once matchings are simplified one can easily find + their nature *) + +let rec what_is_cases cases = match cases with +| ({pat_desc=Tpat_any} :: _, _) :: rem -> what_is_cases rem +| (({pat_desc=(Tpat_var _|Tpat_or (_,_,_)|Tpat_alias (_,_,_))}::_),_)::_ + -> assert false (* applies to simplified matchings only *) +| (p::_,_)::_ -> p +| [] -> omega +| _ -> assert false + + + +(* A few operations on default environments *) +let as_matrix cases = get_mins le_pats (List.map (fun (ps,_) -> ps) cases) + +let cons_default matrix raise_num default = + match matrix with + | [] -> default + | _ -> (matrix,raise_num)::default + +let default_compat p def = + List.fold_right + (fun (pss,i) r -> + let qss = + List.fold_right + (fun qs r -> match qs with + | q::rem when may_compat p q -> rem::r + | _ -> r) + pss [] in + match qss with + | [] -> r + | _ -> (qss,i)::r) + def [] + +(* Or-pattern expansion, variables are a complication w.r.t. the article *) + +exception Cannot_flatten + +let mk_alpha_env arg aliases ids = + List.map + (fun id -> id, + if List.mem id aliases then + match arg with + | Some v -> v + | _ -> raise Cannot_flatten + else + Ident.create_local (Ident.name id)) + ids + +let rec explode_or_pat arg patl mk_action rem vars aliases = function + | {pat_desc = Tpat_or (p1,p2,_)} -> + explode_or_pat + arg patl mk_action + (explode_or_pat arg patl mk_action rem vars aliases p2) + vars aliases p1 + | {pat_desc = Tpat_alias (p,id, _)} -> + explode_or_pat arg patl mk_action rem vars (id::aliases) p + | {pat_desc = Tpat_var (x, _)} -> + let env = mk_alpha_env arg (x::aliases) vars in + (omega::patl,mk_action (List.map snd env))::rem + | p -> + let env = mk_alpha_env arg aliases vars in + (alpha_pat env p::patl,mk_action (List.map snd env))::rem + +let pm_free_variables {cases=cases} = + List.fold_right + (fun (_,act) r -> Ident.Set.union (free_variables act) r) + cases Ident.Set.empty + + +(* Basic grouping predicates *) +let pat_as_constr = function + | {pat_desc=Tpat_construct (_, cstr,_)} -> cstr + | _ -> fatal_error "Matching.pat_as_constr" + +let group_const_int = function + | {pat_desc= Tpat_constant Const_int _ } -> true + | _ -> false + +let group_const_char = function + | {pat_desc= Tpat_constant Const_char _ } -> true + | _ -> false + +let group_const_string = function + | {pat_desc= Tpat_constant Const_string _ } -> true + | _ -> false + +let group_const_float = function + | {pat_desc= Tpat_constant Const_float _ } -> true + | _ -> false + +let group_const_int32 = function + | {pat_desc= Tpat_constant Const_int32 _ } -> true + | _ -> false + +let group_const_int64 = function + | {pat_desc= Tpat_constant Const_int64 _ } -> true + | _ -> false + +let group_const_nativeint = function + | {pat_desc= Tpat_constant Const_nativeint _ } -> true + | _ -> false + +and group_constructor = function + | {pat_desc = Tpat_construct (_,_,_)} -> true + | _ -> false + +and group_variant = function + | {pat_desc = Tpat_variant (_, _, _)} -> true + | _ -> false + +and group_var = function + | {pat_desc=Tpat_any} -> true + | _ -> false + +and group_tuple = function + | {pat_desc = (Tpat_tuple _|Tpat_any)} -> true + | _ -> false + +and group_record = function + | {pat_desc = (Tpat_record _|Tpat_any)} -> true + | _ -> false + +and group_array = function + | {pat_desc=Tpat_array _} -> true + | _ -> false + +and group_lazy = function + | {pat_desc = Tpat_lazy _} -> true + | _ -> false + +let get_group p = match p.pat_desc with +| Tpat_any -> group_var +| Tpat_constant Const_int _ -> group_const_int +| Tpat_constant Const_char _ -> group_const_char +| Tpat_constant Const_string _ -> group_const_string +| Tpat_constant Const_float _ -> group_const_float +| Tpat_constant Const_int32 _ -> group_const_int32 +| Tpat_constant Const_int64 _ -> group_const_int64 +| Tpat_constant Const_nativeint _ -> group_const_nativeint +| Tpat_construct _ -> group_constructor +| Tpat_tuple _ -> group_tuple +| Tpat_record _ -> group_record +| Tpat_array _ -> group_array +| Tpat_variant (_,_,_) -> group_variant +| Tpat_lazy _ -> group_lazy +| _ -> fatal_error "Matching.get_group" + + + +let is_or p = match p.pat_desc with +| Tpat_or _ -> true +| _ -> false + +(* Conditions for appending to the Or matrix *) +let conda p q = not (may_compat p q) +and condb act ps qs = not (is_guarded act) && Parmatch.le_pats qs ps + +let or_ok p ps l = + List.for_all + (function + | ({pat_desc=Tpat_or _} as q::qs,act) -> + conda p q || condb act ps qs + | _ -> true) + l + +(* Insert or append a pattern in the Or matrix *) + +let equiv_pat p q = le_pat p q && le_pat q p + +let rec get_equiv p l = match l with + | (q::_,_) as cl::rem -> + if equiv_pat p q then + let others,rem = get_equiv p rem in + cl::others,rem + else + [],l + | _ -> [],l + + +let insert_or_append p ps act ors no = + let rec attempt seen = function + | (q::qs,act_q) as cl::rem -> + if is_or q then begin + if may_compat p q then + if + Typedtree.pat_bound_idents p = [] && + Typedtree.pat_bound_idents q = [] && + equiv_pat p q + then (* attempt insert, for equivalent orpats with no variables *) + let _, not_e = get_equiv q rem in + if + or_ok p ps not_e && (* check append condition for head of O *) + List.for_all (* check insert condition for tail of O *) + (fun cl -> match cl with + | (q::_,_) -> not (may_compat p q) + | _ -> assert false) + seen + then (* insert *) + List.rev_append seen ((p::ps,act)::cl::rem), no + else (* fail to insert or append *) + ors,(p::ps,act)::no + else if condb act_q ps qs then (* check condition (b) for append *) + attempt (cl::seen) rem + else + ors,(p::ps,act)::no + else (* p # q, go on with append/insert *) + attempt (cl::seen) rem + end else (* q is not an or-pat, go on with append/insert *) + attempt (cl::seen) rem + | _ -> (* [] in fact *) + (p::ps,act)::ors,no in (* success in appending *) + attempt [] ors + +(* Reconstruct default information from half_compiled pm list *) + +let rec rebuild_matrix pmh = match pmh with + | Pm pm -> as_matrix pm.cases + | PmOr {or_matrix=m} -> m + | PmVar x -> add_omega_column (rebuild_matrix x.inside) + +let rec rebuild_default nexts def = match nexts with +| [] -> def +| (e, pmh)::rem -> + (add_omega_column (rebuild_matrix pmh), e):: + rebuild_default rem def + +let rebuild_nexts arg nexts k = + List.fold_right + (fun (e, pm) k -> (e, PmVar {inside=pm ; var_arg=arg})::k) + nexts k + + +(* + Split a matching. + Splitting is first directed by or-patterns, then by + tests (e.g. constructors)/variable transitions. + + The approach is greedy, every split function attempts to + raise rows as much as possible in the top matrix, + then splitting applies again to the remaining rows. + + Some precompilation of or-patterns and + variable pattern occurs. Mostly this means that bindings + are performed now, being replaced by let-bindings + in actions (cf. simplify_cases). + + Additionally, if the match argument is a variable, matchings whose + first column is made of variables only are split further + (cf. precompile_var). + +*) + + +let rec split_or argo cls args def = + + let cls = simplify_cases args cls in + + let rec do_split before ors no = function + | [] -> + cons_next + (List.rev before) (List.rev ors) (List.rev no) + | ((p::ps,act) as cl)::rem -> + if up_ok cl no then + if is_or p then + let ors, no = insert_or_append p ps act ors no in + do_split before ors no rem + else begin + if up_ok cl ors then + do_split (cl::before) ors no rem + else if or_ok p ps ors then + do_split before (cl::ors) no rem + else + do_split before ors (cl::no) rem + end + else + do_split before ors (cl::no) rem + | _ -> assert false + + and cons_next yes yesor = function + | [] -> + precompile_or argo yes yesor args def [] + | rem -> + let {me=next ; matrix=matrix ; top_default=def},nexts = + do_split [] [] [] rem in + let idef = next_raise_count () in + precompile_or + argo yes yesor args + (cons_default matrix idef def) + ((idef,next)::nexts) in + + do_split [] [] [] cls + +(* Ultra-naive splitting, close to semantics, used for extension, + as potential rebind prevents any kind of optimisation *) + +and split_naive cls args def k = + + let rec split_exc cstr0 yes = function + | [] -> + let yes = List.rev yes in + { me = Pm {cases=yes; args=args; default=def;} ; + matrix = as_matrix yes ; + top_default=def}, + k + | (p::_,_ as cl)::rem -> + if group_constructor p then + let cstr = pat_as_constr p in + if cstr = cstr0 then split_exc cstr0 (cl::yes) rem + else + let yes = List.rev yes in + let {me=next ; matrix=matrix ; top_default=def}, nexts = + split_exc cstr [cl] rem in + let idef = next_raise_count () in + let def = cons_default matrix idef def in + { me = Pm {cases=yes; args=args; default=def} ; + matrix = as_matrix yes ; + top_default = def; }, + (idef,next)::nexts + else + let yes = List.rev yes in + let {me=next ; matrix=matrix ; top_default=def}, nexts = + split_noexc [cl] rem in + let idef = next_raise_count () in + let def = cons_default matrix idef def in + { me = Pm {cases=yes; args=args; default=def} ; + matrix = as_matrix yes ; + top_default = def; }, + (idef,next)::nexts + | _ -> assert false + + and split_noexc yes = function + | [] -> precompile_var args (List.rev yes) def k + | (p::_,_ as cl)::rem -> + if group_constructor p then + let yes= List.rev yes in + let {me=next; matrix=matrix; top_default=def;},nexts = + split_exc (pat_as_constr p) [cl] rem in + let idef = next_raise_count () in + precompile_var + args yes + (cons_default matrix idef def) + ((idef,next)::nexts) + else split_noexc (cl::yes) rem + | _ -> assert false in + + match cls with + | [] -> assert false + | (p::_,_ as cl)::rem -> + if group_constructor p then + split_exc (pat_as_constr p) [cl] rem + else + split_noexc [cl] rem + | _ -> assert false + +and split_constr cls args def k = + let ex_pat = what_is_cases cls in + match ex_pat.pat_desc with + | Tpat_any -> precompile_var args cls def k + | Tpat_construct (_,{cstr_tag=Cstr_extension _},_) -> + split_naive cls args def k + | _ -> + + let group = get_group ex_pat in + + let rec split_ex yes no = function + | [] -> + let yes = List.rev yes and no = List.rev no in + begin match no with + | [] -> + {me = Pm {cases=yes ; args=args ; default=def} ; + matrix = as_matrix yes ; + top_default = def}, + k + | cl::rem -> + begin match yes with + | [] -> + (* Could not success in raising up a constr matching up *) + split_noex [cl] [] rem + | _ -> + let {me=next ; matrix=matrix ; top_default=def}, nexts = + split_noex [cl] [] rem in + let idef = next_raise_count () in + let def = cons_default matrix idef def in + {me = Pm {cases=yes ; args=args ; default=def} ; + matrix = as_matrix yes ; + top_default = def }, + (idef, next)::nexts + end + end + | (p::_,_) as cl::rem -> + if group p && up_ok cl no then + split_ex (cl::yes) no rem + else + split_ex yes (cl::no) rem + | _ -> assert false + + and split_noex yes no = function + | [] -> + let yes = List.rev yes and no = List.rev no in + begin match no with + | [] -> precompile_var args yes def k + | cl::rem -> + let {me=next ; matrix=matrix ; top_default=def}, nexts = + split_ex [cl] [] rem in + let idef = next_raise_count () in + precompile_var + args yes + (cons_default matrix idef def) + ((idef,next)::nexts) + end + | [ps,_ as cl] + when List.for_all group_var ps && yes <> [] -> + (* This enables an extra division in some frequent cases : + last row is made of variables only *) + split_noex yes (cl::no) [] + | (p::_,_) as cl::rem -> + if not (group p) && up_ok cl no then + split_noex (cl::yes) no rem + else + split_noex yes (cl::no) rem + | _ -> assert false in + + match cls with + | ((p::_,_) as cl)::rem -> + if group p then split_ex [cl] [] rem + else split_noex [cl] [] rem + | _ -> assert false + +and precompile_var args cls def k = match args with +| [] -> assert false +| _::((Lvar v as av,_) as arg)::rargs -> + begin match cls with + | [_] -> (* as split as it can *) + dont_precompile_var args cls def k + | _ -> +(* Precompile *) + let var_cls = + List.map + (fun (ps,act) -> match ps with + | _::ps -> ps,act | _ -> assert false) + cls + and var_def = make_default (fun _ rem -> rem) def in + let {me=first ; matrix=matrix}, nexts = + split_or (Some v) var_cls (arg::rargs) var_def in + +(* Compute top information *) + match nexts with + | [] -> (* If you need *) + dont_precompile_var args cls def k + | _ -> + let rfirst = + {me = PmVar {inside=first ; var_arg = av} ; + matrix = add_omega_column matrix ; + top_default = rebuild_default nexts def ; } + and rnexts = rebuild_nexts av nexts k in + rfirst, rnexts + end +| _ -> + dont_precompile_var args cls def k + +and dont_precompile_var args cls def k = + {me = Pm {cases = cls ; args = args ; default = def } ; + matrix=as_matrix cls ; + top_default=def},k + +and precompile_or argo cls ors args def k = match ors with +| [] -> split_constr cls args def k +| _ -> + let rec do_cases = function + | ({pat_desc=Tpat_or _} as orp::patl, action)::rem -> + let others,rem = get_equiv orp rem in + let orpm = + {cases = + (patl, action):: + List.map + (function + | (_::ps,action) -> ps,action + | _ -> assert false) + others ; + args = (match args with _::r -> r | _ -> assert false) ; + default = default_compat orp def} in + let pm_fv = pm_free_variables orpm in + let vars = + Typedtree.pat_bound_idents_full orp + |> List.filter (fun (id, _, _) -> Ident.Set.mem id pm_fv) + |> List.map (fun (id,_,ty) -> id,Typeopt.value_kind orp.pat_env ty) + in + let or_num = next_raise_count () in + let new_patl = Parmatch.omega_list patl in + + let mk_new_action vs = + Lstaticraise + (or_num, List.map (fun v -> Lvar v) vs) in + + let body,handlers = do_cases rem in + explode_or_pat + argo new_patl mk_new_action body (List.map fst vars) [] orp, + let mat = [[orp]] in + ((mat, or_num, vars , orpm):: handlers) + | cl::rem -> + let new_ord,new_to_catch = do_cases rem in + cl::new_ord,new_to_catch + | [] -> [],[] in + + let end_body, handlers = do_cases ors in + let matrix = as_matrix (cls@ors) + and body = {cases=cls@end_body ; args=args ; default=def} in + {me = PmOr {body=body ; handlers=handlers ; or_matrix=matrix} ; + matrix=matrix ; + top_default=def}, + k + +let split_precompile argo pm = + let {me=next}, nexts = split_or argo pm.cases pm.args pm.default in + if dbg && (nexts <> [] || (match next with PmOr _ -> true | _ -> false)) + then begin + Format.eprintf "** SPLIT **\n" ; + pretty_pm pm ; + pretty_precompiled_res next nexts + end ; + next, nexts + + +(* General divide functions *) + +let add_line patl_action pm = pm.cases <- patl_action :: pm.cases; pm + +type cell = + {pm : pattern_matching ; + ctx : ctx list ; + pat : pattern} + +let add make_matching_fun division eq_key key patl_action args = + try + let (_,cell) = List.find (fun (k,_) -> eq_key key k) division in + cell.pm.cases <- patl_action :: cell.pm.cases; + division + with Not_found -> + let cell = make_matching_fun args in + cell.pm.cases <- [patl_action] ; + (key, cell) :: division + + +let divide make eq_key get_key get_args ctx pm = + + let rec divide_rec = function + | (p::patl,action) :: rem -> + let this_match = divide_rec rem in + add + (make p pm.default ctx) + this_match eq_key (get_key p) (get_args p patl,action) pm.args + | _ -> [] in + + divide_rec pm.cases + + +let divide_line make_ctx make get_args pat ctx pm = + let rec divide_rec = function + | (p::patl,action) :: rem -> + let this_match = divide_rec rem in + add_line (get_args p patl, action) this_match + | _ -> make pm.default pm.args in + + {pm = divide_rec pm.cases ; + ctx=make_ctx ctx ; + pat=pat} + + + +(* Then come various functions, + There is one set of functions per matching style + (constants, constructors etc.) + + - matcher functions are arguments to make_default (for default handlers) + They may raise NoMatch or OrPat and perform the full + matching (selection + arguments). + + + - get_args and get_key are for the compiled matrices, note that + selection and getting arguments are separated. + + - make_ _matching combines the previous functions for producing + new ``pattern_matching'' records. +*) + + + +let rec matcher_const cst p rem = match p.pat_desc with +| Tpat_or (p1,p2,_) -> + begin try + matcher_const cst p1 rem with + | NoMatch -> matcher_const cst p2 rem + end +| Tpat_constant c1 when const_compare c1 cst = 0 -> rem +| Tpat_any -> rem +| _ -> raise NoMatch + +let get_key_constant caller = function + | {pat_desc= Tpat_constant cst} -> cst + | p -> + Format.eprintf "BAD: %s" caller ; + pretty_pat p ; + assert false + +let get_args_constant _ rem = rem + +let make_constant_matching p def ctx = function + [] -> fatal_error "Matching.make_constant_matching" + | (_ :: argl) -> + let def = + make_default + (matcher_const (get_key_constant "make" p)) def + and ctx = + filter_ctx p ctx in + {pm = {cases = []; args = argl ; default = def} ; + ctx = ctx ; + pat = normalize_pat p} + + + + +let divide_constant ctx m = + divide + make_constant_matching + (fun c d -> const_compare c d = 0) (get_key_constant "divide") + get_args_constant + ctx m + +(* Matching against a constructor *) + + +let make_field_args loc binding_kind arg first_pos last_pos argl = + let rec make_args pos = + if pos > last_pos + then argl + else (Lprim(Pfield pos, [arg], loc), binding_kind) :: make_args (pos + 1) + in make_args first_pos + +let get_key_constr = function + | {pat_desc=Tpat_construct (_, cstr,_)} -> cstr.cstr_tag + | _ -> assert false + +let get_args_constr p rem = match p with +| {pat_desc=Tpat_construct (_, _, args)} -> args @ rem +| _ -> assert false + +(* NB: matcher_constr applies to default matrices. + + In that context, matching by constructors of extensible + types degrades to arity checking, due to potential rebinding. + This comparison is performed by Types.may_equal_constr. +*) + +let matcher_constr cstr = match cstr.cstr_arity with +| 0 -> + let rec matcher_rec q rem = match q.pat_desc with + | Tpat_or (p1,p2,_) -> + begin + try matcher_rec p1 rem + with NoMatch -> matcher_rec p2 rem + end + | Tpat_construct (_, cstr',[]) + when Types.may_equal_constr cstr cstr' -> rem + | Tpat_any -> rem + | _ -> raise NoMatch in + matcher_rec +| 1 -> + let rec matcher_rec q rem = match q.pat_desc with + | Tpat_or (p1,p2,_) -> + let r1 = try Some (matcher_rec p1 rem) with NoMatch -> None + and r2 = try Some (matcher_rec p2 rem) with NoMatch -> None in + begin match r1,r2 with + | None, None -> raise NoMatch + | Some r1, None -> r1 + | None, Some r2 -> r2 + | Some (a1::_), Some (a2::_) -> + {a1 with + pat_loc = Location.none ; + pat_desc = Tpat_or (a1, a2, None)}:: + rem + | _, _ -> assert false + end + | Tpat_construct (_, cstr', [arg]) + when Types.may_equal_constr cstr cstr' -> arg::rem + | Tpat_any -> omega::rem + | _ -> raise NoMatch in + matcher_rec +| _ -> + fun q rem -> match q.pat_desc with + | Tpat_or (_,_,_) -> raise OrPat + | Tpat_construct (_,cstr',args) + when Types.may_equal_constr cstr cstr' -> args @ rem + | Tpat_any -> Parmatch.omegas cstr.cstr_arity @ rem + | _ -> raise NoMatch + +let make_constr_matching p def ctx = function + [] -> fatal_error "Matching.make_constr_matching" + | ((arg, _mut) :: argl) -> + let cstr = pat_as_constr p in + let newargs = + if cstr.cstr_inlined <> None then + (arg, Alias) :: argl + else match cstr.cstr_tag with + Cstr_constant _ | Cstr_block _ -> + make_field_args p.pat_loc Alias arg 0 (cstr.cstr_arity - 1) argl + | Cstr_unboxed -> (arg, Alias) :: argl + | Cstr_extension _ -> + make_field_args p.pat_loc Alias arg 1 cstr.cstr_arity argl in + {pm= + {cases = []; args = newargs; + default = make_default (matcher_constr cstr) def} ; + ctx = filter_ctx p ctx ; + pat=normalize_pat p} + + +let divide_constructor ctx pm = + divide + make_constr_matching + (=) get_key_constr get_args_constr + ctx pm + +(* Matching against a variant *) + +let rec matcher_variant_const lab p rem = match p.pat_desc with +| Tpat_or (p1, p2, _) -> + begin + try + matcher_variant_const lab p1 rem + with + | NoMatch -> matcher_variant_const lab p2 rem + end +| Tpat_variant (lab1,_,_) when lab1=lab -> rem +| Tpat_any -> rem +| _ -> raise NoMatch + + +let make_variant_matching_constant p lab def ctx = function + [] -> fatal_error "Matching.make_variant_matching_constant" + | (_ :: argl) -> + let def = make_default (matcher_variant_const lab) def + and ctx = filter_ctx p ctx in + {pm={ cases = []; args = argl ; default=def} ; + ctx=ctx ; + pat = normalize_pat p} + +let matcher_variant_nonconst lab p rem = match p.pat_desc with +| Tpat_or (_,_,_) -> raise OrPat +| Tpat_variant (lab1,Some arg,_) when lab1=lab -> arg::rem +| Tpat_any -> omega::rem +| _ -> raise NoMatch + + +let make_variant_matching_nonconst p lab def ctx = function + [] -> fatal_error "Matching.make_variant_matching_nonconst" + | ((arg, _mut) :: argl) -> + let def = make_default (matcher_variant_nonconst lab) def + and ctx = filter_ctx p ctx in + {pm= + {cases = []; args = (Lprim(Pfield 1, [arg], p.pat_loc), Alias) :: argl; + default=def} ; + ctx=ctx ; + pat = normalize_pat p} + +let divide_variant row ctx {cases = cl; args = al; default=def} = + let row = Btype.row_repr row in + let rec divide = function + ({pat_desc = Tpat_variant(lab, pato, _)} as p:: patl, action) :: rem -> + let variants = divide rem in + if try Btype.row_field_repr (List.assoc lab row.row_fields) = Rabsent + with Not_found -> true + then + variants + else begin + let tag = Btype.hash_variant lab in + match pato with + None -> + add (make_variant_matching_constant p lab def ctx) variants + (=) (Cstr_constant tag) (patl, action) al + | Some pat -> + add (make_variant_matching_nonconst p lab def ctx) variants + (=) (Cstr_block tag) (pat :: patl, action) al + end + | _ -> [] + in + divide cl + +(* + Three ``no-test'' cases + *) + +(* Matching against a variable *) + +let get_args_var _ rem = rem + + +let make_var_matching def = function + | [] -> fatal_error "Matching.make_var_matching" + | _::argl -> + {cases=[] ; + args = argl ; + default= make_default get_args_var def} + +let divide_var ctx pm = + divide_line ctx_lshift make_var_matching get_args_var omega ctx pm + +(* Matching and forcing a lazy value *) + +let get_arg_lazy p rem = match p with +| {pat_desc = Tpat_any} -> omega :: rem +| {pat_desc = Tpat_lazy arg} -> arg :: rem +| _ -> assert false + +let matcher_lazy p rem = match p.pat_desc with +| Tpat_or (_,_,_) -> raise OrPat +| Tpat_any +| Tpat_var _ -> omega :: rem +| Tpat_lazy arg -> arg :: rem +| _ -> raise NoMatch + +(* Inlining the tag tests before calling the primitive that works on + lazy blocks. This is also used in translcore.ml. + No other call than Obj.tag when the value has been forced before. +*) + +let prim_obj_tag = + Primitive.simple ~name:"caml_obj_tag" ~arity:1 ~alloc:false + +let get_mod_field modname field = + lazy ( + let mod_ident = Ident.create_persistent modname in + let env = Env.add_persistent_structure mod_ident Env.initial_safe_string in + match Env.open_pers_signature modname env with + | exception Not_found -> fatal_error ("Module "^modname^" unavailable.") + | env -> begin + match Env.lookup_value (Longident.Lident field) env with + | exception Not_found -> + fatal_error ("Primitive "^modname^"."^field^" not found.") + | (path, _) -> transl_value_path Location.none env path + end + ) + +let code_force_lazy_block = + get_mod_field "CamlinternalLazy" "force_lazy_block" +let code_force_lazy = + get_mod_field "CamlinternalLazy" "force" +;; + +(* inline_lazy_force inlines the beginning of the code of Lazy.force. When + the value argument is tagged as: + - forward, take field 0 + - lazy, call the primitive that forces (without testing again the tag) + - anything else, return it + + Using Lswitch below relies on the fact that the GC does not shortcut + Forward(val_out_of_heap). +*) + +let inline_lazy_force_cond arg loc = + let idarg = Ident.create_local "lzarg" in + let varg = Lvar idarg in + let tag = Ident.create_local "tag" in + let force_fun = Lazy.force code_force_lazy_block in + Llet(Strict, Pgenval, idarg, arg, + Llet(Alias, Pgenval, tag, Lprim(Pccall prim_obj_tag, [varg], loc), + Lifthenelse( + (* if (tag == Obj.forward_tag) then varg.(0) else ... *) + Lprim(Pintcomp Ceq, + [Lvar tag; Lconst(Const_base(Const_int Obj.forward_tag))], + loc), + Lprim(Pfield 0, [varg], loc), + Lifthenelse( + (* ... if (tag == Obj.lazy_tag) then Lazy.force varg else ... *) + Lprim(Pintcomp Ceq, + [Lvar tag; Lconst(Const_base(Const_int Obj.lazy_tag))], + loc), + Lapply{ap_should_be_tailcall=false; + ap_loc=loc; + ap_func=force_fun; + ap_args=[varg]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise}, + (* ... arg *) + varg)))) + +let inline_lazy_force_switch arg loc = + let idarg = Ident.create_local "lzarg" in + let varg = Lvar idarg in + let force_fun = Lazy.force code_force_lazy_block in + Llet(Strict, Pgenval, idarg, arg, + Lifthenelse( + Lprim(Pisint, [varg], loc), varg, + (Lswitch + (varg, + { sw_numconsts = 0; sw_consts = []; + sw_numblocks = 256; (* PR#6033 - tag ranges from 0 to 255 *) + sw_blocks = + [ (Obj.forward_tag, Lprim(Pfield 0, [varg], loc)); + (Obj.lazy_tag, + Lapply{ap_should_be_tailcall=false; + ap_loc=loc; + ap_func=force_fun; + ap_args=[varg]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise}) ]; + sw_failaction = Some varg }, loc )))) + +let inline_lazy_force arg loc = + if !Clflags.afl_instrument then + (* Disable inlining optimisation if AFL instrumentation active, + so that the GC forwarding optimisation is not visible in the + instrumentation output. + (see https://github.com/stedolan/crowbar/issues/14) *) + Lapply{ap_should_be_tailcall = false; + ap_loc=loc; + ap_func=Lazy.force code_force_lazy; + ap_args=[arg]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise} + else + if !Clflags.native_code then + (* Lswitch generates compact and efficient native code *) + inline_lazy_force_switch arg loc + else + (* generating bytecode: Lswitch would generate too many rather big + tables (~ 250 elts); conditionals are better *) + inline_lazy_force_cond arg loc + +let make_lazy_matching def = function + [] -> fatal_error "Matching.make_lazy_matching" + | (arg,_mut) :: argl -> + { cases = []; + args = + (inline_lazy_force arg Location.none, Strict) :: argl; + default = make_default matcher_lazy def } + +let divide_lazy p ctx pm = + divide_line + (filter_ctx p) + make_lazy_matching + get_arg_lazy + p ctx pm + +(* Matching against a tuple pattern *) + + +let get_args_tuple arity p rem = match p with +| {pat_desc = Tpat_any} -> omegas arity @ rem +| {pat_desc = Tpat_tuple args} -> + args @ rem +| _ -> assert false + +let matcher_tuple arity p rem = match p.pat_desc with +| Tpat_or (_,_,_) -> raise OrPat +| Tpat_any +| Tpat_var _ -> omegas arity @ rem +| Tpat_tuple args when List.length args = arity -> args @ rem +| _ -> raise NoMatch + +let make_tuple_matching loc arity def = function + [] -> fatal_error "Matching.make_tuple_matching" + | (arg, _mut) :: argl -> + let rec make_args pos = + if pos >= arity + then argl + else (Lprim(Pfield pos, [arg], loc), Alias) :: make_args (pos + 1) in + {cases = []; args = make_args 0 ; + default=make_default (matcher_tuple arity) def} + + +let divide_tuple arity p ctx pm = + divide_line + (filter_ctx p) + (make_tuple_matching p.pat_loc arity) + (get_args_tuple arity) p ctx pm + +(* Matching against a record pattern *) + + +let record_matching_line num_fields lbl_pat_list = + let patv = Array.make num_fields omega in + List.iter (fun (_, lbl, pat) -> patv.(lbl.lbl_pos) <- pat) lbl_pat_list; + Array.to_list patv + +let get_args_record num_fields p rem = match p with +| {pat_desc=Tpat_any} -> + record_matching_line num_fields [] @ rem +| {pat_desc=Tpat_record (lbl_pat_list,_)} -> + record_matching_line num_fields lbl_pat_list @ rem +| _ -> assert false + +let matcher_record num_fields p rem = match p.pat_desc with +| Tpat_or (_,_,_) -> raise OrPat +| Tpat_any +| Tpat_var _ -> + record_matching_line num_fields [] @ rem +| Tpat_record ([], _) when num_fields = 0 -> rem +| Tpat_record ((_, lbl, _) :: _ as lbl_pat_list, _) + when Array.length lbl.lbl_all = num_fields -> + record_matching_line num_fields lbl_pat_list @ rem +| _ -> raise NoMatch + +let make_record_matching loc all_labels def = function + [] -> fatal_error "Matching.make_record_matching" + | ((arg, _mut) :: argl) -> + let rec make_args pos = + if pos >= Array.length all_labels then argl else begin + let lbl = all_labels.(pos) in + let access = + match lbl.lbl_repres with + | Record_regular | Record_inlined _ -> + Lprim (Pfield lbl.lbl_pos, [arg], loc) + | Record_unboxed _ -> arg + | Record_float -> Lprim (Pfloatfield lbl.lbl_pos, [arg], loc) + | Record_extension _ -> Lprim (Pfield (lbl.lbl_pos + 1), [arg], loc) + in + let str = + match lbl.lbl_mut with + Immutable -> Alias + | Mutable -> StrictOpt in + (access, str) :: make_args(pos + 1) + end in + let nfields = Array.length all_labels in + let def= make_default (matcher_record nfields) def in + {cases = []; args = make_args 0 ; default = def} + + +let divide_record all_labels p ctx pm = + let get_args = get_args_record (Array.length all_labels) in + divide_line + (filter_ctx p) + (make_record_matching p.pat_loc all_labels) + get_args + p ctx pm + +(* Matching against an array pattern *) + +let get_key_array = function + | {pat_desc=Tpat_array patl} -> List.length patl + | _ -> assert false + +let get_args_array p rem = match p with +| {pat_desc=Tpat_array patl} -> patl@rem +| _ -> assert false + +let matcher_array len p rem = match p.pat_desc with +| Tpat_or (_,_,_) -> raise OrPat +| Tpat_array args when List.length args=len -> args @ rem +| Tpat_any -> Parmatch.omegas len @ rem +| _ -> raise NoMatch + +let make_array_matching kind p def ctx = function + | [] -> fatal_error "Matching.make_array_matching" + | ((arg, _mut) :: argl) -> + let len = get_key_array p in + let rec make_args pos = + if pos >= len + then argl + else (Lprim(Parrayrefu kind, + [arg; Lconst(Const_base(Const_int pos))], + p.pat_loc), + StrictOpt) :: make_args (pos + 1) in + let def = make_default (matcher_array len) def + and ctx = filter_ctx p ctx in + {pm={cases = []; args = make_args 0 ; default = def} ; + ctx=ctx ; + pat = normalize_pat p} + +let divide_array kind ctx pm = + divide + (make_array_matching kind) + (=) get_key_array get_args_array ctx pm + + +(* + Specific string test sequence + Will be called by the bytecode compiler, from bytegen.ml. + The strategy is first dichotomic search (we perform 3-way tests + with compare_string), then sequence of equality tests + when there are less then T=strings_test_threshold static strings to match. + + Increasing T entails (slightly) less code, decreasing T + (slightly) favors runtime speed. + T=8 looks a decent tradeoff. +*) + +(* Utilities *) + +let strings_test_threshold = 8 + +let prim_string_notequal = + Pccall(Primitive.simple + ~name:"caml_string_notequal" + ~arity:2 + ~alloc:false) + +let prim_string_compare = + Pccall(Primitive.simple + ~name:"caml_string_compare" + ~arity:2 + ~alloc:false) + +let bind_sw arg k = match arg with +| Lvar _ -> k arg +| _ -> + let id = Ident.create_local "switch" in + Llet (Strict,Pgenval,id,arg,k (Lvar id)) + + +(* Sequential equality tests *) + +let make_string_test_sequence loc arg sw d = + let d,sw = match d with + | None -> + begin match sw with + | (_,d)::sw -> d,sw + | [] -> assert false + end + | Some d -> d,sw in + bind_sw arg + (fun arg -> + List.fold_right + (fun (s,lam) k -> + Lifthenelse + (Lprim + (prim_string_notequal, + [arg; Lconst (Const_immstring s)], loc), + k,lam)) + sw d) + +let rec split k xs = match xs with +| [] -> assert false +| x0::xs -> + if k <= 1 then [],x0,xs + else + let xs,y0,ys = split (k-2) xs in + x0::xs,y0,ys + +let zero_lam = Lconst (Const_base (Const_int 0)) + +let tree_way_test loc arg lt eq gt = + Lifthenelse + (Lprim (Pintcomp Clt,[arg;zero_lam], loc),lt, + Lifthenelse(Lprim (Pintcomp Clt,[zero_lam;arg], loc),gt,eq)) + +(* Dichotomic tree *) + + +let rec do_make_string_test_tree loc arg sw delta d = + let len = List.length sw in + if len <= strings_test_threshold+delta then + make_string_test_sequence loc arg sw d + else + let lt,(s,act),gt = split len sw in + bind_sw + (Lprim + (prim_string_compare, + [arg; Lconst (Const_immstring s)], loc)) + (fun r -> + tree_way_test loc r + (do_make_string_test_tree loc arg lt delta d) + act + (do_make_string_test_tree loc arg gt delta d)) + +(* Entry point *) +let expand_stringswitch loc arg sw d = match d with +| None -> + bind_sw arg + (fun arg -> do_make_string_test_tree loc arg sw 0 None) +| Some e -> + bind_sw arg + (fun arg -> + make_catch e + (fun d -> do_make_string_test_tree loc arg sw 1 (Some d))) + +(**********************) +(* Generic test trees *) +(**********************) + +(* Sharing *) + +(* Add handler, if shared *) +let handle_shared () = + let hs = ref (fun x -> x) in + let handle_shared act = match act with + | Switch.Single act -> act + | Switch.Shared act -> + let i,h = make_catch_delayed act in + let ohs = !hs in + hs := (fun act -> h (ohs act)) ; + make_exit i in + hs,handle_shared + + +let share_actions_tree sw d = + let store = StoreExp.mk_store () in +(* Default action is always shared *) + let d = + match d with + | None -> None + | Some d -> Some (store.Switch.act_store_shared () d) in +(* Store all other actions *) + let sw = + List.map (fun (cst,act) -> cst,store.Switch.act_store () act) sw in + +(* Retrieve all actions, including potential default *) + let acts = store.Switch.act_get_shared () in + +(* Array of actual actions *) + let hs,handle_shared = handle_shared () in + let acts = Array.map handle_shared acts in + +(* Reconstruct default and switch list *) + let d = match d with + | None -> None + | Some d -> Some (acts.(d)) in + let sw = List.map (fun (cst,j) -> cst,acts.(j)) sw in + !hs,sw,d + +(* Note: dichotomic search requires sorted input with no duplicates *) +let rec uniq_lambda_list sw = match sw with + | []|[_] -> sw + | (c1,_ as p1)::((c2,_)::sw2 as sw1) -> + if const_compare c1 c2 = 0 then uniq_lambda_list (p1::sw2) + else p1::uniq_lambda_list sw1 + +let sort_lambda_list l = + let l = + List.stable_sort (fun (x,_) (y,_) -> const_compare x y) l in + uniq_lambda_list l + +let rec cut n l = + if n = 0 then [],l + else match l with + [] -> raise (Invalid_argument "cut") + | a::l -> let l1,l2 = cut (n-1) l in a::l1, l2 + +let rec do_tests_fail loc fail tst arg = function + | [] -> fail + | (c, act)::rem -> + Lifthenelse + (Lprim (tst, [arg ; Lconst (Const_base c)], loc), + do_tests_fail loc fail tst arg rem, + act) + +let rec do_tests_nofail loc tst arg = function + | [] -> fatal_error "Matching.do_tests_nofail" + | [_,act] -> act + | (c,act)::rem -> + Lifthenelse + (Lprim (tst, [arg ; Lconst (Const_base c)], loc), + do_tests_nofail loc tst arg rem, + act) + +let make_test_sequence loc fail tst lt_tst arg const_lambda_list = + let const_lambda_list = sort_lambda_list const_lambda_list in + let hs,const_lambda_list,fail = + share_actions_tree const_lambda_list fail in + + let rec make_test_sequence const_lambda_list = + if List.length const_lambda_list >= 4 && lt_tst <> Pignore then + split_sequence const_lambda_list + else match fail with + | None -> do_tests_nofail loc tst arg const_lambda_list + | Some fail -> do_tests_fail loc fail tst arg const_lambda_list + + and split_sequence const_lambda_list = + let list1, list2 = + cut (List.length const_lambda_list / 2) const_lambda_list in + Lifthenelse(Lprim(lt_tst, + [arg; Lconst(Const_base (fst(List.hd list2)))], + loc), + make_test_sequence list1, make_test_sequence list2) + in + hs (make_test_sequence const_lambda_list) + + +module SArg = struct + type primitive = Lambda.primitive + + let eqint = Pintcomp Ceq + let neint = Pintcomp Cne + let leint = Pintcomp Cle + let ltint = Pintcomp Clt + let geint = Pintcomp Cge + let gtint = Pintcomp Cgt + + type act = Lambda.lambda + + let make_prim p args = Lprim (p,args,Location.none) + let make_offset arg n = match n with + | 0 -> arg + | _ -> Lprim (Poffsetint n,[arg],Location.none) + + let bind arg body = + let newvar,newarg = match arg with + | Lvar v -> v,arg + | _ -> + let newvar = Ident.create_local "switcher" in + newvar,Lvar newvar in + bind Alias newvar arg (body newarg) + let make_const i = Lconst (Const_base (Const_int i)) + let make_isout h arg = Lprim (Pisout, [h ; arg],Location.none) + let make_isin h arg = Lprim (Pnot,[make_isout h arg],Location.none) + let make_if cond ifso ifnot = Lifthenelse (cond, ifso, ifnot) + let make_switch loc arg cases acts = + let l = ref [] in + for i = Array.length cases-1 downto 0 do + l := (i,acts.(cases.(i))) :: !l + done ; + Lswitch(arg, + {sw_numconsts = Array.length cases ; sw_consts = !l ; + sw_numblocks = 0 ; sw_blocks = [] ; + sw_failaction = None}, loc) + let make_catch = make_catch_delayed + let make_exit = make_exit + +end + +(* Action sharing for Lswitch argument *) +let share_actions_sw sw = +(* Attempt sharing on all actions *) + let store = StoreExp.mk_store () in + let fail = match sw.sw_failaction with + | None -> None + | Some fail -> + (* Fail is translated to exit, whatever happens *) + Some (store.Switch.act_store_shared () fail) in + let consts = + List.map + (fun (i,e) -> i,store.Switch.act_store () e) + sw.sw_consts + and blocks = + List.map + (fun (i,e) -> i,store.Switch.act_store () e) + sw.sw_blocks in + let acts = store.Switch.act_get_shared () in + let hs,handle_shared = handle_shared () in + let acts = Array.map handle_shared acts in + let fail = match fail with + | None -> None + | Some fail -> Some (acts.(fail)) in + !hs, + { sw with + sw_consts = List.map (fun (i,j) -> i,acts.(j)) consts ; + sw_blocks = List.map (fun (i,j) -> i,acts.(j)) blocks ; + sw_failaction = fail; } + +(* Reintroduce fail action in switch argument, + for the sake of avoiding carrying over huge switches *) + +let reintroduce_fail sw = match sw.sw_failaction with +| None -> + let t = Hashtbl.create 17 in + let seen (_,l) = match as_simple_exit l with + | Some i -> + let old = try Hashtbl.find t i with Not_found -> 0 in + Hashtbl.replace t i (old+1) + | None -> () in + List.iter seen sw.sw_consts ; + List.iter seen sw.sw_blocks ; + let i_max = ref (-1) + and max = ref (-1) in + Hashtbl.iter + (fun i c -> + if c > !max then begin + i_max := i ; + max := c + end) t ; + if !max >= 3 then + let default = !i_max in + let remove = + List.filter + (fun (_,lam) -> match as_simple_exit lam with + | Some j -> j <> default + | None -> true) in + {sw with + sw_consts = remove sw.sw_consts ; + sw_blocks = remove sw.sw_blocks ; + sw_failaction = Some (make_exit default)} + else sw +| Some _ -> sw + + +module Switcher = Switch.Make(SArg) +open Switch + +let rec last def = function + | [] -> def + | [x,_] -> x + | _::rem -> last def rem + +let get_edges low high l = match l with +| [] -> low, high +| (x,_)::_ -> x, last high l + + +let as_interval_canfail fail low high l = + let store = StoreExp.mk_store () in + + let do_store _tag act = + + let i = store.act_store () act in +(* + eprintf "STORE [%s] %i %s\n" tag i (string_of_lam act) ; +*) + i in + + let rec nofail_rec cur_low cur_high cur_act = function + | [] -> + if cur_high = high then + [cur_low,cur_high,cur_act] + else + [(cur_low,cur_high,cur_act) ; (cur_high+1,high, 0)] + | ((i,act_i)::rem) as all -> + let act_index = do_store "NO" act_i in + if cur_high+1= i then + if act_index=cur_act then + nofail_rec cur_low i cur_act rem + else if act_index=0 then + (cur_low,i-1, cur_act)::fail_rec i i rem + else + (cur_low, i-1, cur_act)::nofail_rec i i act_index rem + else if act_index = 0 then + (cur_low, cur_high, cur_act):: + fail_rec (cur_high+1) (cur_high+1) all + else + (cur_low, cur_high, cur_act):: + (cur_high+1,i-1,0):: + nofail_rec i i act_index rem + + and fail_rec cur_low cur_high = function + | [] -> [(cur_low, cur_high, 0)] + | (i,act_i)::rem -> + let index = do_store "YES" act_i in + if index=0 then fail_rec cur_low i rem + else + (cur_low,i-1,0):: + nofail_rec i i index rem in + + let init_rec = function + | [] -> [low,high,0] + | (i,act_i)::rem -> + let index = do_store "INIT" act_i in + if index=0 then + fail_rec low i rem + else + if low < i then + (low,i-1,0)::nofail_rec i i index rem + else + nofail_rec i i index rem in + + assert (do_store "FAIL" fail = 0) ; (* fail has action index 0 *) + let r = init_rec l in + Array.of_list r, store + +let as_interval_nofail l = + let store = StoreExp.mk_store () in + let rec some_hole = function + | []|[_] -> false + | (i,_)::((j,_)::_ as rem) -> + j > i+1 || some_hole rem in + let rec i_rec cur_low cur_high cur_act = function + | [] -> + [cur_low, cur_high, cur_act] + | (i,act)::rem -> + let act_index = store.act_store () act in + if act_index = cur_act then + i_rec cur_low i cur_act rem + else + (cur_low, cur_high, cur_act):: + i_rec i i act_index rem in + let inters = match l with + | (i,act)::rem -> + let act_index = + (* In case there is some hole and that a switch is emitted, + action 0 will be used as the action of unreachable + cases (cf. switch.ml, make_switch). + Hence, this action will be shared *) + if some_hole rem then + store.act_store_shared () act + else + store.act_store () act in + assert (act_index = 0) ; + i_rec i i act_index rem + | _ -> assert false in + + Array.of_list inters, store + + +let sort_int_lambda_list l = + List.sort + (fun (i1,_) (i2,_) -> + if i1 < i2 then -1 + else if i2 < i1 then 1 + else 0) + l + +let as_interval fail low high l = + let l = sort_int_lambda_list l in + get_edges low high l, + (match fail with + | None -> as_interval_nofail l + | Some act -> as_interval_canfail act low high l) + +let call_switcher loc fail arg low high int_lambda_list = + let edges, (cases, actions) = + as_interval fail low high int_lambda_list in + Switcher.zyva loc edges arg cases actions + + +let rec list_as_pat = function + | [] -> fatal_error "Matching.list_as_pat" + | [pat] -> pat + | pat::rem -> + {pat with pat_desc = Tpat_or (pat,list_as_pat rem,None)} + + +let complete_pats_constrs = function + | p::_ as pats -> + List.map + (pat_of_constr p) + (complete_constrs p (List.map get_key_constr pats)) + | _ -> assert false + + +(* + Following two ``failaction'' function compute n, the trap handler + to jump to in case of failure of elementary tests +*) + +let mk_failaction_neg partial ctx def = match partial with +| Partial -> + begin match def with + | (_,idef)::_ -> + Some (Lstaticraise (idef,[])),jumps_singleton idef ctx + | [] -> + (* Act as Total, this means + If no appropriate default matrix exists, + then this switch cannot fail *) + None, jumps_empty + end +| Total -> + None, jumps_empty + + + +(* In line with the article and simpler than before *) +let mk_failaction_pos partial seen ctx defs = + if dbg then begin + Format.eprintf "**POS**\n" ; + pretty_def defs ; + () + end ; + let rec scan_def env to_test defs = match to_test,defs with + | ([],_)|(_,[]) -> + List.fold_left + (fun (klist,jumps) (pats,i)-> + let action = Lstaticraise (i,[]) in + let klist = + List.fold_right + (fun pat r -> (get_key_constr pat,action)::r) + pats klist + and jumps = + jumps_add i (ctx_lub (list_as_pat pats) ctx) jumps in + klist,jumps) + ([],jumps_empty) env + | _,(pss,idef)::rem -> + let now, later = + List.partition + (fun (_p,p_ctx) -> ctx_match p_ctx pss) to_test in + match now with + | [] -> scan_def env to_test rem + | _ -> scan_def ((List.map fst now,idef)::env) later rem in + + let fail_pats = complete_pats_constrs seen in + if List.length fail_pats < !Clflags.match_context_rows then begin + let fail,jmps = + scan_def + [] + (List.map + (fun pat -> pat, ctx_lub pat ctx) + fail_pats) + defs in + if dbg then begin + eprintf "POSITIVE JUMPS [%i]:\n" (List.length fail_pats); + pretty_jumps jmps + end ; + None,fail,jmps + end else begin (* Too many non-matched constructors -> reduced information *) + if dbg then eprintf "POS->NEG!!!\n%!" ; + let fail,jumps = mk_failaction_neg partial ctx defs in + if dbg then + eprintf "FAIL: %s\n" + (match fail with + | None -> "" + | Some lam -> string_of_lam lam) ; + fail,[],jumps + end + +let combine_constant loc arg cst partial ctx def + (const_lambda_list, total, _pats) = + let fail, local_jumps = + mk_failaction_neg partial ctx def in + let lambda1 = + match cst with + | Const_int _ -> + let int_lambda_list = + List.map (function Const_int n, l -> n,l | _ -> assert false) + const_lambda_list in + call_switcher loc fail arg min_int max_int int_lambda_list + | Const_char _ -> + let int_lambda_list = + List.map (function Const_char c, l -> (Char.code c, l) + | _ -> assert false) + const_lambda_list in + call_switcher loc fail arg 0 255 int_lambda_list + | Const_string _ -> +(* Note as the bytecode compiler may resort to dichotomic search, + the clauses of stringswitch are sorted with duplicates removed. + This partly applies to the native code compiler, which requires + no duplicates *) + let const_lambda_list = sort_lambda_list const_lambda_list in + let sw = + List.map + (fun (c,act) -> match c with + | Const_string (s,_) -> s,act + | _ -> assert false) + const_lambda_list in + let hs,sw,fail = share_actions_tree sw fail in + hs (Lstringswitch (arg,sw,fail,loc)) + | Const_float _ -> + make_test_sequence loc + fail + (Pfloatcomp CFneq) (Pfloatcomp CFlt) + arg const_lambda_list + | Const_int32 _ -> + make_test_sequence loc + fail + (Pbintcomp(Pint32, Cne)) (Pbintcomp(Pint32, Clt)) + arg const_lambda_list + | Const_int64 _ -> + make_test_sequence loc + fail + (Pbintcomp(Pint64, Cne)) (Pbintcomp(Pint64, Clt)) + arg const_lambda_list + | Const_nativeint _ -> + make_test_sequence loc + fail + (Pbintcomp(Pnativeint, Cne)) (Pbintcomp(Pnativeint, Clt)) + arg const_lambda_list + in lambda1,jumps_union local_jumps total + + + +let split_cases tag_lambda_list = + let rec split_rec = function + [] -> ([], []) + | (cstr, act) :: rem -> + let (consts, nonconsts) = split_rec rem in + match cstr with + Cstr_constant n -> ((n, act) :: consts, nonconsts) + | Cstr_block n -> (consts, (n, act) :: nonconsts) + | Cstr_unboxed -> (consts, (0, act) :: nonconsts) + | Cstr_extension _ -> assert false in + let const, nonconst = split_rec tag_lambda_list in + sort_int_lambda_list const, + sort_int_lambda_list nonconst + +let split_extension_cases tag_lambda_list = + let rec split_rec = function + [] -> ([], []) + | (cstr, act) :: rem -> + let (consts, nonconsts) = split_rec rem in + match cstr with + Cstr_extension(path, true) -> ((path, act) :: consts, nonconsts) + | Cstr_extension(path, false) -> (consts, (path, act) :: nonconsts) + | _ -> assert false in + split_rec tag_lambda_list + + +let combine_constructor loc arg ex_pat cstr partial ctx def + (tag_lambda_list, total1, pats) = + if cstr.cstr_consts < 0 then begin + (* Special cases for extensions *) + let fail, local_jumps = + mk_failaction_neg partial ctx def in + let lambda1 = + let consts, nonconsts = split_extension_cases tag_lambda_list in + let default, consts, nonconsts = + match fail with + | None -> + begin match consts, nonconsts with + | _, (_, act)::rem -> act, consts, rem + | (_, act)::rem, _ -> act, rem, nonconsts + | _ -> assert false + end + | Some fail -> fail, consts, nonconsts in + let nonconst_lambda = + match nonconsts with + [] -> default + | _ -> + let tag = Ident.create_local "tag" in + let tests = + List.fold_right + (fun (path, act) rem -> + let ext = transl_extension_path loc ex_pat.pat_env path in + Lifthenelse(Lprim(Pintcomp Ceq, [Lvar tag; ext], loc), + act, rem)) + nonconsts + default + in + Llet(Alias, Pgenval,tag, Lprim(Pfield 0, [arg], loc), tests) + in + List.fold_right + (fun (path, act) rem -> + let ext = transl_extension_path loc ex_pat.pat_env path in + Lifthenelse(Lprim(Pintcomp Ceq, [arg; ext], loc), + act, rem)) + consts + nonconst_lambda + in + lambda1, jumps_union local_jumps total1 + end else begin + (* Regular concrete type *) + let ncases = List.length tag_lambda_list + and nconstrs = cstr.cstr_consts + cstr.cstr_nonconsts in + let sig_complete = ncases = nconstrs in + let fail_opt,fails,local_jumps = + if sig_complete then None,[],jumps_empty + else + mk_failaction_pos partial pats ctx def in + + let tag_lambda_list = fails @ tag_lambda_list in + let (consts, nonconsts) = split_cases tag_lambda_list in + let lambda1 = + match fail_opt,same_actions tag_lambda_list with + | None,Some act -> act (* Identical actions, no failure *) + | _ -> + match + (cstr.cstr_consts, cstr.cstr_nonconsts, consts, nonconsts) + with + | (1, 1, [0, act1], [0, act2]) -> + (* Typically, match on lists, will avoid isint primitive in that + case *) + Lifthenelse(arg, act2, act1) + | (n,0,_,[]) -> (* The type defines constant constructors only *) + call_switcher loc fail_opt arg 0 (n-1) consts + | (n, _, _, _) -> + let act0 = + (* = Some act when all non-const constructors match to act *) + match fail_opt,nonconsts with + | Some a,[] -> Some a + | Some _,_ -> + if List.length nonconsts = cstr.cstr_nonconsts then + same_actions nonconsts + else None + | None,_ -> same_actions nonconsts in + match act0 with + | Some act -> + Lifthenelse + (Lprim (Pisint, [arg], loc), + call_switcher loc + fail_opt arg + 0 (n-1) consts, + act) +(* Emit a switch, as bytecode implements this sophisticated instruction *) + | None -> + let sw = + {sw_numconsts = cstr.cstr_consts; sw_consts = consts; + sw_numblocks = cstr.cstr_nonconsts; sw_blocks = nonconsts; + sw_failaction = fail_opt} in + let hs,sw = share_actions_sw sw in + let sw = reintroduce_fail sw in + hs (Lswitch (arg,sw,loc)) in + lambda1, jumps_union local_jumps total1 + end + +let make_test_sequence_variant_constant fail arg int_lambda_list = + let _, (cases, actions) = + as_interval fail min_int max_int int_lambda_list in + Switcher.test_sequence arg cases actions + +let call_switcher_variant_constant loc fail arg int_lambda_list = + call_switcher loc fail arg min_int max_int int_lambda_list + + +let call_switcher_variant_constr loc fail arg int_lambda_list = + let v = Ident.create_local "variant" in + Llet(Alias, Pgenval, v, Lprim(Pfield 0, [arg], loc), + call_switcher loc + fail (Lvar v) min_int max_int int_lambda_list) + +let combine_variant loc row arg partial ctx def + (tag_lambda_list, total1, _pats) = + let row = Btype.row_repr row in + let num_constr = ref 0 in + if row.row_closed then + List.iter + (fun (_, f) -> + match Btype.row_field_repr f with + Rabsent | Reither(true, _::_, _, _) -> () + | _ -> incr num_constr) + row.row_fields + else + num_constr := max_int; + let test_int_or_block arg if_int if_block = + Lifthenelse(Lprim (Pisint, [arg], loc), if_int, if_block) in + let sig_complete = List.length tag_lambda_list = !num_constr + and one_action = same_actions tag_lambda_list in + let fail, local_jumps = + if + sig_complete || (match partial with Total -> true | _ -> false) + then + None, jumps_empty + else + mk_failaction_neg partial ctx def in + let (consts, nonconsts) = split_cases tag_lambda_list in + let lambda1 = match fail, one_action with + | None, Some act -> act + | _,_ -> + match (consts, nonconsts) with + | ([_, act1], [_, act2]) when fail=None -> + test_int_or_block arg act1 act2 + | (_, []) -> (* One can compare integers and pointers *) + make_test_sequence_variant_constant fail arg consts + | ([], _) -> + let lam = call_switcher_variant_constr loc + fail arg nonconsts in + (* One must not dereference integers *) + begin match fail with + | None -> lam + | Some fail -> test_int_or_block arg fail lam + end + | (_, _) -> + let lam_const = + call_switcher_variant_constant loc + fail arg consts + and lam_nonconst = + call_switcher_variant_constr loc + fail arg nonconsts in + test_int_or_block arg lam_const lam_nonconst + in + lambda1, jumps_union local_jumps total1 + + +let combine_array loc arg kind partial ctx def + (len_lambda_list, total1, _pats) = + let fail, local_jumps = mk_failaction_neg partial ctx def in + let lambda1 = + let newvar = Ident.create_local "len" in + let switch = + call_switcher loc + fail (Lvar newvar) + 0 max_int len_lambda_list in + bind + Alias newvar (Lprim(Parraylength kind, [arg], loc)) switch in + lambda1, jumps_union local_jumps total1 + +(* Insertion of debugging events *) + +let rec event_branch repr lam = + begin match lam, repr with + (_, None) -> + lam + | (Levent(lam', ev), Some r) -> + incr r; + Levent(lam', {lev_loc = ev.lev_loc; + lev_kind = ev.lev_kind; + lev_repr = repr; + lev_env = ev.lev_env}) + | (Llet(str, k, id, lam, body), _) -> + Llet(str, k, id, lam, event_branch repr body) + | Lstaticraise _,_ -> lam + | (_, Some _) -> + Printlambda.lambda Format.str_formatter lam ; + fatal_error + ("Matching.event_branch: "^Format.flush_str_formatter ()) + end + + +(* + This exception is raised when the compiler cannot produce code + because control cannot reach the compiled clause, + + Unused is raised initially in compile_test. + + compile_list (for compiling switch results) catch Unused + + comp_match_handlers (for compiling split matches) + may reraise Unused + + +*) + +exception Unused + +let compile_list compile_fun division = + + let rec c_rec totals = function + | [] -> [], jumps_unions totals, [] + | (key, cell) :: rem -> + begin match cell.ctx with + | [] -> c_rec totals rem + | _ -> + try + let (lambda1, total1) = compile_fun cell.ctx cell.pm in + let c_rem, total, new_pats = + c_rec + (jumps_map ctx_combine total1::totals) rem in + ((key,lambda1)::c_rem), total, (cell.pat::new_pats) + with + | Unused -> c_rec totals rem + end in + c_rec [] division + + +let compile_orhandlers compile_fun lambda1 total1 ctx to_catch = + let rec do_rec r total_r = function + | [] -> r,total_r + | (mat,i,vars,pm)::rem -> + begin try + let ctx = select_columns mat ctx in + let handler_i, total_i = + compile_fun ctx pm in + match raw_action r with + | Lstaticraise (j,args) -> + if i=j then + List.fold_right2 (bind_with_value_kind Alias) + vars args handler_i, + jumps_map (ctx_rshift_num (ncols mat)) total_i + else + do_rec r total_r rem + | _ -> + do_rec + (Lstaticcatch (r,(i,vars), handler_i)) + (jumps_union + (jumps_remove i total_r) + (jumps_map (ctx_rshift_num (ncols mat)) total_i)) + rem + with + | Unused -> + do_rec (Lstaticcatch (r, (i,vars), lambda_unit)) total_r rem + end in + do_rec lambda1 total1 to_catch + + +let compile_test compile_fun partial divide combine ctx to_match = + let division = divide ctx to_match in + let c_div = compile_list compile_fun division in + match c_div with + | [],_,_ -> + begin match mk_failaction_neg partial ctx to_match.default with + | None,_ -> raise Unused + | Some l,total -> l,total + end + | _ -> + combine ctx to_match.default c_div + +(* Attempt to avoid some useless bindings by lowering them *) + +(* Approximation of v present in lam *) +let rec approx_present v = function + | Lconst _ -> false + | Lstaticraise (_,args) -> + List.exists (fun lam -> approx_present v lam) args + | Lprim (_,args,_) -> + List.exists (fun lam -> approx_present v lam) args + | Llet (Alias, _k, _, l1, l2) -> + approx_present v l1 || approx_present v l2 + | Lvar vv -> Ident.same v vv + | _ -> true + +let rec lower_bind v arg lam = match lam with +| Lifthenelse (cond, ifso, ifnot) -> + let pcond = approx_present v cond + and pso = approx_present v ifso + and pnot = approx_present v ifnot in + begin match pcond, pso, pnot with + | false, false, false -> lam + | false, true, false -> + Lifthenelse (cond, lower_bind v arg ifso, ifnot) + | false, false, true -> + Lifthenelse (cond, ifso, lower_bind v arg ifnot) + | _,_,_ -> bind Alias v arg lam + end +| Lswitch (ls,({sw_consts=[i,act] ; sw_blocks = []} as sw), loc) + when not (approx_present v ls) -> + Lswitch (ls, {sw with sw_consts = [i,lower_bind v arg act]}, loc) +| Lswitch (ls,({sw_consts=[] ; sw_blocks = [i,act]} as sw), loc) + when not (approx_present v ls) -> + Lswitch (ls, {sw with sw_blocks = [i,lower_bind v arg act]}, loc) +| Llet (Alias, k, vv, lv, l) -> + if approx_present v lv then + bind Alias v arg lam + else + Llet (Alias, k, vv, lv, lower_bind v arg l) +| _ -> + bind Alias v arg lam + +let bind_check str v arg lam = match str,arg with +| _, Lvar _ ->bind str v arg lam +| Alias,_ -> lower_bind v arg lam +| _,_ -> bind str v arg lam + +let comp_exit ctx m = match m.default with +| (_,i)::_ -> Lstaticraise (i,[]), jumps_singleton i ctx +| _ -> fatal_error "Matching.comp_exit" + + + +let rec comp_match_handlers comp_fun partial ctx arg first_match next_matchs = + match next_matchs with + | [] -> comp_fun partial ctx arg first_match + | rem -> + let rec c_rec body total_body = function + | [] -> body, total_body + (* Hum, -1 means never taken + | (-1,pm)::rem -> c_rec body total_body rem *) + | (i,pm)::rem -> + let ctx_i,total_rem = jumps_extract i total_body in + begin match ctx_i with + | [] -> c_rec body total_body rem + | _ -> + try + let li,total_i = + comp_fun + (match rem with [] -> partial | _ -> Partial) + ctx_i arg pm in + c_rec + (Lstaticcatch (body,(i,[]),li)) + (jumps_union total_i total_rem) + rem + with + | Unused -> + c_rec (Lstaticcatch (body,(i,[]),lambda_unit)) + total_rem rem + end in + try + let first_lam,total = comp_fun Partial ctx arg first_match in + c_rec first_lam total rem + with Unused -> match next_matchs with + | [] -> raise Unused + | (_,x)::xs -> comp_match_handlers comp_fun partial ctx arg x xs + +(* To find reasonable names for variables *) + +let rec name_pattern default = function + (pat :: _, _) :: rem -> + begin match pat.pat_desc with + Tpat_var (id, _) -> id + | Tpat_alias(_, id, _) -> id + | _ -> name_pattern default rem + end + | _ -> Ident.create_local default + +let arg_to_var arg cls = match arg with +| Lvar v -> v,arg +| _ -> + let v = name_pattern "*match*" cls in + v,Lvar v + + +(* + The main compilation function. + Input: + repr=used for inserting debug events + partial=exhaustiveness information from Parmatch + ctx=a context + m=a pattern matching + + Output: a lambda term, a jump summary {..., exit number -> context, .. } +*) + +let rec compile_match repr partial ctx m = match m with +| { cases = []; args = [] } -> comp_exit ctx m +| { cases = ([], action) :: rem } -> + if is_guarded action then begin + let (lambda, total) = + compile_match None partial ctx { m with cases = rem } in + event_branch repr (patch_guarded lambda action), total + end else + (event_branch repr action, jumps_empty) +| { args = (arg, str)::argl } -> + let v,newarg = arg_to_var arg m.cases in + let first_match,rem = + split_precompile (Some v) + { m with args = (newarg, Alias) :: argl } in + let (lam, total) = + comp_match_handlers + ((if dbg then do_compile_matching_pr else do_compile_matching) repr) + partial ctx newarg first_match rem in + bind_check str v arg lam, total +| _ -> assert false + + +(* verbose version of do_compile_matching, for debug *) + +and do_compile_matching_pr repr partial ctx arg x = + Format.eprintf "COMPILE: %s\nMATCH\n" + (match partial with Partial -> "Partial" | Total -> "Total") ; + pretty_precompiled x ; + Format.eprintf "CTX\n" ; + pretty_ctx ctx ; + let (_, jumps) as r = do_compile_matching repr partial ctx arg x in + Format.eprintf "JUMPS\n" ; + pretty_jumps jumps ; + r + +and do_compile_matching repr partial ctx arg pmh = match pmh with +| Pm pm -> + let pat = what_is_cases pm.cases in + begin match pat.pat_desc with + | Tpat_any -> + compile_no_test + divide_var ctx_rshift repr partial ctx pm + | Tpat_tuple patl -> + compile_no_test + (divide_tuple (List.length patl) (normalize_pat pat)) ctx_combine + repr partial ctx pm + | Tpat_record ((_, lbl,_)::_,_) -> + compile_no_test + (divide_record lbl.lbl_all (normalize_pat pat)) + ctx_combine repr partial ctx pm + | Tpat_constant cst -> + compile_test + (compile_match repr partial) partial + divide_constant + (combine_constant pat.pat_loc arg cst partial) + ctx pm + | Tpat_construct (_, cstr, _) -> + compile_test + (compile_match repr partial) partial + divide_constructor + (combine_constructor pat.pat_loc arg pat cstr partial) + ctx pm + | Tpat_array _ -> + let kind = Typeopt.array_pattern_kind pat in + compile_test (compile_match repr partial) partial + (divide_array kind) (combine_array pat.pat_loc arg kind partial) + ctx pm + | Tpat_lazy _ -> + compile_no_test + (divide_lazy (normalize_pat pat)) + ctx_combine repr partial ctx pm + | Tpat_variant(_, _, row) -> + compile_test (compile_match repr partial) partial + (divide_variant !row) + (combine_variant pat.pat_loc !row arg partial) + ctx pm + | _ -> assert false + end +| PmVar {inside=pmh ; var_arg=arg} -> + let lam, total = + do_compile_matching repr partial (ctx_lshift ctx) arg pmh in + lam, jumps_map ctx_rshift total +| PmOr {body=body ; handlers=handlers} -> + let lam, total = compile_match repr partial ctx body in + compile_orhandlers (compile_match repr partial) lam total ctx handlers + +and compile_no_test divide up_ctx repr partial ctx to_match = + let {pm=this_match ; ctx=this_ctx } = divide ctx to_match in + let lambda,total = compile_match repr partial this_ctx this_match in + lambda, jumps_map up_ctx total + + + + +(* The entry points *) + +(* + If there is a guard in a matching or a lazy pattern, + then set exhaustiveness info to Partial. + (because of side effects, assume the worst). + + Notice that exhaustiveness information is trusted by the compiler, + that is, a match flagged as Total should not fail at runtime. + More specifically, for instance if match y with x::_ -> x is flagged + total (as it happens during JoCaml compilation) then y cannot be [] + at runtime. As a consequence, the static Total exhaustiveness information + have to be downgraded to Partial, in the dubious cases where guards + or lazy pattern execute arbitrary code that may perform side effects + and change the subject values. +LM: + Lazy pattern was PR#5992, initial patch by lpw25. + I have generalized the patch, so as to also find mutable fields. +*) + +let find_in_pat pred = + let rec find_rec p = + pred p.pat_desc || + begin match p.pat_desc with + | Tpat_alias (p,_,_) | Tpat_variant (_,Some p,_) | Tpat_lazy p -> + find_rec p + | Tpat_tuple ps|Tpat_construct (_,_,ps) | Tpat_array ps -> + List.exists find_rec ps + | Tpat_record (lpats,_) -> + List.exists + (fun (_, _, p) -> find_rec p) + lpats + | Tpat_or (p,q,_) -> + find_rec p || find_rec q + | Tpat_constant _ | Tpat_var _ + | Tpat_any | Tpat_variant (_,None,_) -> false + | Tpat_exception _ -> assert false + end in + find_rec + +let is_lazy_pat = function + | Tpat_lazy _ -> true + | Tpat_alias _ | Tpat_variant _ | Tpat_record _ + | Tpat_tuple _|Tpat_construct _ | Tpat_array _ + | Tpat_or _ | Tpat_constant _ | Tpat_var _ | Tpat_any + -> false + | Tpat_exception _ -> assert false + +let is_lazy p = find_in_pat is_lazy_pat p + +let have_mutable_field p = match p with +| Tpat_record (lps,_) -> + List.exists + (fun (_,lbl,_) -> + match lbl.Types.lbl_mut with + | Mutable -> true + | Immutable -> false) + lps +| Tpat_alias _ | Tpat_variant _ | Tpat_lazy _ +| Tpat_tuple _|Tpat_construct _ | Tpat_array _ +| Tpat_or _ +| Tpat_constant _ | Tpat_var _ | Tpat_any + -> false +| Tpat_exception _ -> assert false + +let is_mutable p = find_in_pat have_mutable_field p + +(* Downgrade Total when + 1. Matching accesses some mutable fields; + 2. And there are guards or lazy patterns. +*) + +let check_partial is_mutable is_lazy pat_act_list = function + | Partial -> Partial + | Total -> + if + pat_act_list = [] || (* allow empty case list *) + List.exists + (fun (pats, lam) -> + is_mutable pats && (is_guarded lam || is_lazy pats)) + pat_act_list + then Partial + else Total + +let check_partial_list = + check_partial (List.exists is_mutable) (List.exists is_lazy) +let check_partial = check_partial is_mutable is_lazy + +(* have toplevel handler when appropriate *) + +let start_ctx n = [{left=[] ; right = omegas n}] + +let check_total total lambda i handler_fun = + if jumps_is_empty total then + lambda + else begin + Lstaticcatch(lambda, (i,[]), handler_fun()) + end + +let compile_matching repr handler_fun arg pat_act_list partial = + let partial = check_partial pat_act_list partial in + match partial with + | Partial -> + let raise_num = next_raise_count () in + let pm = + { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; + args = [arg, Strict] ; + default = [[[omega]],raise_num]} in + begin try + let (lambda, total) = compile_match repr partial (start_ctx 1) pm in + check_total total lambda raise_num handler_fun + with + | Unused -> assert false (* ; handler_fun() *) + end + | Total -> + let pm = + { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; + args = [arg, Strict] ; + default = []} in + let (lambda, total) = compile_match repr partial (start_ctx 1) pm in + assert (jumps_is_empty total) ; + lambda + + +let partial_function loc () = + let slot = + transl_extension_path loc + Env.initial_safe_string Predef.path_match_failure + in + let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in + Lprim(Praise Raise_regular, [Lprim(Pmakeblock(0, Immutable, None), + [slot; Lconst(Const_block(0, + [Const_base(Const_string (fname, None)); + Const_base(Const_int line); + Const_base(Const_int char)]))], loc)], loc) + +let for_function loc repr param pat_act_list partial = + compile_matching repr (partial_function loc) param pat_act_list partial + +(* In the following two cases, exhaustiveness info is not available! *) +let for_trywith param pat_act_list = + compile_matching None + (fun () -> Lprim(Praise Raise_reraise, [param], Location.none)) + param pat_act_list Partial + +let simple_for_let loc param pat body = + compile_matching None (partial_function loc) param [pat, body] Partial + + +(* Optimize binding of immediate tuples + + The goal of the implementation of 'for_let' below, which replaces + 'simple_for_let', is to avoid tuple allocation in cases such as + this one: + + let (x,y) = + let foo = ... in + if foo then (1, 2) else (3,4) + in bar + + The compiler easily optimizes the simple `let (x,y) = (1,2) in ...` + case (call to Matching.for_multiple_match from Translcore), but + didn't optimize situations where the rhs tuples are hidden under + a more complex context. + + The idea comes from Alain Frisch who suggested and implemented + the following compilation method, based on Lassign: + + let x = dummy in let y = dummy in + begin + let foo = ... in + if foo then + (let x1 = 1 in let y1 = 2 in x <- x1; y <- y1) + else + (let x2 = 3 in let y2 = 4 in x <- x2; y <- y2) + end; + bar + + The current implementation from Gabriel Scherer uses Lstaticcatch / + Lstaticraise instead: + + catch + let foo = ... in + if foo then + (let x1 = 1 in let y1 = 2 in exit x1 y1) + else + (let x2 = 3 in let y2 = 4 in exit x2 y2) + with x y -> + bar + + The catch/exit is used to avoid duplication of the let body ('bar' + in the example), on 'if' branches for example; it is useless for + linear contexts such as 'let', but we don't need to be careful to + generate nice code because Simplif will remove such useless + catch/exit. +*) + +let rec map_return f = function + | Llet (str, k, id, l1, l2) -> Llet (str, k, id, l1, map_return f l2) + | Lletrec (l1, l2) -> Lletrec (l1, map_return f l2) + | Lifthenelse (lcond, lthen, lelse) -> + Lifthenelse (lcond, map_return f lthen, map_return f lelse) + | Lsequence (l1, l2) -> Lsequence (l1, map_return f l2) + | Levent (l, ev) -> Levent (map_return f l, ev) + | Ltrywith (l1, id, l2) -> Ltrywith (map_return f l1, id, map_return f l2) + | Lstaticcatch (l1, b, l2) -> + Lstaticcatch (map_return f l1, b, map_return f l2) + | Lstaticraise _ | Lprim(Praise _, _, _) as l -> l + | l -> f l + +(* The 'opt' reference indicates if the optimization is worthy. + + It is shared by the different calls to 'assign_pat' performed from + 'map_return'. For example with the code + let (x, y) = if foo then z else (1,2) + the else-branch will activate the optimization for both branches. + + That means that the optimization is activated if *there exists* an + interesting tuple in one hole of the let-rhs context. We could + choose to activate it only if *all* holes are interesting. We made + that choice because being optimistic is extremely cheap (one static + exit/catch overhead in the "wrong cases"), while being pessimistic + can be costly (one unnecessary tuple allocation). +*) + +let assign_pat opt nraise catch_ids loc pat lam = + let rec collect acc pat lam = match pat.pat_desc, lam with + | Tpat_tuple patl, Lprim(Pmakeblock _, lams, _) -> + opt := true; + List.fold_left2 collect acc patl lams + | Tpat_tuple patl, Lconst(Const_block(_, scl)) -> + opt := true; + let collect_const acc pat sc = collect acc pat (Lconst sc) in + List.fold_left2 collect_const acc patl scl + | _ -> + (* pattern idents will be bound in staticcatch (let body), so we + refresh them here to guarantee binders uniqueness *) + let pat_ids = pat_bound_idents pat in + let fresh_ids = List.map (fun id -> id, Ident.rename id) pat_ids in + (fresh_ids, alpha_pat fresh_ids pat, lam) :: acc + in + + (* sublets were accumulated by 'collect' with the leftmost tuple + pattern at the bottom of the list; to respect right-to-left + evaluation order for tuples, we must evaluate sublets + top-to-bottom. To preserve tail-rec, we will fold_left the + reversed list. *) + let rev_sublets = List.rev (collect [] pat lam) in + let exit = + (* build an Ident.tbl to avoid quadratic refreshing costs *) + let add t (id, fresh_id) = Ident.add id fresh_id t in + let add_ids acc (ids, _pat, _lam) = List.fold_left add acc ids in + let tbl = List.fold_left add_ids Ident.empty rev_sublets in + let fresh_var id = Lvar (Ident.find_same id tbl) in + Lstaticraise(nraise, List.map fresh_var catch_ids) + in + let push_sublet code (_ids, pat, lam) = simple_for_let loc lam pat code in + List.fold_left push_sublet exit rev_sublets + +let for_let loc param pat body = + match pat.pat_desc with + | Tpat_any -> + (* This eliminates a useless variable (and stack slot in bytecode) + for "let _ = ...". See #6865. *) + Lsequence(param, body) + | Tpat_var (id, _) -> + (* fast path, and keep track of simple bindings to unboxable numbers *) + let k = Typeopt.value_kind pat.pat_env pat.pat_type in + Llet(Strict, k, id, param, body) + | _ -> + let opt = ref false in + let nraise = next_raise_count () in + let catch_ids = pat_bound_idents_full pat in + let ids_with_kinds = + List.map (fun (id, _, typ) -> id, Typeopt.value_kind pat.pat_env typ) + catch_ids + in + let ids = List.map (fun (id, _, _) -> id) catch_ids in + let bind = map_return (assign_pat opt nraise ids loc pat) param in + if !opt then Lstaticcatch(bind, (nraise, ids_with_kinds), body) + else simple_for_let loc param pat body + +(* Handling of tupled functions and matchings *) + +(* Easy case since variables are available *) +let for_tupled_function loc paraml pats_act_list partial = + let partial = check_partial_list pats_act_list partial in + let raise_num = next_raise_count () in + let omegas = [List.map (fun _ -> omega) paraml] in + let pm = + { cases = pats_act_list; + args = List.map (fun id -> (Lvar id, Strict)) paraml ; + default = [omegas,raise_num] + } in + try + let (lambda, total) = compile_match None partial + (start_ctx (List.length paraml)) pm in + check_total total lambda raise_num (partial_function loc) + with + | Unused -> partial_function loc () + + + +let flatten_pattern size p = match p.pat_desc with +| Tpat_tuple args -> args +| Tpat_any -> omegas size +| _ -> raise Cannot_flatten + +let rec flatten_pat_line size p k = match p.pat_desc with +| Tpat_any -> omegas size::k +| Tpat_tuple args -> args::k +| Tpat_or (p1,p2,_) -> flatten_pat_line size p1 (flatten_pat_line size p2 k) +| Tpat_alias (p,_,_) -> (* Note: if this 'as' pat is here, then this is a + useless binding, solves PR#3780 *) + flatten_pat_line size p k +| _ -> fatal_error "Matching.flatten_pat_line" + +let flatten_cases size cases = + List.map + (fun (ps,action) -> match ps with + | [p] -> flatten_pattern size p,action + | _ -> fatal_error "Matching.flatten_case") + cases + +let flatten_matrix size pss = + List.fold_right + (fun ps r -> match ps with + | [p] -> flatten_pat_line size p r + | _ -> fatal_error "Matching.flatten_matrix") + pss [] + +let flatten_def size def = + List.map + (fun (pss,i) -> flatten_matrix size pss,i) + def + +let flatten_pm size args pm = + {args = args ; cases = flatten_cases size pm.cases ; + default = flatten_def size pm.default} + + +let flatten_precompiled size args pmh = match pmh with +| Pm pm -> Pm (flatten_pm size args pm) +| PmOr {body=b ; handlers=hs ; or_matrix=m} -> + PmOr + {body=flatten_pm size args b ; + handlers= + List.map + (fun (mat,i,vars,pm) -> flatten_matrix size mat,i,vars,pm) + hs ; + or_matrix=flatten_matrix size m ;} +| PmVar _ -> assert false + +(* + compiled_flattened is a ``comp_fun'' argument to comp_match_handlers. + Hence it needs a fourth argument, which it ignores +*) + +let compile_flattened repr partial ctx _ pmh = match pmh with +| Pm pm -> compile_match repr partial ctx pm +| PmOr {body=b ; handlers=hs} -> + let lam, total = compile_match repr partial ctx b in + compile_orhandlers (compile_match repr partial) lam total ctx hs +| PmVar _ -> assert false + +let do_for_multiple_match loc paraml pat_act_list partial = + let repr = None in + let partial = check_partial pat_act_list partial in + let raise_num,pm1 = + match partial with + | Partial -> + let raise_num = next_raise_count () in + raise_num, + { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; + args = [Lprim(Pmakeblock(0, Immutable, None), paraml, loc), Strict]; + default = [[[omega]],raise_num] } + | _ -> + -1, + { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; + args = [Lprim(Pmakeblock(0, Immutable, None), paraml, loc), Strict]; + default = [] } in + + try + try +(* Once for checking that compilation is possible *) + let next, nexts = split_precompile None pm1 in + + let size = List.length paraml + and idl = List.map (fun _ -> Ident.create_local "*match*") paraml in + let args = List.map (fun id -> Lvar id, Alias) idl in + + let flat_next = flatten_precompiled size args next + and flat_nexts = + List.map + (fun (e,pm) -> e,flatten_precompiled size args pm) + nexts in + + let lam, total = + comp_match_handlers + (compile_flattened repr) + partial (start_ctx size) () flat_next flat_nexts in + List.fold_right2 (bind Strict) idl paraml + (match partial with + | Partial -> + check_total total lam raise_num (partial_function loc) + | Total -> + assert (jumps_is_empty total) ; + lam) + with Cannot_flatten -> + let (lambda, total) = compile_match None partial (start_ctx 1) pm1 in + begin match partial with + | Partial -> + check_total total lambda raise_num (partial_function loc) + | Total -> + assert (jumps_is_empty total) ; + lambda + end + with Unused -> + assert false (* ; partial_function loc () *) + +(* PR#4828: Believe it or not, the 'paraml' argument below + may not be side effect free. *) + +let param_to_var param = match param with +| Lvar v -> v,None +| _ -> Ident.create_local "*match*",Some param + +let bind_opt (v,eo) k = match eo with +| None -> k +| Some e -> Lambda.bind Strict v e k + +let for_multiple_match loc paraml pat_act_list partial = + let v_paraml = List.map param_to_var paraml in + let paraml = List.map (fun (v,_) -> Lvar v) v_paraml in + List.fold_right bind_opt v_paraml + (do_for_multiple_match loc paraml pat_act_list partial) diff --git a/lambda/matching.mli b/lambda/matching.mli new file mode 100644 index 0000000000..f29901bd0c --- /dev/null +++ b/lambda/matching.mli @@ -0,0 +1,46 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Compilation of pattern-matching *) + +open Typedtree +open Lambda + + +(* Entry points to match compiler *) +val for_function: + Location.t -> int ref option -> lambda -> (pattern * lambda) list -> + partial -> lambda +val for_trywith: + lambda -> (pattern * lambda) list -> lambda +val for_let: + Location.t -> lambda -> pattern -> lambda -> lambda +val for_multiple_match: + Location.t -> lambda list -> (pattern * lambda) list -> partial -> + lambda + +val for_tupled_function: + Location.t -> Ident.t list -> (pattern list * lambda) list -> + partial -> lambda + +exception Cannot_flatten + +val flatten_pattern: int -> pattern -> pattern list + +(* Expand stringswitch to string test tree *) +val expand_stringswitch: + Location.t -> lambda -> (string * lambda) list -> lambda option -> lambda + +val inline_lazy_force : lambda -> Location.t -> lambda diff --git a/lambda/printlambda.ml b/lambda/printlambda.ml new file mode 100644 index 0000000000..e4bb26a686 --- /dev/null +++ b/lambda/printlambda.ml @@ -0,0 +1,648 @@ +(**************************************************************************) +(* *) +(* 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 Primitive +open Types +open Lambda + + +let rec struct_const ppf = function + | Const_base(Const_int n) -> fprintf ppf "%i" n + | Const_base(Const_char c) -> fprintf ppf "%C" c + | Const_base(Const_string (s, _)) -> fprintf ppf "%S" s + | Const_immstring s -> fprintf ppf "#%S" s + | Const_base(Const_float f) -> fprintf ppf "%s" f + | Const_base(Const_int32 n) -> fprintf ppf "%lil" n + | Const_base(Const_int64 n) -> fprintf ppf "%LiL" n + | Const_base(Const_nativeint n) -> fprintf ppf "%nin" n + | Const_pointer n -> fprintf ppf "%ia" n + | Const_block(tag, []) -> + fprintf ppf "[%i]" tag + | Const_block(tag, sc1::scl) -> + let sconsts ppf scl = + List.iter (fun sc -> fprintf ppf "@ %a" struct_const sc) scl in + fprintf ppf "@[<1>[%i:@ @[%a%a@]]@]" tag struct_const sc1 sconsts scl + | Const_float_array [] -> + fprintf ppf "[| |]" + | Const_float_array (f1 :: fl) -> + let floats ppf fl = + List.iter (fun f -> fprintf ppf "@ %s" f) fl in + fprintf ppf "@[<1>[|@[%s%a@]|]@]" f1 floats fl + +let array_kind = function + | Pgenarray -> "gen" + | Paddrarray -> "addr" + | Pintarray -> "int" + | Pfloatarray -> "float" + +let boxed_integer_name = function + | Pnativeint -> "nativeint" + | Pint32 -> "int32" + | Pint64 -> "int64" + +let value_kind ppf = function + | Pgenval -> () + | Pintval -> fprintf ppf "[int]" + | Pfloatval -> fprintf ppf "[float]" + | Pboxedintval bi -> fprintf ppf "[%s]" (boxed_integer_name bi) + +let return_kind ppf = function + | Pgenval -> () + | Pintval -> fprintf ppf ": int@ " + | Pfloatval -> fprintf ppf ": float@ " + | Pboxedintval bi -> fprintf ppf ": %s@ " (boxed_integer_name bi) + +let field_kind = function + | Pgenval -> "*" + | Pintval -> "int" + | Pfloatval -> "float" + | Pboxedintval bi -> boxed_integer_name bi + +let print_boxed_integer_conversion ppf bi1 bi2 = + fprintf ppf "%s_of_%s" (boxed_integer_name bi2) (boxed_integer_name bi1) + +let boxed_integer_mark name = function + | Pnativeint -> Printf.sprintf "Nativeint.%s" name + | Pint32 -> Printf.sprintf "Int32.%s" name + | Pint64 -> Printf.sprintf "Int64.%s" name + +let print_boxed_integer name ppf bi = + fprintf ppf "%s" (boxed_integer_mark name bi);; + +let print_bigarray name unsafe kind ppf layout = + fprintf ppf "Bigarray.%s[%s,%s]" + (if unsafe then "unsafe_"^ name else name) + (match kind with + | Pbigarray_unknown -> "generic" + | Pbigarray_float32 -> "float32" + | Pbigarray_float64 -> "float64" + | Pbigarray_sint8 -> "sint8" + | Pbigarray_uint8 -> "uint8" + | Pbigarray_sint16 -> "sint16" + | Pbigarray_uint16 -> "uint16" + | Pbigarray_int32 -> "int32" + | Pbigarray_int64 -> "int64" + | Pbigarray_caml_int -> "camlint" + | Pbigarray_native_int -> "nativeint" + | Pbigarray_complex32 -> "complex32" + | Pbigarray_complex64 -> "complex64") + (match layout with + | Pbigarray_unknown_layout -> "unknown" + | Pbigarray_c_layout -> "C" + | Pbigarray_fortran_layout -> "Fortran") + +let record_rep ppf r = + match r with + | Record_regular -> fprintf ppf "regular" + | Record_inlined i -> fprintf ppf "inlined(%i)" i + | Record_unboxed false -> fprintf ppf "unboxed" + | Record_unboxed true -> fprintf ppf "inlined(unboxed)" + | Record_float -> fprintf ppf "float" + | Record_extension path -> fprintf ppf "ext(%a)" Printtyp.path path +;; + +let block_shape ppf shape = match shape with + | None | Some [] -> () + | Some l when List.for_all ((=) Pgenval) l -> () + | Some [elt] -> + Format.fprintf ppf " (%s)" (field_kind elt) + | Some (h :: t) -> + Format.fprintf ppf " (%s" (field_kind h); + List.iter (fun elt -> + Format.fprintf ppf ",%s" (field_kind elt)) + t; + Format.fprintf ppf ")" + +let integer_comparison ppf = function + | Ceq -> fprintf ppf "==" + | Cne -> fprintf ppf "!=" + | Clt -> fprintf ppf "<" + | Cle -> fprintf ppf "<=" + | Cgt -> fprintf ppf ">" + | Cge -> fprintf ppf ">=" + +let float_comparison ppf = function + | CFeq -> fprintf ppf "==." + | CFneq -> fprintf ppf "!=." + | CFlt -> fprintf ppf "<." + | CFnlt -> fprintf ppf "!<." + | CFle -> fprintf ppf "<=." + | CFnle -> fprintf ppf "!<=." + | CFgt -> fprintf ppf ">." + | CFngt -> fprintf ppf "!>." + | CFge -> fprintf ppf ">=." + | CFnge -> fprintf ppf "!>=." + +let primitive ppf = function + | Pidentity -> fprintf ppf "id" + | Pbytes_to_string -> fprintf ppf "bytes_to_string" + | Pbytes_of_string -> fprintf ppf "bytes_of_string" + | Pignore -> fprintf ppf "ignore" + | Prevapply -> fprintf ppf "revapply" + | Pdirapply -> fprintf ppf "dirapply" + | Pgetglobal id -> fprintf ppf "global %a" Ident.print id + | Psetglobal id -> fprintf ppf "setglobal %a" Ident.print id + | Pmakeblock(tag, Immutable, shape) -> + fprintf ppf "makeblock %i%a" tag block_shape shape + | Pmakeblock(tag, Mutable, shape) -> + fprintf ppf "makemutable %i%a" tag 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" record_rep rep size + | Pccall p -> fprintf ppf "%s" p.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) -> 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) -> 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) + | Pctconst c -> + let const_name = match c with + | Big_endian -> "big_endian" + | Word_size -> "word_size" + | Int_size -> "int_size" + | Max_wosize -> "max_wosize" + | Ostype_unix -> "ostype_unix" + | Ostype_win32 -> "ostype_win32" + | Ostype_cygwin -> "ostype_cygwin" + | Backend_type -> "backend_type" in + fprintf ppf "sys.constant_%s" const_name + | 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) -> print_boxed_integer_conversion ppf bi1 bi2 + | 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) -> + print_bigarray "get" unsafe kind ppf layout + | Pbigarrayset(unsafe, _n, kind, layout) -> + print_bigarray "set" unsafe kind ppf layout + | Pbigarraydim(n) -> fprintf ppf "Bigarray.dim_%i" n + | Pstring_load_16(unsafe) -> + if unsafe then fprintf ppf "string.unsafe_get16" + else fprintf ppf "string.get16" + | Pstring_load_32(unsafe) -> + if unsafe then fprintf ppf "string.unsafe_get32" + else fprintf ppf "string.get32" + | Pstring_load_64(unsafe) -> + if unsafe then fprintf ppf "string.unsafe_get64" + else fprintf ppf "string.get64" + | Pbytes_load_16(unsafe) -> + if unsafe then fprintf ppf "bytes.unsafe_get16" + else fprintf ppf "bytes.get16" + | Pbytes_load_32(unsafe) -> + if unsafe then fprintf ppf "bytes.unsafe_get32" + else fprintf ppf "bytes.get32" + | Pbytes_load_64(unsafe) -> + if unsafe then fprintf ppf "bytes.unsafe_get64" + else fprintf ppf "bytes.get64" + | Pbytes_set_16(unsafe) -> + if unsafe then fprintf ppf "bytes.unsafe_set16" + else fprintf ppf "bytes.set16" + | Pbytes_set_32(unsafe) -> + if unsafe then fprintf ppf "bytes.unsafe_set32" + else fprintf ppf "bytes.set32" + | Pbytes_set_64(unsafe) -> + if unsafe then fprintf ppf "bytes.unsafe_set64" + else fprintf ppf "bytes.set64" + | Pbigstring_load_16(unsafe) -> + if unsafe then fprintf ppf "bigarray.array1.unsafe_get16" + else fprintf ppf "bigarray.array1.get16" + | Pbigstring_load_32(unsafe) -> + if unsafe then fprintf ppf "bigarray.array1.unsafe_get32" + else fprintf ppf "bigarray.array1.get32" + | Pbigstring_load_64(unsafe) -> + if unsafe then fprintf ppf "bigarray.array1.unsafe_get64" + else fprintf ppf "bigarray.array1.get64" + | Pbigstring_set_16(unsafe) -> + if unsafe then fprintf ppf "bigarray.array1.unsafe_set16" + else fprintf ppf "bigarray.array1.set16" + | Pbigstring_set_32(unsafe) -> + if unsafe then fprintf ppf "bigarray.array1.unsafe_set32" + else fprintf ppf "bigarray.array1.set32" + | Pbigstring_set_64(unsafe) -> + if unsafe then fprintf ppf "bigarray.array1.unsafe_set64" + else fprintf ppf "bigarray.array1.set64" + | Pbswap16 -> fprintf ppf "bswap16" + | Pbbswap(bi) -> print_boxed_integer "bswap" ppf bi + | Pint_as_pointer -> fprintf ppf "int_as_pointer" + | Popaque -> fprintf ppf "opaque" + +let name_of_primitive = function + | Pidentity -> "Pidentity" + | Pbytes_of_string -> "Pbytes_of_string" + | Pbytes_to_string -> "Pbytes_to_string" + | Pignore -> "Pignore" + | Prevapply -> "Prevapply" + | Pdirapply -> "Pdirapply" + | Pgetglobal _ -> "Pgetglobal" + | Psetglobal _ -> "Psetglobal" + | Pmakeblock _ -> "Pmakeblock" + | Pfield _ -> "Pfield" + | Pfield_computed -> "Pfield_computed" + | Psetfield _ -> "Psetfield" + | Psetfield_computed _ -> "Psetfield_computed" + | Pfloatfield _ -> "Pfloatfield" + | Psetfloatfield _ -> "Psetfloatfield" + | Pduprecord _ -> "Pduprecord" + | Pccall _ -> "Pccall" + | Praise _ -> "Praise" + | Psequand -> "Psequand" + | Psequor -> "Psequor" + | Pnot -> "Pnot" + | Pnegint -> "Pnegint" + | Paddint -> "Paddint" + | Psubint -> "Psubint" + | Pmulint -> "Pmulint" + | Pdivint _ -> "Pdivint" + | Pmodint _ -> "Pmodint" + | Pandint -> "Pandint" + | Porint -> "Porint" + | Pxorint -> "Pxorint" + | Plslint -> "Plslint" + | Plsrint -> "Plsrint" + | Pasrint -> "Pasrint" + | Pintcomp _ -> "Pintcomp" + | Poffsetint _ -> "Poffsetint" + | Poffsetref _ -> "Poffsetref" + | Pintoffloat -> "Pintoffloat" + | Pfloatofint -> "Pfloatofint" + | Pnegfloat -> "Pnegfloat" + | Pabsfloat -> "Pabsfloat" + | Paddfloat -> "Paddfloat" + | Psubfloat -> "Psubfloat" + | Pmulfloat -> "Pmulfloat" + | Pdivfloat -> "Pdivfloat" + | Pfloatcomp _ -> "Pfloatcomp" + | Pstringlength -> "Pstringlength" + | Pstringrefu -> "Pstringrefu" + | Pstringrefs -> "Pstringrefs" + | Pbyteslength -> "Pbyteslength" + | Pbytesrefu -> "Pbytesrefu" + | Pbytessetu -> "Pbytessetu" + | Pbytesrefs -> "Pbytesrefs" + | Pbytessets -> "Pbytessets" + | Parraylength _ -> "Parraylength" + | Pmakearray _ -> "Pmakearray" + | Pduparray _ -> "Pduparray" + | Parrayrefu _ -> "Parrayrefu" + | Parraysetu _ -> "Parraysetu" + | Parrayrefs _ -> "Parrayrefs" + | Parraysets _ -> "Parraysets" + | Pctconst _ -> "Pctconst" + | Pisint -> "Pisint" + | Pisout -> "Pisout" + | Pbintofint _ -> "Pbintofint" + | Pintofbint _ -> "Pintofbint" + | Pcvtbint _ -> "Pcvtbint" + | Pnegbint _ -> "Pnegbint" + | Paddbint _ -> "Paddbint" + | Psubbint _ -> "Psubbint" + | Pmulbint _ -> "Pmulbint" + | Pdivbint _ -> "Pdivbint" + | Pmodbint _ -> "Pmodbint" + | Pandbint _ -> "Pandbint" + | Porbint _ -> "Porbint" + | Pxorbint _ -> "Pxorbint" + | Plslbint _ -> "Plslbint" + | Plsrbint _ -> "Plsrbint" + | Pasrbint _ -> "Pasrbint" + | Pbintcomp _ -> "Pbintcomp" + | Pbigarrayref _ -> "Pbigarrayref" + | Pbigarrayset _ -> "Pbigarrayset" + | Pbigarraydim _ -> "Pbigarraydim" + | Pstring_load_16 _ -> "Pstring_load_16" + | Pstring_load_32 _ -> "Pstring_load_32" + | Pstring_load_64 _ -> "Pstring_load_64" + | Pbytes_load_16 _ -> "Pbytes_load_16" + | Pbytes_load_32 _ -> "Pbytes_load_32" + | Pbytes_load_64 _ -> "Pbytes_load_64" + | Pbytes_set_16 _ -> "Pbytes_set_16" + | Pbytes_set_32 _ -> "Pbytes_set_32" + | Pbytes_set_64 _ -> "Pbytes_set_64" + | Pbigstring_load_16 _ -> "Pbigstring_load_16" + | Pbigstring_load_32 _ -> "Pbigstring_load_32" + | Pbigstring_load_64 _ -> "Pbigstring_load_64" + | Pbigstring_set_16 _ -> "Pbigstring_set_16" + | Pbigstring_set_32 _ -> "Pbigstring_set_32" + | Pbigstring_set_64 _ -> "Pbigstring_set_64" + | Pbswap16 -> "Pbswap16" + | Pbbswap _ -> "Pbbswap" + | Pint_as_pointer -> "Pint_as_pointer" + | Popaque -> "Popaque" + +let function_attribute ppf { inline; specialise; local; is_a_functor; stub } = + if is_a_functor then + fprintf ppf "is_a_functor@ "; + if stub then + fprintf ppf "stub@ "; + begin match inline with + | Default_inline -> () + | Always_inline -> fprintf ppf "always_inline@ " + | Never_inline -> fprintf ppf "never_inline@ " + | Unroll i -> fprintf ppf "unroll(%i)@ " i + end; + begin match specialise with + | Default_specialise -> () + | Always_specialise -> fprintf ppf "always_specialise@ " + | Never_specialise -> fprintf ppf "never_specialise@ " + end; + begin match local with + | Default_local -> () + | Always_local -> fprintf ppf "always_local@ " + | Never_local -> fprintf ppf "never_local@ " + end + +let apply_tailcall_attribute ppf tailcall = + if tailcall then + fprintf ppf " @@tailcall" + +let apply_inlined_attribute ppf = function + | Default_inline -> () + | Always_inline -> fprintf ppf " always_inline" + | Never_inline -> fprintf ppf " never_inline" + | Unroll i -> fprintf ppf " never_inline(%i)" i + +let apply_specialised_attribute ppf = function + | Default_specialise -> () + | Always_specialise -> fprintf ppf " always_specialise" + | Never_specialise -> fprintf ppf " never_specialise" + +let rec lam ppf = function + | Lvar id -> + Ident.print ppf id + | Lconst cst -> + struct_const ppf cst + | Lapply ap -> + let lams ppf largs = + List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in + fprintf ppf "@[<2>(apply@ %a%a%a%a%a)@]" lam ap.ap_func lams ap.ap_args + apply_tailcall_attribute ap.ap_should_be_tailcall + apply_inlined_attribute ap.ap_inlined + apply_specialised_attribute ap.ap_specialised + | Lfunction{kind; params; return; body; attr} -> + let pr_params ppf params = + match kind with + | Curried -> + List.iter (fun (param, k) -> + fprintf ppf "@ %a%a" Ident.print param value_kind k) params + | Tupled -> + fprintf ppf " ("; + let first = ref true in + List.iter + (fun (param, k) -> + if !first then first := false else fprintf ppf ",@ "; + Ident.print ppf param; + value_kind ppf k) + params; + fprintf ppf ")" in + fprintf ppf "@[<2>(function%a@ %a%a%a)@]" pr_params params + function_attribute attr return_kind return lam body + | Llet(str, k, id, arg, body) -> + let kind = function + Alias -> "a" | Strict -> "" | StrictOpt -> "o" | Variable -> "v" + in + let rec letbody = function + | Llet(str, k, id, arg, body) -> + fprintf ppf "@ @[<2>%a =%s%a@ %a@]" + Ident.print id (kind str) value_kind k lam arg; + letbody body + | expr -> expr in + fprintf ppf "@[<2>(let@ @[(@[<2>%a =%s%a@ %a@]" + Ident.print id (kind str) value_kind k lam arg; + let expr = letbody body in + fprintf ppf ")@]@ %a)@]" lam expr + | Lletrec(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@]" Ident.print id lam l) + id_arg_list in + fprintf ppf + "@[<2>(letrec@ (@[%a@])@ %a)@]" bindings id_arg_list lam body + | Lprim(prim, largs, _) -> + let lams ppf largs = + List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in + fprintf ppf "@[<2>(%a%a)@]" primitive prim lams largs + | Lswitch(larg, sw, _loc) -> + let switch ppf sw = + 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.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.sw_blocks ; + begin match sw.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 %a@ @[%a@])@]" + (match sw.sw_failaction with None -> "switch*" | _ -> "switch") + lam larg switch sw + | Lstringswitch(arg, cases, default, _) -> + let switch ppf cases = + let spc = ref false in + List.iter + (fun (s, l) -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[case \"%s\":@ %a@]" (String.escaped s) lam l) + cases; + 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@])@]" lam arg switch cases + | Lstaticraise (i, ls) -> + let lams ppf largs = + List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in + fprintf ppf "@[<2>(exit@ %d%a)@]" i lams ls; + | Lstaticcatch(lbody, (i, vars), lhandler) -> + fprintf ppf "@[<2>(catch@ %a@;<1 -1>with (%d%a)@ %a)@]" + lam lbody i + (fun ppf vars -> + List.iter + (fun (x, k) -> fprintf ppf " %a%a" Ident.print x value_kind k) + vars + ) + vars + lam lhandler + | Ltrywith(lbody, param, lhandler) -> + fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]" + lam lbody Ident.print param lam lhandler + | Lifthenelse(lcond, lif, lelse) -> + fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" lam lcond lam lif lam lelse + | Lsequence(l1, l2) -> + fprintf ppf "@[<2>(seq@ %a@ %a)@]" lam l1 sequence l2 + | Lwhile(lcond, lbody) -> + fprintf ppf "@[<2>(while@ %a@ %a)@]" lam lcond lam lbody + | Lfor(param, lo, hi, dir, body) -> + fprintf ppf "@[<2>(for %a@ %a@ %s@ %a@ %a)@]" + Ident.print param lam lo + (match dir with Upto -> "to" | Downto -> "downto") + lam hi lam body + | Lassign(id, expr) -> + fprintf ppf "@[<2>(assign@ %a@ %a)@]" Ident.print id lam expr + | Lsend (k, met, obj, largs, _) -> + let args ppf largs = + List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in + let kind = + if k = Self then "self" else if k = Cached then "cache" else "" in + fprintf ppf "@[<2>(send%s@ %a@ %a%a)@]" kind lam obj lam met args largs + | Levent(expr, ev) -> + let kind = + match ev.lev_kind with + | Lev_before -> "before" + | Lev_after _ -> "after" + | Lev_function -> "funct-body" + | Lev_pseudo -> "pseudo" + | Lev_module_definition ident -> + Format.asprintf "module-defn(%a)" Ident.print ident + in + fprintf ppf "@[<2>(%s %s(%i)%s:%i-%i@ %a)@]" kind + ev.lev_loc.Location.loc_start.Lexing.pos_fname + ev.lev_loc.Location.loc_start.Lexing.pos_lnum + (if ev.lev_loc.Location.loc_ghost then "" else "") + ev.lev_loc.Location.loc_start.Lexing.pos_cnum + ev.lev_loc.Location.loc_end.Lexing.pos_cnum + lam expr + | Lifused(id, expr) -> + fprintf ppf "@[<2>(ifused@ %a@ %a)@]" Ident.print id lam expr + +and sequence ppf = function + | Lsequence(l1, l2) -> + fprintf ppf "%a@ %a" sequence l1 sequence l2 + | l -> + lam ppf l + +let structured_constant = struct_const + +let lambda = lam + +let program ppf { code } = lambda ppf code diff --git a/lambda/printlambda.mli b/lambda/printlambda.mli new file mode 100644 index 0000000000..7dab5229ac --- /dev/null +++ b/lambda/printlambda.mli @@ -0,0 +1,32 @@ +(**************************************************************************) +(* *) +(* 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 Lambda + +open Format + +val integer_comparison: formatter -> integer_comparison -> unit +val float_comparison: formatter -> float_comparison -> unit +val structured_constant: formatter -> structured_constant -> unit +val lambda: formatter -> lambda -> unit +val program: formatter -> program -> unit +val primitive: formatter -> primitive -> unit +val name_of_primitive : primitive -> string +val value_kind : formatter -> value_kind -> unit +val block_shape : formatter -> value_kind list option -> unit +val record_rep : formatter -> Types.record_representation -> unit +val print_bigarray : + string -> bool -> Lambda.bigarray_kind -> formatter -> + Lambda.bigarray_layout -> unit diff --git a/lambda/runtimedef.mli b/lambda/runtimedef.mli new file mode 100644 index 0000000000..3baabb643b --- /dev/null +++ b/lambda/runtimedef.mli @@ -0,0 +1,19 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Values and functions known and/or provided by the runtime system *) + +val builtin_exceptions: string array +val builtin_primitives: string array diff --git a/lambda/simplif.ml b/lambda/simplif.ml new file mode 100644 index 0000000000..d57171e8b1 --- /dev/null +++ b/lambda/simplif.ml @@ -0,0 +1,854 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Elimination of useless Llet(Alias) bindings. + Also transform let-bound references into variables. *) + +open Asttypes +open Lambda + +(* To transform let-bound references into variables *) + +exception Real_reference + +let rec eliminate_ref id = function + Lvar v as lam -> + if Ident.same v id then raise Real_reference else lam + | Lconst _ as lam -> lam + | Lapply ap -> + Lapply{ap with ap_func = eliminate_ref id ap.ap_func; + ap_args = List.map (eliminate_ref id) ap.ap_args} + | Lfunction _ as lam -> + if Ident.Set.mem id (free_variables lam) + then raise Real_reference + else lam + | Llet(str, kind, v, e1, e2) -> + Llet(str, kind, v, eliminate_ref id e1, eliminate_ref id e2) + | Lletrec(idel, e2) -> + Lletrec(List.map (fun (v, e) -> (v, eliminate_ref id e)) idel, + eliminate_ref id e2) + | Lprim(Pfield 0, [Lvar v], _) when Ident.same v id -> + Lvar id + | Lprim(Psetfield(0, _, _), [Lvar v; e], _) when Ident.same v id -> + Lassign(id, eliminate_ref id e) + | Lprim(Poffsetref delta, [Lvar v], loc) when Ident.same v id -> + Lassign(id, Lprim(Poffsetint delta, [Lvar id], loc)) + | Lprim(p, el, loc) -> + Lprim(p, List.map (eliminate_ref id) el, loc) + | Lswitch(e, sw, loc) -> + Lswitch(eliminate_ref id e, + {sw_numconsts = sw.sw_numconsts; + sw_consts = + List.map (fun (n, e) -> (n, eliminate_ref id e)) sw.sw_consts; + sw_numblocks = sw.sw_numblocks; + sw_blocks = + List.map (fun (n, e) -> (n, eliminate_ref id e)) sw.sw_blocks; + sw_failaction = + Misc.may_map (eliminate_ref id) sw.sw_failaction; }, + loc) + | Lstringswitch(e, sw, default, loc) -> + Lstringswitch + (eliminate_ref id e, + List.map (fun (s, e) -> (s, eliminate_ref id e)) sw, + Misc.may_map (eliminate_ref id) default, loc) + | Lstaticraise (i,args) -> + Lstaticraise (i,List.map (eliminate_ref id) args) + | Lstaticcatch(e1, i, e2) -> + Lstaticcatch(eliminate_ref id e1, i, eliminate_ref id e2) + | Ltrywith(e1, v, e2) -> + Ltrywith(eliminate_ref id e1, v, eliminate_ref id e2) + | Lifthenelse(e1, e2, e3) -> + Lifthenelse(eliminate_ref id e1, + eliminate_ref id e2, + eliminate_ref id e3) + | Lsequence(e1, e2) -> + Lsequence(eliminate_ref id e1, eliminate_ref id e2) + | Lwhile(e1, e2) -> + Lwhile(eliminate_ref id e1, eliminate_ref id e2) + | Lfor(v, e1, e2, dir, e3) -> + Lfor(v, eliminate_ref id e1, eliminate_ref id e2, + dir, eliminate_ref id e3) + | Lassign(v, e) -> + Lassign(v, eliminate_ref id e) + | Lsend(k, m, o, el, loc) -> + Lsend(k, eliminate_ref id m, eliminate_ref id o, + List.map (eliminate_ref id) el, loc) + | Levent(l, ev) -> + Levent(eliminate_ref id l, ev) + | Lifused(v, e) -> + Lifused(v, eliminate_ref id e) + +(* Simplification of exits *) + +type exit = { + mutable count: int; + mutable max_depth: int; +} + +let simplify_exits lam = + + (* Count occurrences of (exit n ...) statements *) + let exits = Hashtbl.create 17 in + + let try_depth = ref 0 in + + let get_exit i = + try Hashtbl.find exits i + with Not_found -> {count = 0; max_depth = 0} + + and incr_exit i nb d = + match Hashtbl.find_opt exits i with + | Some r -> + r.count <- r.count + nb; + r.max_depth <- max r.max_depth d + | None -> + let r = {count = nb; max_depth = d} in + Hashtbl.add exits i r + in + + let rec count = function + | (Lvar _| Lconst _) -> () + | Lapply ap -> count ap.ap_func; List.iter count ap.ap_args + | Lfunction {body} -> count body + | Llet(_str, _kind, _v, l1, l2) -> + count l2; count l1 + | Lletrec(bindings, body) -> + List.iter (fun (_v, l) -> count l) bindings; + count body + | Lprim(_p, ll, _) -> List.iter count ll + | Lswitch(l, sw, _loc) -> + count_default sw ; + count l; + List.iter (fun (_, l) -> count l) sw.sw_consts; + List.iter (fun (_, l) -> count l) sw.sw_blocks + | Lstringswitch(l, sw, d, _) -> + count l; + List.iter (fun (_, l) -> count l) sw; + begin match d with + | None -> () + | Some d -> match sw with + | []|[_] -> count d + | _ -> count d; count d (* default will get replicated *) + end + | Lstaticraise (i,ls) -> incr_exit i 1 !try_depth; List.iter count ls + | Lstaticcatch (l1,(i,[]),Lstaticraise (j,[])) -> + (* i will be replaced by j in l1, so each occurrence of i in l1 + increases j's ref count *) + count l1 ; + let ic = get_exit i in + incr_exit j ic.count (max !try_depth ic.max_depth) + | Lstaticcatch(l1, (i,_), l2) -> + count l1; + (* If l1 does not contain (exit i), + l2 will be removed, so don't count its exits *) + if (get_exit i).count > 0 then + count l2 + | Ltrywith(l1, _v, l2) -> incr try_depth; count l1; decr try_depth; count l2 + | Lifthenelse(l1, l2, l3) -> count l1; count l2; count l3 + | Lsequence(l1, l2) -> count l1; count l2 + | Lwhile(l1, l2) -> count l1; count l2 + | Lfor(_, l1, l2, _dir, l3) -> count l1; count l2; count l3 + | Lassign(_v, l) -> count l + | Lsend(_k, m, o, ll, _) -> List.iter count (m::o::ll) + | Levent(l, _) -> count l + | Lifused(_v, l) -> count l + + and count_default sw = match sw.sw_failaction with + | None -> () + | Some al -> + let nconsts = List.length sw.sw_consts + and nblocks = List.length sw.sw_blocks in + if + nconsts < sw.sw_numconsts && nblocks < sw.sw_numblocks + then begin (* default action will occur twice in native code *) + count al ; count al + end else begin (* default action will occur once *) + assert (nconsts < sw.sw_numconsts || nblocks < sw.sw_numblocks) ; + count al + end + in + count lam; + assert(!try_depth = 0); + + (* + Second pass simplify ``catch body with (i ...) handler'' + - if (exit i ...) does not occur in body, suppress catch + - if (exit i ...) occurs exactly once in body, + substitute it with handler + - If handler is a single variable, replace (exit i ..) with it + Note: + In ``catch body with (i x1 .. xn) handler'' + Substituted expression is + let y1 = x1 and ... yn = xn in + handler[x1 <- y1 ; ... ; xn <- yn] + For the sake of preserving the uniqueness of bound variables. + (No alpha conversion of ``handler'' is presently needed, since + substitution of several ``(exit i ...)'' + occurs only when ``handler'' is a variable.) + *) + + let subst = Hashtbl.create 17 in + + let rec simplif = function + | (Lvar _|Lconst _) as l -> l + | Lapply ap -> + Lapply{ap with ap_func = simplif ap.ap_func; + ap_args = List.map simplif ap.ap_args} + | Lfunction{kind; params; return; body = l; attr; loc} -> + Lfunction{kind; params; return; body = simplif l; attr; loc} + | Llet(str, kind, v, l1, l2) -> Llet(str, kind, v, simplif l1, simplif l2) + | Lletrec(bindings, body) -> + Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body) + | Lprim(p, ll, loc) -> begin + let ll = List.map simplif ll in + match p, ll with + (* Simplify %revapply, for n-ary functions with n > 1 *) + | Prevapply, [x; Lapply ap] + | Prevapply, [x; Levent (Lapply ap,_)] -> + Lapply {ap with ap_args = ap.ap_args @ [x]; ap_loc = loc} + | Prevapply, [x; f] -> Lapply {ap_should_be_tailcall=false; + ap_loc=loc; + ap_func=f; + ap_args=[x]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise} + + (* Simplify %apply, for n-ary functions with n > 1 *) + | Pdirapply, [Lapply ap; x] + | Pdirapply, [Levent (Lapply ap,_); x] -> + Lapply {ap with ap_args = ap.ap_args @ [x]; ap_loc = loc} + | Pdirapply, [f; x] -> Lapply {ap_should_be_tailcall=false; + ap_loc=loc; + ap_func=f; + ap_args=[x]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise} + (* Simplify %identity *) + | Pidentity, [e] -> e + + (* Simplify Obj.with_tag *) + | Pccall { Primitive.prim_name = "caml_obj_with_tag"; _ }, + [Lconst (Const_base (Const_int tag)); + Lprim (Pmakeblock (_, mut, shape), fields, loc)] -> + Lprim (Pmakeblock(tag, mut, shape), fields, loc) + | Pccall { Primitive.prim_name = "caml_obj_with_tag"; _ }, + [Lconst (Const_base (Const_int tag)); + Lconst (Const_block (_, fields))] -> + Lconst (Const_block (tag, fields)) + + | _ -> Lprim(p, ll, loc) + end + | Lswitch(l, sw, loc) -> + let new_l = simplif l + and new_consts = List.map (fun (n, e) -> (n, simplif e)) sw.sw_consts + and new_blocks = List.map (fun (n, e) -> (n, simplif e)) sw.sw_blocks + and new_fail = Misc.may_map simplif sw.sw_failaction in + Lswitch + (new_l, + {sw with sw_consts = new_consts ; sw_blocks = new_blocks; + sw_failaction = new_fail}, + loc) + | Lstringswitch(l,sw,d,loc) -> + Lstringswitch + (simplif l,List.map (fun (s,l) -> s,simplif l) sw, + Misc.may_map simplif d,loc) + | Lstaticraise (i,[]) as l -> + begin try + let _,handler = Hashtbl.find subst i in + handler + with + | Not_found -> l + end + | Lstaticraise (i,ls) -> + let ls = List.map simplif ls in + begin try + let xs,handler = Hashtbl.find subst i in + let ys = List.map (fun (x, k) -> Ident.rename x, k) xs in + let env = + List.fold_right2 + (fun (x, _) (y, _) env -> Ident.Map.add x y env) + xs ys Ident.Map.empty + in + List.fold_right2 + (fun (y, kind) l r -> Llet (Strict, kind, y, l, r)) + ys ls (Lambda.rename env handler) + with + | Not_found -> Lstaticraise (i,ls) + end + | Lstaticcatch (l1,(i,[]),(Lstaticraise (_j,[]) as l2)) -> + Hashtbl.add subst i ([],simplif l2) ; + simplif l1 + | Lstaticcatch (l1,(i,xs),l2) -> + let {count; max_depth} = get_exit i in + if count = 0 then + (* Discard staticcatch: not matching exit *) + simplif l1 + else if count = 1 && max_depth <= !try_depth then begin + (* Inline handler if there is a single occurrence and it is not + nested within an inner try..with *) + assert(max_depth = !try_depth); + Hashtbl.add subst i (xs,simplif l2); + simplif l1 + end else + Lstaticcatch (simplif l1, (i,xs), simplif l2) + | Ltrywith(l1, v, l2) -> + incr try_depth; + let l1 = simplif l1 in + decr try_depth; + Ltrywith(l1, v, simplif l2) + | Lifthenelse(l1, l2, l3) -> Lifthenelse(simplif l1, simplif l2, simplif l3) + | Lsequence(l1, l2) -> Lsequence(simplif l1, simplif l2) + | Lwhile(l1, l2) -> Lwhile(simplif l1, simplif l2) + | Lfor(v, l1, l2, dir, l3) -> + Lfor(v, simplif l1, simplif l2, dir, simplif l3) + | Lassign(v, l) -> Lassign(v, simplif l) + | Lsend(k, m, o, ll, loc) -> + Lsend(k, simplif m, simplif o, List.map simplif ll, loc) + | Levent(l, ev) -> Levent(simplif l, ev) + | Lifused(v, l) -> Lifused (v,simplif l) + in + simplif lam + +(* Compile-time beta-reduction of functions immediately applied: + Lapply(Lfunction(Curried, params, body), args, loc) -> + let paramN = argN in ... let param1 = arg1 in body + Lapply(Lfunction(Tupled, params, body), [Lprim(Pmakeblock(args))], loc) -> + let paramN = argN in ... let param1 = arg1 in body + Assumes |args| = |params|. +*) + +let beta_reduce params body args = + List.fold_left2 (fun l (param, kind) arg -> Llet(Strict, kind, param, arg, l)) + body params args + +(* Simplification of lets *) + +let simplify_lets lam = + + (* Disable optimisations for bytecode compilation with -g flag *) + let optimize = !Clflags.native_code || not !Clflags.debug in + + (* First pass: count the occurrences of all let-bound identifiers *) + + let occ = (Hashtbl.create 83: (Ident.t, int ref) Hashtbl.t) in + (* The global table [occ] associates to each let-bound identifier + the number of its uses (as a reference): + - 0 if never used + - 1 if used exactly once in and not under a lambda or within a loop + - > 1 if used several times or under a lambda or within a loop. + The local table [bv] associates to each locally-let-bound variable + its reference count, as above. [bv] is enriched at let bindings + but emptied when crossing lambdas and loops. *) + + (* Current use count of a variable. *) + let count_var v = + try + !(Hashtbl.find occ v) + with Not_found -> + 0 + + (* Entering a [let]. Returns updated [bv]. *) + and bind_var bv v = + let r = ref 0 in + Hashtbl.add occ v r; + Ident.Map.add v r bv + + (* Record a use of a variable *) + and use_var bv v n = + try + let r = Ident.Map.find v bv in r := !r + n + with Not_found -> + (* v is not locally bound, therefore this is a use under a lambda + or within a loop. Increase use count by 2 -- enough so + that single-use optimizations will not apply. *) + try + let r = Hashtbl.find occ v in r := !r + 2 + with Not_found -> + (* Not a let-bound variable, ignore *) + () in + + let rec count bv = function + | Lconst _ -> () + | Lvar v -> + use_var bv v 1 + | Lapply{ap_func = Lfunction{kind = Curried; params; body}; ap_args = args} + when optimize && List.length params = List.length args -> + count bv (beta_reduce params body args) + | Lapply{ap_func = Lfunction{kind = Tupled; params; body}; + ap_args = [Lprim(Pmakeblock _, args, _)]} + when optimize && List.length params = List.length args -> + count bv (beta_reduce params body args) + | Lapply{ap_func = l1; ap_args = ll} -> + count bv l1; List.iter (count bv) ll + | Lfunction {body} -> + count Ident.Map.empty body + | Llet(_str, _k, v, Lvar w, l2) when optimize -> + (* v will be replaced by w in l2, so each occurrence of v in l2 + increases w's refcount *) + count (bind_var bv v) l2; + use_var bv w (count_var v) + | Llet(str, _kind, v, l1, l2) -> + count (bind_var bv v) l2; + (* If v is unused, l1 will be removed, so don't count its variables *) + if str = Strict || count_var v > 0 then count bv l1 + | Lletrec(bindings, body) -> + List.iter (fun (_v, l) -> count bv l) bindings; + count bv body + | Lprim(_p, ll, _) -> List.iter (count bv) ll + | Lswitch(l, sw, _loc) -> + count_default bv sw ; + count bv l; + List.iter (fun (_, l) -> count bv l) sw.sw_consts; + List.iter (fun (_, l) -> count bv l) sw.sw_blocks + | Lstringswitch(l, sw, d, _) -> + count bv l ; + List.iter (fun (_, l) -> count bv l) sw ; + begin match d with + | Some d -> + begin match sw with + | []|[_] -> count bv d + | _ -> count bv d ; count bv d + end + | None -> () + end + | Lstaticraise (_i,ls) -> List.iter (count bv) ls + | Lstaticcatch(l1, _, l2) -> count bv l1; count bv l2 + | Ltrywith(l1, _v, l2) -> count bv l1; count bv l2 + | Lifthenelse(l1, l2, l3) -> count bv l1; count bv l2; count bv l3 + | Lsequence(l1, l2) -> count bv l1; count bv l2 + | Lwhile(l1, l2) -> count Ident.Map.empty l1; count Ident.Map.empty l2 + | Lfor(_, l1, l2, _dir, l3) -> + count bv l1; count bv l2; count Ident.Map.empty l3 + | Lassign(_v, l) -> + (* Lalias-bound variables are never assigned, so don't increase + v's refcount *) + count bv l + | Lsend(_, m, o, ll, _) -> List.iter (count bv) (m::o::ll) + | Levent(l, _) -> count bv l + | Lifused(v, l) -> + if count_var v > 0 then count bv l + + and count_default bv sw = match sw.sw_failaction with + | None -> () + | Some al -> + let nconsts = List.length sw.sw_consts + and nblocks = List.length sw.sw_blocks in + if + nconsts < sw.sw_numconsts && nblocks < sw.sw_numblocks + then begin (* default action will occur twice in native code *) + count bv al ; count bv al + end else begin (* default action will occur once *) + assert (nconsts < sw.sw_numconsts || nblocks < sw.sw_numblocks) ; + count bv al + end + in + count Ident.Map.empty lam; + + (* Second pass: remove Lalias bindings of unused variables, + and substitute the bindings of variables used exactly once. *) + + let subst = Hashtbl.create 83 in + +(* This (small) optimisation is always legal, it may uncover some + tail call later on. *) + + let mklet str kind v e1 e2 = match e2 with + | Lvar w when optimize && Ident.same v w -> e1 + | _ -> Llet (str, kind,v,e1,e2) in + + + let rec simplif = function + Lvar v as l -> + begin try + Hashtbl.find subst v + with Not_found -> + l + end + | Lconst _ as l -> l + | Lapply{ap_func = Lfunction{kind = Curried; params; body}; ap_args = args} + when optimize && List.length params = List.length args -> + simplif (beta_reduce params body args) + | Lapply{ap_func = Lfunction{kind = Tupled; params; body}; + ap_args = [Lprim(Pmakeblock _, args, _)]} + when optimize && List.length params = List.length args -> + simplif (beta_reduce params body args) + | Lapply ap -> Lapply {ap with ap_func = simplif ap.ap_func; + ap_args = List.map simplif ap.ap_args} + | Lfunction{kind; params; return=return1; body = l; attr; loc} -> + begin match simplif l with + Lfunction{kind=Curried; params=params'; return=return2; body; attr; loc} + when kind = Curried && optimize -> + (* The return type is the type of the value returned after + applying all the parameters to the function. The return + type of the merged function taking [params @ params'] as + parameters is the type returned after applying [params']. *) + let return = return2 in + Lfunction{kind; params = params @ params'; return; body; attr; loc} + | body -> + Lfunction{kind; params; return = return1; body; attr; loc} + end + | Llet(_str, _k, v, Lvar w, l2) when optimize -> + Hashtbl.add subst v (simplif (Lvar w)); + simplif l2 + | Llet(Strict, kind, v, + Lprim(Pmakeblock(0, Mutable, kind_ref) as prim, [linit], loc), lbody) + when optimize -> + let slinit = simplif linit in + let slbody = simplif lbody in + begin try + let kind = match kind_ref with + | None -> Pgenval + | Some [field_kind] -> field_kind + | Some _ -> assert false + in + mklet Variable kind v slinit (eliminate_ref v slbody) + with Real_reference -> + mklet Strict kind v (Lprim(prim, [slinit], loc)) slbody + end + | Llet(Alias, kind, v, l1, l2) -> + begin match count_var v with + 0 -> simplif l2 + | 1 when optimize -> Hashtbl.add subst v (simplif l1); simplif l2 + | _ -> Llet(Alias, kind, v, simplif l1, simplif l2) + end + | Llet(StrictOpt, kind, v, l1, l2) -> + begin match count_var v with + 0 -> simplif l2 + | _ -> mklet StrictOpt kind v (simplif l1) (simplif l2) + end + | Llet(str, kind, v, l1, l2) -> mklet str kind v (simplif l1) (simplif l2) + | Lletrec(bindings, body) -> + Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body) + | Lprim(p, ll, loc) -> Lprim(p, List.map simplif ll, loc) + | Lswitch(l, sw, loc) -> + let new_l = simplif l + and new_consts = List.map (fun (n, e) -> (n, simplif e)) sw.sw_consts + and new_blocks = List.map (fun (n, e) -> (n, simplif e)) sw.sw_blocks + and new_fail = Misc.may_map simplif sw.sw_failaction in + Lswitch + (new_l, + {sw with sw_consts = new_consts ; sw_blocks = new_blocks; + sw_failaction = new_fail}, + loc) + | Lstringswitch (l,sw,d,loc) -> + Lstringswitch + (simplif l,List.map (fun (s,l) -> s,simplif l) sw, + Misc.may_map simplif d,loc) + | Lstaticraise (i,ls) -> + Lstaticraise (i, List.map simplif ls) + | Lstaticcatch(l1, (i,args), l2) -> + Lstaticcatch (simplif l1, (i,args), simplif l2) + | Ltrywith(l1, v, l2) -> Ltrywith(simplif l1, v, simplif l2) + | Lifthenelse(l1, l2, l3) -> Lifthenelse(simplif l1, simplif l2, simplif l3) + | Lsequence(Lifused(v, l1), l2) -> + if count_var v > 0 + then Lsequence(simplif l1, simplif l2) + else simplif l2 + | Lsequence(l1, l2) -> Lsequence(simplif l1, simplif l2) + | Lwhile(l1, l2) -> Lwhile(simplif l1, simplif l2) + | Lfor(v, l1, l2, dir, l3) -> + Lfor(v, simplif l1, simplif l2, dir, simplif l3) + | Lassign(v, l) -> Lassign(v, simplif l) + | Lsend(k, m, o, ll, loc) -> + Lsend(k, simplif m, simplif o, List.map simplif ll, loc) + | Levent(l, ev) -> Levent(simplif l, ev) + | Lifused(v, l) -> + if count_var v > 0 then simplif l else lambda_unit + in + simplif lam + +(* Tail call info in annotation files *) + +let is_tail_native_heuristic : (int -> bool) ref = + ref (fun _ -> true) + +let rec emit_tail_infos is_tail lambda = + let call_kind args = + if is_tail + && ((not !Clflags.native_code) + || (!is_tail_native_heuristic (List.length args))) + then Annot.Tail + else Annot.Stack in + match lambda with + | Lvar _ -> () + | Lconst _ -> () + | Lapply ap -> + if ap.ap_should_be_tailcall + && not is_tail + && Warnings.is_active Warnings.Expect_tailcall + then Location.prerr_warning ap.ap_loc Warnings.Expect_tailcall; + emit_tail_infos false ap.ap_func; + list_emit_tail_infos false ap.ap_args; + if !Clflags.annotations then + Stypes.record (Stypes.An_call (ap.ap_loc, call_kind ap.ap_args)) + | Lfunction {body = lam} -> + emit_tail_infos true lam + | Llet (_str, _k, _, lam, body) -> + emit_tail_infos false lam; + emit_tail_infos is_tail body + | Lletrec (bindings, body) -> + List.iter (fun (_, lam) -> emit_tail_infos false lam) bindings; + emit_tail_infos is_tail body + | Lprim (Pidentity, [arg], _) -> + emit_tail_infos is_tail arg + | Lprim ((Pbytes_to_string | Pbytes_of_string), [arg], _) -> + emit_tail_infos is_tail arg + | Lprim (Psequand, [arg1; arg2], _) + | Lprim (Psequor, [arg1; arg2], _) -> + emit_tail_infos false arg1; + emit_tail_infos is_tail arg2 + | Lprim (_, l, _) -> + list_emit_tail_infos false l + | Lswitch (lam, sw, _loc) -> + emit_tail_infos false lam; + list_emit_tail_infos_fun snd is_tail sw.sw_consts; + list_emit_tail_infos_fun snd is_tail sw.sw_blocks; + Misc.may (emit_tail_infos is_tail) sw.sw_failaction + | Lstringswitch (lam, sw, d, _) -> + emit_tail_infos false lam; + List.iter + (fun (_,lam) -> emit_tail_infos is_tail lam) + sw ; + Misc.may (emit_tail_infos is_tail) d + | Lstaticraise (_, l) -> + list_emit_tail_infos false l + | Lstaticcatch (body, _, handler) -> + emit_tail_infos is_tail body; + emit_tail_infos is_tail handler + | Ltrywith (body, _, handler) -> + emit_tail_infos false body; + emit_tail_infos is_tail handler + | Lifthenelse (cond, ifso, ifno) -> + emit_tail_infos false cond; + emit_tail_infos is_tail ifso; + emit_tail_infos is_tail ifno + | Lsequence (lam1, lam2) -> + emit_tail_infos false lam1; + emit_tail_infos is_tail lam2 + | Lwhile (cond, body) -> + emit_tail_infos false cond; + emit_tail_infos false body + | Lfor (_, low, high, _, body) -> + emit_tail_infos false low; + emit_tail_infos false high; + emit_tail_infos false body + | Lassign (_, lam) -> + emit_tail_infos false lam + | Lsend (_, meth, obj, args, loc) -> + emit_tail_infos false meth; + emit_tail_infos false obj; + list_emit_tail_infos false args; + if !Clflags.annotations then + Stypes.record (Stypes.An_call (loc, call_kind (obj :: args))); + | Levent (lam, _) -> + emit_tail_infos is_tail lam + | Lifused (_, lam) -> + emit_tail_infos is_tail lam +and list_emit_tail_infos_fun f is_tail = + List.iter (fun x -> emit_tail_infos is_tail (f x)) +and list_emit_tail_infos is_tail = + List.iter (emit_tail_infos is_tail) + +(* Split a function with default parameters into a wrapper and an + inner function. The wrapper fills in missing optional parameters + with their default value and tail-calls the inner function. The + wrapper can then hopefully be inlined on most call sites to avoid + the overhead associated with boxing an optional argument with a + 'Some' constructor, only to deconstruct it immediately in the + function's body. *) + +let split_default_wrapper ~id:fun_id ~kind ~params ~return ~body ~attr ~loc = + let rec aux map = function + | Llet(Strict, k, id, (Lifthenelse(Lvar optparam, _, _) as def), rest) when + Ident.name optparam = "*opt*" && List.mem_assoc optparam params + && not (List.mem_assoc optparam map) + -> + let wrapper_body, inner = aux ((optparam, id) :: map) rest in + Llet(Strict, k, id, def, wrapper_body), inner + | _ when map = [] -> raise Exit + | body -> + (* Check that those *opt* identifiers don't appear in the remaining + body. This should not appear, but let's be on the safe side. *) + let fv = Lambda.free_variables body in + List.iter (fun (id, _) -> if Ident.Set.mem id fv then raise Exit) map; + + let inner_id = Ident.create_local (Ident.name fun_id ^ "_inner") in + let map_param p = try List.assoc p map with Not_found -> p in + let args = List.map (fun (p, _) -> Lvar (map_param p)) params in + let wrapper_body = + Lapply { + ap_func = Lvar inner_id; + ap_args = args; + ap_loc = Location.none; + ap_should_be_tailcall = false; + ap_inlined = Default_inline; + ap_specialised = Default_specialise; + } + in + let inner_params = List.map map_param (List.map fst params) in + let new_ids = List.map Ident.rename inner_params in + let subst = + List.fold_left2 (fun s id new_id -> + Ident.Map.add id new_id s + ) Ident.Map.empty inner_params new_ids + in + let body = Lambda.rename subst body in + let inner_fun = + Lfunction { kind = Curried; + params = List.map (fun id -> id, Pgenval) new_ids; + return; body; attr; loc; } + in + (wrapper_body, (inner_id, inner_fun)) + in + try + let body, inner = aux [] body in + let attr = default_stub_attribute in + [(fun_id, Lfunction{kind; params; return; body; attr; loc}); inner] + with Exit -> + [(fun_id, Lfunction{kind; params; return; body; attr; loc})] + +(* Simplify local let-bound functions: if all occurrences are + fully-applied function calls in the same "tail scope", replace the + function by a staticcatch handler (on that scope). + + This handles as a special case functions used exactly once (in any + scope) for a full application. +*) + +type slot = + { + nargs: int; + mutable scope: lambda option; + } + +module LamTbl = Hashtbl.Make(struct + type t = lambda + let equal = (==) + let hash = Hashtbl.hash + end) + +let simplify_local_functions lam = + let slots = Hashtbl.create 16 in + let static_id = Hashtbl.create 16 in (* function id -> static id *) + let static = LamTbl.create 16 in (* scope -> static function on that scope *) + (* We keep track of the current "tail scope", identified + by the outermost lambda for which the the current lambda + is in tail position. *) + let current_scope = ref lam in + let check_static lf = + if lf.attr.local = Always_local then + Location.prerr_warning lf.loc + (Warnings.Inlining_impossible + "This function cannot be compiled into a static continuation") + in + let enabled = function + | {local = Always_local; _} + | {local = Default_local; inline = (Never_inline | Default_inline); _} + -> true + | {local = Default_local; inline = (Always_inline | Unroll _); _} + | {local = Never_local; _} + -> false + in + let rec tail = function + | Llet (_str, _kind, id, Lfunction lf, cont) when enabled lf.attr -> + let r = {nargs=List.length lf.params; scope=None} in + Hashtbl.add slots id r; + tail cont; + begin match Hashtbl.find_opt slots id with + | Some {scope = Some scope; _} -> + let st = next_raise_count () in + let sc = + (* Do not move higher than current lambda *) + if scope == !current_scope then cont + else scope + in + Hashtbl.add static_id id st; + LamTbl.add static sc (st, lf); + (* The body of the function will become an handler + in that "scope". *) + with_scope ~scope lf.body + | _ -> + check_static lf; + (* note: if scope = None, the function is unused *) + non_tail lf.body + end + | Lapply {ap_func = Lvar id; ap_args; _} -> + begin match Hashtbl.find_opt slots id with + | Some {nargs; _} when nargs <> List.length ap_args -> + (* Wrong arity *) + Hashtbl.remove slots id + | Some {scope = Some scope; _} when scope != !current_scope -> + (* Different "tail scope" *) + Hashtbl.remove slots id + | Some ({scope = None; _} as slot) -> + (* First use of the function: remember the current tail scope *) + slot.scope <- Some !current_scope + | _ -> + () + end; + List.iter non_tail ap_args + | Lvar id -> + Hashtbl.remove slots id + | Lfunction lf as lam -> + check_static lf; + Lambda.shallow_iter ~tail ~non_tail lam + | lam -> + Lambda.shallow_iter ~tail ~non_tail lam + and non_tail lam = + with_scope ~scope:lam lam + and with_scope ~scope lam = + let old_scope = !current_scope in + current_scope := scope; + tail lam; + current_scope := old_scope + in + tail lam; + let rec rewrite lam0 = + let lam = + match lam0 with + | Llet (_, _, id, _, cont) when Hashtbl.mem static_id id -> + rewrite cont + | Lapply {ap_func = Lvar id; ap_args; _} when Hashtbl.mem static_id id -> + Lstaticraise (Hashtbl.find static_id id, List.map rewrite ap_args) + | lam -> + Lambda.shallow_map rewrite lam + in + List.fold_right + (fun (st, lf) lam -> + Lstaticcatch (lam, (st, lf.params), rewrite lf.body) + ) + (LamTbl.find_all static lam0) + lam + in + if LamTbl.length static = 0 then + lam + else + rewrite lam + +(* The entry point: + simplification + emission of tailcall annotations, if needed. *) + +let simplify_lambda lam = + let lam = + lam + |> (if !Clflags.native_code || not !Clflags.debug + then simplify_local_functions else Fun.id + ) + |> simplify_exits + |> simplify_lets + in + if !Clflags.annotations || Warnings.is_active Warnings.Expect_tailcall + then emit_tail_infos true lam; + lam diff --git a/lambda/simplif.mli b/lambda/simplif.mli new file mode 100644 index 0000000000..d5ca210e5a --- /dev/null +++ b/lambda/simplif.mli @@ -0,0 +1,44 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(** Lambda simplification. + + {b Warning:} this module is unstable and part of + {{!Compiler_libs}compiler-libs}. + +*) + +(* Elimination of useless Llet(Alias) bindings. + Transformation of let-bound references into variables. + Simplification over staticraise/staticcatch constructs. + Generation of tail-call annotations if -annot is set. *) + +open Lambda + +val simplify_lambda: lambda -> lambda + +val split_default_wrapper + : id:Ident.t + -> kind:function_kind + -> params:(Ident.t * Lambda.value_kind) list + -> return:Lambda.value_kind + -> body:lambda + -> attr:function_attribute + -> loc:Location.t + -> (Ident.t * lambda) list + +(* To be filled by asmcomp/selectgen.ml *) +val is_tail_native_heuristic: (int -> bool) ref + (* # arguments -> can tailcall *) diff --git a/lambda/switch.ml b/lambda/switch.ml new file mode 100644 index 0000000000..89bfe83a07 --- /dev/null +++ b/lambda/switch.ml @@ -0,0 +1,877 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Luc Maranget, projet Moscova, INRIA Rocquencourt *) +(* *) +(* Copyright 2000 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 'a shared = Shared of 'a | Single of 'a + +type ('a, 'ctx) t_store = + {act_get : unit -> 'a array ; + act_get_shared : unit -> 'a shared array ; + act_store : 'ctx -> 'a -> int ; + act_store_shared : 'ctx -> 'a -> int ; } + +exception Not_simple + +module type Stored = sig + type t + type key + val compare_key : key -> key -> int + val make_key : t -> key option +end + +module type CtxStored = sig + include Stored + type context + val make_key : context -> t -> key option +end + +module CtxStore(A:CtxStored) = struct + module AMap = + Map.Make(struct type t = A.key let compare = A.compare_key end) + + type intern = + { mutable map : (bool * int) AMap.t ; + mutable next : int ; + mutable acts : (bool * A.t) list; } + + let mk_store () = + let st = + { map = AMap.empty ; + next = 0 ; + acts = [] ; } in + + let add mustshare act = + let i = st.next in + st.acts <- (mustshare,act) :: st.acts ; + st.next <- i+1 ; + i in + + let store mustshare ctx act = match A.make_key ctx act with + | Some key -> + begin try + let (shared,i) = AMap.find key st.map in + if not shared then st.map <- AMap.add key (true,i) st.map ; + i + with Not_found -> + let i = add mustshare act in + st.map <- AMap.add key (mustshare,i) st.map ; + i + end + | None -> + add mustshare act + + and get () = Array.of_list (List.rev_map (fun (_,act) -> act) st.acts) + + and get_shared () = + let acts = + Array.of_list + (List.rev_map + (fun (shared,act) -> + if shared then Shared act else Single act) + st.acts) in + AMap.iter + (fun _ (shared,i) -> + if shared then match acts.(i) with + | Single act -> acts.(i) <- Shared act + | Shared _ -> ()) + st.map ; + acts in + {act_store = store false ; act_store_shared = store true ; + act_get = get; act_get_shared = get_shared; } +end + +module Store(A:Stored) = struct + module Me = + CtxStore + (struct + include A + type context = unit + let make_key () = A.make_key + end) + + let mk_store = Me.mk_store +end + + + +module type S = +sig + type primitive + val eqint : primitive + val neint : primitive + val leint : primitive + val ltint : primitive + val geint : primitive + val gtint : primitive + type act + + val bind : act -> (act -> act) -> act + val make_const : int -> act + val make_offset : act -> int -> act + val make_prim : primitive -> act list -> act + val make_isout : act -> act -> act + val make_isin : act -> act -> act + val make_if : act -> act -> act -> act + val make_switch : Location.t -> act -> int array -> act array -> act + val make_catch : act -> int * (act -> act) + val make_exit : int -> act +end + +(* The module will ``produce good code for the case statement'' *) +(* + Adaptation of + R.L. Berstein + ``Producing good code for the case statement'' + Software Practice and Experience, 15(10) (1985) + and + D.L. Spuler + ``Two-Way Comparison Search Trees, a Generalisation of Binary Search Trees + and Split Trees'' + ``Compiler Code Generation for Multiway Branch Statement as + a Static Search Problem'' + Technical Reports, James Cook University +*) +(* + Main adaptation is considering interval tests + (implemented as one addition + one unsigned test and branch) + which leads to exhaustive search for finding the optimal + test sequence in small cases and heuristics otherwise. +*) +module Make (Arg : S) = +struct + + type 'a inter = + {cases : (int * int * int) array ; + actions : 'a array} + + type 'a t_ctx = {off : int ; arg : 'a} + + let cut = ref 8 + and more_cut = ref 16 + +(* +let pint chan i = + if i = min_int then Printf.fprintf chan "-oo" + else if i=max_int then Printf.fprintf chan "oo" + else Printf.fprintf chan "%d" i + +let pcases chan cases = + for i =0 to Array.length cases-1 do + let l,h,act = cases.(i) in + if l=h then + Printf.fprintf chan "%d:%d " l act + else + Printf.fprintf chan "%a..%a:%d " pint l pint h act + done + +let prerr_inter i = Printf.fprintf stderr + "cases=%a" pcases i.cases +*) + + let get_act cases i = + let _,_,r = cases.(i) in + r + and get_low cases i = + let r,_,_ = cases.(i) in + r + + type ctests = { + mutable n : int ; + mutable ni : int ; + } + + let too_much = {n=max_int ; ni=max_int} + +(* +let ptests chan {n=n ; ni=ni} = + Printf.fprintf chan "{n=%d ; ni=%d}" n ni + +let pta chan t = + for i =0 to Array.length t-1 do + Printf.fprintf chan "%d: %a\n" i ptests t.(i) + done +*) + + let less_tests c1 c2 = + if c1.n < c2.n then + true + else if c1.n = c2.n then begin + if c1.ni < c2.ni then + true + else + false + end else + false + + and eq_tests c1 c2 = c1.n = c2.n && c1.ni=c2.ni + + let less2tests (c1,d1) (c2,d2) = + if eq_tests c1 c2 then + less_tests d1 d2 + else + less_tests c1 c2 + + let add_test t1 t2 = + t1.n <- t1.n + t2.n ; + t1.ni <- t1.ni + t2.ni ; + + type t_ret = Inter of int * int | Sep of int | No + +(* +let pret chan = function + | Inter (i,j)-> Printf.fprintf chan "Inter %d %d" i j + | Sep i -> Printf.fprintf chan "Sep %d" i + | No -> Printf.fprintf chan "No" +*) + + let coupe cases i = + let l,_,_ = cases.(i) in + l, + Array.sub cases 0 i, + Array.sub cases i (Array.length cases-i) + + + let case_append c1 c2 = + let len1 = Array.length c1 + and len2 = Array.length c2 in + match len1,len2 with + | 0,_ -> c2 + | _,0 -> c1 + | _,_ -> + let l1,h1,act1 = c1.(Array.length c1-1) + and l2,h2,act2 = c2.(0) in + if act1 = act2 then + let r = Array.make (len1+len2-1) c1.(0) in + for i = 0 to len1-2 do + r.(i) <- c1.(i) + done ; + + let l = + if len1-2 >= 0 then begin + let _,h,_ = r.(len1-2) in + if h+1 < l1 then + h+1 + else + l1 + end else + l1 + and h = + if 1 < len2-1 then begin + let l,_,_ = c2.(1) in + if h2+1 < l then + l-1 + else + h2 + end else + h2 in + r.(len1-1) <- (l,h,act1) ; + for i=1 to len2-1 do + r.(len1-1+i) <- c2.(i) + done ; + r + else if h1 > l1 then + let r = Array.make (len1+len2) c1.(0) in + for i = 0 to len1-2 do + r.(i) <- c1.(i) + done ; + r.(len1-1) <- (l1,l2-1,act1) ; + for i=0 to len2-1 do + r.(len1+i) <- c2.(i) + done ; + r + else if h2 > l2 then + let r = Array.make (len1+len2) c1.(0) in + for i = 0 to len1-1 do + r.(i) <- c1.(i) + done ; + r.(len1) <- (h1+1,h2,act2) ; + for i=1 to len2-1 do + r.(len1+i) <- c2.(i) + done ; + r + else + Array.append c1 c2 + + + let coupe_inter i j cases = + let lcases = Array.length cases in + let low,_,_ = cases.(i) + and _,high,_ = cases.(j) in + low,high, + Array.sub cases i (j-i+1), + case_append (Array.sub cases 0 i) (Array.sub cases (j+1) (lcases-(j+1))) + + type kind = Kvalue of int | Kinter of int | Kempty + +(* +let pkind chan = function + | Kvalue i ->Printf.fprintf chan "V%d" i + | Kinter i -> Printf.fprintf chan "I%d" i + | Kempty -> Printf.fprintf chan "E" + +let rec pkey chan = function + | [] -> () + | [k] -> pkind chan k + | k::rem -> + Printf.fprintf chan "%a %a" pkey rem pkind k +*) + + let t = Hashtbl.create 17 + + let make_key cases = + let seen = ref [] + and count = ref 0 in + let rec got_it act = function + | [] -> + seen := (act,!count):: !seen ; + let r = !count in + incr count ; + r + | (act0,index) :: rem -> + if act0 = act then + index + else + got_it act rem in + + let make_one l h act = + if l=h then + Kvalue (got_it act !seen) + else + Kinter (got_it act !seen) in + + let rec make_rec i pl = + if i < 0 then + [] + else + let l,h,act = cases.(i) in + if pl = h+1 then + make_one l h act::make_rec (i-1) l + else + Kempty::make_one l h act::make_rec (i-1) l in + + let l,h,act = cases.(Array.length cases-1) in + make_one l h act::make_rec (Array.length cases-2) l + + + let same_act t = + let len = Array.length t in + let a = get_act t (len-1) in + let rec do_rec i = + if i < 0 then true + else + let b = get_act t i in + b=a && do_rec (i-1) in + do_rec (len-2) + + +(* + Interval test x in [l,h] works by checking x-l in [0,h-l] + * This may be false for arithmetic modulo 2^31 + * Subtracting l may change the relative ordering of values + and invalid the invariant that matched values are given in + increasing order + + To avoid this, interval check is allowed only when the + integers indeed present in the whole case interval are + in [-2^16 ; 2^16] + + This condition is checked by zyva +*) + + let inter_limit = 1 lsl 16 + + let ok_inter = ref false + + let rec opt_count top cases = + let key = make_key cases in + try + Hashtbl.find t key + with + | Not_found -> + let r = + let lcases = Array.length cases in + match lcases with + | 0 -> assert false + | _ when same_act cases -> No, ({n=0; ni=0},{n=0; ni=0}) + | _ -> + if lcases < !cut then + enum top cases + else if lcases < !more_cut then + heuristic cases + else + divide cases in + Hashtbl.add t key r ; + r + + and divide cases = + let lcases = Array.length cases in + let m = lcases/2 in + let _,left,right = coupe cases m in + let ci = {n=1 ; ni=0} + and cm = {n=1 ; ni=0} + and _,(cml,cleft) = opt_count false left + and _,(cmr,cright) = opt_count false right in + add_test ci cleft ; + add_test ci cright ; + if less_tests cml cmr then + add_test cm cmr + else + add_test cm cml ; + Sep m,(cm, ci) + + and heuristic cases = + let lcases = Array.length cases in + + let sep,csep = divide cases + + and inter,cinter = + if !ok_inter then begin + let _,_,act0 = cases.(0) + and _,_,act1 = cases.(lcases-1) in + if act0 = act1 then begin + let low, high, inside, outside = coupe_inter 1 (lcases-2) cases in + let _,(cmi,cinside) = opt_count false inside + and _,(cmo,coutside) = opt_count false outside + and cmij = {n=1 ; ni=(if low=high then 0 else 1)} + and cij = {n=1 ; ni=(if low=high then 0 else 1)} in + add_test cij cinside ; + add_test cij coutside ; + if less_tests cmi cmo then + add_test cmij cmo + else + add_test cmij cmi ; + Inter (1,lcases-2),(cmij,cij) + end else + Inter (-1,-1),(too_much, too_much) + end else + Inter (-1,-1),(too_much, too_much) in + if less2tests csep cinter then + sep,csep + else + inter,cinter + + + and enum top cases = + let lcases = Array.length cases in + let lim, with_sep = + let best = ref (-1) and best_cost = ref (too_much,too_much) in + + for i = 1 to lcases-(1) do + let _,left,right = coupe cases i in + let ci = {n=1 ; ni=0} + and cm = {n=1 ; ni=0} + and _,(cml,cleft) = opt_count false left + and _,(cmr,cright) = opt_count false right in + add_test ci cleft ; + add_test ci cright ; + if less_tests cml cmr then + add_test cm cmr + else + add_test cm cml ; + + if + less2tests (cm,ci) !best_cost + then begin + if top then + Printf.fprintf stderr "Get it: %d\n" i ; + best := i ; + best_cost := (cm,ci) + end + done ; + !best, !best_cost in + + let ilow, ihigh, with_inter = + if not !ok_inter then + let rlow = ref (-1) and rhigh = ref (-1) + and best_cost= ref (too_much,too_much) in + for i=1 to lcases-2 do + let low, high, inside, outside = coupe_inter i i cases in + if low=high then begin + let _,(cmi,cinside) = opt_count false inside + and _,(cmo,coutside) = opt_count false outside + and cmij = {n=1 ; ni=0} + and cij = {n=1 ; ni=0} in + add_test cij cinside ; + add_test cij coutside ; + if less_tests cmi cmo then + add_test cmij cmo + else + add_test cmij cmi ; + if less2tests (cmij,cij) !best_cost then begin + rlow := i ; + rhigh := i ; + best_cost := (cmij,cij) + end + end + done ; + !rlow, !rhigh, !best_cost + else + let rlow = ref (-1) and rhigh = ref (-1) + and best_cost= ref (too_much,too_much) in + for i=1 to lcases-2 do + for j=i to lcases-2 do + let low, high, inside, outside = coupe_inter i j cases in + let _,(cmi,cinside) = opt_count false inside + and _,(cmo,coutside) = opt_count false outside + and cmij = {n=1 ; ni=(if low=high then 0 else 1)} + and cij = {n=1 ; ni=(if low=high then 0 else 1)} in + add_test cij cinside ; + add_test cij coutside ; + if less_tests cmi cmo then + add_test cmij cmo + else + add_test cmij cmi ; + if less2tests (cmij,cij) !best_cost then begin + rlow := i ; + rhigh := j ; + best_cost := (cmij,cij) + end + done + done ; + !rlow, !rhigh, !best_cost in + let r = ref (Inter (ilow,ihigh)) and rc = ref with_inter in + if less2tests with_sep !rc then begin + r := Sep lim ; rc := with_sep + end ; + !r, !rc + + let make_if_test test arg i ifso ifnot = + Arg.make_if + (Arg.make_prim test [arg ; Arg.make_const i]) + ifso ifnot + + let make_if_lt arg i ifso ifnot = match i with + | 1 -> + make_if_test Arg.leint arg 0 ifso ifnot + | _ -> + make_if_test Arg.ltint arg i ifso ifnot + + and make_if_ge arg i ifso ifnot = match i with + | 1 -> + make_if_test Arg.gtint arg 0 ifso ifnot + | _ -> + make_if_test Arg.geint arg i ifso ifnot + + and make_if_eq arg i ifso ifnot = + make_if_test Arg.eqint arg i ifso ifnot + + and make_if_ne arg i ifso ifnot = + make_if_test Arg.neint arg i ifso ifnot + + let do_make_if_out h arg ifso ifno = + Arg.make_if (Arg.make_isout h arg) ifso ifno + + let make_if_out ctx l d mk_ifso mk_ifno = match l with + | 0 -> + do_make_if_out + (Arg.make_const d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) + | _ -> + Arg.bind + (Arg.make_offset ctx.arg (-l)) + (fun arg -> + let ctx = {off= (-l+ctx.off) ; arg=arg} in + do_make_if_out + (Arg.make_const d) arg (mk_ifso ctx) (mk_ifno ctx)) + + let do_make_if_in h arg ifso ifno = + Arg.make_if (Arg.make_isin h arg) ifso ifno + + let make_if_in ctx l d mk_ifso mk_ifno = match l with + | 0 -> + do_make_if_in + (Arg.make_const d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) + | _ -> + Arg.bind + (Arg.make_offset ctx.arg (-l)) + (fun arg -> + let ctx = {off= (-l+ctx.off) ; arg=arg} in + do_make_if_in + (Arg.make_const d) arg (mk_ifso ctx) (mk_ifno ctx)) + + let rec c_test ctx ({cases=cases ; actions=actions} as s) = + let lcases = Array.length cases in + assert(lcases > 0) ; + if lcases = 1 then + actions.(get_act cases 0) ctx + + else begin + + let w,_c = opt_count false cases in +(* + Printf.fprintf stderr + "off=%d tactic=%a for %a\n" + ctx.off pret w pcases cases ; + *) + match w with + | No -> actions.(get_act cases 0) ctx + | Inter (i,j) -> + let low,high,inside, outside = coupe_inter i j cases in + let _,(cinside,_) = opt_count false inside + and _,(coutside,_) = opt_count false outside in + (* Costs are retrieved to put the code with more remaining tests + in the privileged (positive) branch of ``if'' *) + if low=high then begin + if less_tests coutside cinside then + make_if_eq + ctx.arg + (low+ctx.off) + (c_test ctx {s with cases=inside}) + (c_test ctx {s with cases=outside}) + else + make_if_ne + ctx.arg + (low+ctx.off) + (c_test ctx {s with cases=outside}) + (c_test ctx {s with cases=inside}) + end else begin + if less_tests coutside cinside then + make_if_in + ctx + (low+ctx.off) + (high-low) + (fun ctx -> c_test ctx {s with cases=inside}) + (fun ctx -> c_test ctx {s with cases=outside}) + else + make_if_out + ctx + (low+ctx.off) + (high-low) + (fun ctx -> c_test ctx {s with cases=outside}) + (fun ctx -> c_test ctx {s with cases=inside}) + end + | Sep i -> + let lim,left,right = coupe cases i in + let _,(cleft,_) = opt_count false left + and _,(cright,_) = opt_count false right in + let left = {s with cases=left} + and right = {s with cases=right} in + + if i=1 && (lim+ctx.off)=1 && get_low cases 0+ctx.off=0 then + make_if_ne + ctx.arg 0 + (c_test ctx right) (c_test ctx left) + else if less_tests cright cleft then + make_if_lt + ctx.arg (lim+ctx.off) + (c_test ctx left) (c_test ctx right) + else + make_if_ge + ctx.arg (lim+ctx.off) + (c_test ctx right) (c_test ctx left) + + end + + + (* Minimal density of switches *) + let theta = ref 0.33333 + + (* Minimal number of tests to make a switch *) + let switch_min = ref 3 + + (* Particular case 0, 1, 2 *) + let particular_case cases i j = + j-i = 2 && + (let l1,_h1,act1 = cases.(i) + and l2,_h2,_act2 = cases.(i+1) + and l3,h3,act3 = cases.(i+2) in + l1+1=l2 && l2+1=l3 && l3=h3 && + act1 <> act3) + + let approx_count cases i j = + let l = j-i+1 in + if l < !cut then + let _,(_,{n=ntests}) = opt_count false (Array.sub cases i l) in + ntests + else + l-1 + + (* Sends back a boolean that says whether is switch is worth or not *) + + let dense {cases} i j = + if i=j then true + else + let l,_,_ = cases.(i) + and _,h,_ = cases.(j) in + let ntests = approx_count cases i j in +(* + (ntests+1) >= theta * (h-l+1) +*) + particular_case cases i j || + (ntests >= !switch_min && + float_of_int ntests +. 1.0 >= + !theta *. (float_of_int h -. float_of_int l +. 1.0)) + + (* Compute clusters by dynamic programming + Adaptation of the correction to Bernstein + ``Correction to `Producing Good Code for the Case Statement' '' + S.K. Kannan and T.A. Proebsting + Software Practice and Experience Vol. 24(2) 233 (Feb 1994) + *) + + let comp_clusters s = + let len = Array.length s.cases in + let min_clusters = Array.make len max_int + and k = Array.make len 0 in + let get_min i = if i < 0 then 0 else min_clusters.(i) in + + for i = 0 to len-1 do + for j = 0 to i do + if + dense s j i && + get_min (j-1) + 1 < min_clusters.(i) + then begin + k.(i) <- j ; + min_clusters.(i) <- get_min (j-1) + 1 + end + done ; + done ; + min_clusters.(len-1),k + + (* Assume j > i *) + let make_switch loc {cases=cases ; actions=actions} i j = + let ll,_,_ = cases.(i) + and _,hh,_ = cases.(j) in + let tbl = Array.make (hh-ll+1) 0 + and t = Hashtbl.create 17 + and index = ref 0 in + let get_index act = + try + Hashtbl.find t act + with + | Not_found -> + let i = !index in + incr index ; + Hashtbl.add t act i ; + i in + + for k=i to j do + let l,h,act = cases.(k) in + let index = get_index act in + for kk=l-ll to h-ll do + tbl.(kk) <- index + done + done ; + let acts = Array.make !index actions.(0) in + Hashtbl.iter + (fun act i -> acts.(i) <- actions.(act)) + t ; + (fun ctx -> + match -ll-ctx.off with + | 0 -> Arg.make_switch loc ctx.arg tbl acts + | _ -> + Arg.bind + (Arg.make_offset ctx.arg (-ll-ctx.off)) + (fun arg -> Arg.make_switch loc arg tbl acts)) + + + let make_clusters loc ({cases=cases ; actions=actions} as s) n_clusters k = + let len = Array.length cases in + let r = Array.make n_clusters (0,0,0) + and t = Hashtbl.create 17 + and index = ref 0 + and bidon = ref (Array.length actions) in + let get_index act = + try + let i,_ = Hashtbl.find t act in + i + with + | Not_found -> + let i = !index in + incr index ; + Hashtbl.add + t act + (i,(fun _ -> actions.(act))) ; + i + and add_index act = + let i = !index in + incr index ; + incr bidon ; + Hashtbl.add t !bidon (i,act) ; + i in + + let rec zyva j ir = + let i = k.(j) in + begin if i=j then + let l,h,act = cases.(i) in + r.(ir) <- (l,h,get_index act) + else (* assert i < j *) + let l,_,_ = cases.(i) + and _,h,_ = cases.(j) in + r.(ir) <- (l,h,add_index (make_switch loc s i j)) + end ; + if i > 0 then zyva (i-1) (ir-1) in + + zyva (len-1) (n_clusters-1) ; + let acts = Array.make !index (fun _ -> assert false) in + Hashtbl.iter (fun _ (i,act) -> acts.(i) <- act) t ; + {cases = r ; actions = acts} + ;; + + + let do_zyva loc (low,high) arg cases actions = + let old_ok = !ok_inter in + ok_inter := (abs low <= inter_limit && abs high <= inter_limit) ; + if !ok_inter <> old_ok then Hashtbl.clear t ; + + let s = {cases=cases ; actions=actions} in + +(* + Printf.eprintf "ZYVA: %B [low=%i,high=%i]\n" !ok_inter low high ; + pcases stderr cases ; + prerr_endline "" ; +*) + let n_clusters,k = comp_clusters s in + let clusters = make_clusters loc s n_clusters k in + c_test {arg=arg ; off=0} clusters + + let abstract_shared actions = + let handlers = ref (fun x -> x) in + let actions = + Array.map + (fun act -> match act with + | Single act -> act + | Shared act -> + let i,h = Arg.make_catch act in + let oh = !handlers in + handlers := (fun act -> h (oh act)) ; + Arg.make_exit i) + actions in + !handlers,actions + + let zyva loc lh arg cases actions = + assert (Array.length cases > 0) ; + let actions = actions.act_get_shared () in + let hs,actions = abstract_shared actions in + hs (do_zyva loc lh arg cases actions) + + and test_sequence arg cases actions = + assert (Array.length cases > 0) ; + let actions = actions.act_get_shared () in + let hs,actions = abstract_shared actions in + let old_ok = !ok_inter in + ok_inter := false ; + if !ok_inter <> old_ok then Hashtbl.clear t ; + let s = + {cases=cases ; + actions=Array.map (fun act -> (fun _ -> act)) actions} in +(* + Printf.eprintf "SEQUENCE: %B\n" !ok_inter ; + pcases stderr cases ; + prerr_endline "" ; +*) + hs (c_test {arg=arg ; off=0} s) + ;; + +end diff --git a/lambda/switch.mli b/lambda/switch.mli new file mode 100644 index 0000000000..b4058c1784 --- /dev/null +++ b/lambda/switch.mli @@ -0,0 +1,129 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Luc Maranget, projet Moscova, INRIA Rocquencourt *) +(* *) +(* Copyright 2000 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. *) +(* *) +(**************************************************************************) + +(* + This module transforms generic switches in combinations + of if tests and switches. +*) + +(* For detecting action sharing, object style *) + +(* Store for actions in object style: + act_store : store an action, returns index in table + In case an action with equal key exists, returns index + of the stored action. Otherwise add entry in table. + act_store_shared : This stored action will always be shared. + act_get : retrieve table + act_get_shared : retrieve table, with sharing explicit +*) + +type 'a shared = Shared of 'a | Single of 'a + +type ('a, 'ctx) t_store = + {act_get : unit -> 'a array ; + act_get_shared : unit -> 'a shared array ; + act_store : 'ctx -> 'a -> int ; + act_store_shared : 'ctx -> 'a -> int ; } + +exception Not_simple + +module type Stored = sig + type t + type key + val compare_key : key -> key -> int + val make_key : t -> key option +end + +module type CtxStored = sig + include Stored + type context + val make_key : context -> t -> key option +end + +module CtxStore(A:CtxStored) : + sig + val mk_store : unit -> (A.t, A.context) t_store + end + +module Store(A:Stored) : + sig + val mk_store : unit -> (A.t, unit) t_store + end + +(* Arguments to the Make functor *) +module type S = + sig + (* type of basic tests *) + type primitive + (* basic tests themselves *) + val eqint : primitive + val neint : primitive + val leint : primitive + val ltint : primitive + val geint : primitive + val gtint : primitive + (* type of actions *) + type act + + (* Various constructors, for making a binder, + adding one integer, etc. *) + val bind : act -> (act -> act) -> act + val make_const : int -> act + val make_offset : act -> int -> act + val make_prim : primitive -> act list -> act + val make_isout : act -> act -> act + val make_isin : act -> act -> act + val make_if : act -> act -> act -> act + (* construct an actual switch : + make_switch arg cases acts + NB: cases is in the value form *) + val make_switch : + Location.t -> act -> int array -> act array -> act + (* Build last minute sharing of action stuff *) + val make_catch : act -> int * (act -> act) + val make_exit : int -> act + + end + + +(* + Make.zyva arg low high cases actions where + - arg is the argument of the switch. + - low, high are the interval limits. + - cases is a list of sub-interval and action indices + - actions is an array of actions. + + All these arguments specify a switch construct and zyva + returns an action that performs the switch. +*) +module Make : + functor (Arg : S) -> + sig +(* Standard entry point, sharing is tracked *) + val zyva : + Location.t -> + (int * int) -> + Arg.act -> + (int * int * int) array -> + (Arg.act, _) t_store -> + Arg.act + +(* Output test sequence, sharing tracked *) + val test_sequence : + Arg.act -> + (int * int * int) array -> + (Arg.act, _) t_store -> + Arg.act + end diff --git a/lambda/translattribute.ml b/lambda/translattribute.ml new file mode 100644 index 0000000000..1520a3b41f --- /dev/null +++ b/lambda/translattribute.ml @@ -0,0 +1,332 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* *) +(* Copyright 2015 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 Typedtree +open Lambda +open Location + +let is_inline_attribute = function + | {txt=("inline"|"ocaml.inline")} -> true + | _ -> false + +let is_inlined_attribute = function + | {txt=("inlined"|"ocaml.inlined")} -> true + | {txt=("unrolled"|"ocaml.unrolled")} when Config.flambda -> true + | _ -> false + +let is_specialise_attribute = function + | {txt=("specialise"|"ocaml.specialise")} when Config.flambda -> true + | _ -> false + +let is_specialised_attribute = function + | {txt=("specialised"|"ocaml.specialised")} when Config.flambda -> true + | _ -> false + +let is_local_attribute = function + | {txt=("local"|"ocaml.local")} -> true + | _ -> false + +let find_attribute p attributes = + let inline_attribute, other_attributes = + List.partition (fun a -> p a.Parsetree.attr_name) attributes + in + let attr = + match inline_attribute with + | [] -> None + | [attr] -> Some attr + | _ :: {Parsetree.attr_name = {txt;loc}; _} :: _ -> + Location.prerr_warning loc (Warnings.Duplicated_attribute txt); + None + in + attr, other_attributes + +let is_unrolled = function + | {txt="unrolled"|"ocaml.unrolled"} -> true + | {txt="inline"|"ocaml.inline"|"inlined"|"ocaml.inlined"} -> false + | _ -> assert false + +let get_id_payload = + let open Parsetree in + function + | PStr [] -> Some "" + | PStr [{pstr_desc = Pstr_eval ({pexp_desc},[])}] -> + begin match pexp_desc with + | Pexp_ident { txt = Longident.Lident id } -> Some id + | _ -> None + end + | _ -> None + +let parse_id_payload txt loc ~default ~empty cases payload = + let[@local] warn () = + let ( %> ) f g x = g (f x) in + let msg = + cases + |> List.map (fst %> Printf.sprintf "'%s'") + |> String.concat ", " + |> Printf.sprintf "It must be either %s or empty" + in + Location.prerr_warning loc (Warnings.Attribute_payload (txt, msg)); + default + in + match get_id_payload payload with + | Some "" -> empty + | None -> warn () + | Some id -> + match List.assoc_opt id cases with + | Some r -> r + | None -> warn () + +let parse_inline_attribute attr = + match attr with + | None -> Default_inline + | Some {Parsetree.attr_name = {txt;loc} as id; attr_payload = payload} -> + let open Parsetree in + if is_unrolled id then begin + (* the 'unrolled' attributes must be used as [@unrolled n]. *) + let warning txt = Warnings.Attribute_payload + (txt, "It must be an integer literal") + in + match payload with + | PStr [{pstr_desc = Pstr_eval ({pexp_desc},[])}] -> begin + match pexp_desc with + | Pexp_constant (Pconst_integer(s, None)) -> begin + try + Unroll (Misc.Int_literal_converter.int s) + with Failure _ -> + Location.prerr_warning loc (warning txt); + Default_inline + end + | _ -> + Location.prerr_warning loc (warning txt); + Default_inline + end + | _ -> + Location.prerr_warning loc (warning txt); + Default_inline + end else + parse_id_payload txt loc + ~default:Default_inline + ~empty:Always_inline + [ + "never", Never_inline; + "always", Always_inline; + ] + payload + +let parse_specialise_attribute attr = + match attr with + | None -> Default_specialise + | Some {Parsetree.attr_name = {txt; loc}; attr_payload = payload} -> + parse_id_payload txt loc + ~default:Default_specialise + ~empty:Always_specialise + [ + "never", Never_specialise; + "always", Always_specialise; + ] + payload + +let parse_local_attribute attr = + match attr with + | None -> Default_local + | Some {Parsetree.attr_name = {txt; loc}; attr_payload = payload} -> + parse_id_payload txt loc + ~default:Default_local + ~empty:Always_local + [ + "never", Never_local; + "always", Always_local; + "maybe", Default_local; + ] + payload + +let get_inline_attribute l = + let attr, _ = find_attribute is_inline_attribute l in + parse_inline_attribute attr + +let get_specialise_attribute l = + let attr, _ = find_attribute is_specialise_attribute l in + parse_specialise_attribute attr + +let get_local_attribute l = + let attr, _ = find_attribute is_local_attribute l in + parse_local_attribute attr + +let check_local_inline loc attr = + match attr.local, attr.inline with + | Always_local, (Always_inline | Unroll _) -> + Location.prerr_warning loc + (Warnings.Duplicated_attribute "local/inline") + | _ -> + () + +let add_inline_attribute expr loc attributes = + match expr, get_inline_attribute attributes with + | expr, Default_inline -> expr + | Lfunction({ attr = { stub = false } as attr } as funct), inline -> + begin match attr.inline with + | Default_inline -> () + | Always_inline | Never_inline | Unroll _ -> + Location.prerr_warning loc + (Warnings.Duplicated_attribute "inline") + end; + let attr = { attr with inline } in + check_local_inline loc attr; + Lfunction { funct with attr = attr } + | expr, (Always_inline | Never_inline | Unroll _) -> + Location.prerr_warning loc + (Warnings.Misplaced_attribute "inline"); + expr + +let add_specialise_attribute expr loc attributes = + match expr, get_specialise_attribute attributes with + | expr, Default_specialise -> expr + | Lfunction({ attr = { stub = false } as attr } as funct), specialise -> + begin match attr.specialise with + | Default_specialise -> () + | Always_specialise | Never_specialise -> + Location.prerr_warning loc + (Warnings.Duplicated_attribute "specialise") + end; + let attr = { attr with specialise } in + Lfunction { funct with attr } + | expr, (Always_specialise | Never_specialise) -> + Location.prerr_warning loc + (Warnings.Misplaced_attribute "specialise"); + expr + +let add_local_attribute expr loc attributes = + match expr, get_local_attribute attributes with + | expr, Default_local -> expr + | Lfunction({ attr = { stub = false } as attr } as funct), local -> + begin match attr.local with + | Default_local -> () + | Always_local | Never_local -> + Location.prerr_warning loc + (Warnings.Duplicated_attribute "local") + end; + let attr = { attr with local } in + check_local_inline loc attr; + Lfunction { funct with attr } + | expr, (Always_local | Never_local) -> + Location.prerr_warning loc + (Warnings.Misplaced_attribute "local"); + expr + +(* Get the [@inlined] attribute payload (or default if not present). + It also returns the expression without this attribute. This is + used to ensure that this attribute is not misplaced: If it + appears on any expression, it is an error, otherwise it would + have been removed by this function *) +let get_and_remove_inlined_attribute e = + let attr, exp_attributes = + find_attribute is_inlined_attribute e.exp_attributes + in + let inlined = parse_inline_attribute attr in + inlined, { e with exp_attributes } + +let get_and_remove_inlined_attribute_on_module e = + let rec get_and_remove mod_expr = + let attr, mod_attributes = + find_attribute is_inlined_attribute mod_expr.mod_attributes + in + let attr = parse_inline_attribute attr in + let attr, mod_desc = + match mod_expr.Typedtree.mod_desc with + | Tmod_constraint (me, mt, mtc, mc) -> + let inner_attr, me = get_and_remove me in + let attr = + match attr with + | Always_inline | Never_inline | Unroll _ -> attr + | Default_inline -> inner_attr + in + attr, Tmod_constraint (me, mt, mtc, mc) + | md -> attr, md + in + attr, { mod_expr with mod_desc; mod_attributes } + in + get_and_remove e + +let get_and_remove_specialised_attribute e = + let attr, exp_attributes = + find_attribute is_specialised_attribute e.exp_attributes + in + let specialised = parse_specialise_attribute attr in + specialised, { e with exp_attributes } + +(* It also removes the attribute from the expression, like + get_inlined_attribute *) +let get_tailcall_attribute e = + let is_tailcall_attribute = function + | {Parsetree.attr_name = {txt=("tailcall"|"ocaml.tailcall")}; _} -> true + | _ -> false + in + let tailcalls, exp_attributes = + List.partition is_tailcall_attribute e.exp_attributes + in + match tailcalls with + | [] -> false, e + | _ :: r -> + begin match r with + | [] -> () + | {Parsetree.attr_name = {txt;loc}; _} :: _ -> + Location.prerr_warning loc (Warnings.Duplicated_attribute txt) + end; + true, { e with exp_attributes } + +let check_attribute e {Parsetree.attr_name = { txt; loc }; _} = + match txt with + | "inline" | "ocaml.inline" + | "specialise" | "ocaml.specialise" -> begin + match e.exp_desc with + | Texp_function _ -> () + | _ -> + Location.prerr_warning loc + (Warnings.Misplaced_attribute txt) + end + | "inlined" | "ocaml.inlined" + | "specialised" | "ocaml.specialised" + | "tailcall" | "ocaml.tailcall" -> + (* Removed by the Texp_apply cases *) + Location.prerr_warning loc + (Warnings.Misplaced_attribute txt) + | _ -> () + +let check_attribute_on_module e {Parsetree.attr_name = { txt; loc }; _} = + match txt with + | "inline" | "ocaml.inline" -> begin + match e.mod_desc with + | Tmod_functor _ -> () + | _ -> + Location.prerr_warning loc + (Warnings.Misplaced_attribute txt) + end + | "inlined" | "ocaml.inlined" -> + (* Removed by the Texp_apply cases *) + Location.prerr_warning loc + (Warnings.Misplaced_attribute txt) + | _ -> () + +let add_function_attributes lam loc attr = + let lam = + add_inline_attribute lam loc attr + in + let lam = + add_specialise_attribute lam loc attr + in + let lam = + add_local_attribute lam loc attr + in + lam diff --git a/lambda/translattribute.mli b/lambda/translattribute.mli new file mode 100644 index 0000000000..bf22fd1c5d --- /dev/null +++ b/lambda/translattribute.mli @@ -0,0 +1,76 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* *) +(* Copyright 2015 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. *) +(* *) +(**************************************************************************) + +val check_attribute + : Typedtree.expression + -> Parsetree.attribute + -> unit + +val check_attribute_on_module + : Typedtree.module_expr + -> Parsetree.attribute + -> unit + +val add_inline_attribute + : Lambda.lambda + -> Location.t + -> Parsetree.attributes + -> Lambda.lambda + +val get_inline_attribute + : Parsetree.attributes + -> Lambda.inline_attribute + +val add_specialise_attribute + : Lambda.lambda + -> Location.t + -> Parsetree.attributes + -> Lambda.lambda + +val get_specialise_attribute + : Parsetree.attributes + -> Lambda.specialise_attribute + +val add_local_attribute + : Lambda.lambda + -> Location.t + -> Parsetree.attributes + -> Lambda.lambda + +val get_local_attribute + : Parsetree.attributes + -> Lambda.local_attribute + +val get_and_remove_inlined_attribute + : Typedtree.expression + -> Lambda.inline_attribute * Typedtree.expression + +val get_and_remove_inlined_attribute_on_module + : Typedtree.module_expr + -> Lambda.inline_attribute * Typedtree.module_expr + +val get_and_remove_specialised_attribute + : Typedtree.expression + -> Lambda.specialise_attribute * Typedtree.expression + +val get_tailcall_attribute + : Typedtree.expression + -> bool * Typedtree.expression + +val add_function_attributes + : Lambda.lambda + -> Location.t + -> Parsetree.attributes + -> Lambda.lambda diff --git a/lambda/translclass.ml b/lambda/translclass.ml new file mode 100644 index 0000000000..10b09066d7 --- /dev/null +++ b/lambda/translclass.ml @@ -0,0 +1,946 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, 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 Asttypes +open Types +open Typedtree +open Lambda +open Translobj +open Translcore + +(* XXX Rajouter des evenements... | Add more events... *) + +type error = Tags of label * label + +exception Error of Location.t * error + +let lfunction params body = + if params = [] then body else + match body with + | Lfunction {kind = Curried; params = params'; body = body'; attr; loc} -> + Lfunction {kind = Curried; params = params @ params'; + return = Pgenval; + body = body'; attr; + loc} + | _ -> + Lfunction {kind = Curried; params; return = Pgenval; + body; + attr = default_function_attribute; + loc = Location.none} + +let lapply ap = + match ap.ap_func with + Lapply ap' -> + Lapply {ap with ap_func = ap'.ap_func; ap_args = ap'.ap_args @ ap.ap_args} + | _ -> + Lapply ap + +let mkappl (func, args) = + Lapply {ap_should_be_tailcall=false; + ap_loc=Location.none; + ap_func=func; + ap_args=args; + ap_inlined=Default_inline; + ap_specialised=Default_specialise};; + +let lsequence l1 l2 = + if l2 = lambda_unit then l1 else Lsequence(l1, l2) + +let lfield v i = Lprim(Pfield i, [Lvar v], Location.none) + +let transl_label l = share (Const_immstring l) + +let transl_meth_list lst = + if lst = [] then Lconst (Const_pointer 0) else + share (Const_block + (0, List.map (fun lab -> Const_immstring lab) lst)) + +let set_inst_var obj id expr = + Lprim(Psetfield_computed (Typeopt.maybe_pointer expr, Assignment), + [Lvar obj; Lvar id; transl_exp expr], Location.none) + +let transl_val tbl create name = + mkappl (oo_prim (if create then "new_variable" else "get_variable"), + [Lvar tbl; transl_label name]) + +let transl_vals tbl create strict vals rem = + List.fold_right + (fun (name, id) rem -> + Llet(strict, Pgenval, id, transl_val tbl create name, rem)) + vals rem + +let meths_super tbl meths inh_meths = + List.fold_right + (fun (nm, id) rem -> + try + (nm, id, + mkappl(oo_prim "get_method", [Lvar tbl; Lvar (Meths.find nm meths)])) + :: rem + with Not_found -> rem) + inh_meths [] + +let bind_super tbl (vals, meths) cl_init = + transl_vals tbl false StrictOpt vals + (List.fold_right (fun (_nm, id, def) rem -> + Llet(StrictOpt, Pgenval, id, def, rem)) + meths cl_init) + +let create_object cl obj init = + let obj' = Ident.create_local "self" in + let (inh_init, obj_init, has_init) = init obj' in + if obj_init = lambda_unit then + (inh_init, + mkappl (oo_prim (if has_init then "create_object_and_run_initializers" + else"create_object_opt"), + [obj; Lvar cl])) + else begin + (inh_init, + Llet(Strict, Pgenval, obj', + mkappl (oo_prim "create_object_opt", [obj; Lvar cl]), + Lsequence(obj_init, + if not has_init then Lvar obj' else + mkappl (oo_prim "run_initializers_opt", + [obj; Lvar obj'; Lvar cl])))) + end + +let name_pattern default p = + match p.pat_desc with + | Tpat_var (id, _) -> id + | Tpat_alias(_, id, _) -> id + | _ -> Ident.create_local default + +let rec build_object_init cl_table obj params inh_init obj_init cl = + match cl.cl_desc with + Tcl_ident (path, _, _) -> + let obj_init = Ident.create_local "obj_init" in + let envs, inh_init = inh_init in + let env = + match envs with None -> [] + | Some envs -> + [Lprim(Pfield (List.length inh_init + 1), + [Lvar envs], + Location.none)] + in + let path_lam = transl_class_path cl.cl_loc cl.cl_env path in + ((envs, (path, path_lam, obj_init) :: inh_init), + mkappl(Lvar obj_init, env @ [obj])) + | Tcl_structure str -> + create_object cl_table obj (fun obj -> + let (inh_init, obj_init, has_init) = + List.fold_right + (fun field (inh_init, obj_init, has_init) -> + match field.cf_desc with + Tcf_inherit (_, cl, _, _, _) -> + let (inh_init, obj_init') = + build_object_init cl_table (Lvar obj) [] inh_init + (fun _ -> lambda_unit) cl + in + (inh_init, lsequence obj_init' obj_init, true) + | Tcf_val (_, _, id, Tcfk_concrete (_, exp), _) -> + (inh_init, lsequence (set_inst_var obj id exp) obj_init, + has_init) + | Tcf_method _ | Tcf_val _ | Tcf_constraint _ | Tcf_attribute _-> + (inh_init, obj_init, has_init) + | Tcf_initializer _ -> + (inh_init, obj_init, true) + ) + str.cstr_fields + (inh_init, obj_init obj, false) + in + (inh_init, + List.fold_right + (fun (id, expr) rem -> + lsequence (Lifused (id, set_inst_var obj id expr)) rem) + params obj_init, + has_init)) + | Tcl_fun (_, pat, vals, cl, partial) -> + let (inh_init, obj_init) = + build_object_init cl_table obj (vals @ params) inh_init obj_init cl + in + (inh_init, + let build params rem = + let param = name_pattern "param" pat in + Lfunction {kind = Curried; params = (param, Pgenval)::params; + return = Pgenval; + attr = default_function_attribute; + loc = pat.pat_loc; + body = Matching.for_function + pat.pat_loc None (Lvar param) [pat, rem] partial} + in + begin match obj_init with + Lfunction {kind = Curried; params; body = rem} -> build params rem + | rem -> build [] rem + end) + | Tcl_apply (cl, oexprs) -> + let (inh_init, obj_init) = + build_object_init cl_table obj params inh_init obj_init cl + in + (inh_init, transl_apply obj_init oexprs Location.none) + | Tcl_let (rec_flag, defs, vals, cl) -> + let (inh_init, obj_init) = + build_object_init cl_table obj (vals @ params) inh_init obj_init cl + in + (inh_init, Translcore.transl_let rec_flag defs obj_init) + | Tcl_open (_, cl) + | Tcl_constraint (cl, _, _, _, _) -> + build_object_init cl_table obj params inh_init obj_init cl + +let rec build_object_init_0 cl_table params cl copy_env subst_env top ids = + match cl.cl_desc with + Tcl_let (_rec_flag, _defs, vals, cl) -> + build_object_init_0 cl_table (vals@params) cl copy_env subst_env top ids + | _ -> + let self = Ident.create_local "self" in + let env = Ident.create_local "env" in + let obj = if ids = [] then lambda_unit else Lvar self in + let envs = if top then None else Some env in + let ((_,inh_init), obj_init) = + build_object_init cl_table obj params (envs,[]) copy_env cl in + let obj_init = + if ids = [] then obj_init else lfunction [self, Pgenval] obj_init in + (inh_init, lfunction [env, Pgenval] (subst_env env inh_init obj_init)) + + +let bind_method tbl lab id cl_init = + Llet(Strict, Pgenval, id, mkappl (oo_prim "get_method_label", + [Lvar tbl; transl_label lab]), + cl_init) + +let bind_methods tbl meths vals cl_init = + let methl = Meths.fold (fun lab id tl -> (lab,id) :: tl) meths [] in + let len = List.length methl and nvals = List.length vals in + if len < 2 && nvals = 0 then Meths.fold (bind_method tbl) meths cl_init else + if len = 0 && nvals < 2 then transl_vals tbl true Strict vals cl_init else + let ids = Ident.create_local "ids" in + let i = ref (len + nvals) in + let getter, names = + if nvals = 0 then "get_method_labels", [] else + "new_methods_variables", [transl_meth_list (List.map fst vals)] + in + Llet(Strict, Pgenval, ids, + mkappl (oo_prim getter, + [Lvar tbl; transl_meth_list (List.map fst methl)] @ names), + List.fold_right + (fun (_lab,id) lam -> decr i; Llet(StrictOpt, Pgenval, id, + lfield ids !i, lam)) + (methl @ vals) cl_init) + +let output_methods tbl methods lam = + match methods with + [] -> lam + | [lab; code] -> + lsequence (mkappl(oo_prim "set_method", [Lvar tbl; lab; code])) lam + | _ -> + lsequence (mkappl(oo_prim "set_methods", + [Lvar tbl; Lprim(Pmakeblock(0,Immutable,None), + methods, Location.none)])) + lam + +let rec ignore_cstrs cl = + match cl.cl_desc with + Tcl_constraint (cl, _, _, _, _) -> ignore_cstrs cl + | Tcl_apply (cl, _) -> ignore_cstrs cl + | _ -> cl + +let rec index a = function + [] -> raise Not_found + | b :: l -> + if b = a then 0 else 1 + index a l + +let bind_id_as_val (id, _) = ("", id) + +let rec build_class_init cla cstr super inh_init cl_init msubst top cl = + match cl.cl_desc with + | Tcl_ident _ -> + begin match inh_init with + | (_, path_lam, obj_init)::inh_init -> + (inh_init, + Llet (Strict, Pgenval, obj_init, + mkappl(Lprim(Pfield 1, [path_lam], Location.none), Lvar cla :: + if top then [Lprim(Pfield 3, [path_lam], Location.none)] + else []), + bind_super cla super cl_init)) + | _ -> + assert false + end + | Tcl_structure str -> + let cl_init = bind_super cla super cl_init in + let (inh_init, cl_init, methods, values) = + List.fold_right + (fun field (inh_init, cl_init, methods, values) -> + match field.cf_desc with + Tcf_inherit (_, cl, _, vals, meths) -> + let cl_init = output_methods cla methods cl_init in + let inh_init, cl_init = + build_class_init cla false + (vals, meths_super cla str.cstr_meths meths) + inh_init cl_init msubst top cl in + (inh_init, cl_init, [], values) + | Tcf_val (name, _, id, _, over) -> + let values = + if over then values else (name.txt, id) :: values + in + (inh_init, cl_init, methods, values) + | Tcf_method (_, _, Tcfk_virtual _) + | Tcf_constraint _ + -> + (inh_init, cl_init, methods, values) + | Tcf_method (name, _, Tcfk_concrete (_, exp)) -> + let met_code = msubst true (transl_exp exp) in + let met_code = + if !Clflags.native_code && List.length met_code = 1 then + (* Force correct naming of method for profiles *) + let met = Ident.create_local ("method_" ^ name.txt) in + [Llet(Strict, Pgenval, met, List.hd met_code, Lvar met)] + else met_code + in + (inh_init, cl_init, + Lvar(Meths.find name.txt str.cstr_meths) :: met_code @ methods, + values) + | Tcf_initializer exp -> + (inh_init, + Lsequence(mkappl (oo_prim "add_initializer", + Lvar cla :: msubst false (transl_exp exp)), + cl_init), + methods, values) + | Tcf_attribute _ -> + (inh_init, cl_init, methods, values)) + str.cstr_fields + (inh_init, cl_init, [], []) + in + let cl_init = output_methods cla methods cl_init in + (inh_init, bind_methods cla str.cstr_meths values cl_init) + | Tcl_fun (_, _pat, vals, cl, _) -> + let (inh_init, cl_init) = + build_class_init cla cstr super inh_init cl_init msubst top cl + in + let vals = List.map bind_id_as_val vals in + (inh_init, transl_vals cla true StrictOpt vals cl_init) + | Tcl_apply (cl, _exprs) -> + build_class_init cla cstr super inh_init cl_init msubst top cl + | Tcl_let (_rec_flag, _defs, vals, cl) -> + let (inh_init, cl_init) = + build_class_init cla cstr super inh_init cl_init msubst top cl + in + let vals = List.map bind_id_as_val vals in + (inh_init, transl_vals cla true StrictOpt vals cl_init) + | Tcl_constraint (cl, _, vals, meths, concr_meths) -> + let virt_meths = + List.filter (fun lab -> not (Concr.mem lab concr_meths)) meths in + let concr_meths = Concr.elements concr_meths in + let narrow_args = + [Lvar cla; + transl_meth_list vals; + transl_meth_list virt_meths; + transl_meth_list concr_meths] in + let cl = ignore_cstrs cl in + begin match cl.cl_desc, inh_init with + | Tcl_ident (path, _, _), (path', path_lam, obj_init)::inh_init -> + assert (Path.same path path'); + let inh = Ident.create_local "inh" + and ofs = List.length vals + 1 + and valids, methids = super in + let cl_init = + List.fold_left + (fun init (nm, id, _) -> + Llet(StrictOpt, Pgenval, id, + lfield inh (index nm concr_meths + ofs), + init)) + cl_init methids in + let cl_init = + List.fold_left + (fun init (nm, id) -> + Llet(StrictOpt, Pgenval, id, + lfield inh (index nm vals + 1), init)) + cl_init valids in + (inh_init, + Llet (Strict, Pgenval, inh, + mkappl(oo_prim "inherits", narrow_args @ + [path_lam; + Lconst(Const_pointer(if top then 1 else 0))]), + Llet(StrictOpt, Pgenval, obj_init, lfield inh 0, cl_init))) + | _ -> + let core cl_init = + build_class_init cla true super inh_init cl_init msubst top cl + in + if cstr then core cl_init else + let (inh_init, cl_init) = + core (Lsequence (mkappl (oo_prim "widen", [Lvar cla]), cl_init)) + in + (inh_init, + Lsequence(mkappl (oo_prim "narrow", narrow_args), + cl_init)) + end + | Tcl_open (_, cl) -> + build_class_init cla cstr super inh_init cl_init msubst top cl + +let rec build_class_lets cl = + match cl.cl_desc with + Tcl_let (rec_flag, defs, _vals, cl') -> + let env, wrap = build_class_lets cl' in + (env, fun x -> + Translcore.transl_let rec_flag defs (wrap x)) + | _ -> + (cl.cl_env, fun x -> x) + +let rec get_class_meths cl = + match cl.cl_desc with + Tcl_structure cl -> + Meths.fold (fun _ -> Ident.Set.add) cl.cstr_meths Ident.Set.empty + | Tcl_ident _ -> Ident.Set.empty + | Tcl_fun (_, _, _, cl, _) + | Tcl_let (_, _, _, cl) + | Tcl_apply (cl, _) + | Tcl_open (_, cl) + | Tcl_constraint (cl, _, _, _, _) -> get_class_meths cl + +(* + XXX Il devrait etre peu couteux d'ecrire des classes : + | Writing classes should be cheap + class c x y = d e f +*) +let rec transl_class_rebind obj_init cl vf = + match cl.cl_desc with + Tcl_ident (path, _, _) -> + if vf = Concrete then begin + try if (Env.find_class path cl.cl_env).cty_new = None then raise Exit + with Not_found -> raise Exit + end; + let path_lam = transl_class_path cl.cl_loc cl.cl_env path in + (path, path_lam, obj_init) + | Tcl_fun (_, pat, _, cl, partial) -> + let path, path_lam, obj_init = transl_class_rebind obj_init cl vf in + let build params rem = + let param = name_pattern "param" pat in + Lfunction {kind = Curried; params = (param, Pgenval)::params; + return = Pgenval; + attr = default_function_attribute; + loc = pat.pat_loc; + body = Matching.for_function + pat.pat_loc None (Lvar param) [pat, rem] partial} + in + (path, path_lam, + match obj_init with + Lfunction {kind = Curried; params; body} -> build params body + | rem -> build [] rem) + | Tcl_apply (cl, oexprs) -> + let path, path_lam, obj_init = transl_class_rebind obj_init cl vf in + (path, path_lam, transl_apply obj_init oexprs Location.none) + | Tcl_let (rec_flag, defs, _vals, cl) -> + let path, path_lam, obj_init = transl_class_rebind obj_init cl vf in + (path, path_lam, Translcore.transl_let rec_flag defs obj_init) + | Tcl_structure _ -> raise Exit + | Tcl_constraint (cl', _, _, _, _) -> + let path, path_lam, obj_init = transl_class_rebind obj_init cl' vf in + let rec check_constraint = function + Cty_constr(path', _, _) when Path.same path path' -> () + | Cty_arrow (_, _, cty) -> check_constraint cty + | _ -> raise Exit + in + check_constraint cl.cl_type; + (path, path_lam, obj_init) + | Tcl_open (_, cl) -> + transl_class_rebind obj_init cl vf + +let rec transl_class_rebind_0 (self:Ident.t) obj_init cl vf = + match cl.cl_desc with + Tcl_let (rec_flag, defs, _vals, cl) -> + let path, path_lam, obj_init = + transl_class_rebind_0 self obj_init cl vf + in + (path, path_lam, Translcore.transl_let rec_flag defs obj_init) + | _ -> + let path, path_lam, obj_init = transl_class_rebind obj_init cl vf in + (path, path_lam, lfunction [self, Pgenval] obj_init) + +let transl_class_rebind cl vf = + try + let obj_init = Ident.create_local "obj_init" + and self = Ident.create_local "self" in + let obj_init0 = + lapply {ap_should_be_tailcall=false; + ap_loc=Location.none; + ap_func=Lvar obj_init; + ap_args=[Lvar self]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise} + in + let _, path_lam, obj_init' = transl_class_rebind_0 self obj_init0 cl vf in + let id = (obj_init' = lfunction [self, Pgenval] obj_init0) in + if id then path_lam else + + let cla = Ident.create_local "class" + and new_init = Ident.create_local "new_init" + and env_init = Ident.create_local "env_init" + and table = Ident.create_local "table" + and envs = Ident.create_local "envs" in + Llet( + Strict, Pgenval, new_init, lfunction [obj_init, Pgenval] obj_init', + Llet( + Alias, Pgenval, cla, path_lam, + Lprim(Pmakeblock(0, Immutable, None), + [mkappl(Lvar new_init, [lfield cla 0]); + lfunction [table, Pgenval] + (Llet(Strict, Pgenval, env_init, + mkappl(lfield cla 1, [Lvar table]), + lfunction [envs, Pgenval] + (mkappl(Lvar new_init, + [mkappl(Lvar env_init, [Lvar envs])])))); + lfield cla 2; + lfield cla 3], + Location.none))) + with Exit -> + lambda_unit + +(* Rewrite a closure using builtins. Improves native code size. *) + +let rec module_path = function + Lvar id -> + let s = Ident.name id in s <> "" && s.[0] >= 'A' && s.[0] <= 'Z' + | Lprim(Pfield _, [p], _) -> module_path p + | Lprim(Pgetglobal _, [], _) -> true + | _ -> false + +let const_path local = function + Lvar id -> not (List.mem id local) + | Lconst _ -> true + | Lfunction {kind = Curried; body} -> + let fv = free_variables body in + List.for_all (fun x -> not (Ident.Set.mem x fv)) local + | p -> module_path p + +let rec builtin_meths self env env2 body = + let const_path = const_path (env::self) in + let conv = function + (* Lvar s when List.mem s self -> "_self", [] *) + | p when const_path p -> "const", [p] + | Lprim(Parrayrefu _, [Lvar s; Lvar n], _) when List.mem s self -> + "var", [Lvar n] + | Lprim(Pfield n, [Lvar e], _) when Ident.same e env -> + "env", [Lvar env2; Lconst(Const_pointer n)] + | Lsend(Self, met, Lvar s, [], _) when List.mem s self -> + "meth", [met] + | _ -> raise Not_found + in + match body with + | Llet(_str, _k, s', Lvar s, body) when List.mem s self -> + builtin_meths (s'::self) env env2 body + | Lapply{ap_func = f; ap_args = [arg]} when const_path f -> + let s, args = conv arg in ("app_"^s, f :: args) + | Lapply{ap_func = f; ap_args = [arg; p]} when const_path f && const_path p -> + let s, args = conv arg in + ("app_"^s^"_const", f :: args @ [p]) + | Lapply{ap_func = f; ap_args = [p; arg]} when const_path f && const_path p -> + let s, args = conv arg in + ("app_const_"^s, f :: p :: args) + | Lsend(Self, Lvar n, Lvar s, [arg], _) when List.mem s self -> + let s, args = conv arg in + ("meth_app_"^s, Lvar n :: args) + | Lsend(Self, met, Lvar s, [], _) when List.mem s self -> + ("get_meth", [met]) + | Lsend(Public, met, arg, [], _) -> + let s, args = conv arg in + ("send_"^s, met :: args) + | Lsend(Cached, met, arg, [_;_], _) -> + let s, args = conv arg in + ("send_"^s, met :: args) + | Lfunction {kind = Curried; params = [x, _]; body} -> + let rec enter self = function + | Lprim(Parraysetu _, [Lvar s; Lvar n; Lvar x'], _) + when Ident.same x x' && List.mem s self -> + ("set_var", [Lvar n]) + | Llet(_str, _k, s', Lvar s, body) when List.mem s self -> + enter (s'::self) body + | _ -> raise Not_found + in enter self body + | Lfunction _ -> raise Not_found + | _ -> + let s, args = conv body in ("get_"^s, args) + +module M = struct + open CamlinternalOO + let builtin_meths self env env2 body = + let builtin, args = builtin_meths self env env2 body in + (* if not arr then [mkappl(oo_prim builtin, args)] else *) + let tag = match builtin with + "get_const" -> GetConst + | "get_var" -> GetVar + | "get_env" -> GetEnv + | "get_meth" -> GetMeth + | "set_var" -> SetVar + | "app_const" -> AppConst + | "app_var" -> AppVar + | "app_env" -> AppEnv + | "app_meth" -> AppMeth + | "app_const_const" -> AppConstConst + | "app_const_var" -> AppConstVar + | "app_const_env" -> AppConstEnv + | "app_const_meth" -> AppConstMeth + | "app_var_const" -> AppVarConst + | "app_env_const" -> AppEnvConst + | "app_meth_const" -> AppMethConst + | "meth_app_const" -> MethAppConst + | "meth_app_var" -> MethAppVar + | "meth_app_env" -> MethAppEnv + | "meth_app_meth" -> MethAppMeth + | "send_const" -> SendConst + | "send_var" -> SendVar + | "send_env" -> SendEnv + | "send_meth" -> SendMeth + | _ -> assert false + in Lconst(Const_pointer(Obj.magic tag)) :: args +end +open M + + +(* + Class translation. + Three subcases: + * reapplication of a known class -> transl_class_rebind + * class without local dependencies -> direct translation + * with local dependencies -> generate a stubs tree, + with a node for every local classes inherited + A class is a 4-tuple: + (obj_init, class_init, env_init, env) + obj_init: creation function (unit -> obj) + class_init: inheritance function (table -> env_init) + (one by source code) + env_init: parameterisation by the local environment + (env -> params -> obj_init) + (one for each combination of inherited class_init ) + env: local environment + If ids=0 (immediate object), then only env_init is conserved. +*) + +(* +let prerr_ids msg ids = + let names = List.map Ident.unique_toplevel_name ids in + prerr_endline (String.concat " " (msg :: names)) +*) + +let free_methods l = + let fv = ref Ident.Set.empty in + let rec free l = + Lambda.iter_head_constructor free l; + match l with + | Lsend(Self, Lvar meth, _, _, _) -> + fv := Ident.Set.add meth !fv + | Lsend _ -> () + | Lfunction{params} -> + List.iter (fun (param, _) -> fv := Ident.Set.remove param !fv) params + | Llet(_str, _k, id, _arg, _body) -> + fv := Ident.Set.remove id !fv + | Lletrec(decl, _body) -> + List.iter (fun (id, _exp) -> fv := Ident.Set.remove id !fv) decl + | Lstaticcatch(_e1, (_,vars), _e2) -> + List.iter (fun (id, _) -> fv := Ident.Set.remove id !fv) vars + | Ltrywith(_e1, exn, _e2) -> + fv := Ident.Set.remove exn !fv + | Lfor(v, _e1, _e2, _dir, _e3) -> + fv := Ident.Set.remove v !fv + | Lassign _ + | Lvar _ | Lconst _ | Lapply _ + | Lprim _ | Lswitch _ | Lstringswitch _ | Lstaticraise _ + | Lifthenelse _ | Lsequence _ | Lwhile _ + | Levent _ | Lifused _ -> () + in free l; !fv + +let transl_class ids cl_id pub_meths cl vflag = + (* First check if it is not only a rebind *) + let rebind = transl_class_rebind cl vflag in + if rebind <> lambda_unit then rebind else + + (* Prepare for heavy environment handling *) + let tables = Ident.create_local (Ident.name cl_id ^ "_tables") in + let (top_env, req) = oo_add_class tables in + let top = not req in + let cl_env, llets = build_class_lets cl in + let new_ids = if top then [] else Env.diff top_env cl_env in + let env2 = Ident.create_local "env" in + let meth_ids = get_class_meths cl in + let subst env lam i0 new_ids' = + let fv = free_variables lam in + (* prerr_ids "cl_id =" [cl_id]; prerr_ids "fv =" (Ident.Set.elements fv); *) + let fv = List.fold_right Ident.Set.remove !new_ids' fv in + (* We need to handle method ids specially, as they do not appear + in the typing environment (PR#3576, PR#4560) *) + (* very hacky: we add and remove free method ids on the fly, + depending on the visit order... *) + method_ids := + Ident.Set.diff (Ident.Set.union (free_methods lam) !method_ids) meth_ids; + (* prerr_ids "meth_ids =" (Ident.Set.elements meth_ids); + prerr_ids "method_ids =" (Ident.Set.elements !method_ids); *) + let new_ids = List.fold_right Ident.Set.add new_ids !method_ids in + let fv = Ident.Set.inter fv new_ids in + new_ids' := !new_ids' @ Ident.Set.elements fv; + (* prerr_ids "new_ids' =" !new_ids'; *) + let i = ref (i0-1) in + List.fold_left + (fun subst id -> + incr i; Ident.Map.add id (lfield env !i) subst) + Ident.Map.empty !new_ids' + in + let new_ids_meths = ref [] in + let no_env_update _ _ env = env in + let msubst arr = function + Lfunction {kind = Curried; params = (self, Pgenval) :: args; body} -> + let env = Ident.create_local "env" in + let body' = + if new_ids = [] then body else + Lambda.subst no_env_update (subst env body 0 new_ids_meths) body in + begin try + (* Doesn't seem to improve size for bytecode *) + (* if not !Clflags.native_code then raise Not_found; *) + if not arr || !Clflags.debug then raise Not_found; + builtin_meths [self] env env2 (lfunction args body') + with Not_found -> + [lfunction ((self, Pgenval) :: args) + (if not (Ident.Set.mem env (free_variables body')) then body' else + Llet(Alias, Pgenval, env, + Lprim(Pfield_computed, + [Lvar self; Lvar env2], + Location.none), + body'))] + end + | _ -> assert false + in + let new_ids_init = ref [] in + let env1 = Ident.create_local "env" and env1' = Ident.create_local "env'" in + let copy_env self = + if top then lambda_unit else + Lifused(env2, Lprim(Psetfield_computed (Pointer, Assignment), + [Lvar self; Lvar env2; Lvar env1'], + Location.none)) + and subst_env envs l lam = + if top then lam else + (* must be called only once! *) + let lam = Lambda.subst no_env_update (subst env1 lam 1 new_ids_init) lam in + Llet(Alias, Pgenval, env1, (if l = [] then Lvar envs else lfield envs 0), + Llet(Alias, Pgenval, env1', + (if !new_ids_init = [] then Lvar env1 else lfield env1 0), + lam)) + in + + (* Now we start compiling the class *) + let cla = Ident.create_local "class" in + let (inh_init, obj_init) = + build_object_init_0 cla [] cl copy_env subst_env top ids in + let inh_init' = List.rev inh_init in + let (inh_init', cl_init) = + build_class_init cla true ([],[]) inh_init' obj_init msubst top cl + in + assert (inh_init' = []); + let table = Ident.create_local "table" + and class_init = Ident.create_local (Ident.name cl_id ^ "_init") + and env_init = Ident.create_local "env_init" + and obj_init = Ident.create_local "obj_init" in + let pub_meths = + List.sort + (fun s s' -> compare (Btype.hash_variant s) (Btype.hash_variant s')) + pub_meths in + let tags = List.map Btype.hash_variant pub_meths in + let rev_map = List.combine tags pub_meths in + List.iter2 + (fun tag name -> + let name' = List.assoc tag rev_map in + if name' <> name then raise(Error(cl.cl_loc, Tags(name, name')))) + tags pub_meths; + let ltable table lam = + Llet(Strict, Pgenval, table, + mkappl (oo_prim "create_table", [transl_meth_list pub_meths]), lam) + and ldirect obj_init = + Llet(Strict, Pgenval, obj_init, cl_init, + Lsequence(mkappl (oo_prim "init_class", [Lvar cla]), + mkappl (Lvar obj_init, [lambda_unit]))) + in + (* Simplest case: an object defined at toplevel (ids=[]) *) + if top && ids = [] then llets (ltable cla (ldirect obj_init)) else + + let concrete = (vflag = Concrete) + and lclass lam = + let cl_init = llets (Lfunction{kind = Curried; + attr = default_function_attribute; + loc = Location.none; + return = Pgenval; + params = [cla, Pgenval]; body = cl_init}) in + Llet(Strict, Pgenval, class_init, cl_init, lam (free_variables cl_init)) + and lbody fv = + if List.for_all (fun id -> not (Ident.Set.mem id fv)) ids then + mkappl (oo_prim "make_class",[transl_meth_list pub_meths; + Lvar class_init]) + else + ltable table ( + Llet( + Strict, Pgenval, env_init, mkappl (Lvar class_init, [Lvar table]), + Lsequence( + mkappl (oo_prim "init_class", [Lvar table]), + Lprim(Pmakeblock(0, Immutable, None), + [mkappl (Lvar env_init, [lambda_unit]); + Lvar class_init; Lvar env_init; lambda_unit], + Location.none)))) + and lbody_virt lenvs = + Lprim(Pmakeblock(0, Immutable, None), + [lambda_unit; Lfunction{kind = Curried; + attr = default_function_attribute; + loc = Location.none; + return = Pgenval; + params = [cla, Pgenval]; body = cl_init}; + lambda_unit; lenvs], + Location.none) + in + (* Still easy: a class defined at toplevel *) + if top && concrete then lclass lbody else + if top then llets (lbody_virt lambda_unit) else + + (* Now for the hard stuff: prepare for table caching *) + let envs = Ident.create_local "envs" + and cached = Ident.create_local "cached" in + let lenvs = + if !new_ids_meths = [] && !new_ids_init = [] && inh_init = [] + then lambda_unit + else Lvar envs in + let lenv = + let menv = + if !new_ids_meths = [] then lambda_unit else + Lprim(Pmakeblock(0, Immutable, None), + List.map (fun id -> Lvar id) !new_ids_meths, + Location.none) in + if !new_ids_init = [] then menv else + Lprim(Pmakeblock(0, Immutable, None), + menv :: List.map (fun id -> Lvar id) !new_ids_init, + Location.none) + and linh_envs = + List.map + (fun (_, path_lam, _) -> Lprim(Pfield 3, [path_lam], Location.none)) + (List.rev inh_init) + in + let make_envs lam = + Llet(StrictOpt, Pgenval, envs, + (if linh_envs = [] then lenv else + Lprim(Pmakeblock(0, Immutable, None), + lenv :: linh_envs, Location.none)), + lam) + and def_ids cla lam = + Llet(StrictOpt, Pgenval, env2, + mkappl (oo_prim "new_variable", [Lvar cla; transl_label ""]), + lam) + in + let inh_paths = + List.filter + (fun (path, _, _) -> List.mem (Path.head path) new_ids) inh_init + in + let inh_keys = + List.map + (fun (_, path_lam, _) -> Lprim(Pfield 1, [path_lam], Location.none)) + inh_paths + in + let lclass lam = + Llet(Strict, Pgenval, class_init, + Lfunction{kind = Curried; params = [cla, Pgenval]; + return = Pgenval; + attr = default_function_attribute; + loc = Location.none; + body = def_ids cla cl_init}, lam) + and lcache lam = + if inh_keys = [] then Llet(Alias, Pgenval, cached, Lvar tables, lam) else + Llet(Strict, Pgenval, cached, + mkappl (oo_prim "lookup_tables", + [Lvar tables; Lprim(Pmakeblock(0, Immutable, None), + inh_keys, Location.none)]), + lam) + and lset cached i lam = + Lprim(Psetfield(i, Pointer, Assignment), + [Lvar cached; lam], Location.none) + in + let ldirect () = + ltable cla + (Llet(Strict, Pgenval, env_init, def_ids cla cl_init, + Lsequence(mkappl (oo_prim "init_class", [Lvar cla]), + lset cached 0 (Lvar env_init)))) + and lclass_virt () = + lset cached 0 + (Lfunction + { + kind = Curried; + attr = default_function_attribute; + loc = Location.none; + return = Pgenval; + params = [cla, Pgenval]; + body = def_ids cla cl_init; + } + ) + in + let lupdate_cache = + if ids = [] then ldirect () else + if not concrete then lclass_virt () else + lclass ( + mkappl (oo_prim "make_class_store", + [transl_meth_list pub_meths; + Lvar class_init; Lvar cached])) in + let lcheck_cache = + if !Clflags.native_code && !Clflags.afl_instrument then + (* When afl-fuzz instrumentation is enabled, ignore the cache + so that the program's behaviour does not change between runs *) + lupdate_cache + else + Lifthenelse(lfield cached 0, lambda_unit, lupdate_cache) in + llets ( + lcache ( + Lsequence(lcheck_cache, + make_envs ( + if ids = [] then mkappl (lfield cached 0, [lenvs]) else + Lprim(Pmakeblock(0, Immutable, None), + (if concrete then + [mkappl (lfield cached 0, [lenvs]); + lfield cached 1; + lfield cached 0; + lenvs] + else [lambda_unit; lfield cached 0; lambda_unit; lenvs]), + Location.none + ))))) + +(* Wrapper for class compilation *) +(* + let cl_id = ci.ci_id_class in +(* TODO: cl_id is used somewhere else as typesharp ? *) + let _arity = List.length ci.ci_params in + let pub_meths = m in + let cl = ci.ci_expr in + let vflag = vf in +*) + +let transl_class ids id pub_meths cl vf = + oo_wrap cl.cl_env false (transl_class ids id pub_meths cl) vf + +let () = + transl_object := (fun id meths cl -> transl_class [] id meths cl Concrete) + +(* Error report *) + +open Format + +let report_error ppf = function + | Tags (lab1, lab2) -> + fprintf ppf "Method labels `%s' and `%s' are incompatible.@ %s" + lab1 lab2 "Change one of them." + +let () = + Location.register_error_of_exn + (function + | Error (loc, err) -> + Some (Location.error_of_printer ~loc report_error err) + | _ -> + None + ) diff --git a/lambda/translclass.mli b/lambda/translclass.mli new file mode 100644 index 0000000000..4c4bed0f63 --- /dev/null +++ b/lambda/translclass.mli @@ -0,0 +1,29 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, 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 Typedtree +open Lambda + +val transl_class : + Ident.t list -> Ident.t -> + string list -> class_expr -> Asttypes.virtual_flag -> lambda;; + +type error = Tags of string * string + +exception Error of Location.t * error + +open Format + +val report_error: formatter -> error -> unit diff --git a/lambda/translcore.ml b/lambda/translcore.ml new file mode 100644 index 0000000000..6fe2dcbbb9 --- /dev/null +++ b/lambda/translcore.ml @@ -0,0 +1,1048 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Translation from typed abstract syntax to lambda terms, + for the core language *) + +open Misc +open Asttypes +open Primitive +open Types +open Typedtree +open Typeopt +open Lambda + +type error = + Free_super_var + | Unreachable_reached + +exception Error of Location.t * error + +let use_dup_for_constant_arrays_bigger_than = 4 + +(* Forward declaration -- to be filled in by Translmod.transl_module *) +let transl_module = + ref((fun _cc _rootpath _modl -> assert false) : + module_coercion -> Path.t option -> module_expr -> lambda) + +let transl_object = + ref (fun _id _s _cl -> assert false : + Ident.t -> string list -> class_expr -> lambda) + +(* Compile an exception/extension definition *) + +let prim_fresh_oo_id = + Pccall (Primitive.simple ~name:"caml_fresh_oo_id" ~arity:1 ~alloc:false) + +let transl_extension_constructor env path ext = + let path = + Printtyp.wrap_printing_env env ~error:true (fun () -> + Option.map (Printtyp.rewrite_double_underscore_paths env) path) + in + let name = + match path, !Clflags.for_package with + None, _ -> Ident.name ext.ext_id + | Some p, None -> Path.name p + | Some p, Some pack -> Printf.sprintf "%s.%s" pack (Path.name p) + in + let loc = ext.ext_loc in + match ext.ext_kind with + Text_decl _ -> + Lprim (Pmakeblock (Obj.object_tag, Immutable, None), + [Lconst (Const_base (Const_string (name, None))); + Lprim (prim_fresh_oo_id, [Lconst (Const_base (Const_int 0))], loc)], + loc) + | Text_rebind(path, _lid) -> + transl_extension_path loc env path + +(* To propagate structured constants *) + +exception Not_constant + +let extract_constant = function + Lconst sc -> sc + | _ -> raise Not_constant + +let extract_float = function + Const_base(Const_float f) -> f + | _ -> fatal_error "Translcore.extract_float" + +(* Push the default values under the functional abstractions *) +(* Also push bindings of module patterns, since this sound *) + +type binding = + | Bind_value of value_binding list + | Bind_module of Ident.t * string loc * module_presence * module_expr + +let rec push_defaults loc bindings cases partial = + match cases with + [{c_lhs=pat; c_guard=None; + c_rhs={exp_desc = Texp_function { arg_label; param; cases; partial; } } + as exp}] -> + let cases = push_defaults exp.exp_loc bindings cases partial in + [{c_lhs=pat; c_guard=None; + c_rhs={exp with exp_desc = Texp_function { arg_label; param; cases; + partial; }}}] + | [{c_lhs=pat; c_guard=None; + c_rhs={exp_attributes=[{Parsetree.attr_name = {txt="#default"};_}]; + exp_desc = Texp_let + (Nonrecursive, binds, ({exp_desc = Texp_function _} as e2))}}] -> + push_defaults loc (Bind_value binds :: bindings) + [{c_lhs=pat;c_guard=None;c_rhs=e2}] + partial + | [{c_lhs=pat; c_guard=None; + c_rhs={exp_attributes=[{Parsetree.attr_name = {txt="#modulepat"};_}]; + exp_desc = Texp_letmodule + (id, name, pres, mexpr, + ({exp_desc = Texp_function _} as e2))}}] -> + push_defaults loc (Bind_module (id, name, pres, mexpr) :: bindings) + [{c_lhs=pat;c_guard=None;c_rhs=e2}] + partial + | [case] -> + let exp = + List.fold_left + (fun exp binds -> + {exp with exp_desc = + match binds with + | Bind_value binds -> Texp_let(Nonrecursive, binds, exp) + | Bind_module (id, name, pres, mexpr) -> + Texp_letmodule (id, name, pres, mexpr, exp)}) + case.c_rhs bindings + in + [{case with c_rhs=exp}] + | {c_lhs=pat; c_rhs=exp; c_guard=_} :: _ when bindings <> [] -> + let param = Typecore.name_cases "param" cases in + let desc = + {val_type = pat.pat_type; val_kind = Val_reg; + val_attributes = []; Types.val_loc = Location.none; } + in + let env = Env.add_value param desc exp.exp_env in + let name = Ident.name param in + let exp = + { exp with exp_loc = loc; exp_env = env; exp_desc = + Texp_match + ({exp with exp_type = pat.pat_type; exp_env = env; exp_desc = + Texp_ident + (Path.Pident param, mknoloc (Longident.Lident name), desc)}, + cases, partial) } + in + push_defaults loc bindings + [{c_lhs={pat with pat_desc = Tpat_var (param, mknoloc name)}; + c_guard=None; c_rhs=exp}] + Total + | _ -> + cases + +(* Insertion of debugging events *) + +let event_before = Translprim.event_before + +let event_after = Translprim.event_after + +let event_function exp lam = + if !Clflags.debug && not !Clflags.native_code then + let repr = Some (ref 0) in + let (info, body) = lam repr in + (info, + Levent(body, {lev_loc = exp.exp_loc; + lev_kind = Lev_function; + lev_repr = repr; + lev_env = exp.exp_env})) + else + lam None + +(* Assertions *) + +let assert_failed exp = + let slot = + transl_extension_path Location.none + Env.initial_safe_string Predef.path_assert_failure + in + let (fname, line, char) = + Location.get_pos_info exp.exp_loc.Location.loc_start + in + Lprim(Praise Raise_regular, [event_after exp + (Lprim(Pmakeblock(0, Immutable, None), + [slot; + Lconst(Const_block(0, + [Const_base(Const_string (fname, None)); + Const_base(Const_int line); + Const_base(Const_int char)]))], exp.exp_loc))], exp.exp_loc) +;; + +let rec cut n l = + if n = 0 then ([],l) else + match l with [] -> failwith "Translcore.cut" + | a::l -> let (l1,l2) = cut (n-1) l in (a::l1,l2) + +(* Translation of expressions *) + +let rec iter_exn_names f pat = + match pat.pat_desc with + | Tpat_var (id, _) -> f id + | Tpat_alias (p, id, _) -> + f id; + iter_exn_names f p + | _ -> () + +let transl_ident loc env ty path desc = + match desc.val_kind with + | Val_prim p -> + Translprim.transl_primitive loc p env ty (Some path) + | Val_anc _ -> + raise(Error(loc, Free_super_var)) + | Val_reg | Val_self _ -> + transl_value_path loc env path + | _ -> fatal_error "Translcore.transl_exp: bad Texp_ident" + +let rec transl_exp e = + List.iter (Translattribute.check_attribute e) e.exp_attributes; + let eval_once = + (* Whether classes for immediate objects must be cached *) + match e.exp_desc with + Texp_function _ | Texp_for _ | Texp_while _ -> false + | _ -> true + in + if eval_once then transl_exp0 e else + Translobj.oo_wrap e.exp_env true transl_exp0 e + +and transl_exp0 e = + match e.exp_desc with + | Texp_ident(path, _, desc) -> + transl_ident e.exp_loc e.exp_env e.exp_type path desc + | Texp_constant cst -> + Lconst(Const_base cst) + | Texp_let(rec_flag, pat_expr_list, body) -> + transl_let rec_flag pat_expr_list (event_before body (transl_exp body)) + | Texp_function { arg_label = _; param; cases; partial; } -> + let ((kind, params, return), body) = + event_function e + (function repr -> + let pl = push_defaults e.exp_loc [] cases partial in + let return_kind = function_return_value_kind e.exp_env e.exp_type in + transl_function e.exp_loc return_kind !Clflags.native_code repr + partial param pl) + in + let attr = default_function_attribute in + let loc = e.exp_loc in + let lam = Lfunction{kind; params; return; body; attr; loc} in + Translattribute.add_function_attributes lam loc e.exp_attributes + | Texp_apply({ exp_desc = Texp_ident(path, _, {val_kind = Val_prim p}); + exp_type = prim_type } as funct, oargs) + when List.length oargs >= p.prim_arity + && List.for_all (fun (_, arg) -> arg <> None) oargs -> + let argl, extra_args = cut p.prim_arity oargs in + let arg_exps = + List.map (function _, Some x -> x | _ -> assert false) argl + in + let args = transl_list arg_exps in + let prim_exp = if extra_args = [] then Some e else None in + let lam = + Translprim.transl_primitive_application + e.exp_loc p e.exp_env prim_type path + prim_exp args arg_exps + in + if extra_args = [] then lam + else begin + let should_be_tailcall, funct = + Translattribute.get_tailcall_attribute funct + in + let inlined, funct = + Translattribute.get_and_remove_inlined_attribute funct + in + let specialised, funct = + Translattribute.get_and_remove_specialised_attribute funct + in + let e = { e with exp_desc = Texp_apply(funct, oargs) } in + event_after e + (transl_apply ~should_be_tailcall ~inlined ~specialised + lam extra_args e.exp_loc) + end + | Texp_apply(funct, oargs) -> + let should_be_tailcall, funct = + Translattribute.get_tailcall_attribute funct + in + let inlined, funct = + Translattribute.get_and_remove_inlined_attribute funct + in + let specialised, funct = + Translattribute.get_and_remove_specialised_attribute funct + in + let e = { e with exp_desc = Texp_apply(funct, oargs) } in + event_after e + (transl_apply ~should_be_tailcall ~inlined ~specialised + (transl_exp funct) oargs e.exp_loc) + | Texp_match(arg, pat_expr_list, partial) -> + transl_match e arg pat_expr_list partial + | Texp_try(body, pat_expr_list) -> + let id = Typecore.name_cases "exn" pat_expr_list in + Ltrywith(transl_exp body, id, + Matching.for_trywith (Lvar id) (transl_cases_try pat_expr_list)) + | Texp_tuple el -> + let ll, shape = transl_list_with_shape el in + begin try + Lconst(Const_block(0, List.map extract_constant ll)) + with Not_constant -> + Lprim(Pmakeblock(0, Immutable, Some shape), ll, e.exp_loc) + end + | Texp_construct(_, cstr, args) -> + let ll, shape = transl_list_with_shape args in + if cstr.cstr_inlined <> None then begin match ll with + | [x] -> x + | _ -> assert false + end else begin match cstr.cstr_tag with + Cstr_constant n -> + Lconst(Const_pointer n) + | Cstr_unboxed -> + (match ll with [v] -> v | _ -> assert false) + | Cstr_block n -> + begin try + Lconst(Const_block(n, List.map extract_constant ll)) + with Not_constant -> + Lprim(Pmakeblock(n, Immutable, Some shape), ll, e.exp_loc) + end + | Cstr_extension(path, is_const) -> + let lam = transl_extension_path e.exp_loc e.exp_env path in + if is_const then lam + else + Lprim(Pmakeblock(0, Immutable, Some (Pgenval :: shape)), + lam :: ll, e.exp_loc) + end + | Texp_extension_constructor (_, path) -> + transl_extension_path e.exp_loc e.exp_env path + | Texp_variant(l, arg) -> + let tag = Btype.hash_variant l in + begin match arg with + None -> Lconst(Const_pointer tag) + | Some arg -> + let lam = transl_exp arg in + try + Lconst(Const_block(0, [Const_base(Const_int tag); + extract_constant lam])) + with Not_constant -> + Lprim(Pmakeblock(0, Immutable, None), + [Lconst(Const_base(Const_int tag)); lam], e.exp_loc) + end + | Texp_record {fields; representation; extended_expression} -> + transl_record e.exp_loc e.exp_env fields representation + extended_expression + | Texp_field(arg, _, lbl) -> + let targ = transl_exp arg in + begin match lbl.lbl_repres with + Record_regular | Record_inlined _ -> + Lprim (Pfield lbl.lbl_pos, [targ], e.exp_loc) + | Record_unboxed _ -> targ + | Record_float -> Lprim (Pfloatfield lbl.lbl_pos, [targ], e.exp_loc) + | Record_extension _ -> + Lprim (Pfield (lbl.lbl_pos + 1), [targ], e.exp_loc) + end + | Texp_setfield(arg, _, lbl, newval) -> + let access = + match lbl.lbl_repres with + Record_regular + | Record_inlined _ -> + Psetfield(lbl.lbl_pos, maybe_pointer newval, Assignment) + | Record_unboxed _ -> assert false + | Record_float -> Psetfloatfield (lbl.lbl_pos, Assignment) + | Record_extension _ -> + Psetfield (lbl.lbl_pos + 1, maybe_pointer newval, Assignment) + in + Lprim(access, [transl_exp arg; transl_exp newval], e.exp_loc) + | Texp_array expr_list -> + let kind = array_kind e in + let ll = transl_list expr_list in + begin try + (* For native code the decision as to which compilation strategy to + use is made later. This enables the Flambda passes to lift certain + kinds of array definitions to symbols. *) + (* Deactivate constant optimization if array is small enough *) + if List.length ll <= use_dup_for_constant_arrays_bigger_than + then begin + raise Not_constant + end; + begin match List.map extract_constant ll with + | exception Not_constant when kind = Pfloatarray -> + (* We cannot currently lift [Pintarray] arrays safely in Flambda + because [caml_modify] might be called upon them (e.g. from + code operating on polymorphic arrays, or functions such as + [caml_array_blit]. + To avoid having different Lambda code for + bytecode/Closure vs. Flambda, we always generate + [Pduparray] here, and deal with it in [Bytegen] (or in + the case of Closure, in [Cmmgen], which already has to + handle [Pduparray Pmakearray Pfloatarray] in the case + where the array turned out to be inconstant). + When not [Pfloatarray], the exception propagates to the handler + below. *) + let imm_array = + Lprim (Pmakearray (kind, Immutable), ll, e.exp_loc) + in + Lprim (Pduparray (kind, Mutable), [imm_array], e.exp_loc) + | cl -> + let imm_array = + match kind with + | Paddrarray | Pintarray -> + Lconst(Const_block(0, cl)) + | Pfloatarray -> + Lconst(Const_float_array(List.map extract_float cl)) + | Pgenarray -> + raise Not_constant (* can this really happen? *) + in + Lprim (Pduparray (kind, Mutable), [imm_array], e.exp_loc) + end + with Not_constant -> + Lprim(Pmakearray (kind, Mutable), ll, e.exp_loc) + end + | Texp_ifthenelse(cond, ifso, Some ifnot) -> + Lifthenelse(transl_exp cond, + event_before ifso (transl_exp ifso), + event_before ifnot (transl_exp ifnot)) + | Texp_ifthenelse(cond, ifso, None) -> + Lifthenelse(transl_exp cond, + event_before ifso (transl_exp ifso), + lambda_unit) + | Texp_sequence(expr1, expr2) -> + Lsequence(transl_exp expr1, event_before expr2 (transl_exp expr2)) + | Texp_while(cond, body) -> + Lwhile(transl_exp cond, event_before body (transl_exp body)) + | Texp_for(param, _, low, high, dir, body) -> + Lfor(param, transl_exp low, transl_exp high, dir, + event_before body (transl_exp body)) + | Texp_send(_, _, Some exp) -> transl_exp exp + | Texp_send(expr, met, None) -> + let obj = transl_exp expr in + let lam = + match met with + Tmeth_val id -> Lsend (Self, Lvar id, obj, [], e.exp_loc) + | Tmeth_name nm -> + let (tag, cache) = Translobj.meth obj nm in + let kind = if cache = [] then Public else Cached in + Lsend (kind, tag, obj, cache, e.exp_loc) + in + event_after e lam + | Texp_new (cl, {Location.loc=loc}, _) -> + Lapply{ap_should_be_tailcall=false; + ap_loc=loc; + ap_func= + Lprim(Pfield 0, [transl_class_path loc e.exp_env cl], loc); + ap_args=[lambda_unit]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise} + | Texp_instvar(path_self, path, _) -> + let self = transl_value_path e.exp_loc e.exp_env path_self in + let var = transl_value_path e.exp_loc e.exp_env path in + Lprim(Pfield_computed, [self; var], e.exp_loc) + | Texp_setinstvar(path_self, path, _, expr) -> + let self = transl_value_path e.exp_loc e.exp_env path_self in + let var = transl_value_path e.exp_loc e.exp_env path in + transl_setinstvar e.exp_loc self var expr + | Texp_override(path_self, modifs) -> + let self = transl_value_path e.exp_loc e.exp_env path_self in + let cpy = Ident.create_local "copy" in + Llet(Strict, Pgenval, cpy, + Lapply{ap_should_be_tailcall=false; + ap_loc=Location.none; + ap_func=Translobj.oo_prim "copy"; + ap_args=[self]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise}, + List.fold_right + (fun (path, _, expr) rem -> + let var = transl_value_path e.exp_loc e.exp_env path in + Lsequence(transl_setinstvar Location.none + (Lvar cpy) var expr, rem)) + modifs + (Lvar cpy)) + | Texp_letmodule(id, loc, Mp_present, modl, body) -> + let defining_expr = + Levent (!transl_module Tcoerce_none None modl, { + lev_loc = loc.loc; + lev_kind = Lev_module_definition id; + lev_repr = None; + lev_env = Env.empty; + }) + in + Llet(Strict, Pgenval, id, defining_expr, transl_exp body) + | Texp_letmodule(_, _, Mp_absent, _, body) -> + transl_exp body + | Texp_letexception(cd, body) -> + Llet(Strict, Pgenval, + cd.ext_id, transl_extension_constructor e.exp_env None cd, + transl_exp body) + | Texp_pack modl -> + !transl_module Tcoerce_none None modl + | Texp_assert {exp_desc=Texp_construct(_, {cstr_name="false"}, _)} -> + assert_failed e + | Texp_assert (cond) -> + if !Clflags.noassert + then lambda_unit + else Lifthenelse (transl_exp cond, lambda_unit, assert_failed e) + | Texp_lazy e -> + (* when e needs no computation (constants, identifiers, ...), we + optimize the translation just as Lazy.lazy_from_val would + do *) + begin match Typeopt.classify_lazy_argument e with + | `Constant_or_function -> + (* A constant expr (of type <> float if [Config.flat_float_array] is + true) gets compiled as itself. *) + transl_exp e + | `Float_that_cannot_be_shortcut -> + (* We don't need to wrap with Popaque: this forward + block will never be shortcutted since it points to a float + and Config.flat_float_array is true. *) + Lprim(Pmakeblock(Obj.forward_tag, Immutable, None), + [transl_exp e], e.exp_loc) + | `Identifier `Forward_value -> + (* CR-someday mshinwell: Consider adding a new primitive + that expresses the construction of forward_tag blocks. + We need to use [Popaque] here to prevent unsound + optimisation in Flambda, but the concept of a mutable + block doesn't really match what is going on here. This + value may subsequently turn into an immediate... *) + Lprim (Popaque, + [Lprim(Pmakeblock(Obj.forward_tag, Immutable, None), + [transl_exp e], e.exp_loc)], + e.exp_loc) + | `Identifier `Other -> + transl_exp e + | `Other -> + (* other cases compile to a lazy block holding a function *) + let fn = Lfunction {kind = Curried; + params= [Ident.create_local "param", Pgenval]; + return = Pgenval; + attr = default_function_attribute; + loc = e.exp_loc; + body = transl_exp e} in + Lprim(Pmakeblock(Config.lazy_tag, Mutable, None), [fn], e.exp_loc) + end + | Texp_object (cs, meths) -> + let cty = cs.cstr_type in + let cl = Ident.create_local "class" in + !transl_object cl meths + { cl_desc = Tcl_structure cs; + cl_loc = e.exp_loc; + cl_type = Cty_signature cty; + cl_env = e.exp_env; + cl_attributes = []; + } + | Texp_letop{let_; ands; param; body; partial} -> + event_after e + (transl_letop e.exp_loc e.exp_env let_ ands param body partial) + | Texp_unreachable -> + raise (Error (e.exp_loc, Unreachable_reached)) + | Texp_open (od, e) -> + let pure = pure_module od.open_expr in + (* this optimization shouldn't be needed because Simplif would + actually remove the [Llet] when it's not used. + But since [scan_used_globals] runs before Simplif, we need to + do it. *) + begin match od.open_bound_items with + | [] when pure = Alias -> transl_exp e + | _ -> + let oid = Ident.create_local "open" in + let body, _ = + List.fold_left (fun (body, pos) id -> + Llet(Alias, Pgenval, id, + Lprim(Pfield pos, [Lvar oid], od.open_loc), body), + pos + 1 + ) (transl_exp e, 0) (bound_value_identifiers od.open_bound_items) + in + Llet(pure, Pgenval, oid, + !transl_module Tcoerce_none None od.open_expr, body) + end + +and pure_module m = + match m.mod_desc with + Tmod_ident _ -> Alias + | Tmod_constraint (m,_,_,_) -> pure_module m + | _ -> Strict + +and transl_list expr_list = + List.map transl_exp expr_list + +and transl_list_with_shape expr_list = + let transl_with_shape e = + let shape = Typeopt.value_kind e.exp_env e.exp_type in + transl_exp e, shape + in + List.split (List.map transl_with_shape expr_list) + +and transl_guard guard rhs = + let expr = event_before rhs (transl_exp rhs) in + match guard with + | None -> expr + | Some cond -> + event_before cond (Lifthenelse(transl_exp cond, expr, staticfail)) + +and transl_case {c_lhs; c_guard; c_rhs} = + c_lhs, transl_guard c_guard c_rhs + +and transl_cases cases = + let cases = + List.filter (fun c -> c.c_rhs.exp_desc <> Texp_unreachable) cases in + List.map transl_case cases + +and transl_case_try {c_lhs; c_guard; c_rhs} = + iter_exn_names Translprim.add_exception_ident c_lhs; + Misc.try_finally + (fun () -> c_lhs, transl_guard c_guard c_rhs) + ~always:(fun () -> + iter_exn_names Translprim.remove_exception_ident c_lhs) + +and transl_cases_try cases = + let cases = + List.filter (fun c -> c.c_rhs.exp_desc <> Texp_unreachable) cases in + List.map transl_case_try cases + +and transl_tupled_cases patl_expr_list = + let patl_expr_list = + List.filter (fun (_,_,e) -> e.exp_desc <> Texp_unreachable) + patl_expr_list in + List.map (fun (patl, guard, expr) -> (patl, transl_guard guard expr)) + patl_expr_list + +and transl_apply ?(should_be_tailcall=false) ?(inlined = Default_inline) + ?(specialised = Default_specialise) lam sargs loc = + let lapply funct args = + match funct with + Lsend(k, lmet, lobj, largs, loc) -> + Lsend(k, lmet, lobj, largs @ args, loc) + | Levent(Lsend(k, lmet, lobj, largs, loc), _) -> + Lsend(k, lmet, lobj, largs @ args, loc) + | Lapply ap -> + Lapply {ap with ap_args = ap.ap_args @ args; ap_loc = loc} + | lexp -> + Lapply {ap_should_be_tailcall=should_be_tailcall; + ap_loc=loc; + ap_func=lexp; + ap_args=args; + ap_inlined=inlined; + ap_specialised=specialised;} + in + let rec build_apply lam args = function + (None, optional) :: l -> + let defs = ref [] in + let protect name lam = + match lam with + Lvar _ | Lconst _ -> lam + | _ -> + let id = Ident.create_local name in + defs := (id, lam) :: !defs; + Lvar id + in + let args, args' = + if List.for_all (fun (_,opt) -> opt) args then [], args + else args, [] in + let lam = + if args = [] then lam else lapply lam (List.rev_map fst args) in + let handle = protect "func" lam + and l = List.map (fun (arg, opt) -> may_map (protect "arg") arg, opt) l + and id_arg = Ident.create_local "param" in + let body = + match build_apply handle ((Lvar id_arg, optional)::args') l with + Lfunction{kind = Curried; params = ids; return; + body = lam; attr; loc} -> + Lfunction{kind = Curried; + params = (id_arg, Pgenval)::ids; + return; + body = lam; attr; + loc} + | Levent(Lfunction{kind = Curried; params = ids; return; + body = lam; attr; loc}, _) -> + Lfunction{kind = Curried; params = (id_arg, Pgenval)::ids; + return; + body = lam; attr; + loc} + | lam -> + Lfunction{kind = Curried; params = [id_arg, Pgenval]; + return = Pgenval; body = lam; + attr = default_stub_attribute; loc = loc} + in + List.fold_left + (fun body (id, lam) -> Llet(Strict, Pgenval, id, lam, body)) + body !defs + | (Some arg, optional) :: l -> + build_apply lam ((arg, optional) :: args) l + | [] -> + lapply lam (List.rev_map fst args) + in + (build_apply lam [] (List.map (fun (l, x) -> + may_map transl_exp x, Btype.is_optional l) + sargs) + : Lambda.lambda) + +and transl_function loc return untuplify_fn repr partial (param:Ident.t) cases = + match cases with + [{c_lhs=pat; c_guard=None; + c_rhs={exp_desc = Texp_function { arg_label = _; param = param'; cases; + partial = partial'; }; exp_env; exp_type} as exp}] + when Parmatch.inactive ~partial pat -> + let kind = value_kind pat.pat_env pat.pat_type in + let return_kind = function_return_value_kind exp_env exp_type in + let ((_, params, return), body) = + transl_function exp.exp_loc return_kind false repr partial' param' cases + in + ((Curried, (param, kind) :: params, return), + Matching.for_function loc None (Lvar param) [pat, body] partial) + | {c_lhs={pat_desc = Tpat_tuple pl}} :: _ when untuplify_fn -> + begin try + let size = List.length pl in + let pats_expr_list = + List.map + (fun {c_lhs; c_guard; c_rhs} -> + (Matching.flatten_pattern size c_lhs, c_guard, c_rhs)) + cases in + let kinds = + (* All the patterns might not share the same types. We must take the + union of the patterns types *) + match pats_expr_list with + | [] -> assert false + | (pats, _, _) :: cases -> + let first_case_kinds = + List.map (fun pat -> value_kind pat.pat_env pat.pat_type) pats + in + List.fold_left + (fun kinds (pats, _, _) -> + List.map2 (fun kind pat -> + value_kind_union kind + (value_kind pat.pat_env pat.pat_type)) + kinds pats) + first_case_kinds cases + in + let tparams = + List.map (fun kind -> Ident.create_local "param", kind) kinds + in + let params = List.map fst tparams in + ((Tupled, tparams, return), + Matching.for_tupled_function loc params + (transl_tupled_cases pats_expr_list) partial) + with Matching.Cannot_flatten -> + ((Curried, [param, Pgenval], return), + Matching.for_function loc repr (Lvar param) + (transl_cases cases) partial) + end + | {c_lhs=pat} :: other_cases -> + let kind = + (* All the patterns might not share the same types. We must take the + union of the patterns types *) + List.fold_left (fun k {c_lhs=pat} -> + Typeopt.value_kind_union k + (value_kind pat.pat_env pat.pat_type)) + (value_kind pat.pat_env pat.pat_type) other_cases + in + ((Curried, [param, kind], return), + Matching.for_function loc repr (Lvar param) + (transl_cases cases) partial) + | [] -> + (* With Camlp4, a pattern matching might be empty *) + ((Curried, [param, Pgenval], return), + Matching.for_function loc repr (Lvar param) + (transl_cases cases) partial) + +(* + Notice: transl_let consumes (ie compiles) its pat_expr_list argument, + and returns a function that will take the body of the lambda-let construct. + This complication allows choosing any compilation order for the + bindings and body of let constructs. +*) +and transl_let rec_flag pat_expr_list = + match rec_flag with + Nonrecursive -> + let rec transl = function + [] -> + fun body -> body + | {vb_pat=pat; vb_expr=expr; vb_attributes=attr; vb_loc} :: rem -> + let lam = transl_exp expr in + let lam = Translattribute.add_function_attributes lam vb_loc attr in + let mk_body = transl rem in + fun body -> Matching.for_let pat.pat_loc lam pat (mk_body body) + in transl pat_expr_list + | Recursive -> + let idlist = + List.map + (fun {vb_pat=pat} -> match pat.pat_desc with + Tpat_var (id,_) -> id + | Tpat_alias ({pat_desc=Tpat_any}, id,_) -> id + | _ -> assert false) + pat_expr_list in + let transl_case {vb_expr=expr; vb_attributes; vb_loc} id = + let lam = transl_exp expr in + let lam = + Translattribute.add_function_attributes lam vb_loc vb_attributes + in + (id, lam) in + let lam_bds = List.map2 transl_case pat_expr_list idlist in + fun body -> Lletrec(lam_bds, body) + +and transl_setinstvar loc self var expr = + Lprim(Psetfield_computed (maybe_pointer expr, Assignment), + [self; var; transl_exp expr], loc) + +and transl_record loc env fields repres opt_init_expr = + let size = Array.length fields in + (* Determine if there are "enough" fields (only relevant if this is a + functional-style record update *) + let no_init = match opt_init_expr with None -> true | _ -> false in + if no_init || size < Config.max_young_wosize + then begin + (* Allocate new record with given fields (and remaining fields + taken from init_expr if any *) + let init_id = Ident.create_local "init" in + let lv = + Array.mapi + (fun i (_, definition) -> + match definition with + | Kept typ -> + let field_kind = value_kind env typ in + let access = + match repres with + Record_regular | Record_inlined _ -> Pfield i + | Record_unboxed _ -> assert false + | Record_extension _ -> Pfield (i + 1) + | Record_float -> Pfloatfield i in + Lprim(access, [Lvar init_id], loc), field_kind + | Overridden (_lid, expr) -> + let field_kind = value_kind expr.exp_env expr.exp_type in + transl_exp expr, field_kind) + fields + in + let ll, shape = List.split (Array.to_list lv) in + let mut = + if Array.exists (fun (lbl, _) -> lbl.lbl_mut = Mutable) fields + then Mutable + else Immutable in + let lam = + try + if mut = Mutable then raise Not_constant; + let cl = List.map extract_constant ll in + match repres with + | Record_regular -> Lconst(Const_block(0, cl)) + | Record_inlined tag -> Lconst(Const_block(tag, cl)) + | Record_unboxed _ -> Lconst(match cl with [v] -> v | _ -> assert false) + | Record_float -> + Lconst(Const_float_array(List.map extract_float cl)) + | Record_extension _ -> + raise Not_constant + with Not_constant -> + match repres with + Record_regular -> + Lprim(Pmakeblock(0, mut, Some shape), ll, loc) + | Record_inlined tag -> + Lprim(Pmakeblock(tag, mut, Some shape), ll, loc) + | Record_unboxed _ -> (match ll with [v] -> v | _ -> assert false) + | Record_float -> + Lprim(Pmakearray (Pfloatarray, mut), ll, loc) + | Record_extension path -> + let slot = transl_extension_path loc env path in + Lprim(Pmakeblock(0, mut, Some (Pgenval :: shape)), slot :: ll, loc) + in + begin match opt_init_expr with + None -> lam + | Some init_expr -> Llet(Strict, Pgenval, init_id, + transl_exp init_expr, lam) + end + end else begin + (* Take a shallow copy of the init record, then mutate the fields + of the copy *) + let copy_id = Ident.create_local "newrecord" in + let update_field cont (lbl, definition) = + match definition with + | Kept _type -> cont + | Overridden (_lid, expr) -> + let upd = + match repres with + Record_regular + | Record_inlined _ -> + Psetfield(lbl.lbl_pos, maybe_pointer expr, Assignment) + | Record_unboxed _ -> assert false + | Record_float -> Psetfloatfield (lbl.lbl_pos, Assignment) + | Record_extension _ -> + Psetfield(lbl.lbl_pos + 1, maybe_pointer expr, Assignment) + in + Lsequence(Lprim(upd, [Lvar copy_id; transl_exp expr], loc), cont) + in + begin match opt_init_expr with + None -> assert false + | Some init_expr -> + Llet(Strict, Pgenval, copy_id, + Lprim(Pduprecord (repres, size), [transl_exp init_expr], loc), + Array.fold_left update_field (Lvar copy_id) fields) + end + end + +and transl_match e arg pat_expr_list partial = + let rewrite_case (val_cases, exn_cases, static_handlers as acc) + ({ c_lhs; c_guard; c_rhs } as case) = + if c_rhs.exp_desc = Texp_unreachable then acc else + let val_pat, exn_pat = split_pattern c_lhs in + match val_pat, exn_pat with + | None, None -> assert false + | Some pv, None -> + let val_case = + transl_case { case with c_lhs = pv } + in + val_case :: val_cases, exn_cases, static_handlers + | None, Some pe -> + let exn_case = transl_case_try { case with c_lhs = pe } in + val_cases, exn_case :: exn_cases, static_handlers + | Some pv, Some pe -> + assert (c_guard = None); + let lbl = next_raise_count () in + let static_raise ids = + Lstaticraise (lbl, List.map (fun id -> Lvar id) ids) + in + (* Simplif doesn't like it if binders are not uniq, so we make sure to + use different names in the value and the exception branches. *) + let ids_full = Typedtree.pat_bound_idents_full pv in + let ids = List.map (fun (id, _, _) -> id) ids_full in + let ids_kinds = + List.map (fun (id, _, ty) -> id, Typeopt.value_kind pv.pat_env ty) + ids_full + in + let vids = List.map Ident.rename ids in + let pv = alpha_pat (List.combine ids vids) pv in + (* Also register the names of the exception so Re-raise happens. *) + iter_exn_names Translprim.add_exception_ident pe; + let rhs = + Misc.try_finally + (fun () -> event_before c_rhs (transl_exp c_rhs)) + ~always:(fun () -> + iter_exn_names Translprim.remove_exception_ident pe) + in + (pv, static_raise vids) :: val_cases, + (pe, static_raise ids) :: exn_cases, + (lbl, ids_kinds, rhs) :: static_handlers + in + let val_cases, exn_cases, static_handlers = + let x, y, z = List.fold_left rewrite_case ([], [], []) pat_expr_list in + List.rev x, List.rev y, List.rev z + in + let static_catch body val_ids handler = + let id = Typecore.name_pattern "exn" (List.map fst exn_cases) in + let static_exception_id = next_raise_count () in + Lstaticcatch + (Ltrywith (Lstaticraise (static_exception_id, body), id, + Matching.for_trywith (Lvar id) exn_cases), + (static_exception_id, val_ids), + handler) + in + let classic = + match arg, exn_cases with + | {exp_desc = Texp_tuple argl}, [] -> + assert (static_handlers = []); + Matching.for_multiple_match e.exp_loc (transl_list argl) val_cases partial + | {exp_desc = Texp_tuple argl}, _ :: _ -> + let val_ids = + List.map + (fun arg -> + Typecore.name_pattern "val" [], + Typeopt.value_kind arg.exp_env arg.exp_type + ) + argl + in + let lvars = List.map (fun (id, _) -> Lvar id) val_ids in + static_catch (transl_list argl) val_ids + (Matching.for_multiple_match e.exp_loc lvars val_cases partial) + | arg, [] -> + assert (static_handlers = []); + Matching.for_function e.exp_loc None (transl_exp arg) val_cases partial + | arg, _ :: _ -> + let val_id = Typecore.name_cases "val" pat_expr_list in + let k = Typeopt.value_kind arg.exp_env arg.exp_type in + static_catch [transl_exp arg] [val_id, k] + (Matching.for_function e.exp_loc None (Lvar val_id) val_cases partial) + in + List.fold_left (fun body (static_exception_id, val_ids, handler) -> + Lstaticcatch (body, (static_exception_id, val_ids), handler) + ) classic static_handlers + +and transl_letop loc env let_ ands param case partial = + let rec loop prev_lam = function + | [] -> prev_lam + | and_ :: rest -> + let left_id = Ident.create_local "left" in + let right_id = Ident.create_local "right" in + let op = + transl_ident and_.bop_op_name.loc env + and_.bop_op_type and_.bop_op_path and_.bop_op_val + in + let exp = transl_exp and_.bop_exp in + let lam = + bind Strict right_id exp + (Lapply{ap_should_be_tailcall = false; + ap_loc = and_.bop_loc; + ap_func = op; + ap_args=[Lvar left_id; Lvar right_id]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise}) + in + bind Strict left_id prev_lam (loop lam rest) + in + let op = + transl_ident let_.bop_op_name.loc env + let_.bop_op_type let_.bop_op_path let_.bop_op_val + in + let exp = loop (transl_exp let_.bop_exp) ands in + let func = + let return_kind = value_kind case.c_rhs.exp_env case.c_rhs.exp_type in + let (kind, params, return), body = + event_function case.c_rhs + (function repr -> + transl_function case.c_rhs.exp_loc return_kind + !Clflags.native_code repr partial param [case]) + in + let attr = default_function_attribute in + let loc = case.c_rhs.exp_loc in + Lfunction{kind; params; return; body; attr; loc} + in + Lapply{ap_should_be_tailcall = false; + ap_loc = loc; + ap_func = op; + ap_args=[exp; func]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise} + +(* Wrapper for class compilation *) + +(* +let transl_exp = transl_exp_wrap + +let transl_let rec_flag pat_expr_list body = + match pat_expr_list with + [] -> body + | (_, expr) :: _ -> + Translobj.oo_wrap expr.exp_env false + (transl_let rec_flag pat_expr_list) body +*) + +(* Error report *) + +open Format + +let report_error ppf = function + | Free_super_var -> + fprintf ppf + "Ancestor names can only be used to select inherited methods" + | Unreachable_reached -> + fprintf ppf "Unreachable expression was reached" + +let () = + Location.register_error_of_exn + (function + | Error (loc, err) -> + Some (Location.error_of_printer ~loc report_error err) + | _ -> + None + ) diff --git a/lambda/translcore.mli b/lambda/translcore.mli new file mode 100644 index 0000000000..7a27dbcb39 --- /dev/null +++ b/lambda/translcore.mli @@ -0,0 +1,50 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Translation from typed abstract syntax to lambda terms, + for the core language *) + +open Asttypes +open Typedtree +open Lambda + +val pure_module : module_expr -> let_kind + +val transl_exp: expression -> lambda +val transl_apply: ?should_be_tailcall:bool + -> ?inlined:inline_attribute + -> ?specialised:specialise_attribute + -> lambda -> (arg_label * expression option) list + -> Location.t -> lambda +val transl_let: rec_flag -> value_binding list -> lambda -> lambda + +val transl_extension_constructor: Env.t -> Path.t option -> + extension_constructor -> lambda + +type error = + Free_super_var + | Unreachable_reached + +exception Error of Location.t * error + +open Format + +val report_error: formatter -> error -> unit + +(* Forward declaration -- to be filled in by Translmod.transl_module *) +val transl_module : + (module_coercion -> Path.t option -> module_expr -> lambda) ref +val transl_object : + (Ident.t -> string list -> class_expr -> lambda) ref diff --git a/lambda/translmod.ml b/lambda/translmod.ml new file mode 100644 index 0000000000..bf111693be --- /dev/null +++ b/lambda/translmod.ml @@ -0,0 +1,1556 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Translation from typed abstract syntax to lambda terms, + for the module language *) + +open Misc +open Asttypes +open Path +open Types +open Typedtree +open Lambda +open Translobj +open Translcore +open Translclass + +type unsafe_component = + | Unsafe_module_binding + | Unsafe_functor + | Unsafe_non_function + | Unsafe_typext + +type unsafe_info = { reason:unsafe_component; loc:Location.t; subid:Ident.t } +type error = + Circular_dependency of (Ident.t * unsafe_info) list +| Conflicting_inline_attributes + +exception Error of Location.t * error + +(* Keep track of the root path (from the root of the namespace to the + currently compiled module expression). Useful for naming extensions. *) + +let global_path glob = Some(Pident glob) +let functor_path path param = + match path with + None -> None + | Some p -> Some(Papply(p, Pident param)) +let field_path path field = + match path with + None -> None + | Some p -> Some(Pdot(p, Ident.name field)) + +(* Compile type extensions *) + +let transl_type_extension env rootpath tyext body = + List.fold_right + (fun ext body -> + let lam = + transl_extension_constructor env (field_path rootpath ext.ext_id) ext + in + Llet(Strict, Pgenval, ext.ext_id, lam, body)) + tyext.tyext_constructors + body + +(* Compile a coercion *) + +let rec apply_coercion loc strict restr arg = + match restr with + Tcoerce_none -> + arg + | Tcoerce_structure(pos_cc_list, id_pos_list) -> + name_lambda strict arg (fun id -> + let get_field pos = Lprim(Pfield pos,[Lvar id], loc) in + let lam = + Lprim(Pmakeblock(0, Immutable, None), + List.map (apply_coercion_field loc get_field) pos_cc_list, + loc) + in + wrap_id_pos_list loc id_pos_list get_field lam) + | Tcoerce_functor(cc_arg, cc_res) -> + let param = Ident.create_local "funarg" in + let carg = apply_coercion loc Alias cc_arg (Lvar param) in + apply_coercion_result loc strict arg [param, Pgenval] [carg] cc_res + | Tcoerce_primitive { pc_loc; pc_desc; pc_env; pc_type; } -> + Translprim.transl_primitive pc_loc pc_desc pc_env pc_type None + | Tcoerce_alias (env, path, cc) -> + let lam = transl_module_path loc env path in + name_lambda strict arg + (fun _ -> apply_coercion loc Alias cc lam) + +and apply_coercion_field loc get_field (pos, cc) = + apply_coercion loc Alias cc (get_field pos) + +and apply_coercion_result loc strict funct params args cc_res = + match cc_res with + | Tcoerce_functor(cc_arg, cc_res) -> + let param = Ident.create_local "funarg" in + let arg = apply_coercion loc Alias cc_arg (Lvar param) in + apply_coercion_result loc strict funct + ((param, Pgenval) :: params) (arg :: args) cc_res + | _ -> + name_lambda strict funct + (fun id -> + Lfunction + { + kind = Curried; + params = List.rev params; + return = Pgenval; + attr = { default_function_attribute with + is_a_functor = true; + stub = true; }; + loc = loc; + body = apply_coercion + loc Strict cc_res + (Lapply{ap_should_be_tailcall=false; + ap_loc=loc; + ap_func=Lvar id; + ap_args=List.rev args; + ap_inlined=Default_inline; + ap_specialised=Default_specialise})}) + +and wrap_id_pos_list loc id_pos_list get_field lam = + let fv = free_variables lam in + (*Format.eprintf "%a@." Printlambda.lambda lam; + Ident.Set.iter (fun id -> Format.eprintf "%a " Ident.print id) fv; + Format.eprintf "@.";*) + let (lam,s) = + List.fold_left (fun (lam, s) (id',pos,c) -> + if Ident.Set.mem id' fv then + let id'' = Ident.create_local (Ident.name id') in + (Llet(Alias, Pgenval, id'', + apply_coercion loc Alias c (get_field pos),lam), + Ident.Map.add id' id'' s) + else (lam, s)) + (lam, Ident.Map.empty) id_pos_list + in + if s == Ident.Map.empty then lam else Lambda.rename s lam + + +(* Compose two coercions + apply_coercion c1 (apply_coercion c2 e) behaves like + apply_coercion (compose_coercions c1 c2) e. *) + +let rec compose_coercions c1 c2 = + match (c1, c2) with + (Tcoerce_none, c2) -> c2 + | (c1, Tcoerce_none) -> c1 + | (Tcoerce_structure (pc1, ids1), Tcoerce_structure (pc2, ids2)) -> + let v2 = Array.of_list pc2 in + let ids1 = + List.map (fun (id,pos1,c1) -> + let (pos2,c2) = v2.(pos1) in (id, pos2, compose_coercions c1 c2)) + ids1 + in + Tcoerce_structure + (List.map + (fun pc -> + match pc with + | _, (Tcoerce_primitive _ | Tcoerce_alias _) -> + (* These cases do not take an argument (the position is -1), + so they do not need adjusting. *) + pc + | (p1, c1) -> + let (p2, c2) = v2.(p1) in + (p2, compose_coercions c1 c2)) + pc1, + ids1 @ ids2) + | (Tcoerce_functor(arg1, res1), Tcoerce_functor(arg2, res2)) -> + Tcoerce_functor(compose_coercions arg2 arg1, + compose_coercions res1 res2) + | (c1, Tcoerce_alias (env, path, c2)) -> + Tcoerce_alias (env, path, compose_coercions c1 c2) + | (_, _) -> + fatal_error "Translmod.compose_coercions" + +(* +let apply_coercion a b c = + Format.eprintf "@[<2>apply_coercion@ %a@]@." Includemod.print_coercion b; + apply_coercion a b c + +let compose_coercions c1 c2 = + let c3 = compose_coercions c1 c2 in + let open Includemod in + Format.eprintf "@[<2>compose_coercions@ (%a)@ (%a) =@ %a@]@." + print_coercion c1 print_coercion c2 print_coercion c3; + c3 +*) + +(* Record the primitive declarations occurring in the module compiled *) + +let primitive_declarations = ref ([] : Primitive.description list) +let record_primitive = function + | {val_kind=Val_prim p;val_loc} -> + Translprim.check_primitive_arity val_loc p; + primitive_declarations := p :: !primitive_declarations + | _ -> () + +(* Utilities for compiling "module rec" definitions *) + +let mod_prim = Lambda.transl_prim "CamlinternalMod" + +let undefined_location loc = + let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in + Lconst(Const_block(0, + [Const_base(Const_string (fname, None)); + Const_base(Const_int line); + Const_base(Const_int char)])) + +exception Initialization_failure of unsafe_info + +let init_shape id modl = + let rec init_shape_mod subid loc env mty = + match Mtype.scrape env mty with + Mty_ident _ + | Mty_alias _ -> + raise (Initialization_failure {reason=Unsafe_module_binding;loc;subid}) + | Mty_signature sg -> + Const_block(0, [Const_block(0, init_shape_struct env sg)]) + | Mty_functor _ -> + (* can we do better? *) + raise (Initialization_failure {reason=Unsafe_functor;loc;subid}) + and init_shape_struct env sg = + match sg with + [] -> [] + | Sig_value(subid, {val_kind=Val_reg; val_type=ty; val_loc=loc},_) :: rem -> + let init_v = + match Ctype.expand_head env ty with + {desc = Tarrow(_,_,_,_)} -> + Const_pointer 0 (* camlinternalMod.Function *) + | {desc = Tconstr(p, _, _)} when Path.same p Predef.path_lazy_t -> + Const_pointer 1 (* camlinternalMod.Lazy *) + | _ -> + let not_a_function = {reason=Unsafe_non_function; loc; subid } in + raise (Initialization_failure not_a_function) in + init_v :: init_shape_struct env rem + | Sig_value(_, {val_kind=Val_prim _}, _) :: rem -> + init_shape_struct env rem + | Sig_value _ :: _rem -> + assert false + | Sig_type(id, tdecl, _, _) :: rem -> + init_shape_struct (Env.add_type ~check:false id tdecl env) rem + | Sig_typext (subid, {ext_loc=loc},_,_) :: _ -> + raise (Initialization_failure {reason=Unsafe_typext; loc; subid}) + | Sig_module(id, Mp_present, md, _, _) :: rem -> + init_shape_mod id md.md_loc env md.md_type :: + init_shape_struct (Env.add_module_declaration ~check:false + id Mp_present md env) rem + | Sig_module(id, Mp_absent, md, _, _) :: rem -> + init_shape_struct + (Env.add_module_declaration ~check:false + id Mp_absent md env) rem + | Sig_modtype(id, minfo, _) :: rem -> + init_shape_struct (Env.add_modtype id minfo env) rem + | Sig_class _ :: rem -> + Const_pointer 2 (* camlinternalMod.Class *) + :: init_shape_struct env rem + | Sig_class_type _ :: rem -> + init_shape_struct env rem + in + try + Ok(undefined_location modl.mod_loc, + Lconst(init_shape_mod id modl.mod_loc modl.mod_env modl.mod_type)) + with Initialization_failure reason -> Result.Error(reason) + +(* Reorder bindings to honor dependencies. *) + +type binding_status = + | Undefined + | Inprogress of int option (** parent node *) + | Defined + +let extract_unsafe_cycle id status init cycle_start = + let info i = match init.(i) with + | Result.Error r -> id.(i), r + | Ok _ -> assert false in + let rec collect stop l i = match status.(i) with + | Inprogress None | Undefined | Defined -> assert false + | Inprogress Some i when i = stop -> info i :: l + | Inprogress Some i -> collect stop (info i::l) i in + collect cycle_start [] cycle_start + +let reorder_rec_bindings bindings = + let id = Array.of_list (List.map (fun (id,_,_,_) -> id) bindings) + and loc = Array.of_list (List.map (fun (_,loc,_,_) -> loc) bindings) + and init = Array.of_list (List.map (fun (_,_,init,_) -> init) bindings) + and rhs = Array.of_list (List.map (fun (_,_,_,rhs) -> rhs) bindings) in + let fv = Array.map Lambda.free_variables rhs in + let num_bindings = Array.length id in + let status = Array.make num_bindings Undefined in + let res = ref [] in + let is_unsafe i = match init.(i) with + | Ok _ -> false + | Result.Error _ -> true in + let init_res i = match init.(i) with + | Result.Error _ -> None + | Ok(a,b) -> Some(a,b) in + let rec emit_binding parent i = + match status.(i) with + Defined -> () + | Inprogress _ -> + status.(i) <- Inprogress parent; + let cycle = extract_unsafe_cycle id status init i in + raise(Error(loc.(i), Circular_dependency cycle)) + | Undefined -> + if is_unsafe i then begin + status.(i) <- Inprogress parent; + for j = 0 to num_bindings - 1 do + if Ident.Set.mem id.(j) fv.(i) then emit_binding (Some i) j + done + end; + res := (id.(i), init_res i, rhs.(i)) :: !res; + status.(i) <- Defined in + for i = 0 to num_bindings - 1 do + match status.(i) with + Undefined -> emit_binding None i + | Inprogress _ -> assert false + | Defined -> () + done; + List.rev !res + +(* Generate lambda-code for a reordered list of bindings *) + +let eval_rec_bindings bindings cont = + let rec bind_inits = function + [] -> + bind_strict bindings + | (_id, None, _rhs) :: rem -> + bind_inits rem + | (id, Some(loc, shape), _rhs) :: rem -> + Llet(Strict, Pgenval, id, + Lapply{ap_should_be_tailcall=false; + ap_loc=Location.none; + ap_func=mod_prim "init_mod"; + ap_args=[loc; shape]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise}, + bind_inits rem) + and bind_strict = function + [] -> + patch_forwards bindings + | (id, None, rhs) :: rem -> + Llet(Strict, Pgenval, id, rhs, bind_strict rem) + | (_id, Some _, _rhs) :: rem -> + bind_strict rem + and patch_forwards = function + [] -> + cont + | (_id, None, _rhs) :: rem -> + patch_forwards rem + | (id, Some(_loc, shape), rhs) :: rem -> + Lsequence(Lapply{ap_should_be_tailcall=false; + ap_loc=Location.none; + ap_func=mod_prim "update_mod"; + ap_args=[shape; Lvar id; rhs]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise}, + patch_forwards rem) + in + bind_inits bindings + +let compile_recmodule compile_rhs bindings cont = + eval_rec_bindings + (reorder_rec_bindings + (List.map + (fun {mb_id=id; mb_expr=modl; mb_loc=loc; _} -> + (id, modl.mod_loc, init_shape id modl, compile_rhs id modl loc)) + bindings)) + cont + +(* Code to translate class entries in a structure *) + +let transl_class_bindings cl_list = + let ids = List.map (fun (ci, _) -> ci.ci_id_class) cl_list in + (ids, + List.map + (fun ({ci_id_class=id; ci_expr=cl; ci_virt=vf}, meths) -> + (id, transl_class ids id meths cl vf)) + cl_list) + +(* Compile one or more functors, merging curried functors to produce + multi-argument functors. Any [@inline] attribute on a functor that is + merged must be consistent with any other [@inline] attribute(s) on the + functor(s) being merged with. Such an attribute will be placed on the + resulting merged functor. *) + +let merge_inline_attributes attr1 attr2 loc = + match Lambda.merge_inline_attributes attr1 attr2 with + | Some attr -> attr + | None -> raise (Error (loc, Conflicting_inline_attributes)) + +let merge_functors mexp coercion root_path = + let rec merge mexp coercion path acc inline_attribute = + let finished = acc, mexp, path, coercion, inline_attribute in + match mexp.mod_desc with + | Tmod_functor (param, _, _, body) -> + let inline_attribute' = + Translattribute.get_inline_attribute mexp.mod_attributes + in + let arg_coercion, res_coercion = + match coercion with + | Tcoerce_none -> Tcoerce_none, Tcoerce_none + | Tcoerce_functor (arg_coercion, res_coercion) -> + arg_coercion, res_coercion + | _ -> fatal_error "Translmod.merge_functors: bad coercion" + in + let loc = mexp.mod_loc in + let path = functor_path path param in + let inline_attribute = + merge_inline_attributes inline_attribute inline_attribute' loc + in + merge body res_coercion path ((param, loc, arg_coercion) :: acc) + inline_attribute + | _ -> finished + in + merge mexp coercion root_path [] Default_inline + +let rec compile_functor mexp coercion root_path loc = + let functor_params_rev, body, body_path, res_coercion, inline_attribute = + merge_functors mexp coercion root_path + in + assert (List.length functor_params_rev >= 1); (* cf. [transl_module] *) + let params, body = + List.fold_left (fun (params, body) (param, loc, arg_coercion) -> + let param' = Ident.rename param in + let arg = apply_coercion loc Alias arg_coercion (Lvar param') in + let params = (param', Pgenval) :: params in + let body = Llet (Alias, Pgenval, param, arg, body) in + params, body) + ([], transl_module res_coercion body_path body) + functor_params_rev + in + Lfunction { + kind = Curried; + params; + return = Pgenval; + attr = { + inline = inline_attribute; + specialise = Default_specialise; + local = Default_local; + is_a_functor = true; + stub = false; + }; + loc; + body; + } + +(* Compile a module expression *) + +and transl_module cc rootpath mexp = + List.iter (Translattribute.check_attribute_on_module mexp) + mexp.mod_attributes; + let loc = mexp.mod_loc in + match mexp.mod_desc with + | Tmod_ident (path,_) -> + apply_coercion loc Strict cc + (transl_module_path loc mexp.mod_env path) + | Tmod_structure str -> + fst (transl_struct loc [] cc rootpath str) + | Tmod_functor _ -> + oo_wrap mexp.mod_env true (fun () -> + compile_functor mexp cc rootpath loc) () + | Tmod_apply(funct, arg, ccarg) -> + let inlined_attribute, funct = + Translattribute.get_and_remove_inlined_attribute_on_module funct + in + oo_wrap mexp.mod_env true + (apply_coercion loc Strict cc) + (Lapply{ap_should_be_tailcall=false; + ap_loc=loc; + ap_func=transl_module Tcoerce_none None funct; + ap_args=[transl_module ccarg None arg]; + ap_inlined=inlined_attribute; + ap_specialised=Default_specialise}) + | Tmod_constraint(arg, _, _, ccarg) -> + transl_module (compose_coercions cc ccarg) rootpath arg + | Tmod_unpack(arg, _) -> + apply_coercion loc Strict cc (Translcore.transl_exp arg) + +and transl_struct loc fields cc rootpath str = + transl_structure loc fields cc rootpath str.str_final_env str.str_items + +(* The function transl_structure is called by the bytecode compiler. + Some effort is made to compile in top to bottom order, in order to display + warning by increasing locations. *) +and transl_structure loc fields cc rootpath final_env = function + [] -> + let body, size = + match cc with + Tcoerce_none -> + Lprim(Pmakeblock(0, Immutable, None), + List.map (fun id -> Lvar id) (List.rev fields), loc), + List.length fields + | Tcoerce_structure(pos_cc_list, id_pos_list) -> + (* Do not ignore id_pos_list ! *) + (*Format.eprintf "%a@.@[" Includemod.print_coercion cc; + List.iter (fun l -> Format.eprintf "%a@ " Ident.print l) + fields; + Format.eprintf "@]@.";*) + let v = Array.of_list (List.rev fields) in + let get_field pos = + if pos < 0 then lambda_unit + else Lvar v.(pos) + in + let ids = List.fold_right Ident.Set.add fields Ident.Set.empty in + let lam = + Lprim(Pmakeblock(0, Immutable, None), + List.map + (fun (pos, cc) -> + match cc with + Tcoerce_primitive p -> + Translprim.transl_primitive p.pc_loc + p.pc_desc p.pc_env p.pc_type None + | _ -> apply_coercion loc Strict cc (get_field pos)) + pos_cc_list, loc) + and id_pos_list = + List.filter (fun (id,_,_) -> not (Ident.Set.mem id ids)) + id_pos_list + in + wrap_id_pos_list loc id_pos_list get_field lam, + List.length pos_cc_list + | _ -> + fatal_error "Translmod.transl_structure" + in + (* This debugging event provides information regarding the structure + items. It is ignored by the OCaml debugger but is used by + Js_of_ocaml to preserve variable names. *) + (if !Clflags.debug && not !Clflags.native_code then + Levent(body, + {lev_loc = loc; + lev_kind = Lev_pseudo; + lev_repr = None; + lev_env = final_env}) + else + body), + size + | item :: rem -> + match item.str_desc with + | Tstr_eval (expr, _) -> + let body, size = + transl_structure loc fields cc rootpath final_env rem + in + Lsequence(transl_exp expr, body), size + | Tstr_value(rec_flag, pat_expr_list) -> + (* Translate bindings first *) + let mk_lam_let = transl_let rec_flag pat_expr_list in + let ext_fields = rev_let_bound_idents pat_expr_list @ fields in + (* Then, translate remainder of struct *) + let body, size = + transl_structure loc ext_fields cc rootpath final_env rem + in + mk_lam_let body, size + | Tstr_primitive descr -> + record_primitive descr.val_val; + transl_structure loc fields cc rootpath final_env rem + | Tstr_type _ -> + transl_structure loc fields cc rootpath final_env rem + | Tstr_typext(tyext) -> + let ids = List.map (fun ext -> ext.ext_id) tyext.tyext_constructors in + let body, size = + transl_structure loc (List.rev_append ids fields) + cc rootpath final_env rem + in + transl_type_extension item.str_env rootpath tyext body, size + | Tstr_exception ext -> + let id = ext.tyexn_constructor.ext_id in + let path = field_path rootpath id in + let body, size = + transl_structure loc (id :: fields) cc rootpath final_env rem + in + Llet(Strict, Pgenval, id, + transl_extension_constructor item.str_env + path + ext.tyexn_constructor, body), + size + | Tstr_module ({mb_presence=Mp_present} as mb) -> + let id = mb.mb_id in + (* Translate module first *) + let module_body = + transl_module Tcoerce_none (field_path rootpath id) mb.mb_expr + in + let module_body = + Translattribute.add_inline_attribute module_body mb.mb_loc + mb.mb_attributes + in + (* Translate remainder second *) + let body, size = + transl_structure loc (id :: fields) cc rootpath final_env rem + in + let module_body = + Levent (module_body, { + lev_loc = mb.mb_loc; + lev_kind = Lev_module_definition id; + lev_repr = None; + lev_env = Env.empty; + }) + in + Llet(pure_module mb.mb_expr, Pgenval, id, + module_body, + body), size + | Tstr_module {mb_presence=Mp_absent} -> + transl_structure loc fields cc rootpath final_env rem + | Tstr_recmodule bindings -> + let ext_fields = + List.rev_append (List.map (fun mb -> mb.mb_id) bindings) fields + in + let body, size = + transl_structure loc ext_fields cc rootpath final_env rem + in + let lam = + compile_recmodule + (fun id modl loc -> + let module_body = + transl_module Tcoerce_none (field_path rootpath id) modl + in + Levent (module_body, { + lev_loc = loc; + lev_kind = Lev_module_definition id; + lev_repr = None; + lev_env = Env.empty; + })) + bindings + body + in + lam, size + | Tstr_class cl_list -> + let (ids, class_bindings) = transl_class_bindings cl_list in + let body, size = + transl_structure loc (List.rev_append ids fields) + cc rootpath final_env rem + in + Lletrec(class_bindings, body), size + | Tstr_include incl -> + let ids = bound_value_identifiers incl.incl_type in + let modl = incl.incl_mod in + let mid = Ident.create_local "include" in + let rec rebind_idents pos newfields = function + [] -> + transl_structure loc newfields cc rootpath final_env rem + | id :: ids -> + let body, size = + rebind_idents (pos + 1) (id :: newfields) ids + in + Llet(Alias, Pgenval, id, + Lprim(Pfield pos, [Lvar mid], incl.incl_loc), body), + size + in + let body, size = rebind_idents 0 fields ids in + Llet(pure_module modl, Pgenval, mid, + transl_module Tcoerce_none None modl, body), + size + + | Tstr_open od -> + let pure = pure_module od.open_expr in + (* this optimization shouldn't be needed because Simplif would + actually remove the [Llet] when it's not used. + But since [scan_used_globals] runs before Simplif, we need to do + it. *) + begin match od.open_bound_items with + | [] when pure = Alias -> + transl_structure loc fields cc rootpath final_env rem + | _ -> + let ids = bound_value_identifiers od.open_bound_items in + let mid = Ident.create_local "open" in + let rec rebind_idents pos newfields = function + [] -> + transl_structure loc newfields cc rootpath final_env rem + | id :: ids -> + let body, size = + rebind_idents (pos + 1) (id :: newfields) ids + in + Llet(Alias, Pgenval, id, + Lprim(Pfield pos, [Lvar mid], od.open_loc), body), + size + in + let body, size = rebind_idents 0 fields ids in + Llet(pure, Pgenval, mid, + transl_module Tcoerce_none None od.open_expr, body), size + end + | Tstr_modtype _ + | Tstr_class_type _ + | Tstr_attribute _ -> + transl_structure loc fields cc rootpath final_env rem + +(* Update forward declaration in Translcore *) +let _ = + Translcore.transl_module := transl_module + +(* Introduce dependencies on modules referenced only by "external". *) + +let scan_used_globals lam = + let globals = ref Ident.Set.empty in + let rec scan lam = + Lambda.iter_head_constructor scan lam; + match lam with + Lprim ((Pgetglobal id | Psetglobal id), _, _) -> + globals := Ident.Set.add id !globals + | _ -> () + in + scan lam; !globals + +let required_globals ~flambda body = + let globals = scan_used_globals body in + let add_global id req = + if not flambda && Ident.Set.mem id globals then + req + else + Ident.Set.add id req + in + let required = + List.fold_left + (fun acc path -> add_global (Path.head path) acc) + (if flambda then globals else Ident.Set.empty) + (Translprim.get_used_primitives ()) + in + let required = + List.fold_right add_global (Env.get_required_globals ()) required + in + Env.reset_required_globals (); + Translprim.clear_used_primitives (); + required + +(* Compile an implementation *) + +let transl_implementation_flambda module_name (str, cc) = + reset_labels (); + primitive_declarations := []; + Translprim.clear_used_primitives (); + let module_id = Ident.create_persistent module_name in + let body, size = + Translobj.transl_label_init + (fun () -> transl_struct Location.none [] cc + (global_path module_id) str) + in + { module_ident = module_id; + main_module_block_size = size; + required_globals = required_globals ~flambda:true body; + code = body } + +let transl_implementation module_name (str, cc) = + let implementation = + transl_implementation_flambda module_name (str, cc) + in + let code = + Lprim (Psetglobal implementation.module_ident, [implementation.code], + Location.none) + in + { implementation with code } + +(* Build the list of value identifiers defined by a toplevel structure + (excluding primitive declarations). *) + +let rec defined_idents = function + [] -> [] + | item :: rem -> + match item.str_desc with + | Tstr_eval _ -> defined_idents rem + | Tstr_value(_rec_flag, pat_expr_list) -> + let_bound_idents pat_expr_list @ defined_idents rem + | Tstr_primitive _ -> defined_idents rem + | Tstr_type _ -> defined_idents rem + | Tstr_typext tyext -> + List.map (fun ext -> ext.ext_id) tyext.tyext_constructors + @ defined_idents rem + | Tstr_exception ext -> ext.tyexn_constructor.ext_id :: defined_idents rem + | Tstr_module {mb_id; mb_presence=Mp_present} -> mb_id :: defined_idents rem + | Tstr_module {mb_presence=Mp_absent} -> defined_idents rem + | Tstr_recmodule decls -> + List.map (fun mb -> mb.mb_id) decls @ defined_idents rem + | Tstr_modtype _ -> defined_idents rem + | Tstr_open od -> + bound_value_identifiers od.open_bound_items @ defined_idents rem + | Tstr_class cl_list -> + List.map (fun (ci, _) -> ci.ci_id_class) cl_list @ defined_idents rem + | Tstr_class_type _ -> defined_idents rem + | Tstr_include incl -> + bound_value_identifiers incl.incl_type @ defined_idents rem + | Tstr_attribute _ -> defined_idents rem + +(* second level idents (module M = struct ... let id = ... end), + and all sub-levels idents *) +let rec more_idents = function + [] -> [] + | item :: rem -> + match item.str_desc with + | Tstr_eval _ -> more_idents rem + | Tstr_value _ -> more_idents rem + | Tstr_primitive _ -> more_idents rem + | Tstr_type _ -> more_idents rem + | Tstr_typext _ -> more_idents rem + | Tstr_exception _ -> more_idents rem + | Tstr_recmodule _ -> more_idents rem + | Tstr_modtype _ -> more_idents rem + | Tstr_open od -> + let rest = more_idents rem in + begin match od.open_expr.mod_desc with + | Tmod_structure str -> all_idents str.str_items @ rest + | _ -> rest + end + | Tstr_class _ -> more_idents rem + | Tstr_class_type _ -> more_idents rem + | Tstr_include{incl_mod={mod_desc = + Tmod_constraint ({mod_desc = Tmod_structure str}, + _, _, _)}} -> + all_idents str.str_items @ more_idents rem + | Tstr_include _ -> more_idents rem + | Tstr_module + {mb_presence=Mp_present; mb_expr={mod_desc = Tmod_structure str}} + | Tstr_module + {mb_presence=Mp_present; + mb_expr={mod_desc= + Tmod_constraint ({mod_desc = Tmod_structure str}, _, _, _)}} -> + all_idents str.str_items @ more_idents rem + | Tstr_module _ -> more_idents rem + | Tstr_attribute _ -> more_idents rem + +and all_idents = function + [] -> [] + | item :: rem -> + match item.str_desc with + | Tstr_eval _ -> all_idents rem + | Tstr_value(_rec_flag, pat_expr_list) -> + let_bound_idents pat_expr_list @ all_idents rem + | Tstr_primitive _ -> all_idents rem + | Tstr_type _ -> all_idents rem + | Tstr_typext tyext -> + List.map (fun ext -> ext.ext_id) tyext.tyext_constructors + @ all_idents rem + | Tstr_exception ext -> ext.tyexn_constructor.ext_id :: all_idents rem + | Tstr_recmodule decls -> + List.map (fun mb -> mb.mb_id) decls @ all_idents rem + | Tstr_modtype _ -> all_idents rem + | Tstr_open od -> + let rest = all_idents rem in + begin match od.open_expr.mod_desc with + | Tmod_structure str -> + bound_value_identifiers od.open_bound_items + @ all_idents str.str_items + @ rest + | _ -> bound_value_identifiers od.open_bound_items @ rest + end + | Tstr_class cl_list -> + List.map (fun (ci, _) -> ci.ci_id_class) cl_list @ all_idents rem + | Tstr_class_type _ -> all_idents rem + + | Tstr_include{incl_type; incl_mod={mod_desc = + Tmod_constraint ({mod_desc = Tmod_structure str}, + _, _, _)}} -> + bound_value_identifiers incl_type + @ all_idents str.str_items + @ all_idents rem + | Tstr_include incl -> + bound_value_identifiers incl.incl_type @ all_idents rem + + | Tstr_module + {mb_id;mb_presence=Mp_present;mb_expr={mod_desc = Tmod_structure str}} + | Tstr_module + {mb_id;mb_presence=Mp_present; + mb_expr= + {mod_desc = + Tmod_constraint ({mod_desc = Tmod_structure str}, _, _, _)}} -> + mb_id :: all_idents str.str_items @ all_idents rem + | Tstr_module {mb_id;mb_presence=Mp_present} -> mb_id :: all_idents rem + | Tstr_module {mb_presence=Mp_absent} -> all_idents rem + | Tstr_attribute _ -> all_idents rem + + +(* A variant of transl_structure used to compile toplevel structure definitions + for the native-code compiler. Store the defined values in the fields + of the global as soon as they are defined, in order to reduce register + pressure. Also rewrites the defining expressions so that they + refer to earlier fields of the structure through the fields of + the global, not by their names. + "map" is a table from defined idents to (pos in global block, coercion). + "prim" is a list of (pos in global block, primitive declaration). *) + +let transl_store_subst = ref Ident.Map.empty + (** In the native toplevel, this reference is threaded through successive + calls of transl_store_structure *) + +let nat_toplevel_name id = + try match Ident.Map.find id !transl_store_subst with + | Lprim(Pfield pos, [Lprim(Pgetglobal glob, [], _)], _) -> (glob,pos) + | _ -> raise Not_found + with Not_found -> + fatal_error("Translmod.nat_toplevel_name: " ^ Ident.unique_name id) + +let field_of_str loc str = + let ids = Array.of_list (defined_idents str.str_items) in + fun (pos, cc) -> + match cc with + | Tcoerce_primitive { pc_loc; pc_desc; pc_env; pc_type; } -> + Translprim.transl_primitive pc_loc pc_desc pc_env pc_type None + | Tcoerce_alias (env, path, cc) -> + let lam = transl_module_path loc env path in + apply_coercion loc Alias cc lam + | _ -> apply_coercion loc Strict cc (Lvar ids.(pos)) + + +let transl_store_structure glob map prims aliases str = + let no_env_update _ _ env = env in + let rec transl_store rootpath subst cont = function + [] -> + transl_store_subst := subst; + Lambda.subst no_env_update subst cont + | item :: rem -> + match item.str_desc with + | Tstr_eval (expr, _attrs) -> + Lsequence(Lambda.subst no_env_update subst (transl_exp expr), + transl_store rootpath subst cont rem) + | Tstr_value(rec_flag, pat_expr_list) -> + let ids = let_bound_idents pat_expr_list in + let lam = + transl_let rec_flag pat_expr_list + (store_idents Location.none ids) + in + Lsequence(Lambda.subst no_env_update subst lam, + transl_store rootpath + (add_idents false ids subst) cont rem) + | Tstr_primitive descr -> + record_primitive descr.val_val; + transl_store rootpath subst cont rem + | Tstr_type _ -> + transl_store rootpath subst cont rem + | Tstr_typext(tyext) -> + let ids = + List.map (fun ext -> ext.ext_id) tyext.tyext_constructors + in + let lam = + transl_type_extension item.str_env rootpath tyext + (store_idents Location.none ids) + in + Lsequence(Lambda.subst no_env_update subst lam, + transl_store rootpath + (add_idents false ids subst) cont rem) + | Tstr_exception ext -> + let id = ext.tyexn_constructor.ext_id in + let path = field_path rootpath id in + let lam = + transl_extension_constructor item.str_env + path + ext.tyexn_constructor + in + Lsequence(Llet(Strict, Pgenval, id, + Lambda.subst no_env_update subst lam, + store_ident ext.tyexn_constructor.ext_loc id), + transl_store rootpath + (add_ident false id subst) cont rem) + | Tstr_module{mb_id=id;mb_loc=loc;mb_presence=Mp_present; + mb_expr={mod_desc = Tmod_structure str} as mexp; + mb_attributes} -> + List.iter (Translattribute.check_attribute_on_module mexp) + mb_attributes; + let lam = + transl_store (field_path rootpath id) subst + lambda_unit str.str_items + in + (* Careful: see next case *) + let subst = !transl_store_subst in + Lsequence(lam, + Llet(Strict, Pgenval, id, + Lambda.subst no_env_update subst + (Lprim(Pmakeblock(0, Immutable, None), + List.map (fun id -> Lvar id) + (defined_idents str.str_items), loc)), + Lsequence(store_ident loc id, + transl_store rootpath + (add_ident true id subst) + cont rem))) + | Tstr_module{ + mb_id=id;mb_loc=loc;mb_presence=Mp_present; + mb_expr= { + mod_desc = Tmod_constraint ( + {mod_desc = Tmod_structure str} as mexp, _, _, + (Tcoerce_structure (map, _) as _cc))}; + mb_attributes + } -> + (* Format.printf "coerc id %s: %a@." (Ident.unique_name id) + Includemod.print_coercion cc; *) + List.iter (Translattribute.check_attribute_on_module mexp) + mb_attributes; + let lam = + transl_store (field_path rootpath id) subst + lambda_unit str.str_items + in + (* Careful: see next case *) + let subst = !transl_store_subst in + let field = field_of_str loc str in + Lsequence(lam, + Llet(Strict, Pgenval, id, + Lambda.subst no_env_update subst + (Lprim(Pmakeblock(0, Immutable, None), + List.map field map, loc)), + Lsequence(store_ident loc id, + transl_store rootpath + (add_ident true id subst) + cont rem))) + | Tstr_module + {mb_id=id; mb_presence=Mp_present; mb_expr=modl; + mb_loc=loc; mb_attributes} -> + let lam = + Translattribute.add_inline_attribute + (transl_module Tcoerce_none (field_path rootpath id) modl) + loc mb_attributes + in + (* Careful: the module value stored in the global may be different + from the local module value, in case a coercion is applied. + If so, keep using the local module value (id) in the remainder of + the compilation unit (add_ident true returns subst unchanged). + If not, we can use the value from the global + (add_ident true adds id -> Pgetglobal... to subst). *) + Llet(Strict, Pgenval, id, Lambda.subst no_env_update subst lam, + Lsequence(store_ident loc id, + transl_store rootpath (add_ident true id subst) + cont rem)) + | Tstr_module {mb_presence=Mp_absent} -> + transl_store rootpath subst cont rem + | Tstr_recmodule bindings -> + let ids = List.map (fun mb -> mb.mb_id) bindings in + compile_recmodule + (fun id modl _loc -> + Lambda.subst no_env_update subst + (transl_module Tcoerce_none + (field_path rootpath id) modl)) + bindings + (Lsequence(store_idents Location.none ids, + transl_store rootpath (add_idents true ids subst) + cont rem)) + | Tstr_class cl_list -> + let (ids, class_bindings) = transl_class_bindings cl_list in + let lam = + Lletrec(class_bindings, store_idents Location.none ids) + in + Lsequence(Lambda.subst no_env_update subst lam, + transl_store rootpath (add_idents false ids subst) + cont rem) + + | Tstr_include{ + incl_loc=loc; + incl_mod= { + mod_desc = Tmod_constraint ( + ({mod_desc = Tmod_structure str} as mexp), _, _, + (Tcoerce_structure (map, _)))}; + incl_attributes; + incl_type; + } -> + List.iter (Translattribute.check_attribute_on_module mexp) + incl_attributes; + (* Shouldn't we use mod_attributes instead of incl_attributes? + Same question for the Tstr_module cases above, btw. *) + let lam = + transl_store None subst lambda_unit str.str_items + (* It is tempting to pass rootpath instead of None + in order to give a more precise name to exceptions + in the included structured, but this would introduce + a difference of behavior compared to bytecode. *) + in + let subst = !transl_store_subst in + let field = field_of_str loc str in + let ids0 = bound_value_identifiers incl_type in + let rec loop ids args = + match ids, args with + | [], [] -> + transl_store rootpath (add_idents true ids0 subst) + cont rem + | id :: ids, arg :: args -> + Llet(Alias, Pgenval, id, + Lambda.subst no_env_update subst (field arg), + Lsequence(store_ident loc id, + loop ids args)) + | _ -> assert false + in + Lsequence(lam, loop ids0 map) + + + | Tstr_include incl -> + let ids = bound_value_identifiers incl.incl_type in + let modl = incl.incl_mod in + let mid = Ident.create_local "include" in + let loc = incl.incl_loc in + let rec store_idents pos = function + | [] -> + transl_store rootpath (add_idents true ids subst) cont rem + | id :: idl -> + Llet(Alias, Pgenval, id, Lprim(Pfield pos, [Lvar mid], loc), + Lsequence(store_ident loc id, + store_idents (pos + 1) idl)) + in + Llet(Strict, Pgenval, mid, + Lambda.subst no_env_update subst + (transl_module Tcoerce_none None modl), + store_idents 0 ids) + | Tstr_open od -> + begin match od.open_expr.mod_desc with + | Tmod_structure str -> + let lam = + transl_store rootpath subst lambda_unit str.str_items + in + let ids = Array.of_list (defined_idents str.str_items) in + let ids0 = bound_value_identifiers od.open_bound_items in + let subst = !transl_store_subst in + let rec store_idents pos = function + | [] -> transl_store rootpath subst cont rem + | id :: idl -> + Llet(Alias, Pgenval, id, Lvar ids.(pos), + Lsequence(store_ident od.open_loc id, + store_idents (pos + 1) idl)) + in + Lsequence(lam, Lambda.subst no_env_update subst + (store_idents 0 ids0)) + | _ -> + let pure = pure_module od.open_expr in + (* this optimization shouldn't be needed because Simplif would + actually remove the [Llet] when it's not used. + But since [scan_used_globals] runs before Simplif, we need to + do it. *) + match od.open_bound_items with + | [] when pure = Alias -> transl_store rootpath subst cont rem + | _ -> + let ids = bound_value_identifiers od.open_bound_items in + let mid = Ident.create_local "open" in + let loc = od.open_loc in + let rec store_idents pos = function + [] -> + transl_store rootpath (add_idents true ids subst) cont + rem + | id :: idl -> + Llet(Alias, Pgenval, id, Lprim(Pfield pos, [Lvar mid], + loc), + Lsequence(store_ident loc id, + store_idents (pos + 1) idl)) + in + Llet(pure, Pgenval, mid, + Lambda.subst no_env_update subst + (transl_module Tcoerce_none None od.open_expr), + store_idents 0 ids) + end + | Tstr_modtype _ + | Tstr_class_type _ + | Tstr_attribute _ -> + transl_store rootpath subst cont rem + + and store_ident loc id = + try + let (pos, cc) = Ident.find_same id map in + let init_val = apply_coercion loc Alias cc (Lvar id) in + Lprim(Psetfield(pos, Pointer, Root_initialization), + [Lprim(Pgetglobal glob, [], loc); init_val], + loc) + with Not_found -> + fatal_error("Translmod.store_ident: " ^ Ident.unique_name id) + + and store_idents loc idlist = + make_sequence (store_ident loc) idlist + + and add_ident may_coerce id subst = + try + let (pos, cc) = Ident.find_same id map in + match cc with + Tcoerce_none -> + Ident.Map.add id + (Lprim(Pfield pos, + [Lprim(Pgetglobal glob, [], Location.none)], + Location.none)) + subst + | _ -> + if may_coerce then subst else assert false + with Not_found -> + assert false + + and add_idents may_coerce idlist subst = + List.fold_right (add_ident may_coerce) idlist subst + + and store_primitive (pos, prim) cont = + Lsequence(Lprim(Psetfield(pos, Pointer, Root_initialization), + [Lprim(Pgetglobal glob, [], Location.none); + Translprim.transl_primitive Location.none + prim.pc_desc prim.pc_env prim.pc_type None], + Location.none), + cont) + + and store_alias (pos, env, path, cc) = + let path_lam = transl_module_path Location.none env path in + let init_val = apply_coercion Location.none Strict cc path_lam in + Lprim(Psetfield(pos, Pointer, Root_initialization), + [Lprim(Pgetglobal glob, [], Location.none); + init_val], + Location.none) + in + let aliases = make_sequence store_alias aliases in + List.fold_right store_primitive prims + (transl_store (global_path glob) !transl_store_subst aliases str) + +(* Transform a coercion and the list of value identifiers defined by + a toplevel structure into a table [id -> (pos, coercion)], + with [pos] being the position in the global block where the value of + [id] must be stored, and [coercion] the coercion to be applied to it. + A given identifier may appear several times + in the coercion (if it occurs several times in the signature); remember + to assign it the position of its last occurrence. + Identifiers that are not exported are assigned positions at the + end of the block (beyond the positions of all exported idents). + Also compute the total size of the global block, + and the list of all primitives exported as values. *) + +let build_ident_map restr idlist more_ids = + let rec natural_map pos map prims aliases = function + | [] -> + (map, prims, aliases, pos) + | id :: rem -> + natural_map (pos+1) + (Ident.add id (pos, Tcoerce_none) map) prims aliases rem + in + let (map, prims, aliases, pos) = + match restr with + | Tcoerce_none -> + natural_map 0 Ident.empty [] [] idlist + | Tcoerce_structure (pos_cc_list, _id_pos_list) -> + (* ignore _id_pos_list as the ids are already bound *) + let idarray = Array.of_list idlist in + let rec export_map pos map prims aliases undef = function + | [] -> + natural_map pos map prims aliases undef + | (_source_pos, Tcoerce_primitive p) :: rem -> + export_map (pos + 1) map + ((pos, p) :: prims) aliases undef rem + | (_source_pos, Tcoerce_alias(env, path, cc)) :: rem -> + export_map (pos + 1) map prims + ((pos, env, path, cc) :: aliases) undef rem + | (source_pos, cc) :: rem -> + let id = idarray.(source_pos) in + export_map (pos + 1) (Ident.add id (pos, cc) map) + prims aliases (list_remove id undef) rem + in + export_map 0 Ident.empty [] [] idlist pos_cc_list + | _ -> + fatal_error "Translmod.build_ident_map" + in + natural_map pos map prims aliases more_ids + +(* Compile an implementation using transl_store_structure + (for the native-code compiler). *) + +let transl_store_gen module_name ({ str_items = str }, restr) topl = + reset_labels (); + primitive_declarations := []; + Translprim.clear_used_primitives (); + let module_id = Ident.create_persistent module_name in + let (map, prims, aliases, size) = + build_ident_map restr (defined_idents str) (more_idents str) in + let f = function + | [ { str_desc = Tstr_eval (expr, _attrs) } ] when topl -> + assert (size = 0); + Lambda.subst (fun _ _ env -> env) !transl_store_subst (transl_exp expr) + | str -> transl_store_structure module_id map prims aliases str + in + transl_store_label_init module_id size f str + (*size, transl_label_init (transl_store_structure module_id map prims str)*) + +let transl_store_phrases module_name str = + transl_store_gen module_name (str,Tcoerce_none) true + +let transl_store_implementation module_name (str, restr) = + let s = !transl_store_subst in + transl_store_subst := Ident.Map.empty; + let (i, code) = transl_store_gen module_name (str, restr) false in + transl_store_subst := s; + { Lambda.main_module_block_size = i; + code; + (* module_ident is not used by closure, but this allow to share + the type with the flambda version *) + module_ident = Ident.create_persistent module_name; + required_globals = required_globals ~flambda:true code } + +(* Compile a toplevel phrase *) + +let toploop_ident = Ident.create_persistent "Toploop" +let toploop_getvalue_pos = 0 (* position of getvalue in module Toploop *) +let toploop_setvalue_pos = 1 (* position of setvalue in module Toploop *) + +let aliased_idents = ref Ident.empty + +let set_toplevel_unique_name id = + aliased_idents := + Ident.add id (Ident.unique_toplevel_name id) !aliased_idents + +let toplevel_name id = + try Ident.find_same id !aliased_idents + with Not_found -> Ident.name id + +let toploop_getvalue id = + Lapply{ap_should_be_tailcall=false; + ap_loc=Location.none; + ap_func=Lprim(Pfield toploop_getvalue_pos, + [Lprim(Pgetglobal toploop_ident, [], Location.none)], + Location.none); + ap_args=[Lconst(Const_base(Const_string (toplevel_name id, None)))]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise} + +let toploop_setvalue id lam = + Lapply{ap_should_be_tailcall=false; + ap_loc=Location.none; + ap_func=Lprim(Pfield toploop_setvalue_pos, + [Lprim(Pgetglobal toploop_ident, [], Location.none)], + Location.none); + ap_args=[Lconst(Const_base(Const_string (toplevel_name id, None))); + lam]; + ap_inlined=Default_inline; + ap_specialised=Default_specialise} + +let toploop_setvalue_id id = toploop_setvalue id (Lvar id) + +let close_toplevel_term (lam, ()) = + Ident.Set.fold (fun id l -> Llet(Strict, Pgenval, id, + toploop_getvalue id, l)) + (free_variables lam) lam + +let transl_toplevel_item item = + match item.str_desc with + Tstr_eval (expr, _) + | Tstr_value(Nonrecursive, + [{vb_pat = {pat_desc=Tpat_any};vb_expr = expr}]) -> + (* special compilation for toplevel "let _ = expr", so + that Toploop can display the result of the expression. + Otherwise, the normal compilation would result + in a Lsequence returning unit. *) + transl_exp expr + | Tstr_value(rec_flag, pat_expr_list) -> + let idents = let_bound_idents pat_expr_list in + transl_let rec_flag pat_expr_list + (make_sequence toploop_setvalue_id idents) + | Tstr_typext(tyext) -> + let idents = + List.map (fun ext -> ext.ext_id) tyext.tyext_constructors + in + (* we need to use unique name in case of multiple + definitions of the same extension constructor in the toplevel *) + List.iter set_toplevel_unique_name idents; + transl_type_extension item.str_env None tyext + (make_sequence toploop_setvalue_id idents) + | Tstr_exception ext -> + set_toplevel_unique_name ext.tyexn_constructor.ext_id; + toploop_setvalue ext.tyexn_constructor.ext_id + (transl_extension_constructor item.str_env None ext.tyexn_constructor) + | Tstr_module {mb_id=id; mb_presence=Mp_present; mb_expr=modl} -> + (* we need to use the unique name for the module because of issues + with "open" (PR#8133) *) + set_toplevel_unique_name id; + let lam = transl_module Tcoerce_none (Some(Pident id)) modl in + toploop_setvalue id lam + | Tstr_recmodule bindings -> + let idents = List.map (fun mb -> mb.mb_id) bindings in + compile_recmodule + (fun id modl _loc -> transl_module Tcoerce_none (Some(Pident id)) modl) + bindings + (make_sequence toploop_setvalue_id idents) + | Tstr_class cl_list -> + (* we need to use unique names for the classes because there might + be a value named identically *) + let (ids, class_bindings) = transl_class_bindings cl_list in + List.iter set_toplevel_unique_name ids; + Lletrec(class_bindings, make_sequence toploop_setvalue_id ids) + | Tstr_include incl -> + let ids = bound_value_identifiers incl.incl_type in + let modl = incl.incl_mod in + let mid = Ident.create_local "include" in + let rec set_idents pos = function + [] -> + lambda_unit + | id :: ids -> + Lsequence(toploop_setvalue id + (Lprim(Pfield pos, [Lvar mid], Location.none)), + set_idents (pos + 1) ids) in + Llet(Strict, Pgenval, mid, + transl_module Tcoerce_none None modl, set_idents 0 ids) + | Tstr_primitive descr -> + record_primitive descr.val_val; + lambda_unit + | Tstr_open od -> + let pure = pure_module od.open_expr in + (* this optimization shouldn't be needed because Simplif would + actually remove the [Llet] when it's not used. + But since [scan_used_globals] runs before Simplif, we need to do + it. *) + begin match od.open_bound_items with + | [] when pure = Alias -> lambda_unit + | _ -> + let ids = bound_value_identifiers od.open_bound_items in + let mid = Ident.create_local "open" in + let rec set_idents pos = function + [] -> + lambda_unit + | id :: ids -> + Lsequence(toploop_setvalue id + (Lprim(Pfield pos, [Lvar mid], Location.none)), + set_idents (pos + 1) ids) + in + Llet(pure, Pgenval, mid, + transl_module Tcoerce_none None od.open_expr, set_idents 0 ids) + end + | Tstr_modtype _ + | Tstr_module {mb_presence=Mp_absent} + | Tstr_type _ + | Tstr_class_type _ + | Tstr_attribute _ -> + lambda_unit + +let transl_toplevel_item_and_close itm = + close_toplevel_term + (transl_label_init (fun () -> transl_toplevel_item itm, ())) + +let transl_toplevel_definition str = + reset_labels (); + Translprim.clear_used_primitives (); + make_sequence transl_toplevel_item_and_close str.str_items + +(* Compile the initialization code for a packed library *) + +let get_component = function + None -> Lconst const_unit + | Some id -> Lprim(Pgetglobal id, [], Location.none) + +let transl_package_flambda component_names coercion = + let size = + match coercion with + | Tcoerce_none -> List.length component_names + | Tcoerce_structure (l, _) -> List.length l + | Tcoerce_functor _ + | Tcoerce_primitive _ + | Tcoerce_alias _ -> assert false + in + size, + apply_coercion Location.none Strict coercion + (Lprim(Pmakeblock(0, Immutable, None), + List.map get_component component_names, + Location.none)) + +let transl_package component_names target_name coercion = + let components = + Lprim(Pmakeblock(0, Immutable, None), + List.map get_component component_names, Location.none) in + Lprim(Psetglobal target_name, + [apply_coercion Location.none Strict coercion components], + Location.none) + (* + let components = + match coercion with + Tcoerce_none -> + List.map get_component component_names + | Tcoerce_structure (pos_cc_list, id_pos_list) -> + (* ignore id_pos_list as the ids are already bound *) + let g = Array.of_list component_names in + List.map + (fun (pos, cc) -> apply_coercion Strict cc (get_component g.(pos))) + pos_cc_list + | _ -> + assert false in + Lprim(Psetglobal target_name, [Lprim(Pmakeblock(0, Immutable), components)]) + *) + +let transl_store_package component_names target_name coercion = + let rec make_sequence fn pos arg = + match arg with + [] -> lambda_unit + | hd :: tl -> Lsequence(fn pos hd, make_sequence fn (pos + 1) tl) in + match coercion with + Tcoerce_none -> + (List.length component_names, + make_sequence + (fun pos id -> + Lprim(Psetfield(pos, Pointer, Root_initialization), + [Lprim(Pgetglobal target_name, [], Location.none); + get_component id], + Location.none)) + 0 component_names) + | Tcoerce_structure (pos_cc_list, _id_pos_list) -> + let components = + Lprim(Pmakeblock(0, Immutable, None), + List.map get_component component_names, + Location.none) + in + let blk = Ident.create_local "block" in + (List.length pos_cc_list, + Llet (Strict, Pgenval, blk, + apply_coercion Location.none Strict coercion components, + make_sequence + (fun pos _id -> + Lprim(Psetfield(pos, Pointer, Root_initialization), + [Lprim(Pgetglobal target_name, [], Location.none); + Lprim(Pfield pos, [Lvar blk], Location.none)], + Location.none)) + 0 pos_cc_list)) + (* + (* ignore id_pos_list as the ids are already bound *) + let id = Array.of_list component_names in + (List.length pos_cc_list, + make_sequence + (fun dst (src, cc) -> + Lprim(Psetfield(dst, false), + [Lprim(Pgetglobal target_name, []); + apply_coercion Strict cc (get_component id.(src))])) + 0 pos_cc_list) + *) + | _ -> assert false + +(* Error report *) + +open Format + +let print_cycle ppf cycle = + let print_ident ppf (x,_) = Format.pp_print_string ppf (Ident.name x) in + let pp_sep ppf () = fprintf ppf "@ -> " in + Format.fprintf ppf "%a%a%s" + (Format.pp_print_list ~pp_sep print_ident) cycle + pp_sep () + (Ident.name @@ fst @@ List.hd cycle) +(* we repeat the first element to make the cycle more apparent *) + +let explanation_submsg (id, {reason;loc;subid}) = + let print fmt = + let printer = Format.dprintf fmt (Ident.name id) (Ident.name subid) in + Location.mkloc printer loc in + match reason with + | Unsafe_module_binding -> print "Module %s defines an unsafe module, %s ." + | Unsafe_functor -> print "Module %s defines an unsafe functor, %s ." + | Unsafe_typext -> + print "Module %s defines an unsafe extension constructor, %s ." + | Unsafe_non_function -> print "Module %s defines an unsafe value, %s ." + +let report_error loc = function + | Circular_dependency cycle -> + let[@manual.ref "s-recursive-modules"] chapter, section = 8, 2 in + Location.errorf ~loc ~sub:(List.map explanation_submsg cycle) + "Cannot safely evaluate the definition of the following cycle@ \ + of recursively-defined modules:@ %a.@ \ + There are no safe modules in this cycle@ (see manual section %d.%d)." + print_cycle cycle chapter section + | Conflicting_inline_attributes -> + Location.errorf "@[Conflicting 'inline' attributes@]" + +let () = + Location.register_error_of_exn + (function + | Error (loc, err) -> Some (report_error loc err) + | _ -> + None + ) + +let reset () = + primitive_declarations := []; + transl_store_subst := Ident.Map.empty; + aliased_idents := Ident.empty; + Env.reset_required_globals (); + Translprim.clear_used_primitives () diff --git a/lambda/translmod.mli b/lambda/translmod.mli new file mode 100644 index 0000000000..d0898c769a --- /dev/null +++ b/lambda/translmod.mli @@ -0,0 +1,61 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Translation from typed abstract syntax to lambda terms, + for the module language *) + +open Typedtree +open Lambda + +val transl_implementation: + string -> structure * module_coercion -> Lambda.program +val transl_store_phrases: string -> structure -> int * lambda +val transl_store_implementation: + string -> structure * module_coercion -> Lambda.program + +val transl_implementation_flambda: + string -> structure * module_coercion -> Lambda.program + +val transl_toplevel_definition: structure -> lambda +val transl_package: + Ident.t option list -> Ident.t -> module_coercion -> lambda +val transl_store_package: + Ident.t option list -> Ident.t -> module_coercion -> int * lambda + +val transl_package_flambda: + Ident.t option list -> module_coercion -> int * lambda + +val toplevel_name: Ident.t -> string +val nat_toplevel_name: Ident.t -> Ident.t * int + +val primitive_declarations: Primitive.description list ref + +type unsafe_component = + | Unsafe_module_binding + | Unsafe_functor + | Unsafe_non_function + | Unsafe_typext + +type unsafe_info = { reason:unsafe_component; loc:Location.t; subid:Ident.t } + +type error = + Circular_dependency of (Ident.t * unsafe_info) list +| Conflicting_inline_attributes + +exception Error of Location.t * error + +val report_error: Location.t -> error -> Location.error + +val reset: unit -> unit diff --git a/lambda/translobj.ml b/lambda/translobj.ml new file mode 100644 index 0000000000..ce06353879 --- /dev/null +++ b/lambda/translobj.ml @@ -0,0 +1,199 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, 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 Asttypes +open Lambda + +(* Get oo primitives identifiers *) + +let oo_prim = Lambda.transl_prim "CamlinternalOO" + +(* Share blocks *) + +let consts : (structured_constant, Ident.t) Hashtbl.t = Hashtbl.create 17 + +let share c = + match c with + Const_block (_n, l) when l <> [] -> + begin try + Lvar (Hashtbl.find consts c) + with Not_found -> + let id = Ident.create_local "shared" in + Hashtbl.add consts c id; + Lvar id + end + | _ -> Lconst c + +(* Collect labels *) + +let cache_required = ref false +let method_cache = ref lambda_unit +let method_count = ref 0 +let method_table = ref [] + +let meth_tag s = Lconst(Const_base(Const_int(Btype.hash_variant s))) + +let next_cache tag = + let n = !method_count in + incr method_count; + (tag, [!method_cache; Lconst(Const_base(Const_int n))]) + +let rec is_path = function + Lvar _ | Lprim (Pgetglobal _, [], _) | Lconst _ -> true + | Lprim (Pfield _, [lam], _) -> is_path lam + | Lprim ((Parrayrefu _ | Parrayrefs _), [lam1; lam2], _) -> + is_path lam1 && is_path lam2 + | _ -> false + +let meth obj lab = + let tag = meth_tag lab in + if not (!cache_required && !Clflags.native_code) then (tag, []) else + if not (is_path obj) then next_cache tag else + try + let r = List.assoc obj !method_table in + try + (tag, List.assoc tag !r) + with Not_found -> + let p = next_cache tag in + r := p :: !r; + p + with Not_found -> + let p = next_cache tag in + method_table := (obj, ref [p]) :: !method_table; + p + +let reset_labels () = + Hashtbl.clear consts; + method_count := 0; + method_table := [] + +(* Insert labels *) + +let int n = Lconst (Const_base (Const_int n)) + +let prim_makearray = + Primitive.simple ~name:"caml_make_vect" ~arity:2 ~alloc:true + +(* Also use it for required globals *) +let transl_label_init_general f = + let expr, size = f () in + let expr = + Hashtbl.fold + (fun c id expr -> Llet(Alias, Pgenval, id, Lconst c, expr)) + consts expr + in + (*let expr = + List.fold_right + (fun id expr -> Lsequence(Lprim(Pgetglobal id, [], Location.none), expr)) + (Env.get_required_globals ()) expr + in + Env.reset_required_globals ();*) + reset_labels (); + expr, size + +let transl_label_init_flambda f = + assert(Config.flambda); + let method_cache_id = Ident.create_local "method_cache" in + method_cache := Lvar method_cache_id; + (* Calling f (usually Translmod.transl_struct) requires the + method_cache variable to be initialised to be able to generate + method accesses. *) + let expr, size = f () in + let expr = + if !method_count = 0 then expr + else + Llet (Strict, Pgenval, method_cache_id, + Lprim (Pccall prim_makearray, + [int !method_count; int 0], + Location.none), + expr) + in + transl_label_init_general (fun () -> expr, size) + +let transl_store_label_init glob size f arg = + assert(not Config.flambda); + assert(!Clflags.native_code); + method_cache := Lprim(Pfield size, + [Lprim(Pgetglobal glob, [], Location.none)], + Location.none); + let expr = f arg in + let (size, expr) = + if !method_count = 0 then (size, expr) else + (size+1, + Lsequence( + Lprim(Psetfield(size, Pointer, Root_initialization), + [Lprim(Pgetglobal glob, [], Location.none); + Lprim (Pccall prim_makearray, + [int !method_count; int 0], + Location.none)], + Location.none), + expr)) + in + let lam, size = transl_label_init_general (fun () -> (expr, size)) in + size, lam + +let transl_label_init f = + if !Clflags.native_code then + transl_label_init_flambda f + else + transl_label_init_general f + +(* Share classes *) + +let wrapping = ref false +let top_env = ref Env.empty +let classes = ref [] +let method_ids = ref Ident.Set.empty + +let oo_add_class id = + classes := id :: !classes; + (!top_env, !cache_required) + +let oo_wrap env req f x = + if !wrapping then + if !cache_required then f x else + Misc.protect_refs [Misc.R (cache_required, true)] (fun () -> + f x + ) + else + Misc.protect_refs [Misc.R (wrapping, true); Misc.R (top_env, env)] + (fun () -> + cache_required := req; + classes := []; + method_ids := Ident.Set.empty; + let lambda = f x in + let lambda = + List.fold_left + (fun lambda id -> + Llet(StrictOpt, Pgenval, id, + Lprim(Pmakeblock(0, Mutable, None), + [lambda_unit; lambda_unit; lambda_unit], + Location.none), + lambda)) + lambda !classes + in + lambda + ) + +let reset () = + Hashtbl.clear consts; + cache_required := false; + method_cache := lambda_unit; + method_count := 0; + method_table := []; + wrapping := false; + top_env := Env.empty; + classes := []; + method_ids := Ident.Set.empty diff --git a/lambda/translobj.mli b/lambda/translobj.mli new file mode 100644 index 0000000000..c27053e961 --- /dev/null +++ b/lambda/translobj.mli @@ -0,0 +1,33 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, 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 Lambda + +val oo_prim: string -> lambda + +val share: structured_constant -> lambda +val meth: lambda -> string -> lambda * lambda list + +val reset_labels: unit -> unit +val transl_label_init: (unit -> lambda * 'a) -> lambda * 'a +val transl_store_label_init: + Ident.t -> int -> ('a -> lambda) -> 'a -> int * lambda + +val method_ids: Ident.Set.t ref (* reset when starting a new wrapper *) + +val oo_wrap: Env.t -> bool -> ('a -> lambda) -> 'a -> lambda +val oo_add_class: Ident.t -> Env.t * bool + +val reset: unit -> unit diff --git a/lambda/translprim.ml b/lambda/translprim.ml new file mode 100644 index 0000000000..d56002b70c --- /dev/null +++ b/lambda/translprim.ml @@ -0,0 +1,811 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Translation of primitives *) + +open Misc +open Asttypes +open Primitive +open Types +open Typedtree +open Typeopt +open Lambda + +type error = + | Unknown_builtin_primitive of string + | Wrong_arity_builtin_primitive of string + +exception Error of Location.t * error + +(* Insertion of debugging events *) + +let event_before exp lam = match lam with +| Lstaticraise (_,_) -> lam +| _ -> + if !Clflags.debug && not !Clflags.native_code + then Levent(lam, {lev_loc = exp.exp_loc; + lev_kind = Lev_before; + lev_repr = None; + lev_env = exp.exp_env}) + else lam + +let event_after exp lam = + if !Clflags.debug && not !Clflags.native_code + then Levent(lam, {lev_loc = exp.exp_loc; + lev_kind = Lev_after exp.exp_type; + lev_repr = None; + lev_env = exp.exp_env}) + else lam + +type comparison = + | Equal + | Not_equal + | Less_equal + | Less_than + | Greater_equal + | Greater_than + | Compare + +type comparison_kind = + | Compare_generic + | Compare_ints + | Compare_floats + | Compare_strings + | Compare_bytes + | Compare_nativeints + | Compare_int32s + | Compare_int64s + +type loc_kind = + | Loc_FILE + | Loc_LINE + | Loc_MODULE + | Loc_LOC + | Loc_POS + +type prim = + | Primitive of Lambda.primitive * int + | External of Primitive.description + | Comparison of comparison * comparison_kind + | Raise of Lambda.raise_kind + | Raise_with_backtrace + | Lazy_force + | Loc of loc_kind + | Send + | Send_self + | Send_cache + +let used_primitives = Hashtbl.create 7 +let add_used_primitive loc env path = + match path with + Some (Path.Pdot _ as path) -> + let path = Env.normalize_path_prefix (Some loc) env path in + let unit = Path.head path in + if Ident.global unit && not (Hashtbl.mem used_primitives path) + then Hashtbl.add used_primitives path loc + | _ -> () + +let clear_used_primitives () = Hashtbl.clear used_primitives +let get_used_primitives () = + Hashtbl.fold (fun path _ acc -> path :: acc) used_primitives [] + +let gen_array_kind = + if Config.flat_float_array then Pgenarray else Paddrarray + +let prim_sys_argv = + Primitive.simple ~name:"caml_sys_argv" ~arity:1 ~alloc:true + +let primitives_table = + create_hashtable 57 [ + "%identity", Primitive (Pidentity, 1); + "%bytes_to_string", Primitive (Pbytes_to_string, 1); + "%bytes_of_string", Primitive (Pbytes_of_string, 1); + "%ignore", Primitive (Pignore, 1); + "%revapply", Primitive (Prevapply, 2); + "%apply", Primitive (Pdirapply, 2); + "%loc_LOC", Loc Loc_LOC; + "%loc_FILE", Loc Loc_FILE; + "%loc_LINE", Loc Loc_LINE; + "%loc_POS", Loc Loc_POS; + "%loc_MODULE", Loc Loc_MODULE; + "%field0", Primitive ((Pfield 0), 1); + "%field1", Primitive ((Pfield 1), 1); + "%setfield0", Primitive ((Psetfield(0, Pointer, Assignment)), 2); + "%makeblock", Primitive ((Pmakeblock(0, Immutable, None)), 1); + "%makemutable", Primitive ((Pmakeblock(0, Mutable, None)), 1); + "%raise", Raise Raise_regular; + "%reraise", Raise Raise_reraise; + "%raise_notrace", Raise Raise_notrace; + "%raise_with_backtrace", Raise_with_backtrace; + "%sequand", Primitive (Psequand, 2); + "%sequor", Primitive (Psequor, 2); + "%boolnot", Primitive (Pnot, 1); + "%big_endian", Primitive ((Pctconst Big_endian), 1); + "%backend_type", Primitive ((Pctconst Backend_type), 1); + "%word_size", Primitive ((Pctconst Word_size), 1); + "%int_size", Primitive ((Pctconst Int_size), 1); + "%max_wosize", Primitive ((Pctconst Max_wosize), 1); + "%ostype_unix", Primitive ((Pctconst Ostype_unix), 1); + "%ostype_win32", Primitive ((Pctconst Ostype_win32), 1); + "%ostype_cygwin", Primitive ((Pctconst Ostype_cygwin), 1); + "%negint", Primitive (Pnegint, 1); + "%succint", Primitive ((Poffsetint 1), 1); + "%predint", Primitive ((Poffsetint(-1)), 1); + "%addint", Primitive (Paddint, 2); + "%subint", Primitive (Psubint, 2); + "%mulint", Primitive (Pmulint, 2); + "%divint", Primitive ((Pdivint Safe), 2); + "%modint", Primitive ((Pmodint Safe), 2); + "%andint", Primitive (Pandint, 2); + "%orint", Primitive (Porint, 2); + "%xorint", Primitive (Pxorint, 2); + "%lslint", Primitive (Plslint, 2); + "%lsrint", Primitive (Plsrint, 2); + "%asrint", Primitive (Pasrint, 2); + "%eq", Primitive ((Pintcomp Ceq), 2); + "%noteq", Primitive ((Pintcomp Cne), 2); + "%ltint", Primitive ((Pintcomp Clt), 2); + "%leint", Primitive ((Pintcomp Cle), 2); + "%gtint", Primitive ((Pintcomp Cgt), 2); + "%geint", Primitive ((Pintcomp Cge), 2); + "%incr", Primitive ((Poffsetref(1)), 1); + "%decr", Primitive ((Poffsetref(-1)), 1); + "%intoffloat", Primitive (Pintoffloat, 1); + "%floatofint", Primitive (Pfloatofint, 1); + "%negfloat", Primitive (Pnegfloat, 1); + "%absfloat", Primitive (Pabsfloat, 1); + "%addfloat", Primitive (Paddfloat, 2); + "%subfloat", Primitive (Psubfloat, 2); + "%mulfloat", Primitive (Pmulfloat, 2); + "%divfloat", Primitive (Pdivfloat, 2); + "%eqfloat", Primitive ((Pfloatcomp CFeq), 2); + "%noteqfloat", Primitive ((Pfloatcomp CFneq), 2); + "%ltfloat", Primitive ((Pfloatcomp CFlt), 2); + "%lefloat", Primitive ((Pfloatcomp CFle), 2); + "%gtfloat", Primitive ((Pfloatcomp CFgt), 2); + "%gefloat", Primitive ((Pfloatcomp CFge), 2); + "%string_length", Primitive (Pstringlength, 1); + "%string_safe_get", Primitive (Pstringrefs, 2); + "%string_safe_set", Primitive (Pbytessets, 3); + "%string_unsafe_get", Primitive (Pstringrefu, 2); + "%string_unsafe_set", Primitive (Pbytessetu, 3); + "%bytes_length", Primitive (Pbyteslength, 1); + "%bytes_safe_get", Primitive (Pbytesrefs, 2); + "%bytes_safe_set", Primitive (Pbytessets, 3); + "%bytes_unsafe_get", Primitive (Pbytesrefu, 2); + "%bytes_unsafe_set", Primitive (Pbytessetu, 3); + "%array_length", Primitive ((Parraylength gen_array_kind), 1); + "%array_safe_get", Primitive ((Parrayrefs gen_array_kind), 2); + "%array_safe_set", Primitive ((Parraysets gen_array_kind), 3); + "%array_unsafe_get", Primitive ((Parrayrefu gen_array_kind), 2); + "%array_unsafe_set", Primitive ((Parraysetu gen_array_kind), 3); + "%obj_size", Primitive ((Parraylength gen_array_kind), 1); + "%obj_field", Primitive ((Parrayrefu gen_array_kind), 2); + "%obj_set_field", Primitive ((Parraysetu gen_array_kind), 3); + "%floatarray_length", Primitive ((Parraylength Pfloatarray), 1); + "%floatarray_safe_get", Primitive ((Parrayrefs Pfloatarray), 2); + "%floatarray_safe_set", Primitive ((Parraysets Pfloatarray), 3); + "%floatarray_unsafe_get", Primitive ((Parrayrefu Pfloatarray), 2); + "%floatarray_unsafe_set", Primitive ((Parraysetu Pfloatarray), 3); + "%obj_is_int", Primitive (Pisint, 1); + "%lazy_force", Lazy_force; + "%nativeint_of_int", Primitive ((Pbintofint Pnativeint), 1); + "%nativeint_to_int", Primitive ((Pintofbint Pnativeint), 1); + "%nativeint_neg", Primitive ((Pnegbint Pnativeint), 1); + "%nativeint_add", Primitive ((Paddbint Pnativeint), 2); + "%nativeint_sub", Primitive ((Psubbint Pnativeint), 2); + "%nativeint_mul", Primitive ((Pmulbint Pnativeint), 2); + "%nativeint_div", + Primitive ((Pdivbint { size = Pnativeint; is_safe = Safe }), 2); + "%nativeint_mod", + Primitive ((Pmodbint { size = Pnativeint; is_safe = Safe }), 2); + "%nativeint_and", Primitive ((Pandbint Pnativeint), 2); + "%nativeint_or", Primitive ( (Porbint Pnativeint), 2); + "%nativeint_xor", Primitive ((Pxorbint Pnativeint), 2); + "%nativeint_lsl", Primitive ((Plslbint Pnativeint), 2); + "%nativeint_lsr", Primitive ((Plsrbint Pnativeint), 2); + "%nativeint_asr", Primitive ((Pasrbint Pnativeint), 2); + "%int32_of_int", Primitive ((Pbintofint Pint32), 1); + "%int32_to_int", Primitive ((Pintofbint Pint32), 1); + "%int32_neg", Primitive ((Pnegbint Pint32), 1); + "%int32_add", Primitive ((Paddbint Pint32), 2); + "%int32_sub", Primitive ((Psubbint Pint32), 2); + "%int32_mul", Primitive ((Pmulbint Pint32), 2); + "%int32_div", Primitive ((Pdivbint { size = Pint32; is_safe = Safe }), 2); + "%int32_mod", Primitive ((Pmodbint { size = Pint32; is_safe = Safe }), 2); + "%int32_and", Primitive ((Pandbint Pint32), 2); + "%int32_or", Primitive ( (Porbint Pint32), 2); + "%int32_xor", Primitive ((Pxorbint Pint32), 2); + "%int32_lsl", Primitive ((Plslbint Pint32), 2); + "%int32_lsr", Primitive ((Plsrbint Pint32), 2); + "%int32_asr", Primitive ((Pasrbint Pint32), 2); + "%int64_of_int", Primitive ((Pbintofint Pint64), 1); + "%int64_to_int", Primitive ((Pintofbint Pint64), 1); + "%int64_neg", Primitive ((Pnegbint Pint64), 1); + "%int64_add", Primitive ((Paddbint Pint64), 2); + "%int64_sub", Primitive ((Psubbint Pint64), 2); + "%int64_mul", Primitive ((Pmulbint Pint64), 2); + "%int64_div", Primitive ((Pdivbint { size = Pint64; is_safe = Safe }), 2); + "%int64_mod", Primitive ((Pmodbint { size = Pint64; is_safe = Safe }), 2); + "%int64_and", Primitive ((Pandbint Pint64), 2); + "%int64_or", Primitive ( (Porbint Pint64), 2); + "%int64_xor", Primitive ((Pxorbint Pint64), 2); + "%int64_lsl", Primitive ((Plslbint Pint64), 2); + "%int64_lsr", Primitive ((Plsrbint Pint64), 2); + "%int64_asr", Primitive ((Pasrbint Pint64), 2); + "%nativeint_of_int32", Primitive ((Pcvtbint(Pint32, Pnativeint)), 1); + "%nativeint_to_int32", Primitive ((Pcvtbint(Pnativeint, Pint32)), 1); + "%int64_of_int32", Primitive ((Pcvtbint(Pint32, Pint64)), 1); + "%int64_to_int32", Primitive ((Pcvtbint(Pint64, Pint32)), 1); + "%int64_of_nativeint", Primitive ((Pcvtbint(Pnativeint, Pint64)), 1); + "%int64_to_nativeint", Primitive ((Pcvtbint(Pint64, Pnativeint)), 1); + "%caml_ba_ref_1", + Primitive + ((Pbigarrayref(false, 1, Pbigarray_unknown, Pbigarray_unknown_layout)), + 2); + "%caml_ba_ref_2", + Primitive + ((Pbigarrayref(false, 2, Pbigarray_unknown, Pbigarray_unknown_layout)), + 3); + "%caml_ba_ref_3", + Primitive + ((Pbigarrayref(false, 3, Pbigarray_unknown, Pbigarray_unknown_layout)), + 4); + "%caml_ba_set_1", + Primitive + ((Pbigarrayset(false, 1, Pbigarray_unknown, Pbigarray_unknown_layout)), + 3); + "%caml_ba_set_2", + Primitive + ((Pbigarrayset(false, 2, Pbigarray_unknown, Pbigarray_unknown_layout)), + 4); + "%caml_ba_set_3", + Primitive + ((Pbigarrayset(false, 3, Pbigarray_unknown, Pbigarray_unknown_layout)), + 5); + "%caml_ba_unsafe_ref_1", + Primitive + ((Pbigarrayref(true, 1, Pbigarray_unknown, Pbigarray_unknown_layout)), + 2); + "%caml_ba_unsafe_ref_2", + Primitive + ((Pbigarrayref(true, 2, Pbigarray_unknown, Pbigarray_unknown_layout)), + 3); + "%caml_ba_unsafe_ref_3", + Primitive + ((Pbigarrayref(true, 3, Pbigarray_unknown, Pbigarray_unknown_layout)), + 4); + "%caml_ba_unsafe_set_1", + Primitive + ((Pbigarrayset(true, 1, Pbigarray_unknown, Pbigarray_unknown_layout)), + 3); + "%caml_ba_unsafe_set_2", + Primitive + ((Pbigarrayset(true, 2, Pbigarray_unknown, Pbigarray_unknown_layout)), + 4); + "%caml_ba_unsafe_set_3", + Primitive + ((Pbigarrayset(true, 3, Pbigarray_unknown, Pbigarray_unknown_layout)), + 5); + "%caml_ba_dim_1", Primitive ((Pbigarraydim(1)), 1); + "%caml_ba_dim_2", Primitive ((Pbigarraydim(2)), 1); + "%caml_ba_dim_3", Primitive ((Pbigarraydim(3)), 1); + "%caml_string_get16", Primitive ((Pstring_load_16(false)), 2); + "%caml_string_get16u", Primitive ((Pstring_load_16(true)), 2); + "%caml_string_get32", Primitive ((Pstring_load_32(false)), 2); + "%caml_string_get32u", Primitive ((Pstring_load_32(true)), 2); + "%caml_string_get64", Primitive ((Pstring_load_64(false)), 2); + "%caml_string_get64u", Primitive ((Pstring_load_64(true)), 2); + "%caml_string_set16", Primitive ((Pbytes_set_16(false)), 3); + "%caml_string_set16u", Primitive ((Pbytes_set_16(true)), 3); + "%caml_string_set32", Primitive ((Pbytes_set_32(false)), 3); + "%caml_string_set32u", Primitive ((Pbytes_set_32(true)), 3); + "%caml_string_set64", Primitive ((Pbytes_set_64(false)), 3); + "%caml_string_set64u", Primitive ((Pbytes_set_64(true)), 3); + "%caml_bytes_get16", Primitive ((Pbytes_load_16(false)), 2); + "%caml_bytes_get16u", Primitive ((Pbytes_load_16(true)), 2); + "%caml_bytes_get32", Primitive ((Pbytes_load_32(false)), 2); + "%caml_bytes_get32u", Primitive ((Pbytes_load_32(true)), 2); + "%caml_bytes_get64", Primitive ((Pbytes_load_64(false)), 2); + "%caml_bytes_get64u", Primitive ((Pbytes_load_64(true)), 2); + "%caml_bytes_set16", Primitive ((Pbytes_set_16(false)), 3); + "%caml_bytes_set16u", Primitive ((Pbytes_set_16(true)), 3); + "%caml_bytes_set32", Primitive ((Pbytes_set_32(false)), 3); + "%caml_bytes_set32u", Primitive ((Pbytes_set_32(true)), 3); + "%caml_bytes_set64", Primitive ((Pbytes_set_64(false)), 3); + "%caml_bytes_set64u", Primitive ((Pbytes_set_64(true)), 3); + "%caml_bigstring_get16", Primitive ((Pbigstring_load_16(false)), 2); + "%caml_bigstring_get16u", Primitive ((Pbigstring_load_16(true)), 2); + "%caml_bigstring_get32", Primitive ((Pbigstring_load_32(false)), 2); + "%caml_bigstring_get32u", Primitive ((Pbigstring_load_32(true)), 2); + "%caml_bigstring_get64", Primitive ((Pbigstring_load_64(false)), 2); + "%caml_bigstring_get64u", Primitive ((Pbigstring_load_64(true)), 2); + "%caml_bigstring_set16", Primitive ((Pbigstring_set_16(false)), 3); + "%caml_bigstring_set16u", Primitive ((Pbigstring_set_16(true)), 3); + "%caml_bigstring_set32", Primitive ((Pbigstring_set_32(false)), 3); + "%caml_bigstring_set32u", Primitive ((Pbigstring_set_32(true)), 3); + "%caml_bigstring_set64", Primitive ((Pbigstring_set_64(false)), 3); + "%caml_bigstring_set64u", Primitive ((Pbigstring_set_64(true)), 3); + "%bswap16", Primitive (Pbswap16, 1); + "%bswap_int32", Primitive ((Pbbswap(Pint32)), 1); + "%bswap_int64", Primitive ((Pbbswap(Pint64)), 1); + "%bswap_native", Primitive ((Pbbswap(Pnativeint)), 1); + "%int_as_pointer", Primitive (Pint_as_pointer, 1); + "%opaque", Primitive (Popaque, 1); + "%sys_argv", External prim_sys_argv; + "%send", Send; + "%sendself", Send_self; + "%sendcache", Send_cache; + "%equal", Comparison(Equal, Compare_generic); + "%notequal", Comparison(Not_equal, Compare_generic); + "%lessequal", Comparison(Less_equal, Compare_generic); + "%lessthan", Comparison(Less_than, Compare_generic); + "%greaterequal", Comparison(Greater_equal, Compare_generic); + "%greaterthan", Comparison(Greater_than, Compare_generic); + "%compare", Comparison(Compare, Compare_generic); + ] + + +let lookup_primitive loc p = + match Hashtbl.find primitives_table p.prim_name with + | prim -> prim + | exception Not_found -> + if String.length p.prim_name > 0 && p.prim_name.[0] = '%' then + raise(Error(loc, Unknown_builtin_primitive p.prim_name)); + External p + +let lookup_primitive_and_mark_used loc p env path = + match lookup_primitive loc p with + | External _ as e -> add_used_primitive loc env path; e + | x -> x + +let simplify_constant_constructor = function + | Equal -> true + | Not_equal -> true + | Less_equal -> false + | Less_than -> false + | Greater_equal -> false + | Greater_than -> false + | Compare -> false + +(* The following function computes the greatest lower bound in the + semilattice of array kinds: + gen + / \ + addr float + | + int + Note that the GLB is not guaranteed to exist, in which case we return + our first argument instead of raising a fatal error because, although + it cannot happen in a well-typed program, (ab)use of Obj.magic can + probably trigger it. +*) +let glb_array_type t1 t2 = + match t1, t2 with + | Pfloatarray, (Paddrarray | Pintarray) + | (Paddrarray | Pintarray), Pfloatarray -> t1 + + | Pgenarray, x | x, Pgenarray -> x + | Paddrarray, x | x, Paddrarray -> x + | Pintarray, Pintarray -> Pintarray + | Pfloatarray, Pfloatarray -> Pfloatarray + +(* Specialize a primitive from available type information. *) + +let specialize_primitive env ty ~has_constant_constructor prim = + let param_tys = + match is_function_type env ty with + | None -> [] + | Some (p1, rhs) -> + match is_function_type env rhs with + | None -> [p1] + | Some (p2, _) -> [p1;p2] + in + match prim, param_tys with + | Primitive (Psetfield(n, Pointer, init), arity), [_; p2] -> begin + match maybe_pointer_type env p2 with + | Pointer -> None + | Immediate -> Some (Primitive (Psetfield(n, Immediate, init), arity)) + end + | Primitive (Parraylength t, arity), [p] -> begin + let array_type = glb_array_type t (array_type_kind env p) in + if t = array_type then None + else Some (Primitive (Parraylength array_type, arity)) + end + | Primitive (Parrayrefu t, arity), p1 :: _ -> begin + let array_type = glb_array_type t (array_type_kind env p1) in + if t = array_type then None + else Some (Primitive (Parrayrefu array_type, arity)) + end + | Primitive (Parraysetu t, arity), p1 :: _ -> begin + let array_type = glb_array_type t (array_type_kind env p1) in + if t = array_type then None + else Some (Primitive (Parraysetu array_type, arity)) + end + | Primitive (Parrayrefs t, arity), p1 :: _ -> begin + let array_type = glb_array_type t (array_type_kind env p1) in + if t = array_type then None + else Some (Primitive (Parrayrefs array_type, arity)) + end + | Primitive (Parraysets t, arity), p1 :: _ -> begin + let array_type = glb_array_type t (array_type_kind env p1) in + if t = array_type then None + else Some (Primitive (Parraysets array_type, arity)) + end + | Primitive (Pbigarrayref(unsafe, n, Pbigarray_unknown, + Pbigarray_unknown_layout), arity), p1 :: _ -> begin + let (k, l) = bigarray_type_kind_and_layout env p1 in + match k, l with + | Pbigarray_unknown, Pbigarray_unknown_layout -> None + | _, _ -> Some (Primitive (Pbigarrayref(unsafe, n, k, l), arity)) + end + | Primitive (Pbigarrayset(unsafe, n, Pbigarray_unknown, + Pbigarray_unknown_layout), arity), p1 :: _ -> begin + let (k, l) = bigarray_type_kind_and_layout env p1 in + match k, l with + | Pbigarray_unknown, Pbigarray_unknown_layout -> None + | _, _ -> Some (Primitive (Pbigarrayset(unsafe, n, k, l), arity)) + end + | Primitive (Pmakeblock(tag, mut, None), arity), fields -> begin + let shape = List.map (Typeopt.value_kind env) fields in + let useful = List.exists (fun knd -> knd <> Pgenval) shape in + if useful then Some (Primitive (Pmakeblock(tag, mut, Some shape), arity)) + else None + end + | Comparison(comp, Compare_generic), p1 :: _ -> + if (has_constant_constructor + && simplify_constant_constructor comp) then begin + Some (Comparison(comp, Compare_ints)) + end else if (is_base_type env p1 Predef.path_int + || is_base_type env p1 Predef.path_char + || (maybe_pointer_type env p1 = Immediate)) then begin + Some (Comparison(comp, Compare_ints)) + end else if is_base_type env p1 Predef.path_float then begin + Some (Comparison(comp, Compare_floats)) + end else if is_base_type env p1 Predef.path_string then begin + Some (Comparison(comp, Compare_strings)) + end else if is_base_type env p1 Predef.path_bytes then begin + Some (Comparison(comp, Compare_bytes)) + end else if is_base_type env p1 Predef.path_nativeint then begin + Some (Comparison(comp, Compare_nativeints)) + end else if is_base_type env p1 Predef.path_int32 then begin + Some (Comparison(comp, Compare_int32s)) + end else if is_base_type env p1 Predef.path_int64 then begin + Some (Comparison(comp, Compare_int64s)) + end else begin + None + end + | _ -> None + +let unboxed_compare name native_repr = + Primitive.make ~name ~alloc:false ~native_name:(name^"_unboxed") + ~native_repr_args:[native_repr;native_repr] ~native_repr_res:Untagged_int + +let caml_equal = + Primitive.simple ~name:"caml_equal" ~arity:2 ~alloc:true +let caml_string_equal = + Primitive.simple ~name:"caml_string_equal" ~arity:2 ~alloc:false +let caml_bytes_equal = + Primitive.simple ~name:"caml_bytes_equal" ~arity:2 ~alloc:false +let caml_notequal = + Primitive.simple ~name:"caml_notequal" ~arity:2 ~alloc:true +let caml_string_notequal = + Primitive.simple ~name:"caml_string_notequal" ~arity:2 ~alloc:false +let caml_bytes_notequal = + Primitive.simple ~name:"caml_bytes_notequal" ~arity:2 ~alloc:false +let caml_lessequal = + Primitive.simple ~name:"caml_lessequal" ~arity:2 ~alloc:true +let caml_string_lessequal = + Primitive.simple ~name:"caml_string_lessequal" ~arity:2 ~alloc:false +let caml_bytes_lessequal = + Primitive.simple ~name:"caml_bytes_lessequal" ~arity:2 ~alloc:false +let caml_lessthan = + Primitive.simple ~name:"caml_lessthan" ~arity:2 ~alloc:true +let caml_string_lessthan = + Primitive.simple ~name:"caml_string_lessthan" ~arity:2 ~alloc:false +let caml_bytes_lessthan = + Primitive.simple ~name:"caml_bytes_lessthan" ~arity:2 ~alloc:false +let caml_greaterequal = + Primitive.simple ~name:"caml_greaterequal" ~arity:2 ~alloc:true +let caml_string_greaterequal = + Primitive.simple ~name:"caml_string_greaterequal" ~arity:2 ~alloc:false +let caml_bytes_greaterequal = + Primitive.simple ~name:"caml_bytes_greaterequal" ~arity:2 ~alloc:false +let caml_greaterthan = + Primitive.simple ~name:"caml_greaterthan" ~arity:2 ~alloc:true +let caml_string_greaterthan = + Primitive.simple ~name:"caml_string_greaterthan" ~arity:2 ~alloc: false +let caml_bytes_greaterthan = + Primitive.simple ~name:"caml_bytes_greaterthan" ~arity:2 ~alloc: false +let caml_compare = + Primitive.simple ~name:"caml_compare" ~arity:2 ~alloc:true +let caml_int_compare = + (* Not unboxed since the comparison is done directly on tagged int *) + Primitive.simple ~name:"caml_int_compare" ~arity:2 ~alloc:false +let caml_float_compare = + unboxed_compare "caml_float_compare" Unboxed_float +let caml_string_compare = + Primitive.simple ~name:"caml_string_compare" ~arity:2 ~alloc:false +let caml_bytes_compare = + Primitive.simple ~name:"caml_bytes_compare" ~arity:2 ~alloc:false +let caml_nativeint_compare = + unboxed_compare "caml_nativeint_compare" (Unboxed_integer Pnativeint) +let caml_int32_compare = + unboxed_compare "caml_int32_compare" (Unboxed_integer Pint32) +let caml_int64_compare = + unboxed_compare "caml_int64_compare" (Unboxed_integer Pint64) + +let comparison_primitive comparison comparison_kind = + match comparison, comparison_kind with + | Equal, Compare_generic -> Pccall caml_equal + | Equal, Compare_ints -> Pintcomp Ceq + | Equal, Compare_floats -> Pfloatcomp CFeq + | Equal, Compare_strings -> Pccall caml_string_equal + | Equal, Compare_bytes -> Pccall caml_bytes_equal + | Equal, Compare_nativeints -> Pbintcomp(Pnativeint, Ceq) + | Equal, Compare_int32s -> Pbintcomp(Pint32, Ceq) + | Equal, Compare_int64s -> Pbintcomp(Pint64, Ceq) + | Not_equal, Compare_generic -> Pccall caml_notequal + | Not_equal, Compare_ints -> Pintcomp Cne + | Not_equal, Compare_floats -> Pfloatcomp CFneq + | Not_equal, Compare_strings -> Pccall caml_string_notequal + | Not_equal, Compare_bytes -> Pccall caml_bytes_notequal + | Not_equal, Compare_nativeints -> Pbintcomp(Pnativeint, Cne) + | Not_equal, Compare_int32s -> Pbintcomp(Pint32, Cne) + | Not_equal, Compare_int64s -> Pbintcomp(Pint64, Cne) + | Less_equal, Compare_generic -> Pccall caml_lessequal + | Less_equal, Compare_ints -> Pintcomp Cle + | Less_equal, Compare_floats -> Pfloatcomp CFle + | Less_equal, Compare_strings -> Pccall caml_string_lessequal + | Less_equal, Compare_bytes -> Pccall caml_bytes_lessequal + | Less_equal, Compare_nativeints -> Pbintcomp(Pnativeint, Cle) + | Less_equal, Compare_int32s -> Pbintcomp(Pint32, Cle) + | Less_equal, Compare_int64s -> Pbintcomp(Pint64, Cle) + | Less_than, Compare_generic -> Pccall caml_lessthan + | Less_than, Compare_ints -> Pintcomp Clt + | Less_than, Compare_floats -> Pfloatcomp CFlt + | Less_than, Compare_strings -> Pccall caml_string_lessthan + | Less_than, Compare_bytes -> Pccall caml_bytes_lessthan + | Less_than, Compare_nativeints -> Pbintcomp(Pnativeint, Clt) + | Less_than, Compare_int32s -> Pbintcomp(Pint32, Clt) + | Less_than, Compare_int64s -> Pbintcomp(Pint64, Clt) + | Greater_equal, Compare_generic -> Pccall caml_greaterequal + | Greater_equal, Compare_ints -> Pintcomp Cge + | Greater_equal, Compare_floats -> Pfloatcomp CFge + | Greater_equal, Compare_strings -> Pccall caml_string_greaterequal + | Greater_equal, Compare_bytes -> Pccall caml_bytes_greaterequal + | Greater_equal, Compare_nativeints -> Pbintcomp(Pnativeint, Cge) + | Greater_equal, Compare_int32s -> Pbintcomp(Pint32, Cge) + | Greater_equal, Compare_int64s -> Pbintcomp(Pint64, Cge) + | Greater_than, Compare_generic -> Pccall caml_greaterthan + | Greater_than, Compare_ints -> Pintcomp Cgt + | Greater_than, Compare_floats -> Pfloatcomp CFgt + | Greater_than, Compare_strings -> Pccall caml_string_greaterthan + | Greater_than, Compare_bytes -> Pccall caml_bytes_greaterthan + | Greater_than, Compare_nativeints -> Pbintcomp(Pnativeint, Cgt) + | Greater_than, Compare_int32s -> Pbintcomp(Pint32, Cgt) + | Greater_than, Compare_int64s -> Pbintcomp(Pint64, Cgt) + | Compare, Compare_generic -> Pccall caml_compare + | Compare, Compare_ints -> Pccall caml_int_compare + | Compare, Compare_floats -> Pccall caml_float_compare + | Compare, Compare_strings -> Pccall caml_string_compare + | Compare, Compare_bytes -> Pccall caml_bytes_compare + | Compare, Compare_nativeints -> Pccall caml_nativeint_compare + | Compare, Compare_int32s -> Pccall caml_int32_compare + | Compare, Compare_int64s -> Pccall caml_int64_compare + +let lambda_of_loc kind loc = + let loc_start = loc.Location.loc_start in + let (file, lnum, cnum) = Location.get_pos_info loc_start in + let file = + if Filename.is_relative file then + file + else + Location.rewrite_absolute_path file in + let enum = loc.Location.loc_end.Lexing.pos_cnum - + loc_start.Lexing.pos_cnum + cnum in + match kind with + | Loc_POS -> + Lconst (Const_block (0, [ + Const_immstring file; + Const_base (Const_int lnum); + Const_base (Const_int cnum); + Const_base (Const_int enum); + ])) + | Loc_FILE -> Lconst (Const_immstring file) + | Loc_MODULE -> + let filename = Filename.basename file in + let name = Env.get_unit_name () in + let module_name = if name = "" then "//"^filename^"//" else name in + Lconst (Const_immstring module_name) + | Loc_LOC -> + let loc = Printf.sprintf "File %S, line %d, characters %d-%d" + file lnum cnum enum in + Lconst (Const_immstring loc) + | Loc_LINE -> Lconst (Const_base (Const_int lnum)) + +let caml_restore_raw_backtrace = + Primitive.simple ~name:"caml_restore_raw_backtrace" ~arity:2 ~alloc:false + +let try_ids = Hashtbl.create 8 + +let add_exception_ident id = + Hashtbl.replace try_ids id () + +let remove_exception_ident id = + Hashtbl.remove try_ids id + +let lambda_of_prim prim_name prim loc args arg_exps = + match prim, args with + | Primitive (prim, arity), args when arity = List.length args -> + Lprim(prim, args, loc) + | External prim, args when prim = prim_sys_argv -> + Lprim(Pccall prim, Lconst (Const_pointer 0) :: args, loc) + | External prim, args -> + Lprim(Pccall prim, args, loc) + | Comparison(comp, knd), ([_;_] as args) -> + let prim = comparison_primitive comp knd in + Lprim(prim, args, loc) + | Raise kind, [arg] -> + let kind = + match kind, arg with + | Raise_regular, Lvar argv when Hashtbl.mem try_ids argv -> + Raise_reraise + | _, _ -> + kind + in + let arg = + match arg_exps with + | None -> arg + | Some [arg_exp] -> event_after arg_exp arg + | Some _ -> assert false + in + Lprim(Praise kind, [arg], loc) + | Raise_with_backtrace, [exn; bt] -> + let vexn = Ident.create_local "exn" in + let raise_arg = + match arg_exps with + | None -> Lvar vexn + | Some [exn_exp; _] -> event_after exn_exp (Lvar vexn) + | Some _ -> assert false + in + Llet(Strict, Pgenval, vexn, exn, + Lsequence(Lprim(Pccall caml_restore_raw_backtrace, + [Lvar vexn; bt], + loc), + Lprim(Praise Raise_reraise, [raise_arg], loc))) + | Lazy_force, [arg] -> + Matching.inline_lazy_force arg Location.none + | Loc kind, [] -> + lambda_of_loc kind loc + | Loc kind, [arg] -> + let lam = lambda_of_loc kind loc in + Lprim(Pmakeblock(0, Immutable, None), [lam; arg], loc) + | Send, [obj; meth] -> + Lsend(Public, meth, obj, [], loc) + | Send_self, [obj; meth] -> + Lsend(Self, meth, obj, [], loc) + | Send_cache, [obj; meth; cache; pos] -> + Lsend(Cached, meth, obj, [cache; pos], loc) + | (Raise _ | Raise_with_backtrace + | Lazy_force | Loc _ | Primitive _ | Comparison _ + | Send | Send_self | Send_cache), _ -> + raise(Error(loc, Wrong_arity_builtin_primitive prim_name)) + +let check_primitive_arity loc p = + let prim = lookup_primitive loc p in + let ok = + match prim with + | Primitive (_,arity) -> arity = p.prim_arity + | External _ -> true + | Comparison _ -> p.prim_arity = 2 + | Raise _ -> p.prim_arity = 1 + | Raise_with_backtrace -> p.prim_arity = 2 + | Lazy_force -> p.prim_arity = 1 + | Loc _ -> p.prim_arity = 1 || p.prim_arity = 0 + | Send | Send_self -> p.prim_arity = 2 + | Send_cache -> p.prim_arity = 4 + in + if not ok then raise(Error(loc, Wrong_arity_builtin_primitive p.prim_name)) + +(* Eta-expand a primitive *) + +let transl_primitive loc p env ty path = + let prim = lookup_primitive_and_mark_used loc p env path in + let has_constant_constructor = false in + let prim = + match specialize_primitive env ty ~has_constant_constructor prim with + | None -> prim + | Some prim -> prim + in + let rec make_params n = + if n <= 0 then [] + else (Ident.create_local "prim", Pgenval) :: make_params (n-1) + in + let params = make_params p.prim_arity in + let args = List.map (fun (id, _) -> Lvar id) params in + let body = lambda_of_prim p.prim_name prim loc args None in + match params with + | [] -> body + | _ -> + Lfunction{ kind = Curried; + params; + return = Pgenval; + attr = default_stub_attribute; + loc = loc; + body = body; } + +(* Determine if a primitive is a Pccall or will be turned later into + a C function call that may raise an exception *) +let primitive_is_ccall = function + | Pccall _ | Pstringrefs | Pbytesrefs | Pbytessets | Parrayrefs _ | + Parraysets _ | Pbigarrayref _ | Pbigarrayset _ | Pduprecord _ | Pdirapply | + Prevapply -> true + | _ -> false + +(* Determine if a primitive should be surrounded by an "after" debug event *) +let primitive_needs_event_after = function + | Primitive (prim,_) -> primitive_is_ccall prim + | External _ -> true + | Comparison(comp, knd) -> + primitive_is_ccall (comparison_primitive comp knd) + | Lazy_force | Send | Send_self | Send_cache -> true + | Raise _ | Raise_with_backtrace | Loc _ -> false + +let transl_primitive_application loc p env ty path exp args arg_exps = + let prim = lookup_primitive_and_mark_used loc p env (Some path) in + let has_constant_constructor = + match arg_exps with + | [_; {exp_desc = Texp_construct(_, {cstr_tag = Cstr_constant _}, _)}] + | [{exp_desc = Texp_construct(_, {cstr_tag = Cstr_constant _}, _)}; _] + | [_; {exp_desc = Texp_variant(_, None)}] + | [{exp_desc = Texp_variant(_, None)}; _] -> true + | _ -> false + in + let prim = + match specialize_primitive env ty ~has_constant_constructor prim with + | None -> prim + | Some prim -> prim + in + let lam = lambda_of_prim p.prim_name prim loc args (Some arg_exps) in + let lam = + if primitive_needs_event_after prim then begin + match exp with + | None -> lam + | Some exp -> event_after exp lam + end else begin + lam + end + in + lam + +(* Error report *) + +open Format + +let report_error ppf = function + | Unknown_builtin_primitive prim_name -> + fprintf ppf "Unknown builtin primitive \"%s\"" prim_name + | Wrong_arity_builtin_primitive prim_name -> + fprintf ppf "Wrong arity for builtin primitive \"%s\"" prim_name + +let () = + Location.register_error_of_exn + (function + | Error (loc, err) -> + Some (Location.error_of_printer ~loc report_error err) + | _ -> + None + ) diff --git a/lambda/translprim.mli b/lambda/translprim.mli new file mode 100644 index 0000000000..abf0f7d589 --- /dev/null +++ b/lambda/translprim.mli @@ -0,0 +1,51 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Insertion of debugging events *) + +val event_before : Typedtree.expression -> Lambda.lambda -> Lambda.lambda + +val event_after : Typedtree.expression -> Lambda.lambda -> Lambda.lambda + +(* Translation of primitives *) + +val add_exception_ident : Ident.t -> unit +val remove_exception_ident : Ident.t -> unit + +val clear_used_primitives : unit -> unit +val get_used_primitives: unit -> Path.t list + +val check_primitive_arity : Location.t -> Primitive.description -> unit + +val transl_primitive : + Location.t -> Primitive.description -> Env.t -> + Types.type_expr -> Path.t option -> Lambda.lambda + +val transl_primitive_application : + Location.t -> Primitive.description -> Env.t -> + Types.type_expr -> Path.t -> Typedtree.expression option -> + Lambda.lambda list -> Typedtree.expression list -> Lambda.lambda + +(* Errors *) + +type error = + | Unknown_builtin_primitive of string + | Wrong_arity_builtin_primitive of string + +exception Error of Location.t * error + +open Format + +val report_error : formatter -> error -> unit 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. *) diff --git a/ocamldoc/Makefile.docfiles b/ocamldoc/Makefile.docfiles index a3f668d5bb..9b02742637 100644 --- a/ocamldoc/Makefile.docfiles +++ b/ocamldoc/Makefile.docfiles @@ -32,7 +32,7 @@ DOC_STDLIB_DIRS = stdlib \ otherlibs/$(UNIXLIB) otherlibs/dynlink \ otherlibs/systhreads -DOC_COMPILERLIBS_DIRS= parsing utils typing bytecomp driver +DOC_COMPILERLIBS_DIRS= parsing utils typing bytecomp driver file_formats lambda DOC_ALL_DIRS = $(DOC_COMPILERLIBS) $(DOC_STDLIB_DIRS) diff --git a/ocamltest/Makefile b/ocamltest/Makefile index c3b5148017..64e8a3a009 100644 --- a/ocamltest/Makefile +++ b/ocamltest/Makefile @@ -168,7 +168,7 @@ bytecode_modules := $(o_files) $(cmo_files) native_modules := $(o_files) $(cmx_files) directories := $(addprefix $(ROOTDIR)/,utils bytecomp parsing stdlib \ - compilerlibs) + compilerlibs file_formats) include_directories := $(addprefix -I , $(directories)) diff --git a/ocamltest/ocaml_modifiers.ml b/ocamltest/ocaml_modifiers.ml index 071e35ec2c..cfa4fbcf56 100644 --- a/ocamltest/ocaml_modifiers.ml +++ b/ocamltest/ocaml_modifiers.ml @@ -98,6 +98,7 @@ let systhreads = let compilerlibs_subdirs = [ "utils"; "parsing"; "toplevel"; "typing"; "bytecomp"; "compilerlibs"; + "file_formats"; "lambda"; ] let add_compiler_subdir subdir = diff --git a/otherlibs/dynlink/.depend b/otherlibs/dynlink/.depend index 0a3555b12a..bbad58081e 100644 --- a/otherlibs/dynlink/.depend +++ b/otherlibs/dynlink/.depend @@ -14,8 +14,7 @@ dynlink_common.cmi : \ dynlink_platform_intf.cmo : \ dynlink_types.cmi \ dynlink_platform_intf.cmi -dynlink_platform_intf.cmi : \ - dynlink_types.cmi +dynlink_platform_intf.cmi : dynlink_types.cmo : \ dynlink_types.cmi dynlink_types.cmi : diff --git a/otherlibs/dynlink/Makefile b/otherlibs/dynlink/Makefile index 39314dec1b..f3c031e37f 100644 --- a/otherlibs/dynlink/Makefile +++ b/otherlibs/dynlink/Makefile @@ -70,8 +70,8 @@ COMPILERLIBS_INTFS=\ parsing/asttypes.mli \ parsing/parsetree.mli \ typing/outcometree.mli \ - bytecomp/cmo_format.mli \ - asmcomp/cmxs_format.mli + file_formats/cmo_format.mli \ + file_formats/cmxs_format.mli # .ml files from compilerlibs that have corresponding .mli files. COMPILERLIBS_SOURCES=\ @@ -103,13 +103,13 @@ COMPILERLIBS_SOURCES=\ typing/subst.ml \ typing/predef.ml \ typing/datarepr.ml \ - typing/cmi_format.ml \ + file_formats/cmi_format.ml \ typing/persistent_env.ml \ typing/env.ml \ - bytecomp/lambda.ml \ + lambda/lambda.ml \ + lambda/runtimedef.ml \ bytecomp/instruct.ml \ bytecomp/opcodes.ml \ - bytecomp/runtimedef.ml \ bytecomp/bytesections.ml \ bytecomp/dll.ml \ bytecomp/meta.ml \ diff --git a/otherlibs/dynlink/dune b/otherlibs/dynlink/dune index f06f776463..32a84264a0 100644 --- a/otherlibs/dynlink/dune +++ b/otherlibs/dynlink/dune @@ -12,17 +12,20 @@ ;* * ;************************************************************************** -(library - (name dynlink) - (wrapped false) - (modules dynlink dynlink_compilerlibs dynlink_common dynlink_types - dynlink_platform_intf) - ; the -33 is specific to the hackery done with dune. - (flags (:standard -nostdlib -w -33)) - (modules_without_implementation dynlink) - (libraries ocamlcommon stdlib)) - -(rule - (targets dynlink_compilerlibs.ml) - (action (write-file %{targets} - "(* empty because we are linking with ocamlcommon *)"))) +; mshinwell: Disabled: this needs to build in the same way as the +; Makefile does, with the [Dynlink_compilerlibs] pack. +; +; (library +; (name dynlink) +; (wrapped false) +; (modules dynlink dynlink_compilerlibs dynlink_common dynlink_types +; dynlink_platform_intf) +; ; the -33 is specific to the hackery done with dune. +; (flags (:standard -nostdlib -w -33)) +; (modules_without_implementation dynlink) +; (libraries ocamlcommon stdlib)) +; +; (rule +; (targets dynlink_compilerlibs.ml) +; (action (write-file %{targets} +; "(* empty because we are linking with ocamlcommon *)"))) diff --git a/testsuite/tools/Makefile b/testsuite/tools/Makefile index 9027bf6195..6e6370d75f 100644 --- a/testsuite/tools/Makefile +++ b/testsuite/tools/Makefile @@ -30,6 +30,7 @@ codegen_INCLUDES=\ -I $(OTOPDIR)/typing \ -I $(OTOPDIR)/middle_end \ -I $(OTOPDIR)/bytecomp \ + -I $(OTOPDIR)/lambda \ -I $(OTOPDIR)/asmcomp codegen_OTHEROBJECTS=\ diff --git a/tools/.depend b/tools/.depend index 52c8ff55cb..0a471a1b46 100644 --- a/tools/.depend +++ b/tools/.depend @@ -54,7 +54,7 @@ cmt2annot.cmo : \ ../typing/ident.cmi \ ../typing/envaux.cmi \ ../typing/env.cmi \ - ../typing/cmt_format.cmi \ + ../file_formats/cmt_format.cmi \ ../parsing/asttypes.cmi \ ../typing/annot.cmi cmt2annot.cmx : \ @@ -71,7 +71,7 @@ cmt2annot.cmx : \ ../typing/ident.cmx \ ../typing/envaux.cmx \ ../typing/env.cmx \ - ../typing/cmt_format.cmx \ + ../file_formats/cmt_format.cmx \ ../parsing/asttypes.cmi \ ../typing/annot.cmi cvt_emit.cmo : @@ -81,11 +81,11 @@ dumpobj.cmo : \ opnames.cmo \ ../bytecomp/opcodes.cmi \ ../parsing/location.cmi \ - ../bytecomp/lambda.cmi \ + ../lambda/lambda.cmi \ ../bytecomp/instruct.cmi \ ../typing/ident.cmi \ ../utils/config.cmi \ - ../bytecomp/cmo_format.cmi \ + ../file_formats/cmo_format.cmi \ ../bytecomp/bytesections.cmi \ ../parsing/asttypes.cmi dumpobj.cmx : \ @@ -93,11 +93,11 @@ dumpobj.cmx : \ opnames.cmx \ ../bytecomp/opcodes.cmx \ ../parsing/location.cmx \ - ../bytecomp/lambda.cmx \ + ../lambda/lambda.cmx \ ../bytecomp/instruct.cmx \ ../typing/ident.cmx \ ../utils/config.cmx \ - ../bytecomp/cmo_format.cmi \ + ../file_formats/cmo_format.cmi \ ../bytecomp/bytesections.cmx \ ../parsing/asttypes.cmi eqparsetree.cmo : \ @@ -132,35 +132,35 @@ make_opcodes.cmo : make_opcodes.cmx : objinfo.cmo : \ ../bytecomp/symtable.cmi \ - ../middle_end/base_types/symbol.cmi \ - ../asmcomp/printclambda.cmi \ + ../middle_end/symbol.cmi \ + ../middle_end/printclambda.cmi \ ../utils/misc.cmi \ - ../middle_end/base_types/linkage_name.cmi \ + ../middle_end/linkage_name.cmi \ ../typing/ident.cmi \ - ../asmcomp/export_info.cmi \ + ../middle_end/flambda/export_info.cmi \ ../utils/config.cmi \ - ../middle_end/base_types/compilation_unit.cmi \ - ../asmcomp/cmxs_format.cmi \ - ../asmcomp/cmx_format.cmi \ - ../typing/cmt_format.cmi \ - ../bytecomp/cmo_format.cmi \ - ../typing/cmi_format.cmi \ + ../middle_end/compilation_unit.cmi \ + ../file_formats/cmxs_format.cmi \ + ../file_formats/cmx_format.cmi \ + ../file_formats/cmt_format.cmi \ + ../file_formats/cmo_format.cmi \ + ../file_formats/cmi_format.cmi \ ../bytecomp/bytesections.cmi objinfo.cmx : \ ../bytecomp/symtable.cmx \ - ../middle_end/base_types/symbol.cmx \ - ../asmcomp/printclambda.cmx \ + ../middle_end/symbol.cmx \ + ../middle_end/printclambda.cmx \ ../utils/misc.cmx \ - ../middle_end/base_types/linkage_name.cmx \ + ../middle_end/linkage_name.cmx \ ../typing/ident.cmx \ - ../asmcomp/export_info.cmx \ + ../middle_end/flambda/export_info.cmx \ ../utils/config.cmx \ - ../middle_end/base_types/compilation_unit.cmx \ - ../asmcomp/cmxs_format.cmi \ - ../asmcomp/cmx_format.cmi \ - ../typing/cmt_format.cmx \ - ../bytecomp/cmo_format.cmi \ - ../typing/cmi_format.cmx \ + ../middle_end/compilation_unit.cmx \ + ../file_formats/cmxs_format.cmi \ + ../file_formats/cmx_format.cmi \ + ../file_formats/cmt_format.cmx \ + ../file_formats/cmo_format.cmi \ + ../file_formats/cmi_format.cmx \ ../bytecomp/bytesections.cmx ocaml299to3.cmo : ocaml299to3.cmx : @@ -205,11 +205,11 @@ opnames.cmx : primreq.cmo : \ ../utils/misc.cmi \ ../utils/config.cmi \ - ../bytecomp/cmo_format.cmi + ../file_formats/cmo_format.cmi primreq.cmx : \ ../utils/misc.cmx \ ../utils/config.cmx \ - ../bytecomp/cmo_format.cmi + ../file_formats/cmo_format.cmi profiling.cmo : \ profiling.cmi profiling.cmx : \ @@ -218,13 +218,13 @@ profiling.cmi : read_cmt.cmo : \ ../parsing/location.cmi \ ../driver/compmisc.cmi \ - ../typing/cmt_format.cmi \ + ../file_formats/cmt_format.cmi \ cmt2annot.cmo \ ../utils/clflags.cmi read_cmt.cmx : \ ../parsing/location.cmx \ ../driver/compmisc.cmx \ - ../typing/cmt_format.cmx \ + ../file_formats/cmt_format.cmx \ cmt2annot.cmx \ ../utils/clflags.cmx scrapelabels.cmo : diff --git a/tools/Makefile b/tools/Makefile index b078df22f4..afefc4d83c 100644 --- a/tools/Makefile +++ b/tools/Makefile @@ -76,8 +76,10 @@ CAMLC = $(BOOT_OCAMLC) -g -nostdlib -I $(ROOTDIR)/boot \ -use-prims $(ROOTDIR)/runtime/primitives -I $(ROOTDIR) CAMLOPT = $(CAMLRUN) $(ROOTDIR)/ocamlopt -g -nostdlib -I $(ROOTDIR)/stdlib CAMLLEX = $(CAMLRUN) $(ROOTDIR)/boot/ocamllex -INCLUDES = $(addprefix -I $(ROOTDIR)/,utils parsing typing bytecomp asmcomp \ - middle_end middle_end/base_types driver toplevel) +INCLUDES = $(addprefix -I $(ROOTDIR)/,utils parsing typing bytecomp \ + middle_end middle_end/closure middle_end/flambda \ + middle_end/flambda/base_types driver toplevel \ + file_formats lambda) COMPFLAGS = -absname -w +a-4-9-41-42-44-45-48 -strict-sequence -warn-error A \ -safe-string -strict-formats -bin-annot $(INCLUDES) LINKFLAGS = $(INCLUDES) @@ -326,9 +328,6 @@ objinfo_helper$(EXE): objinfo_helper.c $(ROOTDIR)/runtime/caml/s.h OBJINFO=$(ROOTDIR)/compilerlibs/ocamlcommon.cma \ $(ROOTDIR)/compilerlibs/ocamlbytecomp.cma \ $(ROOTDIR)/compilerlibs/ocamlmiddleend.cma \ - $(ROOTDIR)/asmcomp/backend_var.cmo \ - $(ROOTDIR)/asmcomp/printclambda.cmo \ - $(ROOTDIR)/asmcomp/export_info.cmo \ objinfo.cmo $(call byte_and_opt,ocamlobjinfo,$(OBJINFO),objinfo_helper$(EXE)) @@ -347,9 +346,6 @@ $(call byte_and_opt,primreq,$(primreq),) LINTAPIDIFF=$(ROOTDIR)/compilerlibs/ocamlcommon.cmxa \ $(ROOTDIR)/compilerlibs/ocamlbytecomp.cmxa \ $(ROOTDIR)/compilerlibs/ocamlmiddleend.cmxa \ - $(ROOTDIR)/asmcomp/backend_var.cmx \ - $(ROOTDIR)/asmcomp/printclambda.cmx \ - $(ROOTDIR)/asmcomp/export_info.cmx \ $(ROOTDIR)/otherlibs/str/str.cmxa \ lintapidiff.cmx diff --git a/toplevel/opttoploop.ml b/toplevel/opttoploop.ml index 4c0f0ef627..0d1f739213 100644 --- a/toplevel/opttoploop.ml +++ b/toplevel/opttoploop.ml @@ -251,13 +251,13 @@ let load_lambda ppf ~module_ident ~required_globals lam size = let fn = Filename.chop_extension dll in if not Config.flambda then Asmgen.compile_implementation_clambda - ~toplevel:need_symbol fn ~ppf_dump:ppf + ~toplevel:need_symbol fn ~backend ~ppf_dump:ppf { Lambda.code=slam ; main_module_block_size=size; module_ident; required_globals } else Asmgen.compile_implementation_flambda ~required_globals ~backend ~toplevel:need_symbol fn ~ppf_dump:ppf - (Middle_end.middle_end ~ppf_dump:ppf ~prefixname:"" ~backend ~size + (Flambda_middle_end.middle_end ~ppf_dump:ppf ~prefixname:"" ~backend ~size ~module_ident ~module_initializer:slam ~filename:"toplevel"); Asmlink.call_linker_shared [fn ^ ext_obj] dll; Sys.remove (fn ^ ext_obj); diff --git a/typing/cmi_format.ml b/typing/cmi_format.ml deleted file mode 100644 index a98520a8a6..0000000000 --- a/typing/cmi_format.ml +++ /dev/null @@ -1,111 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Fabrice Le Fessant, INRIA Saclay *) -(* *) -(* Copyright 2012 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 Misc - -type pers_flags = - | Rectypes - | Alerts of alerts - | Opaque - | Unsafe_string - -type error = - | Not_an_interface of filepath - | Wrong_version_interface of filepath * string - | Corrupted_interface of filepath - -exception Error of error - -type cmi_infos = { - cmi_name : Misc.modname; - cmi_sign : Types.signature_item list; - cmi_crcs : crcs; - cmi_flags : pers_flags list; -} - -let input_cmi ic = - let (name, sign) = input_value ic in - let crcs = input_value ic in - let flags = input_value ic in - { - cmi_name = name; - cmi_sign = sign; - cmi_crcs = crcs; - cmi_flags = flags; - } - -let read_cmi filename = - let ic = open_in_bin filename in - try - let buffer = - really_input_string ic (String.length Config.cmi_magic_number) - in - if buffer <> Config.cmi_magic_number then begin - close_in ic; - let pre_len = String.length Config.cmi_magic_number - 3 in - if String.sub buffer 0 pre_len - = String.sub Config.cmi_magic_number 0 pre_len then - begin - let msg = - if buffer < Config.cmi_magic_number then "an older" else "a newer" in - raise (Error (Wrong_version_interface (filename, msg))) - end else begin - raise(Error(Not_an_interface filename)) - end - end; - let cmi = input_cmi ic in - close_in ic; - cmi - with End_of_file | Failure _ -> - close_in ic; - raise(Error(Corrupted_interface(filename))) - | Error e -> - close_in ic; - raise (Error e) - -let output_cmi filename oc cmi = -(* beware: the provided signature must have been substituted for saving *) - output_string oc Config.cmi_magic_number; - output_value oc (cmi.cmi_name, cmi.cmi_sign); - flush oc; - let crc = Digest.file filename in - let crcs = (cmi.cmi_name, Some crc) :: cmi.cmi_crcs in - output_value oc crcs; - output_value oc cmi.cmi_flags; - crc - -(* Error report *) - -open Format - -let report_error ppf = function - | Not_an_interface filename -> - fprintf ppf "%a@ is not a compiled interface" - Location.print_filename filename - | Wrong_version_interface (filename, older_newer) -> - fprintf ppf - "%a@ is not a compiled interface for this version of OCaml.@.\ - It seems to be for %s version of OCaml." - Location.print_filename filename older_newer - | Corrupted_interface filename -> - fprintf ppf "Corrupted compiled interface@ %a" - Location.print_filename filename - -let () = - Location.register_error_of_exn - (function - | Error err -> Some (Location.error_of_printer_file report_error err) - | _ -> None - ) diff --git a/typing/cmi_format.mli b/typing/cmi_format.mli deleted file mode 100644 index d4d665fdf5..0000000000 --- a/typing/cmi_format.mli +++ /dev/null @@ -1,51 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Fabrice Le Fessant, INRIA Saclay *) -(* *) -(* Copyright 2012 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 Misc - -type pers_flags = - | Rectypes - | Alerts of alerts - | Opaque - | Unsafe_string - -type cmi_infos = { - cmi_name : modname; - cmi_sign : Types.signature_item list; - cmi_crcs : crcs; - cmi_flags : pers_flags list; -} - -(* write the magic + the cmi information *) -val output_cmi : string -> out_channel -> cmi_infos -> Digest.t - -(* read the cmi information (the magic is supposed to have already been read) *) -val input_cmi : in_channel -> cmi_infos - -(* read a cmi from a filename, checking the magic *) -val read_cmi : string -> cmi_infos - -(* Error report *) - -type error = - | Not_an_interface of filepath - | Wrong_version_interface of filepath * string - | Corrupted_interface of filepath - -exception Error of error - -open Format - -val report_error: formatter -> error -> unit diff --git a/typing/cmt_format.ml b/typing/cmt_format.ml deleted file mode 100644 index 09c787d966..0000000000 --- a/typing/cmt_format.ml +++ /dev/null @@ -1,194 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Fabrice Le Fessant, INRIA Saclay *) -(* *) -(* Copyright 2012 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 Cmi_format -open Typedtree - -(* Note that in Typerex, there is an awful hack to save a cmt file - together with the interface file that was generated by ocaml (this - is because the installed version of ocaml might differ from the one - integrated in Typerex). -*) - - - -let read_magic_number ic = - let len_magic_number = String.length Config.cmt_magic_number in - really_input_string ic len_magic_number - -type binary_annots = - | Packed of Types.signature * string list - | Implementation of structure - | Interface of signature - | Partial_implementation of binary_part array - | Partial_interface of binary_part array - -and binary_part = -| Partial_structure of structure -| Partial_structure_item of structure_item -| Partial_expression of expression -| Partial_pattern of pattern -| Partial_class_expr of class_expr -| Partial_signature of signature -| Partial_signature_item of signature_item -| Partial_module_type of module_type - -type cmt_infos = { - cmt_modname : string; - cmt_annots : binary_annots; - cmt_value_dependencies : - (Types.value_description * Types.value_description) list; - cmt_comments : (string * Location.t) list; - cmt_args : string array; - cmt_sourcefile : string option; - cmt_builddir : string; - cmt_loadpath : string list; - cmt_source_digest : Digest.t option; - cmt_initial_env : Env.t; - cmt_imports : (string * Digest.t option) list; - cmt_interface_digest : Digest.t option; - cmt_use_summaries : bool; -} - -type error = - Not_a_typedtree of string - -let need_to_clear_env = - try ignore (Sys.getenv "OCAML_BINANNOT_WITHENV"); false - with Not_found -> true - -let keep_only_summary = Env.keep_only_summary - -open Tast_mapper - -let cenv = - {Tast_mapper.default with env = fun _sub env -> keep_only_summary env} - -let clear_part = function - | Partial_structure s -> Partial_structure (cenv.structure cenv s) - | Partial_structure_item s -> - Partial_structure_item (cenv.structure_item cenv s) - | Partial_expression e -> Partial_expression (cenv.expr cenv e) - | Partial_pattern p -> Partial_pattern (cenv.pat cenv p) - | Partial_class_expr ce -> Partial_class_expr (cenv.class_expr cenv ce) - | Partial_signature s -> Partial_signature (cenv.signature cenv s) - | Partial_signature_item s -> - Partial_signature_item (cenv.signature_item cenv s) - | Partial_module_type s -> Partial_module_type (cenv.module_type cenv s) - -let clear_env binary_annots = - if need_to_clear_env then - match binary_annots with - | Implementation s -> Implementation (cenv.structure cenv s) - | Interface s -> Interface (cenv.signature cenv s) - | Packed _ -> binary_annots - | Partial_implementation array -> - Partial_implementation (Array.map clear_part array) - | Partial_interface array -> - Partial_interface (Array.map clear_part array) - - else binary_annots - -exception Error of error - -let input_cmt ic = (input_value ic : cmt_infos) - -let output_cmt oc cmt = - output_string oc Config.cmt_magic_number; - output_value oc (cmt : cmt_infos) - -let read filename = -(* Printf.fprintf stderr "Cmt_format.read %s\n%!" filename; *) - let ic = open_in_bin filename in - Misc.try_finally - ~always:(fun () -> close_in ic) - (fun () -> - let magic_number = read_magic_number ic in - let cmi, cmt = - if magic_number = Config.cmt_magic_number then - None, Some (input_cmt ic) - else if magic_number = Config.cmi_magic_number then - let cmi = Cmi_format.input_cmi ic in - let cmt = try - let magic_number = read_magic_number ic in - if magic_number = Config.cmt_magic_number then - let cmt = input_cmt ic in - Some cmt - else None - with _ -> None - in - Some cmi, cmt - else - raise(Cmi_format.Error(Cmi_format.Not_an_interface filename)) - in - cmi, cmt - ) - -let read_cmt filename = - match read filename with - _, None -> raise (Error (Not_a_typedtree filename)) - | _, Some cmt -> cmt - -let read_cmi filename = - match read filename with - None, _ -> - raise (Cmi_format.Error (Cmi_format.Not_an_interface filename)) - | Some cmi, _ -> cmi - -let saved_types = ref [] -let value_deps = ref [] - -let clear () = - saved_types := []; - value_deps := [] - -let add_saved_type b = saved_types := b :: !saved_types -let get_saved_types () = !saved_types -let set_saved_types l = saved_types := l - -let record_value_dependency vd1 vd2 = - if vd1.Types.val_loc <> vd2.Types.val_loc then - value_deps := (vd1, vd2) :: !value_deps - -let save_cmt filename modname binary_annots sourcefile initial_env cmi = - if !Clflags.binary_annotations && not !Clflags.print_types then begin - Misc.output_to_file_via_temporary - ~mode:[Open_binary] filename - (fun temp_file_name oc -> - let this_crc = - match cmi with - | None -> None - | Some cmi -> Some (output_cmi temp_file_name oc cmi) - in - let source_digest = Misc.may_map Digest.file sourcefile in - let cmt = { - cmt_modname = modname; - cmt_annots = clear_env binary_annots; - cmt_value_dependencies = !value_deps; - cmt_comments = Lexer.comments (); - cmt_args = Sys.argv; - cmt_sourcefile = sourcefile; - cmt_builddir = Location.rewrite_absolute_path (Sys.getcwd ()); - cmt_loadpath = Load_path.get_paths (); - cmt_source_digest = source_digest; - cmt_initial_env = if need_to_clear_env then - keep_only_summary initial_env else initial_env; - cmt_imports = List.sort compare (Env.imports ()); - cmt_interface_digest = this_crc; - cmt_use_summaries = need_to_clear_env; - } in - output_cmt oc cmt) - end; - clear () diff --git a/typing/cmt_format.mli b/typing/cmt_format.mli deleted file mode 100644 index 7649de7b6e..0000000000 --- a/typing/cmt_format.mli +++ /dev/null @@ -1,123 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Fabrice Le Fessant, INRIA Saclay *) -(* *) -(* Copyright 2012 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. *) -(* *) -(**************************************************************************) - -(** cmt and cmti files format. *) - -open Misc - -(** The layout of a cmt file is as follows: - := \{\} \{cmt infos\} \{\} - where is the cmi file format: - := . - More precisely, the optional part must be present if and only if - the file is: - - a cmti, or - - a cmt, for a ml file which has no corresponding mli (hence no - corresponding cmti). - - Thus, we provide a common reading function for cmi and cmt(i) - files which returns an option for each of the three parts: cmi - info, cmt info, source info. *) - -open Typedtree - -type binary_annots = - | Packed of Types.signature * string list - | Implementation of structure - | Interface of signature - | Partial_implementation of binary_part array - | Partial_interface of binary_part array - -and binary_part = - | Partial_structure of structure - | Partial_structure_item of structure_item - | Partial_expression of expression - | Partial_pattern of pattern - | Partial_class_expr of class_expr - | Partial_signature of signature - | Partial_signature_item of signature_item - | Partial_module_type of module_type - -type cmt_infos = { - cmt_modname : modname; - cmt_annots : binary_annots; - cmt_value_dependencies : - (Types.value_description * Types.value_description) list; - cmt_comments : (string * Location.t) list; - cmt_args : string array; - cmt_sourcefile : string option; - cmt_builddir : string; - cmt_loadpath : string list; - cmt_source_digest : string option; - cmt_initial_env : Env.t; - cmt_imports : crcs; - cmt_interface_digest : Digest.t option; - cmt_use_summaries : bool; -} - -type error = - Not_a_typedtree of string - -exception Error of error - -(** [read filename] opens filename, and extract both the cmi_infos, if - it exists, and the cmt_infos, if it exists. Thus, it can be used - with .cmi, .cmt and .cmti files. - - .cmti files always contain a cmi_infos at the beginning. .cmt files - only contain a cmi_infos at the beginning if there is no associated - .cmti file. -*) -val read : string -> Cmi_format.cmi_infos option * cmt_infos option - -val read_cmt : string -> cmt_infos -val read_cmi : string -> Cmi_format.cmi_infos - -(** [save_cmt filename modname binary_annots sourcefile initial_env cmi] - writes a cmt(i) file. *) -val save_cmt : - string -> (* filename.cmt to generate *) - string -> (* module name *) - binary_annots -> - string option -> (* source file *) - Env.t -> (* initial env *) - Cmi_format.cmi_infos option -> (* if a .cmi was generated *) - unit - -(* Miscellaneous functions *) - -val read_magic_number : in_channel -> string - -val clear: unit -> unit - -val add_saved_type : binary_part -> unit -val get_saved_types : unit -> binary_part list -val set_saved_types : binary_part list -> unit - -val record_value_dependency: - Types.value_description -> Types.value_description -> unit - - -(* - - val is_magic_number : string -> bool - val read : in_channel -> Env.cmi_infos option * t - val write_magic_number : out_channel -> unit - val write : out_channel -> t -> unit - - val find : string list -> string -> string - val read_signature : 'a -> string -> Types.signature * 'b list * 'c list - -*) diff --git a/utils/int_replace_polymorphic_compare.ml b/utils/int_replace_polymorphic_compare.ml new file mode 100644 index 0000000000..7cd6bf1099 --- /dev/null +++ b/utils/int_replace_polymorphic_compare.ml @@ -0,0 +1,8 @@ +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/utils/int_replace_polymorphic_compare.mli b/utils/int_replace_polymorphic_compare.mli new file mode 100644 index 0000000000..689e741b66 --- /dev/null +++ b/utils/int_replace_polymorphic_compare.mli @@ -0,0 +1,8 @@ +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 -- cgit v1.2.1