diff options
Diffstat (limited to 'middle_end')
-rw-r--r-- | middle_end/backend_var.ml | 87 | ||||
-rw-r--r-- | middle_end/backend_var.mli | 54 | ||||
-rw-r--r-- | middle_end/clambda.ml | 203 | ||||
-rw-r--r-- | middle_end/clambda.mli | 153 | ||||
-rw-r--r-- | middle_end/clambda_primitives.ml | 155 | ||||
-rw-r--r-- | middle_end/clambda_primitives.mli | 158 | ||||
-rw-r--r-- | middle_end/closure/closure.ml | 1472 | ||||
-rw-r--r-- | middle_end/closure/closure.mli | 24 | ||||
-rw-r--r-- | middle_end/compilation_unit.ml (renamed from middle_end/base_types/compilation_unit.ml) | 0 | ||||
-rw-r--r-- | middle_end/compilation_unit.mli (renamed from middle_end/base_types/compilation_unit.mli) | 0 | ||||
-rw-r--r-- | middle_end/compilenv.ml | 452 | ||||
-rw-r--r-- | middle_end/compilenv.mli | 153 | ||||
-rw-r--r-- | middle_end/convert_primitives.ml | 153 | ||||
-rw-r--r-- | middle_end/convert_primitives.mli | 17 | ||||
-rw-r--r-- | middle_end/debuginfo.ml | 145 | ||||
-rw-r--r-- | middle_end/debuginfo.mli | 46 | ||||
-rw-r--r-- | middle_end/flambda/alias_analysis.ml (renamed from middle_end/alias_analysis.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/alias_analysis.mli (renamed from middle_end/alias_analysis.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/allocated_const.ml (renamed from middle_end/allocated_const.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/allocated_const.mli (renamed from middle_end/allocated_const.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/augment_specialised_args.ml (renamed from middle_end/augment_specialised_args.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/augment_specialised_args.mli (renamed from middle_end/augment_specialised_args.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/base_types/closure_element.ml (renamed from middle_end/base_types/closure_element.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/base_types/closure_element.mli (renamed from middle_end/base_types/closure_element.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/base_types/closure_id.ml (renamed from middle_end/base_types/closure_id.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/base_types/closure_id.mli (renamed from middle_end/base_types/closure_id.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/base_types/closure_origin.ml (renamed from middle_end/base_types/closure_origin.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/base_types/closure_origin.mli (renamed from middle_end/base_types/closure_origin.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/base_types/export_id.ml (renamed from middle_end/base_types/export_id.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/base_types/export_id.mli (renamed from middle_end/base_types/export_id.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/base_types/id_types.ml (renamed from middle_end/base_types/id_types.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/base_types/id_types.mli (renamed from middle_end/base_types/id_types.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/base_types/mutable_variable.ml (renamed from middle_end/base_types/mutable_variable.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/base_types/mutable_variable.mli (renamed from middle_end/base_types/mutable_variable.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/base_types/set_of_closures_id.ml (renamed from middle_end/base_types/set_of_closures_id.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/base_types/set_of_closures_id.mli (renamed from middle_end/base_types/set_of_closures_id.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/base_types/set_of_closures_origin.ml (renamed from middle_end/base_types/set_of_closures_origin.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/base_types/set_of_closures_origin.mli (renamed from middle_end/base_types/set_of_closures_origin.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/base_types/static_exception.ml (renamed from middle_end/base_types/static_exception.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/base_types/static_exception.mli (renamed from middle_end/base_types/static_exception.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/base_types/tag.ml (renamed from middle_end/base_types/tag.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/base_types/tag.mli (renamed from middle_end/base_types/tag.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/base_types/var_within_closure.ml (renamed from middle_end/base_types/var_within_closure.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/base_types/var_within_closure.mli (renamed from middle_end/base_types/var_within_closure.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/build_export_info.ml | 711 | ||||
-rw-r--r-- | middle_end/flambda/build_export_info.mli | 25 | ||||
-rw-r--r-- | middle_end/flambda/closure_conversion.ml (renamed from middle_end/closure_conversion.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/closure_conversion.mli (renamed from middle_end/closure_conversion.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/closure_conversion_aux.ml (renamed from middle_end/closure_conversion_aux.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/closure_conversion_aux.mli (renamed from middle_end/closure_conversion_aux.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/closure_offsets.ml | 89 | ||||
-rw-r--r-- | middle_end/flambda/closure_offsets.mli | 27 | ||||
-rw-r--r-- | middle_end/flambda/effect_analysis.ml (renamed from middle_end/effect_analysis.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/effect_analysis.mli (renamed from middle_end/effect_analysis.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/export_info.ml | 555 | ||||
-rw-r--r-- | middle_end/flambda/export_info.mli | 195 | ||||
-rw-r--r-- | middle_end/flambda/export_info_for_pack.ml | 231 | ||||
-rw-r--r-- | middle_end/flambda/export_info_for_pack.mli | 34 | ||||
-rw-r--r-- | middle_end/flambda/extract_projections.ml (renamed from middle_end/extract_projections.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/extract_projections.mli (renamed from middle_end/extract_projections.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/find_recursive_functions.ml (renamed from middle_end/find_recursive_functions.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/find_recursive_functions.mli (renamed from middle_end/find_recursive_functions.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/flambda.ml (renamed from middle_end/flambda.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/flambda.mli (renamed from middle_end/flambda.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/flambda_invariants.ml (renamed from middle_end/flambda_invariants.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/flambda_invariants.mli (renamed from middle_end/flambda_invariants.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/flambda_iterators.ml (renamed from middle_end/flambda_iterators.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/flambda_iterators.mli (renamed from middle_end/flambda_iterators.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/flambda_middle_end.ml (renamed from middle_end/middle_end.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/flambda_middle_end.mli (renamed from middle_end/middle_end.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/flambda_to_clambda.ml | 749 | ||||
-rw-r--r-- | middle_end/flambda/flambda_to_clambda.mli | 38 | ||||
-rw-r--r-- | middle_end/flambda/flambda_utils.ml (renamed from middle_end/flambda_utils.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/flambda_utils.mli (renamed from middle_end/flambda_utils.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/freshening.ml (renamed from middle_end/freshening.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/freshening.mli (renamed from middle_end/freshening.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/import_approx.ml | 222 | ||||
-rw-r--r-- | middle_end/flambda/import_approx.mli | 34 | ||||
-rw-r--r-- | middle_end/flambda/inconstant_idents.ml (renamed from middle_end/inconstant_idents.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/inconstant_idents.mli (renamed from middle_end/inconstant_idents.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/initialize_symbol_to_let_symbol.ml (renamed from middle_end/initialize_symbol_to_let_symbol.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/initialize_symbol_to_let_symbol.mli (renamed from middle_end/initialize_symbol_to_let_symbol.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/inline_and_simplify.ml (renamed from middle_end/inline_and_simplify.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/inline_and_simplify.mli (renamed from middle_end/inline_and_simplify.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/inline_and_simplify_aux.ml (renamed from middle_end/inline_and_simplify_aux.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/inline_and_simplify_aux.mli (renamed from middle_end/inline_and_simplify_aux.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/inlining_cost.ml (renamed from middle_end/inlining_cost.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/inlining_cost.mli (renamed from middle_end/inlining_cost.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/inlining_decision.ml (renamed from middle_end/inlining_decision.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/inlining_decision.mli (renamed from middle_end/inlining_decision.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/inlining_decision_intf.mli (renamed from middle_end/inlining_decision_intf.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/inlining_stats.ml (renamed from middle_end/inlining_stats.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/inlining_stats.mli (renamed from middle_end/inlining_stats.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/inlining_stats_types.ml (renamed from middle_end/inlining_stats_types.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/inlining_stats_types.mli (renamed from middle_end/inlining_stats_types.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/inlining_transforms.ml (renamed from middle_end/inlining_transforms.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/inlining_transforms.mli (renamed from middle_end/inlining_transforms.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/invariant_params.ml (renamed from middle_end/invariant_params.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/invariant_params.mli (renamed from middle_end/invariant_params.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/lift_code.ml (renamed from middle_end/lift_code.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/lift_code.mli (renamed from middle_end/lift_code.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/lift_constants.ml (renamed from middle_end/lift_constants.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/lift_constants.mli (renamed from middle_end/lift_constants.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/lift_let_to_initialize_symbol.ml (renamed from middle_end/lift_let_to_initialize_symbol.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/lift_let_to_initialize_symbol.mli (renamed from middle_end/lift_let_to_initialize_symbol.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/parameter.ml (renamed from middle_end/parameter.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/parameter.mli (renamed from middle_end/parameter.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/pass_wrapper.ml (renamed from middle_end/pass_wrapper.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/pass_wrapper.mli (renamed from middle_end/pass_wrapper.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/projection.ml (renamed from middle_end/projection.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/projection.mli (renamed from middle_end/projection.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/ref_to_variables.ml (renamed from middle_end/ref_to_variables.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/ref_to_variables.mli (renamed from middle_end/ref_to_variables.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/remove_free_vars_equal_to_args.ml (renamed from middle_end/remove_free_vars_equal_to_args.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/remove_free_vars_equal_to_args.mli (renamed from middle_end/remove_free_vars_equal_to_args.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/remove_unused_arguments.ml (renamed from middle_end/remove_unused_arguments.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/remove_unused_arguments.mli (renamed from middle_end/remove_unused_arguments.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/remove_unused_closure_vars.ml (renamed from middle_end/remove_unused_closure_vars.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/remove_unused_closure_vars.mli (renamed from middle_end/remove_unused_closure_vars.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/remove_unused_program_constructs.ml (renamed from middle_end/remove_unused_program_constructs.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/remove_unused_program_constructs.mli (renamed from middle_end/remove_unused_program_constructs.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/share_constants.ml (renamed from middle_end/share_constants.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/share_constants.mli (renamed from middle_end/share_constants.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/simple_value_approx.ml (renamed from middle_end/simple_value_approx.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/simple_value_approx.mli (renamed from middle_end/simple_value_approx.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/simplify_boxed_integer_ops.ml (renamed from middle_end/simplify_boxed_integer_ops.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/simplify_boxed_integer_ops.mli (renamed from middle_end/simplify_boxed_integer_ops.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/simplify_boxed_integer_ops_intf.mli (renamed from middle_end/simplify_boxed_integer_ops_intf.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/simplify_common.ml (renamed from middle_end/simplify_common.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/simplify_common.mli (renamed from middle_end/simplify_common.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/simplify_primitives.ml (renamed from middle_end/simplify_primitives.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/simplify_primitives.mli (renamed from middle_end/simplify_primitives.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/traverse_for_exported_symbols.ml | 267 | ||||
-rw-r--r-- | middle_end/flambda/traverse_for_exported_symbols.mli | 41 | ||||
-rw-r--r-- | middle_end/flambda/un_anf.ml | 817 | ||||
-rw-r--r-- | middle_end/flambda/un_anf.mli | 23 | ||||
-rw-r--r-- | middle_end/flambda/unbox_closures.ml (renamed from middle_end/unbox_closures.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/unbox_closures.mli (renamed from middle_end/unbox_closures.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/unbox_free_vars_of_closures.ml (renamed from middle_end/unbox_free_vars_of_closures.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/unbox_free_vars_of_closures.mli (renamed from middle_end/unbox_free_vars_of_closures.mli) | 0 | ||||
-rw-r--r-- | middle_end/flambda/unbox_specialised_args.ml (renamed from middle_end/unbox_specialised_args.ml) | 0 | ||||
-rw-r--r-- | middle_end/flambda/unbox_specialised_args.mli (renamed from middle_end/unbox_specialised_args.mli) | 0 | ||||
-rw-r--r-- | middle_end/int_replace_polymorphic_compare.ml | 8 | ||||
-rw-r--r-- | middle_end/int_replace_polymorphic_compare.mli | 8 | ||||
-rw-r--r-- | middle_end/linkage_name.ml (renamed from middle_end/base_types/linkage_name.ml) | 0 | ||||
-rw-r--r-- | middle_end/linkage_name.mli (renamed from middle_end/base_types/linkage_name.mli) | 0 | ||||
-rw-r--r-- | middle_end/printclambda.ml | 272 | ||||
-rw-r--r-- | middle_end/printclambda.mli | 26 | ||||
-rw-r--r-- | middle_end/printclambda_primitives.ml | 202 | ||||
-rw-r--r-- | middle_end/printclambda_primitives.mli | 18 | ||||
-rw-r--r-- | middle_end/semantics_of_primitives.ml | 153 | ||||
-rw-r--r-- | middle_end/semantics_of_primitives.mli | 69 | ||||
-rw-r--r-- | middle_end/symbol.ml (renamed from middle_end/base_types/symbol.ml) | 0 | ||||
-rw-r--r-- | middle_end/symbol.mli (renamed from middle_end/base_types/symbol.mli) | 0 | ||||
-rw-r--r-- | middle_end/variable.ml (renamed from middle_end/base_types/variable.ml) | 0 | ||||
-rw-r--r-- | middle_end/variable.mli (renamed from middle_end/base_types/variable.mli) | 0 |
156 files changed, 7879 insertions, 207 deletions
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 "@[<hov 1>(\ + @[<hov 1>(module_path@ %a)@]@ \ + @[<hov 1>(location@ %a)@]@ \ + @[<hov 1>(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/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/base_types/compilation_unit.ml b/middle_end/compilation_unit.ml index 7fb48167bc..7fb48167bc 100644 --- a/middle_end/base_types/compilation_unit.ml +++ b/middle_end/compilation_unit.ml diff --git a/middle_end/base_types/compilation_unit.mli b/middle_end/compilation_unit.mli index fc7d3bfded..fc7d3bfded 100644 --- a/middle_end/base_types/compilation_unit.mli +++ b/middle_end/compilation_unit.mli 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/alias_analysis.ml b/middle_end/flambda/alias_analysis.ml index fe97a36f51..fe97a36f51 100644 --- a/middle_end/alias_analysis.ml +++ b/middle_end/flambda/alias_analysis.ml diff --git a/middle_end/alias_analysis.mli b/middle_end/flambda/alias_analysis.mli index 515daeffa3..515daeffa3 100644 --- a/middle_end/alias_analysis.mli +++ b/middle_end/flambda/alias_analysis.mli diff --git a/middle_end/allocated_const.ml b/middle_end/flambda/allocated_const.ml index 78dc4ee103..78dc4ee103 100644 --- a/middle_end/allocated_const.ml +++ b/middle_end/flambda/allocated_const.ml diff --git a/middle_end/allocated_const.mli b/middle_end/flambda/allocated_const.mli index 0bdbe49ec4..0bdbe49ec4 100644 --- a/middle_end/allocated_const.mli +++ b/middle_end/flambda/allocated_const.mli diff --git a/middle_end/augment_specialised_args.ml b/middle_end/flambda/augment_specialised_args.ml index c3a3078512..c3a3078512 100644 --- a/middle_end/augment_specialised_args.ml +++ b/middle_end/flambda/augment_specialised_args.ml diff --git a/middle_end/augment_specialised_args.mli b/middle_end/flambda/augment_specialised_args.mli index 5c48a12652..5c48a12652 100644 --- a/middle_end/augment_specialised_args.mli +++ b/middle_end/flambda/augment_specialised_args.mli diff --git a/middle_end/base_types/closure_element.ml b/middle_end/flambda/base_types/closure_element.ml index 561e080396..561e080396 100644 --- a/middle_end/base_types/closure_element.ml +++ b/middle_end/flambda/base_types/closure_element.ml diff --git a/middle_end/base_types/closure_element.mli b/middle_end/flambda/base_types/closure_element.mli index d78dd9b369..d78dd9b369 100644 --- a/middle_end/base_types/closure_element.mli +++ b/middle_end/flambda/base_types/closure_element.mli diff --git a/middle_end/base_types/closure_id.ml b/middle_end/flambda/base_types/closure_id.ml index 466f59a237..466f59a237 100644 --- a/middle_end/base_types/closure_id.ml +++ b/middle_end/flambda/base_types/closure_id.ml diff --git a/middle_end/base_types/closure_id.mli b/middle_end/flambda/base_types/closure_id.mli index 853a07f7f4..853a07f7f4 100644 --- a/middle_end/base_types/closure_id.mli +++ b/middle_end/flambda/base_types/closure_id.mli diff --git a/middle_end/base_types/closure_origin.ml b/middle_end/flambda/base_types/closure_origin.ml index 2285c687e3..2285c687e3 100644 --- a/middle_end/base_types/closure_origin.ml +++ b/middle_end/flambda/base_types/closure_origin.ml diff --git a/middle_end/base_types/closure_origin.mli b/middle_end/flambda/base_types/closure_origin.mli index 86fcd56cc6..86fcd56cc6 100644 --- a/middle_end/base_types/closure_origin.mli +++ b/middle_end/flambda/base_types/closure_origin.mli diff --git a/middle_end/base_types/export_id.ml b/middle_end/flambda/base_types/export_id.ml index 681ac955af..681ac955af 100644 --- a/middle_end/base_types/export_id.ml +++ b/middle_end/flambda/base_types/export_id.ml diff --git a/middle_end/base_types/export_id.mli b/middle_end/flambda/base_types/export_id.mli index 54c14418e4..54c14418e4 100644 --- a/middle_end/base_types/export_id.mli +++ b/middle_end/flambda/base_types/export_id.mli diff --git a/middle_end/base_types/id_types.ml b/middle_end/flambda/base_types/id_types.ml index 6d2e274311..6d2e274311 100644 --- a/middle_end/base_types/id_types.ml +++ b/middle_end/flambda/base_types/id_types.ml diff --git a/middle_end/base_types/id_types.mli b/middle_end/flambda/base_types/id_types.mli index 48ca037caf..48ca037caf 100644 --- a/middle_end/base_types/id_types.mli +++ b/middle_end/flambda/base_types/id_types.mli diff --git a/middle_end/base_types/mutable_variable.ml b/middle_end/flambda/base_types/mutable_variable.ml index 07fe3152da..07fe3152da 100644 --- a/middle_end/base_types/mutable_variable.ml +++ b/middle_end/flambda/base_types/mutable_variable.ml diff --git a/middle_end/base_types/mutable_variable.mli b/middle_end/flambda/base_types/mutable_variable.mli index 17fe208fe0..17fe208fe0 100644 --- a/middle_end/base_types/mutable_variable.mli +++ b/middle_end/flambda/base_types/mutable_variable.mli diff --git a/middle_end/base_types/set_of_closures_id.ml b/middle_end/flambda/base_types/set_of_closures_id.ml index 681ac955af..681ac955af 100644 --- a/middle_end/base_types/set_of_closures_id.ml +++ b/middle_end/flambda/base_types/set_of_closures_id.ml diff --git a/middle_end/base_types/set_of_closures_id.mli b/middle_end/flambda/base_types/set_of_closures_id.mli index 811cb66102..811cb66102 100644 --- a/middle_end/base_types/set_of_closures_id.mli +++ b/middle_end/flambda/base_types/set_of_closures_id.mli diff --git a/middle_end/base_types/set_of_closures_origin.ml b/middle_end/flambda/base_types/set_of_closures_origin.ml index a5ef8c7c3d..a5ef8c7c3d 100644 --- a/middle_end/base_types/set_of_closures_origin.ml +++ b/middle_end/flambda/base_types/set_of_closures_origin.ml diff --git a/middle_end/base_types/set_of_closures_origin.mli b/middle_end/flambda/base_types/set_of_closures_origin.mli index 4c9cfdcf80..4c9cfdcf80 100644 --- a/middle_end/base_types/set_of_closures_origin.mli +++ b/middle_end/flambda/base_types/set_of_closures_origin.mli diff --git a/middle_end/base_types/static_exception.ml b/middle_end/flambda/base_types/static_exception.ml index 6cecae6328..6cecae6328 100644 --- a/middle_end/base_types/static_exception.ml +++ b/middle_end/flambda/base_types/static_exception.ml diff --git a/middle_end/base_types/static_exception.mli b/middle_end/flambda/base_types/static_exception.mli index 88f690aa10..88f690aa10 100644 --- a/middle_end/base_types/static_exception.mli +++ b/middle_end/flambda/base_types/static_exception.mli diff --git a/middle_end/base_types/tag.ml b/middle_end/flambda/base_types/tag.ml index cfa51ddbb2..cfa51ddbb2 100644 --- a/middle_end/base_types/tag.ml +++ b/middle_end/flambda/base_types/tag.ml diff --git a/middle_end/base_types/tag.mli b/middle_end/flambda/base_types/tag.mli index 12ce55255c..12ce55255c 100644 --- a/middle_end/base_types/tag.mli +++ b/middle_end/flambda/base_types/tag.mli diff --git a/middle_end/base_types/var_within_closure.ml b/middle_end/flambda/base_types/var_within_closure.ml index 466f59a237..466f59a237 100644 --- a/middle_end/base_types/var_within_closure.ml +++ b/middle_end/flambda/base_types/var_within_closure.ml diff --git a/middle_end/base_types/var_within_closure.mli b/middle_end/flambda/base_types/var_within_closure.mli index 56f0af0ad6..56f0af0ad6 100644 --- a/middle_end/base_types/var_within_closure.mli +++ b/middle_end/flambda/base_types/var_within_closure.mli 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/closure_conversion.ml b/middle_end/flambda/closure_conversion.ml index 9bdd30ead9..9bdd30ead9 100644 --- a/middle_end/closure_conversion.ml +++ b/middle_end/flambda/closure_conversion.ml diff --git a/middle_end/closure_conversion.mli b/middle_end/flambda/closure_conversion.mli index f5fab0a7ed..f5fab0a7ed 100644 --- a/middle_end/closure_conversion.mli +++ b/middle_end/flambda/closure_conversion.mli diff --git a/middle_end/closure_conversion_aux.ml b/middle_end/flambda/closure_conversion_aux.ml index cfcaf34d1b..cfcaf34d1b 100644 --- a/middle_end/closure_conversion_aux.ml +++ b/middle_end/flambda/closure_conversion_aux.ml diff --git a/middle_end/closure_conversion_aux.mli b/middle_end/flambda/closure_conversion_aux.mli index f16f05f0d7..f16f05f0d7 100644 --- a/middle_end/closure_conversion_aux.mli +++ b/middle_end/flambda/closure_conversion_aux.mli 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/effect_analysis.ml b/middle_end/flambda/effect_analysis.ml index d0cbd44180..d0cbd44180 100644 --- a/middle_end/effect_analysis.ml +++ b/middle_end/flambda/effect_analysis.ml diff --git a/middle_end/effect_analysis.mli b/middle_end/flambda/effect_analysis.mli index b025bf0f87..b025bf0f87 100644 --- a/middle_end/effect_analysis.mli +++ b/middle_end/flambda/effect_analysis.mli 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 "<None>" + | 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 "@[<hov 2>(%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 "@[<hov 2>%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 "@[<hov 2>Globals:@ "; + fprintf ppf "@]@ @[<hov 2>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 "@[<v 2>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 "@]@ @[<v 2>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/extract_projections.ml b/middle_end/flambda/extract_projections.ml index 33cd473ecd..33cd473ecd 100644 --- a/middle_end/extract_projections.ml +++ b/middle_end/flambda/extract_projections.ml diff --git a/middle_end/extract_projections.mli b/middle_end/flambda/extract_projections.mli index 47456bda0a..47456bda0a 100644 --- a/middle_end/extract_projections.mli +++ b/middle_end/flambda/extract_projections.mli diff --git a/middle_end/find_recursive_functions.ml b/middle_end/flambda/find_recursive_functions.ml index e69433039f..e69433039f 100644 --- a/middle_end/find_recursive_functions.ml +++ b/middle_end/flambda/find_recursive_functions.ml diff --git a/middle_end/find_recursive_functions.mli b/middle_end/flambda/find_recursive_functions.mli index 3c2dd5b1fb..3c2dd5b1fb 100644 --- a/middle_end/find_recursive_functions.mli +++ b/middle_end/flambda/find_recursive_functions.mli diff --git a/middle_end/flambda.ml b/middle_end/flambda/flambda.ml index 243e2e3f9c..243e2e3f9c 100644 --- a/middle_end/flambda.ml +++ b/middle_end/flambda/flambda.ml diff --git a/middle_end/flambda.mli b/middle_end/flambda/flambda.mli index 325c15ee1c..325c15ee1c 100644 --- a/middle_end/flambda.mli +++ b/middle_end/flambda/flambda.mli diff --git a/middle_end/flambda_invariants.ml b/middle_end/flambda/flambda_invariants.ml index 250a2e9af7..250a2e9af7 100644 --- a/middle_end/flambda_invariants.ml +++ b/middle_end/flambda/flambda_invariants.ml diff --git a/middle_end/flambda_invariants.mli b/middle_end/flambda/flambda_invariants.mli index 252578e88e..252578e88e 100644 --- a/middle_end/flambda_invariants.mli +++ b/middle_end/flambda/flambda_invariants.mli diff --git a/middle_end/flambda_iterators.ml b/middle_end/flambda/flambda_iterators.ml index a69575da63..a69575da63 100644 --- a/middle_end/flambda_iterators.ml +++ b/middle_end/flambda/flambda_iterators.ml diff --git a/middle_end/flambda_iterators.mli b/middle_end/flambda/flambda_iterators.mli index 02fe685097..02fe685097 100644 --- a/middle_end/flambda_iterators.mli +++ b/middle_end/flambda/flambda_iterators.mli diff --git a/middle_end/middle_end.ml b/middle_end/flambda/flambda_middle_end.ml index e604a3285b..e604a3285b 100644 --- a/middle_end/middle_end.ml +++ b/middle_end/flambda/flambda_middle_end.ml diff --git a/middle_end/middle_end.mli b/middle_end/flambda/flambda_middle_end.mli index 584cb45a98..584cb45a98 100644 --- a/middle_end/middle_end.mli +++ b/middle_end/flambda/flambda_middle_end.mli 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 -> "<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_utils.ml b/middle_end/flambda/flambda_utils.ml index c204f5e67c..c204f5e67c 100644 --- a/middle_end/flambda_utils.ml +++ b/middle_end/flambda/flambda_utils.ml diff --git a/middle_end/flambda_utils.mli b/middle_end/flambda/flambda_utils.mli index 0f7b318627..0f7b318627 100644 --- a/middle_end/flambda_utils.mli +++ b/middle_end/flambda/flambda_utils.mli diff --git a/middle_end/freshening.ml b/middle_end/flambda/freshening.ml index 891861a33e..891861a33e 100644 --- a/middle_end/freshening.ml +++ b/middle_end/flambda/freshening.ml diff --git a/middle_end/freshening.mli b/middle_end/flambda/freshening.mli index 1550797ac1..1550797ac1 100644 --- a/middle_end/freshening.mli +++ b/middle_end/flambda/freshening.mli 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/inconstant_idents.ml b/middle_end/flambda/inconstant_idents.ml index 59f8aa8a8c..59f8aa8a8c 100644 --- a/middle_end/inconstant_idents.ml +++ b/middle_end/flambda/inconstant_idents.ml diff --git a/middle_end/inconstant_idents.mli b/middle_end/flambda/inconstant_idents.mli index 2c5309e022..2c5309e022 100644 --- a/middle_end/inconstant_idents.mli +++ b/middle_end/flambda/inconstant_idents.mli diff --git a/middle_end/initialize_symbol_to_let_symbol.ml b/middle_end/flambda/initialize_symbol_to_let_symbol.ml index 31246b0d46..31246b0d46 100644 --- a/middle_end/initialize_symbol_to_let_symbol.ml +++ b/middle_end/flambda/initialize_symbol_to_let_symbol.ml diff --git a/middle_end/initialize_symbol_to_let_symbol.mli b/middle_end/flambda/initialize_symbol_to_let_symbol.mli index fc54f76075..fc54f76075 100644 --- a/middle_end/initialize_symbol_to_let_symbol.mli +++ b/middle_end/flambda/initialize_symbol_to_let_symbol.mli diff --git a/middle_end/inline_and_simplify.ml b/middle_end/flambda/inline_and_simplify.ml index 7d304cd88f..7d304cd88f 100644 --- a/middle_end/inline_and_simplify.ml +++ b/middle_end/flambda/inline_and_simplify.ml diff --git a/middle_end/inline_and_simplify.mli b/middle_end/flambda/inline_and_simplify.mli index 9a8e6e8b46..9a8e6e8b46 100644 --- a/middle_end/inline_and_simplify.mli +++ b/middle_end/flambda/inline_and_simplify.mli diff --git a/middle_end/inline_and_simplify_aux.ml b/middle_end/flambda/inline_and_simplify_aux.ml index bb725e8c64..bb725e8c64 100644 --- a/middle_end/inline_and_simplify_aux.ml +++ b/middle_end/flambda/inline_and_simplify_aux.ml diff --git a/middle_end/inline_and_simplify_aux.mli b/middle_end/flambda/inline_and_simplify_aux.mli index 79d84a31b8..79d84a31b8 100644 --- a/middle_end/inline_and_simplify_aux.mli +++ b/middle_end/flambda/inline_and_simplify_aux.mli diff --git a/middle_end/inlining_cost.ml b/middle_end/flambda/inlining_cost.ml index 33e870f90a..33e870f90a 100644 --- a/middle_end/inlining_cost.ml +++ b/middle_end/flambda/inlining_cost.ml diff --git a/middle_end/inlining_cost.mli b/middle_end/flambda/inlining_cost.mli index 345f67abad..345f67abad 100644 --- a/middle_end/inlining_cost.mli +++ b/middle_end/flambda/inlining_cost.mli diff --git a/middle_end/inlining_decision.ml b/middle_end/flambda/inlining_decision.ml index ca462a5613..ca462a5613 100644 --- a/middle_end/inlining_decision.ml +++ b/middle_end/flambda/inlining_decision.ml diff --git a/middle_end/inlining_decision.mli b/middle_end/flambda/inlining_decision.mli index 3694e30366..3694e30366 100644 --- a/middle_end/inlining_decision.mli +++ b/middle_end/flambda/inlining_decision.mli diff --git a/middle_end/inlining_decision_intf.mli b/middle_end/flambda/inlining_decision_intf.mli index 15a080316c..15a080316c 100644 --- a/middle_end/inlining_decision_intf.mli +++ b/middle_end/flambda/inlining_decision_intf.mli diff --git a/middle_end/inlining_stats.ml b/middle_end/flambda/inlining_stats.ml index 6809d4cbb4..6809d4cbb4 100644 --- a/middle_end/inlining_stats.ml +++ b/middle_end/flambda/inlining_stats.ml diff --git a/middle_end/inlining_stats.mli b/middle_end/flambda/inlining_stats.mli index f1e84fdcea..f1e84fdcea 100644 --- a/middle_end/inlining_stats.mli +++ b/middle_end/flambda/inlining_stats.mli diff --git a/middle_end/inlining_stats_types.ml b/middle_end/flambda/inlining_stats_types.ml index 7aef0796d9..7aef0796d9 100644 --- a/middle_end/inlining_stats_types.ml +++ b/middle_end/flambda/inlining_stats_types.ml diff --git a/middle_end/inlining_stats_types.mli b/middle_end/flambda/inlining_stats_types.mli index 9d476c8981..9d476c8981 100644 --- a/middle_end/inlining_stats_types.mli +++ b/middle_end/flambda/inlining_stats_types.mli diff --git a/middle_end/inlining_transforms.ml b/middle_end/flambda/inlining_transforms.ml index b08e62bb0a..b08e62bb0a 100644 --- a/middle_end/inlining_transforms.ml +++ b/middle_end/flambda/inlining_transforms.ml diff --git a/middle_end/inlining_transforms.mli b/middle_end/flambda/inlining_transforms.mli index e31d1b0849..e31d1b0849 100644 --- a/middle_end/inlining_transforms.mli +++ b/middle_end/flambda/inlining_transforms.mli diff --git a/middle_end/invariant_params.ml b/middle_end/flambda/invariant_params.ml index a43cfdace1..a43cfdace1 100644 --- a/middle_end/invariant_params.ml +++ b/middle_end/flambda/invariant_params.ml diff --git a/middle_end/invariant_params.mli b/middle_end/flambda/invariant_params.mli index c68514203c..c68514203c 100644 --- a/middle_end/invariant_params.mli +++ b/middle_end/flambda/invariant_params.mli diff --git a/middle_end/lift_code.ml b/middle_end/flambda/lift_code.ml index 02292c46e1..02292c46e1 100644 --- a/middle_end/lift_code.ml +++ b/middle_end/flambda/lift_code.ml diff --git a/middle_end/lift_code.mli b/middle_end/flambda/lift_code.mli index 92ecda0154..92ecda0154 100644 --- a/middle_end/lift_code.mli +++ b/middle_end/flambda/lift_code.mli diff --git a/middle_end/lift_constants.ml b/middle_end/flambda/lift_constants.ml index dd60de9ce2..dd60de9ce2 100644 --- a/middle_end/lift_constants.ml +++ b/middle_end/flambda/lift_constants.ml diff --git a/middle_end/lift_constants.mli b/middle_end/flambda/lift_constants.mli index 969c365e33..969c365e33 100644 --- a/middle_end/lift_constants.mli +++ b/middle_end/flambda/lift_constants.mli diff --git a/middle_end/lift_let_to_initialize_symbol.ml b/middle_end/flambda/lift_let_to_initialize_symbol.ml index ccef0d8a1f..ccef0d8a1f 100644 --- a/middle_end/lift_let_to_initialize_symbol.ml +++ b/middle_end/flambda/lift_let_to_initialize_symbol.ml diff --git a/middle_end/lift_let_to_initialize_symbol.mli b/middle_end/flambda/lift_let_to_initialize_symbol.mli index afb1c60f9c..afb1c60f9c 100644 --- a/middle_end/lift_let_to_initialize_symbol.mli +++ b/middle_end/flambda/lift_let_to_initialize_symbol.mli diff --git a/middle_end/parameter.ml b/middle_end/flambda/parameter.ml index 0c916dd7ae..0c916dd7ae 100644 --- a/middle_end/parameter.ml +++ b/middle_end/flambda/parameter.ml diff --git a/middle_end/parameter.mli b/middle_end/flambda/parameter.mli index ceed16786b..ceed16786b 100644 --- a/middle_end/parameter.mli +++ b/middle_end/flambda/parameter.mli diff --git a/middle_end/pass_wrapper.ml b/middle_end/flambda/pass_wrapper.ml index a20053326f..a20053326f 100644 --- a/middle_end/pass_wrapper.ml +++ b/middle_end/flambda/pass_wrapper.ml diff --git a/middle_end/pass_wrapper.mli b/middle_end/flambda/pass_wrapper.mli index 3a30e61d6d..3a30e61d6d 100644 --- a/middle_end/pass_wrapper.mli +++ b/middle_end/flambda/pass_wrapper.mli diff --git a/middle_end/projection.ml b/middle_end/flambda/projection.ml index 2c660a2a28..2c660a2a28 100644 --- a/middle_end/projection.ml +++ b/middle_end/flambda/projection.ml diff --git a/middle_end/projection.mli b/middle_end/flambda/projection.mli index 1b251ca262..1b251ca262 100644 --- a/middle_end/projection.mli +++ b/middle_end/flambda/projection.mli diff --git a/middle_end/ref_to_variables.ml b/middle_end/flambda/ref_to_variables.ml index f93948f912..f93948f912 100644 --- a/middle_end/ref_to_variables.ml +++ b/middle_end/flambda/ref_to_variables.ml diff --git a/middle_end/ref_to_variables.mli b/middle_end/flambda/ref_to_variables.mli index 38d3688917..38d3688917 100644 --- a/middle_end/ref_to_variables.mli +++ b/middle_end/flambda/ref_to_variables.mli diff --git a/middle_end/remove_free_vars_equal_to_args.ml b/middle_end/flambda/remove_free_vars_equal_to_args.ml index 6327d30cda..6327d30cda 100644 --- a/middle_end/remove_free_vars_equal_to_args.ml +++ b/middle_end/flambda/remove_free_vars_equal_to_args.ml diff --git a/middle_end/remove_free_vars_equal_to_args.mli b/middle_end/flambda/remove_free_vars_equal_to_args.mli index 49f25ac106..49f25ac106 100644 --- a/middle_end/remove_free_vars_equal_to_args.mli +++ b/middle_end/flambda/remove_free_vars_equal_to_args.mli diff --git a/middle_end/remove_unused_arguments.ml b/middle_end/flambda/remove_unused_arguments.ml index f70da729ae..f70da729ae 100644 --- a/middle_end/remove_unused_arguments.ml +++ b/middle_end/flambda/remove_unused_arguments.ml diff --git a/middle_end/remove_unused_arguments.mli b/middle_end/flambda/remove_unused_arguments.mli index 759b32f2d2..759b32f2d2 100644 --- a/middle_end/remove_unused_arguments.mli +++ b/middle_end/flambda/remove_unused_arguments.mli diff --git a/middle_end/remove_unused_closure_vars.ml b/middle_end/flambda/remove_unused_closure_vars.ml index 0d4ad621dd..0d4ad621dd 100644 --- a/middle_end/remove_unused_closure_vars.ml +++ b/middle_end/flambda/remove_unused_closure_vars.ml diff --git a/middle_end/remove_unused_closure_vars.mli b/middle_end/flambda/remove_unused_closure_vars.mli index 225697a814..225697a814 100644 --- a/middle_end/remove_unused_closure_vars.mli +++ b/middle_end/flambda/remove_unused_closure_vars.mli diff --git a/middle_end/remove_unused_program_constructs.ml b/middle_end/flambda/remove_unused_program_constructs.ml index 059d68bcba..059d68bcba 100644 --- a/middle_end/remove_unused_program_constructs.ml +++ b/middle_end/flambda/remove_unused_program_constructs.ml diff --git a/middle_end/remove_unused_program_constructs.mli b/middle_end/flambda/remove_unused_program_constructs.mli index 3a722011bb..3a722011bb 100644 --- a/middle_end/remove_unused_program_constructs.mli +++ b/middle_end/flambda/remove_unused_program_constructs.mli diff --git a/middle_end/share_constants.ml b/middle_end/flambda/share_constants.ml index 2bbd7134b8..2bbd7134b8 100644 --- a/middle_end/share_constants.ml +++ b/middle_end/flambda/share_constants.ml diff --git a/middle_end/share_constants.mli b/middle_end/flambda/share_constants.mli index 7fec22bc44..7fec22bc44 100644 --- a/middle_end/share_constants.mli +++ b/middle_end/flambda/share_constants.mli diff --git a/middle_end/simple_value_approx.ml b/middle_end/flambda/simple_value_approx.ml index 34fc5ce056..34fc5ce056 100644 --- a/middle_end/simple_value_approx.ml +++ b/middle_end/flambda/simple_value_approx.ml diff --git a/middle_end/simple_value_approx.mli b/middle_end/flambda/simple_value_approx.mli index dd38652f5b..dd38652f5b 100644 --- a/middle_end/simple_value_approx.mli +++ b/middle_end/flambda/simple_value_approx.mli diff --git a/middle_end/simplify_boxed_integer_ops.ml b/middle_end/flambda/simplify_boxed_integer_ops.ml index 1f95a1ec2d..1f95a1ec2d 100644 --- a/middle_end/simplify_boxed_integer_ops.ml +++ b/middle_end/flambda/simplify_boxed_integer_ops.ml diff --git a/middle_end/simplify_boxed_integer_ops.mli b/middle_end/flambda/simplify_boxed_integer_ops.mli index f3461043a1..f3461043a1 100644 --- a/middle_end/simplify_boxed_integer_ops.mli +++ b/middle_end/flambda/simplify_boxed_integer_ops.mli diff --git a/middle_end/simplify_boxed_integer_ops_intf.mli b/middle_end/flambda/simplify_boxed_integer_ops_intf.mli index f30987ae11..f30987ae11 100644 --- a/middle_end/simplify_boxed_integer_ops_intf.mli +++ b/middle_end/flambda/simplify_boxed_integer_ops_intf.mli diff --git a/middle_end/simplify_common.ml b/middle_end/flambda/simplify_common.ml index fcbbcfbcba..fcbbcfbcba 100644 --- a/middle_end/simplify_common.ml +++ b/middle_end/flambda/simplify_common.ml diff --git a/middle_end/simplify_common.mli b/middle_end/flambda/simplify_common.mli index c667bfffe5..c667bfffe5 100644 --- a/middle_end/simplify_common.mli +++ b/middle_end/flambda/simplify_common.mli diff --git a/middle_end/simplify_primitives.ml b/middle_end/flambda/simplify_primitives.ml index 349d2f40ba..349d2f40ba 100644 --- a/middle_end/simplify_primitives.ml +++ b/middle_end/flambda/simplify_primitives.ml diff --git a/middle_end/simplify_primitives.mli b/middle_end/flambda/simplify_primitives.mli index a6b6330c03..a6b6330c03 100644 --- a/middle_end/simplify_primitives.mli +++ b/middle_end/flambda/simplify_primitives.mli 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/unbox_closures.ml b/middle_end/flambda/unbox_closures.ml index 5c86bed3da..5c86bed3da 100644 --- a/middle_end/unbox_closures.ml +++ b/middle_end/flambda/unbox_closures.ml diff --git a/middle_end/unbox_closures.mli b/middle_end/flambda/unbox_closures.mli index fb935a622b..fb935a622b 100644 --- a/middle_end/unbox_closures.mli +++ b/middle_end/flambda/unbox_closures.mli diff --git a/middle_end/unbox_free_vars_of_closures.ml b/middle_end/flambda/unbox_free_vars_of_closures.ml index 7a4e48ed44..7a4e48ed44 100644 --- a/middle_end/unbox_free_vars_of_closures.ml +++ b/middle_end/flambda/unbox_free_vars_of_closures.ml diff --git a/middle_end/unbox_free_vars_of_closures.mli b/middle_end/flambda/unbox_free_vars_of_closures.mli index 3ee181ee3c..3ee181ee3c 100644 --- a/middle_end/unbox_free_vars_of_closures.mli +++ b/middle_end/flambda/unbox_free_vars_of_closures.mli diff --git a/middle_end/unbox_specialised_args.ml b/middle_end/flambda/unbox_specialised_args.ml index 70eb87601a..70eb87601a 100644 --- a/middle_end/unbox_specialised_args.ml +++ b/middle_end/flambda/unbox_specialised_args.ml diff --git a/middle_end/unbox_specialised_args.mli b/middle_end/flambda/unbox_specialised_args.mli index f019176482..f019176482 100644 --- a/middle_end/unbox_specialised_args.mli +++ b/middle_end/flambda/unbox_specialised_args.mli 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/base_types/linkage_name.ml b/middle_end/linkage_name.ml index 46febfba8f..46febfba8f 100644 --- a/middle_end/base_types/linkage_name.ml +++ b/middle_end/linkage_name.ml diff --git a/middle_end/base_types/linkage_name.mli b/middle_end/linkage_name.mli index 58731917cd..58731917cd 100644 --- a/middle_end/base_types/linkage_name.mli +++ b/middle_end/linkage_name.mli 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@ @[<hv 1>(@[<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@ @[<hv 1>(@[<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@ (@[<hv 1>%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 + "@[<v 0>@[<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 "@[<hv 1>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 "@[<hv 1>default:@ %a@]" lam d + | None -> () + end in + fprintf ppf + "@[<1>(switch %a@ @[<v 0>%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 "@[<hov 1>(%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/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/base_types/symbol.ml b/middle_end/symbol.ml index 22a2e0a70e..22a2e0a70e 100644 --- a/middle_end/base_types/symbol.ml +++ b/middle_end/symbol.ml diff --git a/middle_end/base_types/symbol.mli b/middle_end/symbol.mli index d2771af244..d2771af244 100644 --- a/middle_end/base_types/symbol.mli +++ b/middle_end/symbol.mli diff --git a/middle_end/base_types/variable.ml b/middle_end/variable.ml index 64099a73b6..64099a73b6 100644 --- a/middle_end/base_types/variable.ml +++ b/middle_end/variable.ml diff --git a/middle_end/base_types/variable.mli b/middle_end/variable.mli index b5d3f136ae..b5d3f136ae 100644 --- a/middle_end/base_types/variable.mli +++ b/middle_end/variable.mli |