diff --git a/backend/debug/dwarf/dwarf_flags/dwarf_flags.ml b/backend/debug/dwarf/dwarf_flags/dwarf_flags.ml index bba42afc40a..241b5cb8ba3 100644 --- a/backend/debug/dwarf/dwarf_flags/dwarf_flags.ml +++ b/backend/debug/dwarf/dwarf_flags/dwarf_flags.ml @@ -141,3 +141,5 @@ let default_gdwarf_self_tail_calls = true let gdwarf_self_tail_calls = ref default_gdwarf_self_tail_calls let gdwarf_may_alter_codegen = ref false + +let dwarf_inlined_frames = ref false diff --git a/backend/debug/dwarf/dwarf_flags/dwarf_flags.mli b/backend/debug/dwarf/dwarf_flags/dwarf_flags.mli index e3da3e987dc..661f23bf8c6 100644 --- a/backend/debug/dwarf/dwarf_flags/dwarf_flags.mli +++ b/backend/debug/dwarf/dwarf_flags/dwarf_flags.mli @@ -68,3 +68,9 @@ val default_ddebug_invariants : bool val ddebug_invariants : bool ref val gdwarf_may_alter_codegen : bool ref + +(** Setting this to [true] will emit sufficient DWARF to get inlined frame + information, but won't emit information e.g. about local variables (unless + [restrict_to_upstream_dwarf] is set to [false], although that implies + this variable being set to [true]). *) +val dwarf_inlined_frames : bool ref diff --git a/backend/debug/dwarf/dwarf_ocaml/dwarf.ml b/backend/debug/dwarf/dwarf_ocaml/dwarf.ml index e6d8959f98a..fa9baf53dd0 100644 --- a/backend/debug/dwarf/dwarf_ocaml/dwarf.ml +++ b/backend/debug/dwarf/dwarf_ocaml/dwarf.ml @@ -61,6 +61,9 @@ let create ~sourcefile ~unit_name ~asm_directives ~get_file_id ~code_begin DS.create ~compilation_unit_header_label ~compilation_unit_proto_die ~value_type_proto_die ~start_of_code_symbol debug_loc_table debug_ranges_table address_table location_list_table + ~get_file_num:get_file_id + (* CR mshinwell: does get_file_id successfully emit .file directives for + files we haven't seen before? *) in { state; asm_directives; @@ -75,18 +78,29 @@ type fundecl = } let dwarf_for_fundecl t fundecl ~fun_end_label = - if not (!Clflags.debug && not !Dwarf_flags.restrict_to_upstream_dwarf) + if not + (!Clflags.debug + && ((not !Dwarf_flags.restrict_to_upstream_dwarf) + || !Dwarf_flags.dwarf_inlined_frames)) then { fun_end_label; fundecl } else let available_ranges_vars, fundecl = - Profile.record "debug_available_ranges_vars" - (fun fundecl -> Available_ranges_vars.create fundecl) + if not !Dwarf_flags.restrict_to_upstream_dwarf + then + Profile.record "debug_available_ranges_vars" + (fun fundecl -> Available_ranges_vars.create fundecl) + ~accumulate:true fundecl + else Available_ranges_vars.empty, fundecl + in + let inlined_frame_ranges, fundecl = + Profile.record "debug_inlined_frame_ranges" + (fun fundecl -> Inlined_frame_ranges.create fundecl) ~accumulate:true fundecl in Dwarf_concrete_instances.for_fundecl ~get_file_id:t.get_file_id t.state fundecl ~fun_end_label:(Asm_label.create_int Text fun_end_label) - available_ranges_vars; + available_ranges_vars inlined_frame_ranges; { fun_end_label; fundecl } let emit t ~basic_block_sections ~binary_backend_available = diff --git a/backend/debug/dwarf/dwarf_ocaml/dwarf_abstract_instances.ml b/backend/debug/dwarf/dwarf_ocaml/dwarf_abstract_instances.ml new file mode 100644 index 00000000000..1e4c51b1a5d --- /dev/null +++ b/backend/debug/dwarf/dwarf_ocaml/dwarf_abstract_instances.ml @@ -0,0 +1,180 @@ +(****************************************************************************** + * flambda-backend * + * Mark Shinwell, Jane Street * + * -------------------------------------------------------------------------- * + * MIT License * + * * + * Copyright (c) 2024 Jane Street Group LLC * + * opensource-contacts@janestreet.com * + * * + * Permission is hereby granted, free of charge, to any person obtaining a * + * copy of this software and associated documentation files (the "Software"), * + * to deal in the Software without restriction, including without limitation * + * the rights to use, copy, modify, merge, publish, distribute, sublicense, * + * and/or sell copies of the Software, and to permit persons to whom the * + * Software is furnished to do so, subject to the following conditions: * + * * + * The above copyright notice and this permission notice shall be included * + * in all copies or substantial portions of the Software. * + * * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL * + * THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * + * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * + * DEALINGS IN THE SOFTWARE. * + ******************************************************************************) + +open! Asm_targets +open! Dwarf_low +open! Dwarf_high +module DAH = Dwarf_attribute_helpers +module DS = Dwarf_state +module L = Linear + +let attributes fun_name = + [DAH.create_name fun_name; DAH.create_external ~is_visible_externally:true] + +let abstract_instance_proto_die_symbol ~fun_symbol = + Asm_symbol.create (Asm_symbol.to_raw_string fun_symbol ^ "_absinst") + +let add_empty state ~compilation_unit_proto_die ~fun_symbol ~demangled_name = + let abstract_instance_proto_die = + (* DWARF-5 specification section 3.3.8.1, page 82. *) + Proto_die.create ~parent:(Some compilation_unit_proto_die) ~tag:Subprogram + ~attribute_values: + [ DAH.create_name (Asm_symbol.encode fun_symbol); + DAH.create_linkage_name ~linkage_name:demangled_name; + DAH.create_external ~is_visible_externally:true ] + () + in + let abstract_instance_proto_die_symbol = + abstract_instance_proto_die_symbol ~fun_symbol + in + Proto_die.set_name abstract_instance_proto_die + abstract_instance_proto_die_symbol; + Asm_symbol.Tbl.add + (DS.function_abstract_instances state) + fun_symbol + (abstract_instance_proto_die, abstract_instance_proto_die_symbol); + abstract_instance_proto_die, abstract_instance_proto_die_symbol + +let add_root state ~parent ~demangled_name fun_symbol ~location_attributes = + let attributes = + [ DAH.create_name (Asm_symbol.encode fun_symbol); + DAH.create_linkage_name ~linkage_name:demangled_name; + DAH.create_external ~is_visible_externally:true ] + @ location_attributes + in + let attribute_values = + attributes + @ [ (* We assume every function might potentially be inlined (and possibly + in the future), so we choose [DW_INL_inlined] as the most appropriate + setting for [DW_AT_inline], even if it doesn't seem exactly correct. + We must set something here to ensure that the subprogram is marked as + an abstract instance root. *) + (* CR mshinwell/xclerc: we could propagate "inline never" attributes to + this point *) + DAH.create_inline Inlined ] + in + let abstract_instance_proto_die_symbol = + abstract_instance_proto_die_symbol ~fun_symbol + in + DS.Debug.log "add_root: fun_symbol=%a\n" Asm_symbol.print fun_symbol; + let abstract_instance_proto_die = + match + Asm_symbol.Tbl.find (DS.function_abstract_instances state) fun_symbol + with + | proto_die, _symbol -> + (* See below in [find] *) + Proto_die.replace_all_attribute_values proto_die attribute_values + | exception Not_found -> + (* DWARF-5 specification section 3.3.8.1, page 82. *) + Proto_die.create ~parent:(Some parent) ~tag:Subprogram ~attribute_values + () + in + Proto_die.set_name abstract_instance_proto_die + abstract_instance_proto_die_symbol; + Asm_symbol.Tbl.add (* or replace *) + (DS.function_abstract_instances state) + fun_symbol + (abstract_instance_proto_die, abstract_instance_proto_die_symbol); + abstract_instance_proto_die, abstract_instance_proto_die_symbol + +type decomposed_singleton_debuginfo = + { demangled_name : string; + fun_symbol : Asm_symbol.t; + compilation_unit : Compilation_unit.t + } + +let decompose_singleton_debuginfo dbg = + let orig_dbg = dbg in + match Debuginfo.to_items dbg with + | [({ dinfo_scopes; dinfo_function_symbol; _ } as item)] -> ( + let module S = Debuginfo.Scoped_location in + let compilation_unit = S.compilation_unit dinfo_scopes in + let dbg = Debuginfo.of_items [item] in + let fun_symbol = + match dinfo_function_symbol with + | Some dinfo_function_symbol -> Asm_symbol.create dinfo_function_symbol + | None -> + Misc.fatal_errorf + "No function symbol in Debuginfo.t: orig_dbg=%a dbg=%a" + Debuginfo.print_compact_extended orig_dbg + Debuginfo.print_compact_extended dbg + in + let demangled_name = + Debuginfo.Scoped_location.string_of_scopes dinfo_scopes + |> Misc.remove_double_underscores + in + match compilation_unit with + | Some compilation_unit -> { demangled_name; fun_symbol; compilation_unit } + | None -> + Misc.fatal_errorf "No compilation unit extracted from: %a" + Debuginfo.print_compact_extended dbg) + | [] -> Misc.fatal_error "Empty Debuginfo.t" + | _ :: _ -> + Misc.fatal_errorf "Non-singleton Debuginfo.t: %a" + Debuginfo.print_compact_extended dbg + +type find_result = + | Ok of Asm_symbol.t + | External_unit of + { demangled_name : string; + fun_symbol : Asm_symbol.t + } + +let find state ~compilation_unit_proto_die (dbg : Debuginfo.t) = + let { demangled_name; fun_symbol; compilation_unit = dbg_comp_unit } = + decompose_singleton_debuginfo dbg + in + DS.Debug.log "found comp unit %a\n%!" Compilation_unit.print dbg_comp_unit; + let this_comp_unit = Compilation_unit.get_current_exn () in + if Compilation_unit.equal dbg_comp_unit this_comp_unit + then ( + DS.Debug.log "looking in function_abstract_instances for %a\n%!" + Asm_symbol.print fun_symbol; + match + Asm_symbol.Tbl.find (DS.function_abstract_instances state) fun_symbol + with + | existing_instance -> + DS.Debug.log "...successfully found existing absint DIE\n%!"; + Ok (snd existing_instance) + | exception Not_found -> + (* Fabricate an empty abstract instance DIE to fill in later, just in case + we haven't seen things in topological order. *) + (* CR mshinwell: does that actually happen now? *) + DS.Debug.log "...making empty absint DIE for %a\n" Asm_symbol.print + fun_symbol; + (* The empty abstract instances are parented to the compilation unit as + they might be referenced by other DIEs in a completely different scope + within the current unit. *) + let _, die_symbol = + add_empty state ~compilation_unit_proto_die ~fun_symbol ~demangled_name + in + Ok die_symbol) + else + (* abstract_instance_proto_die_symbol ~fun_symbol *) + (* See the call site of this function *) + External_unit { demangled_name; fun_symbol } diff --git a/backend/debug/dwarf/dwarf_ocaml/dwarf_abstract_instances.mli b/backend/debug/dwarf/dwarf_ocaml/dwarf_abstract_instances.mli new file mode 100644 index 00000000000..53b1d0830dc --- /dev/null +++ b/backend/debug/dwarf/dwarf_ocaml/dwarf_abstract_instances.mli @@ -0,0 +1,59 @@ +(****************************************************************************** + * flambda-backend * + * Mark Shinwell, Jane Street * + * -------------------------------------------------------------------------- * + * MIT License * + * * + * Copyright (c) 2024 Jane Street Group LLC * + * opensource-contacts@janestreet.com * + * * + * Permission is hereby granted, free of charge, to any person obtaining a * + * copy of this software and associated documentation files (the "Software"), * + * to deal in the Software without restriction, including without limitation * + * the rights to use, copy, modify, merge, publish, distribute, sublicense, * + * and/or sell copies of the Software, and to permit persons to whom the * + * Software is furnished to do so, subject to the following conditions: * + * * + * The above copyright notice and this permission notice shall be included * + * in all copies or substantial portions of the Software. * + * * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL * + * THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * + * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * + * DEALINGS IN THE SOFTWARE. * + ******************************************************************************) + +(** Management of DWARF "abstract instances" for functions. *) + +open! Asm_targets +open! Dwarf_low +open! Dwarf_high + +val attributes : string -> Dwarf_attribute_values.Attribute_value.t list + +(** Add an abstract instance root. *) +val add_root : + Dwarf_state.t -> + parent:Proto_die.t -> + demangled_name:string -> + Asm_symbol.t -> + location_attributes:Dwarf_attribute_values.Attribute_value.t list -> + Proto_die.t * Asm_symbol.t + +type find_result = private + | Ok of Asm_symbol.t + | External_unit of + { demangled_name : string; + fun_symbol : Asm_symbol.t + } + +val find : + Dwarf_state.t -> + compilation_unit_proto_die:Proto_die.t -> + Debuginfo.t -> + find_result +(* val find_maybe_in_another_unit_or_add : Dwarf_state.t -> + function_proto_die:Proto_die.t -> Linear.fundecl -> Asm_symbol.t option *) diff --git a/backend/debug/dwarf/dwarf_ocaml/dwarf_concrete_instances.ml b/backend/debug/dwarf/dwarf_ocaml/dwarf_concrete_instances.ml index 93bce1aeb82..f540af91787 100644 --- a/backend/debug/dwarf/dwarf_ocaml/dwarf_concrete_instances.ml +++ b/backend/debug/dwarf/dwarf_ocaml/dwarf_concrete_instances.ml @@ -17,44 +17,24 @@ open Asm_targets open Dwarf_high module DAH = Dwarf_attribute_helpers +module DS = Dwarf_state module L = Linear -let remove_double_underscores s = - let len = String.length s in - let buf = Buffer.create len in - let skip = ref false in - let rec loop i = - if i < len - then ( - let c = String.get s i in - if c = '.' then skip := true; - if (not !skip) && c = '_' && i + 1 < len && String.get s (i + 1) = '_' - then ( - Buffer.add_char buf '.'; - skip := true; - loop (i + 2)) - else ( - Buffer.add_char buf c; - loop (i + 1))) - in - loop 0; - Buffer.contents buf - let for_fundecl ~get_file_id state (fundecl : L.fundecl) ~fun_end_label - available_ranges_vars = + available_ranges_vars inlined_frame_ranges = let parent = Dwarf_state.compilation_unit_proto_die state in let fun_name = fundecl.fun_name in + let loc = Debuginfo.to_location fundecl.fun_dbg in let linkage_name = match Debuginfo.Dbg.to_list (Debuginfo.get_dbg fundecl.fun_dbg) with | [item] -> Debuginfo.Scoped_location.string_of_scopes item.dinfo_scopes - |> remove_double_underscores - (* Not sure what to do in the cases below *) + |> Misc.remove_double_underscores + (* XXX Not sure what to do in the cases below *) | [] | _ :: _ -> fun_name in let start_sym = Asm_symbol.create fun_name in let location_attributes = - let loc = Debuginfo.to_location fundecl.fun_dbg in if Location.is_none loc then [DAH.create_artificial ()] else @@ -70,27 +50,39 @@ let for_fundecl ~get_file_id state (fundecl : L.fundecl) ~fun_end_label :: DAH.create_decl_column startchar :: attributes in + let _abstract_instance_root_proto_die, _abstract_instance_root_symbol = + (* Add the abstract instance root for this function *) + DS.Debug.log "*** Adding absint root for %s\n%!" fundecl.fun_name; + Dwarf_abstract_instances.add_root state ~parent ~demangled_name:linkage_name + start_sym ~location_attributes + in let attribute_values = - location_attributes - @ [ DAH.create_name fun_name; - DAH.create_linkage_name ~linkage_name; - DAH.create_low_pc_from_symbol start_sym; - DAH.create_high_pc ~low_pc:start_sym fun_end_label; - (* CR mshinwell: Probably no need to set this at the moment since the - low PC value should be assumed, which is correct. *) - DAH.create_entry_pc_from_symbol start_sym; - DAH.create_stmt_list - ~debug_line_label:(Asm_label.for_dwarf_section Asm_section.Debug_line) - ] + [ DAH.create_low_pc_from_symbol start_sym; + DAH.create_high_pc ~low_pc:start_sym fun_end_label; + (* CR mshinwell: Probably no need to set this at the moment since the low + PC value should be assumed, which is correct. *) + DAH.create_entry_pc_from_symbol start_sym; + DAH.create_stmt_list + ~debug_line_label:(Asm_label.for_dwarf_section Asm_section.Debug_line); + DAH.create_abstract_origin ~die_symbol:_abstract_instance_root_symbol ] in let concrete_instance_proto_die = Proto_die.create ~parent:(Some parent) ~tag:Subprogram ~attribute_values () in - Profile.record "dwarf_variables_and_parameters" - (fun () -> - Dwarf_variables_and_parameters.dwarf state - ~function_proto_die:concrete_instance_proto_die available_ranges_vars) - ~accumulate:true (); + let _inlined_frame_proto_dies = + Profile.record "dwarf_inlined_frames" + (fun () -> + Dwarf_inlined_frames.dwarf state fundecl + ~function_proto_die:concrete_instance_proto_die inlined_frame_ranges) + ~accumulate:true () + in + if not !Dwarf_flags.restrict_to_upstream_dwarf + then + Profile.record "dwarf_variables_and_parameters" + (fun () -> + Dwarf_variables_and_parameters.dwarf state + ~function_proto_die:concrete_instance_proto_die available_ranges_vars) + ~accumulate:true (); (* CR mshinwell: When cross-referencing of DIEs across files is necessary we need to be careful about symbol table size. let name = Printf.sprintf "__concrete_instance_%s" fun_name in Proto_die.set_name diff --git a/backend/debug/dwarf/dwarf_ocaml/dwarf_concrete_instances.mli b/backend/debug/dwarf/dwarf_ocaml/dwarf_concrete_instances.mli index aa2478f6cd3..49e2d7a67d8 100644 --- a/backend/debug/dwarf/dwarf_ocaml/dwarf_concrete_instances.mli +++ b/backend/debug/dwarf/dwarf_ocaml/dwarf_concrete_instances.mli @@ -18,4 +18,5 @@ val for_fundecl : Linear.fundecl -> fun_end_label:Asm_targets.Asm_label.t -> Available_ranges_vars.t -> + Inlined_frame_ranges.t -> unit diff --git a/backend/debug/dwarf/dwarf_ocaml/dwarf_inlined_frames.ml b/backend/debug/dwarf/dwarf_ocaml/dwarf_inlined_frames.ml new file mode 100644 index 00000000000..b179e896e6f --- /dev/null +++ b/backend/debug/dwarf/dwarf_ocaml/dwarf_inlined_frames.ml @@ -0,0 +1,339 @@ +(****************************************************************************** + * flambda-backend * + * Mark Shinwell, Jane Street * + * -------------------------------------------------------------------------- * + * MIT License * + * * + * Copyright (c) 2024 Jane Street Group LLC * + * opensource-contacts@janestreet.com * + * * + * Permission is hereby granted, free of charge, to any person obtaining a * + * copy of this software and associated documentation files (the "Software"), * + * to deal in the Software without restriction, including without limitation * + * the rights to use, copy, modify, merge, publish, distribute, sublicense, * + * and/or sell copies of the Software, and to permit persons to whom the * + * Software is furnished to do so, subject to the following conditions: * + * * + * The above copyright notice and this permission notice shall be included * + * in all copies or substantial portions of the Software. * + * * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL * + * THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * + * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * + * DEALINGS IN THE SOFTWARE. * + ******************************************************************************) + +open! Asm_targets +open! Dwarf_low +open! Dwarf_high +module DAH = Dwarf_attribute_helpers +module DS = Dwarf_state +module IF = Inlined_frame_ranges +module K = IF.Inlined_frames.Key +module L = Linear +module String = Misc.Stdlib.String + +type ranges = + | Contiguous of + { start_pos : Asm_label.t; + start_pos_offset : int; + end_pos : Asm_label.t; + end_pos_offset : int + } + | Discontiguous of + Dwarf_4_range_list_entry.t list * Range_list.t * Address_index.Pair.Set.t + +let create_contiguous_range_list_and_summarise subrange = + let start_pos = IF.Subrange.start_pos subrange in + let start_pos_offset = IF.Subrange.start_pos_offset subrange in + let end_pos = IF.Subrange.end_pos subrange in + let end_pos_offset = IF.Subrange.end_pos_offset subrange in + Contiguous + { start_pos = Asm_label.create_int Text start_pos; + start_pos_offset; + end_pos = Asm_label.create_int Text end_pos; + end_pos_offset + } + +let create_discontiguous_range_list_entry state dwarf_4_range_list_entries + range_list summary subrange = + let start_pos = IF.Subrange.start_pos subrange in + let start_pos_offset = IF.Subrange.start_pos_offset subrange in + let end_pos = IF.Subrange.end_pos subrange in + let end_pos_offset = IF.Subrange.end_pos_offset subrange in + let start_of_code_symbol = DS.start_of_code_symbol state in + let start_inclusive = + Address_table.add (DS.address_table state) + (Asm_label.create_int Text start_pos) + ~adjustment:start_pos_offset ~start_of_code_symbol + in + let end_exclusive = + Address_table.add (DS.address_table state) + (Asm_label.create_int Text end_pos) + ~adjustment:end_pos_offset ~start_of_code_symbol + in + let range_list_entry : Range_list_entry.entry = + (* DWARF-5 spec page 54 line 1. *) + Startx_endx { start_inclusive; end_exclusive; payload = () } + in + let range_list_entry = + Range_list_entry.create range_list_entry ~start_of_code_symbol + in + (* We still use the [Range_list] when emitting DWARF-4 (even though it is a + DWARF-5 structure) for the purposes of de-duplicating ranges. *) + let range_list = Range_list.add range_list range_list_entry in + let summary = + Address_index.Pair.Set.add (start_inclusive, end_exclusive) summary + in + match !Dwarf_flags.gdwarf_version with + | Four -> + let range_list_entry = + Dwarf_4_range_list_entry.create_range_list_entry + ~start_of_code_symbol:(DS.start_of_code_symbol state) + ~first_address_when_in_scope:(Asm_label.create_int Text start_pos) + ~first_address_when_not_in_scope:(Asm_label.create_int Text end_pos) + ~first_address_when_not_in_scope_offset:(Some end_pos_offset) + in + DS.Debug.log "range_list_entry: start=%d end=%d+%d\n%!" start_pos end_pos + end_pos_offset; + range_list_entry :: dwarf_4_range_list_entries, range_list, summary + | Five -> dwarf_4_range_list_entries, range_list, summary + +let create_discontiguous_range_list_and_summarise state range = + let dwarf_4_range_list_entries, range_list, summary = + IF.Range.fold range + ~init:([], Range_list.create (), Address_index.Pair.Set.empty) + ~f:(fun (dwarf_4_range_list_entries, range_list, summary) subrange -> + create_discontiguous_range_list_entry state dwarf_4_range_list_entries + range_list summary subrange) + in + Discontiguous (dwarf_4_range_list_entries, range_list, summary) + +let create_range_list_and_summarise state range = + match IF.Range.get_singleton range with + | No_ranges -> None + | One_subrange subrange -> + Some (create_contiguous_range_list_and_summarise subrange) + | More_than_one_subrange -> + Some (create_discontiguous_range_list_and_summarise state range) + +(* "Summaries", sets of pairs of the starting and ending points of ranges, are + used to dedup entries in the range list table. We do this for range lists but + not yet for location lists since deduping entries in the latter would involve + comparing DWARF location descriptions. *) +module All_summaries = Identifiable.Make (struct + include Address_index.Pair.Set + + let hash t = Hashtbl.hash (elements t) +end) + +let die_for_inlined_frame state ~compilation_unit_proto_die ~parent + range_list_attributes block = + let abstract_instance_symbol = + Dwarf_abstract_instances.find state ~compilation_unit_proto_die block + in + let abstract_instance = + match abstract_instance_symbol with + | Ok abstract_instance_symbol -> + [DAH.create_abstract_origin ~die_symbol:abstract_instance_symbol] + | External_unit { demangled_name; fun_symbol } -> + (* CR mshinwell: fix references to DIEs across object files + + Note from discussion with gbury 2024-04-26: there is going to be a + problem if a piece of code in a different unit actually got deleted, + and in the current unit an inlining stack mentions it. *) + (* For references to DIEs in other units, we reconstitute as many of their + attributes as we can and put them directly into the DIE for the inlined + frame, making use of DWARF-5 spec page 85, line 30 onwards. This won't + provide parameter information for the functions concerned, but will do + for now, until we sort out how to properly reference DIEs across units + (in a way which will also work on macOS). In particular it should + otherwise suffice for backtraces. *) + [ DAH.create_name (Asm_symbol.encode fun_symbol); + DAH.create_linkage_name ~linkage_name:demangled_name; + DAH.create_external ~is_visible_externally:true ] + in + let block : Debuginfo.item = List.hd (Debuginfo.to_items block) in + Proto_die.create ~parent:(Some parent) ~tag:Inlined_subroutine + ~attribute_values: + (abstract_instance @ range_list_attributes + @ [DAH.create_call_file (Dwarf_state.get_file_num state block.dinfo_file)] + @ (if block.dinfo_line >= 0 + then [DAH.create_call_line block.dinfo_line] + else []) + @ + if block.dinfo_char_start >= 0 + then [DAH.create_call_column block.dinfo_char_start] + else []) + () + +let create_range_list_attributes_and_summarise state range all_summaries = + match create_range_list_and_summarise state range with + | None -> [], all_summaries + | Some (Contiguous { start_pos; start_pos_offset; end_pos; end_pos_offset }) + -> + (* Save space by avoiding the emission of a range list. *) + let start_pos_offset = Targetint.of_int start_pos_offset in + let end_pos_offset = Targetint.of_int end_pos_offset in + let low_pc = + DAH.create_low_pc_with_offset start_pos ~offset_in_bytes:start_pos_offset + in + let high_pc = + DAH.create_high_pc_offset ~low_pc:start_pos + ~low_pc_offset_in_bytes:start_pos_offset ~high_pc:end_pos + ~high_pc_offset_in_bytes:end_pos_offset + in + [low_pc; high_pc], all_summaries + | Some (Discontiguous (dwarf_4_range_list_entries, _range_list, summary)) -> ( + match All_summaries.Map.find summary all_summaries with + | exception Not_found -> + let range_list_attributes = + match !Dwarf_flags.gdwarf_version with + | Four -> + let range_list = + Dwarf_4_range_list.create + ~range_list_entries:dwarf_4_range_list_entries + in + let range_list_attribute = + Debug_ranges_table.insert (DS.debug_ranges_table state) ~range_list + in + [range_list_attribute] + | Five -> + (* CR mshinwell: implement DWARF-5 support *) + (* let range_list_index = Range_list_table.add (DS.range_list_table + state) range_list in DAH.create_ranges range_list_index *) + Misc.fatal_error "not yet implemented" + in + let all_summaries = + All_summaries.Map.add summary range_list_attributes all_summaries + in + range_list_attributes, all_summaries + | range_list_attributes -> range_list_attributes, all_summaries) + +let rec create_down_to_innermost_frame fundecl state ~compilation_unit_proto_die + ~(prefix : Debuginfo.item list) ~(blocks_outermost_first : Debuginfo.t) + scope_proto_dies all_summaries ~parent_die range inlined_frame_ranges = + DS.Debug.log ">> create_down_to_innermost_frame: %a || %a\n%!" + Debuginfo.print_compact_extended + (Debuginfo.of_items prefix) + Debuginfo.print_compact_extended blocks_outermost_first; + match Debuginfo.to_items blocks_outermost_first with + | [] -> + (* Empty inlining stack for some reason, just ignore it. *) + scope_proto_dies, all_summaries + | block_item :: deeper_blocks -> ( + let block = Debuginfo.of_items [block_item] in + DS.Debug.log "...the current block is %a\n%!" + Debuginfo.print_compact_extended block; + (* The key of [scope_proto_dies] is the current prefix concatenated to to + the current block. It seems like maybe just the current block could be + used, but that would cause incorrect conflation of DIEs when a given + function symbol occurs more than once in any particular inlining stack. + (For example if [f] is inlined into itself, then two separate DIEs should + be produced.) *) + let scope_key = Debuginfo.of_items (prefix @ [block_item]) in + match K.Map.find scope_key scope_proto_dies with + | existing_die -> + DS.Debug.log "prefix+block already has a proto DIE (ref %a)\n%!" + Asm_label.print + (Proto_die.reference existing_die); + create_down_to_innermost_frame fundecl state ~compilation_unit_proto_die + ~prefix:(prefix @ [block_item]) + ~blocks_outermost_first:(Debuginfo.of_items deeper_blocks) + scope_proto_dies all_summaries ~parent_die:existing_die range + inlined_frame_ranges + | exception Not_found -> + (* See comment in the [dwarf] function below. The DIEs for everything + except the innermost inlined frame should already exist because of the + order of iteration over ranges. *) + (match deeper_blocks with + | [] -> () + | _ :: _ -> + Misc.fatal_errorf + "Dwarf_inlined_frames.create_down_to_innermost_frame:@ Expected DIE \ + for %a to already have been created.@ Full inlining stack is:@ %a \ + || %a@ All ranges for %s:@ %a%!" + Debuginfo.print_compact_extended block + Debuginfo.print_compact_extended + (Debuginfo.of_items prefix) + Debuginfo.print_compact_extended blocks_outermost_first + fundecl.L.fun_name IF.print inlined_frame_ranges); + DS.Debug.log "New DIE will be needed, parent DIE ref is %a\n%!" + Asm_label.print + (Proto_die.reference parent_die); + let range_list_attributes, all_summaries = + create_range_list_attributes_and_summarise state range all_summaries + in + let inlined_subroutine_die = + die_for_inlined_frame state ~compilation_unit_proto_die + ~parent:parent_die range_list_attributes block + in + DS.Debug.log "Our DIE ref (DW_TAG_inlined_subroutine) for %a is %a\n%!" + Debuginfo.print_compact_extended block Asm_label.print + (Proto_die.reference inlined_subroutine_die); + let scope_proto_dies = + K.Map.add scope_key inlined_subroutine_die scope_proto_dies + in + scope_proto_dies, all_summaries) + +let dwarf state (fundecl : L.fundecl) inlined_frame_ranges ~function_proto_die = + DS.Debug.log "\n\nDwarf_inlined_frames.dwarf: function proto DIE is %a\n%!" + Asm_label.print + (Proto_die.reference function_proto_die); + let all_blocks = IF.all_indexes inlined_frame_ranges in + let scope_proto_dies, _all_summaries = + IF.Inlined_frames.Index.Set.fold + (fun (block_with_parents : Debuginfo.t) (scope_proto_dies, all_summaries) -> + DS.Debug.log "--------------------------------------------------\n"; + DS.Debug.log "START: %a\n%!" Debuginfo.print_compact_extended + block_with_parents; + (* The head of [block_with_parents] always corresponds to [fundecl] and + thus will be associated with [function_proto_die]. As such we don't + need to create any DW_TAG_inlined_subroutine DIEs for it. *) + let first_item, parents_outermost_first = + (* "Outermost" = less deep inlining *) + let block_with_parents = Debuginfo.to_items block_with_parents in + match block_with_parents with + | [] -> + Misc.fatal_errorf "Empty debuginfo in function %s" fundecl.fun_name + | first_item :: parents -> first_item, Debuginfo.of_items parents + in + DS.Debug.log "Having removed fundecl item: %a\n%!" + Debuginfo.print_compact_extended parents_outermost_first; + let compilation_unit_proto_die = DS.compilation_unit_proto_die state in + let scope_proto_dies, all_summaries = + (* We only need to look the range up once for the current + [Debuginfo.t] (which contains all blocks in the inlining stack + under consideration). This might seem wrong in the case where a + function [f0] is inlined into a function [f] and we are considering + an inlining stack coming from the instructions whose debuginfo has + [f; f0]: would we not fail to extend the range of [f] correctly + across all of its instructions (rather than just the ones coming + from [f0])? The answer is no, because this loop will also receive a + range for [f] itself, and that will have been first because + [Index.Set.fold] operates in ascending order. See assertion + above. *) + DS.Debug.log + "finding ranges for key (current block + all parents): %a\n%!" + K.print block_with_parents; + match IF.find inlined_frame_ranges block_with_parents with + | range -> + create_down_to_innermost_frame fundecl state + ~compilation_unit_proto_die ~prefix:[first_item] + ~blocks_outermost_first:parents_outermost_first scope_proto_dies + all_summaries ~parent_die:function_proto_die range + inlined_frame_ranges + | exception Not_found -> + Misc.fatal_errorf + "Function %s:@ couldn't find block_with_parents=%a.@ All ranges:" + fundecl.L.fun_name Debuginfo.print_compact_extended + block_with_parents IF.print inlined_frame_ranges + in + scope_proto_dies, all_summaries) + all_blocks + (K.Map.empty, All_summaries.Map.empty) + in + scope_proto_dies diff --git a/backend/debug/dwarf/dwarf_ocaml/dwarf_inlined_frames.mli b/backend/debug/dwarf/dwarf_ocaml/dwarf_inlined_frames.mli new file mode 100644 index 00000000000..1b7325c1403 --- /dev/null +++ b/backend/debug/dwarf/dwarf_ocaml/dwarf_inlined_frames.mli @@ -0,0 +1,39 @@ +(****************************************************************************** + * flambda-backend * + * Mark Shinwell, Jane Street * + * -------------------------------------------------------------------------- * + * MIT License * + * * + * Copyright (c) 2024 Jane Street Group LLC * + * opensource-contacts@janestreet.com * + * * + * Permission is hereby granted, free of charge, to any person obtaining a * + * copy of this software and associated documentation files (the "Software"), * + * to deal in the Software without restriction, including without limitation * + * the rights to use, copy, modify, merge, publish, distribute, sublicense, * + * and/or sell copies of the Software, and to permit persons to whom the * + * Software is furnished to do so, subject to the following conditions: * + * * + * The above copyright notice and this permission notice shall be included * + * in all copies or substantial portions of the Software. * + * * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL * + * THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * + * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * + * DEALINGS IN THE SOFTWARE. * + ******************************************************************************) + +(** Generation of descriptions of inlined frames in DWARF. *) + +open! Dwarf_low +open! Dwarf_high + +val dwarf : + Dwarf_state.t -> + Linear.fundecl -> + Inlined_frame_ranges.t -> + function_proto_die:Proto_die.t -> + Proto_die.t Inlined_frame_ranges.Inlined_frames.Key.Map.t diff --git a/backend/debug/dwarf/dwarf_ocaml/dwarf_state.ml b/backend/debug/dwarf/dwarf_ocaml/dwarf_state.ml index 0a21b7a6098..1cdf6690572 100644 --- a/backend/debug/dwarf/dwarf_ocaml/dwarf_state.ml +++ b/backend/debug/dwarf/dwarf_ocaml/dwarf_state.ml @@ -24,12 +24,14 @@ type t = debug_loc_table : Debug_loc_table.t; debug_ranges_table : Debug_ranges_table.t; address_table : Address_table.t; - location_list_table : Location_list_table.t + location_list_table : Location_list_table.t; + function_abstract_instances : (Proto_die.t * Asm_symbol.t) Asm_symbol.Tbl.t; + get_file_num : string -> int } let create ~compilation_unit_header_label ~compilation_unit_proto_die ~value_type_proto_die ~start_of_code_symbol debug_loc_table - debug_ranges_table address_table location_list_table = + debug_ranges_table address_table location_list_table ~get_file_num = { compilation_unit_header_label; compilation_unit_proto_die; value_type_proto_die; @@ -37,7 +39,9 @@ let create ~compilation_unit_header_label ~compilation_unit_proto_die debug_loc_table; debug_ranges_table; address_table; - location_list_table + location_list_table; + function_abstract_instances = Asm_symbol.Tbl.create 42; + get_file_num } let compilation_unit_header_label t = t.compilation_unit_header_label @@ -55,3 +59,16 @@ let debug_ranges_table t = t.debug_ranges_table let address_table t = t.address_table let location_list_table t = t.location_list_table + +let function_abstract_instances t = t.function_abstract_instances + +let can_reference_dies_across_units _t = true + +let get_file_num t filename = t.get_file_num filename + +module Debug = struct + let log f = + match Sys.getenv "DWARF_DEBUG" with + | exception Not_found -> Format.ifprintf Format.err_formatter f + | _ -> Format.eprintf f +end diff --git a/backend/debug/dwarf/dwarf_ocaml/dwarf_state.mli b/backend/debug/dwarf/dwarf_ocaml/dwarf_state.mli index 611fc39c4f3..a85198261cf 100644 --- a/backend/debug/dwarf/dwarf_ocaml/dwarf_state.mli +++ b/backend/debug/dwarf/dwarf_ocaml/dwarf_state.mli @@ -29,6 +29,7 @@ val create : Debug_ranges_table.t -> Address_table.t -> Location_list_table.t -> + get_file_num:(string -> int) -> t val compilation_unit_header_label : t -> Asm_label.t @@ -46,3 +47,14 @@ val debug_ranges_table : t -> Debug_ranges_table.t val address_table : t -> Address_table.t val location_list_table : t -> Location_list_table.t + +val function_abstract_instances : + t -> (Proto_die.t * Asm_symbol.t) Asm_symbol.Tbl.t + +val can_reference_dies_across_units : t -> bool + +val get_file_num : t -> string -> int + +module Debug : sig + val log : ('a, Format.formatter, unit) format -> 'a +end diff --git a/backend/debug/inlined_frame_ranges.ml b/backend/debug/inlined_frame_ranges.ml new file mode 100644 index 00000000000..fae0869ec3a --- /dev/null +++ b/backend/debug/inlined_frame_ranges.ml @@ -0,0 +1,189 @@ +(****************************************************************************** + * flambda-backend * + * Mark Shinwell, Jane Street * + * -------------------------------------------------------------------------- * + * MIT License * + * * + * Copyright (c) 2024 Jane Street Group LLC * + * opensource-contacts@janestreet.com * + * * + * Permission is hereby granted, free of charge, to any person obtaining a * + * copy of this software and associated documentation files (the "Software"), * + * to deal in the Software without restriction, including without limitation * + * the rights to use, copy, modify, merge, publish, distribute, sublicense, * + * and/or sell copies of the Software, and to permit persons to whom the * + * Software is furnished to do so, subject to the following conditions: * + * * + * The above copyright notice and this permission notice shall be included * + * in all copies or substantial portions of the Software. * + * * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL * + * THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * + * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * + * DEALINGS IN THE SOFTWARE. * + ******************************************************************************) + +module L = Linear + +(* CR mshinwell/xclerc/poechsel: + + 1. maybe "set" isn't the correct algebraic structure for the Compute_ranges + interface + + 2. maybe a list-based structure could be used here instead (not for variable + ranges) *) + +module Inlined_frames = struct + module Key = struct + module T0 = struct + type t = Debuginfo.t + + let print = Debuginfo.print_compact_extended + + let compare t1 t2 = + (* It needs to be the case that [compare shorter longer] returns -1 (and + vice-versa) when [shorter] is a prefix of [longer] whilst also having + fewer frames. See dwarf_inlined_frames:create_up_to_root. *) + let items1 = Debuginfo.to_items t1 in + let items2 = Debuginfo.to_items t2 in + let rec loop (items1 : Debuginfo.item list) + (items2 : Debuginfo.item list) = + match items1, items2 with + | [], [] -> 0 + | [], _ :: _ -> -1 + | _ :: _, [] -> 1 + | i1 :: items1, i2 :: items2 -> + (* CR mshinwell: think about the [None] cases some more *) + let c = Option.compare String.compare i1.dinfo_uid i2.dinfo_uid in + if c <> 0 + then c + else + let c = + Option.compare String.compare i1.dinfo_function_symbol + i2.dinfo_function_symbol + in + if c <> 0 then c else loop items1 items2 + in + loop items1 items2 + + let equal t1 t2 = compare t1 t2 = 0 + + let hash = Hashtbl.hash + + let output _ _ = Misc.fatal_error "Not implemented" + end + + include T0 + include Identifiable.Make (T0) + + type key = t + + module Raw_set = Set + + module Set = struct + type t = + | Ok of Raw_set.t + | Unreachable + + let of_list keys = Ok (Raw_set.of_list keys) + + let union t1 t2 = + match t1, t2 with + | Unreachable, _ | _, Unreachable -> Unreachable + | Ok s1, Ok s2 -> Ok (Raw_set.union s1 s2) + + let inter t1 t2 = + match t1, t2 with + | Unreachable, t | t, Unreachable -> t + | Ok s1, Ok s2 -> Ok (Raw_set.inter s1 s2) + + let diff t1 t2 = + match t1, t2 with + | Unreachable, _ -> Unreachable + | _, Unreachable -> Ok Raw_set.empty + | Ok s1, Ok s2 -> Ok (Raw_set.diff s1 s2) + + let fold f t init = + match t with Unreachable -> init | Ok s -> Raw_set.fold f s init + + let print ppf t = + match t with + | Unreachable -> Format.pp_print_string ppf "Unreachable" + | Ok s -> Raw_set.print ppf s + end + + let parent t = + match List.rev t with [] | [_] -> None | _ :: t -> Some (List.rev t) + + let all_parents _t = [] + end + + module Index = struct + include Key + module Set = Raw_set + end + + module Subrange_state : Compute_ranges_intf.S_subrange_state = struct + type t = unit + + let create () = () + + let advance_over_instruction () _ = () + end + + module Subrange_info : + Compute_ranges_intf.S_subrange_info + with type key := Key.t + with type subrange_state := Subrange_state.t = struct + type t = unit + + let create _var _subrange_state ~fun_contains_calls:_ ~fun_num_stack_slots:_ + = + () + + let print ppf () = Format.pp_print_string ppf "()" + end + + module Range_info : + Compute_ranges_intf.S_range_info + with type key := Key.t + with type index := Index.t = struct + type t = unit + + let create _fundecl key ~start_insn:_ = Some (key, ()) + + let print ppf () = Format.pp_print_string ppf "()" + end + + let available_before (insn : L.instruction) = + let get_parents (dbg : Debuginfo.item list) : Debuginfo.t list = + match List.rev dbg with + | [] | [_] -> [] + | _ :: parents -> + let rec loop (t : Debuginfo.item list) = + match t with + | [] -> [] + | _ :: tl -> Debuginfo.of_items (List.rev t) :: loop tl + in + loop parents + in + let insn_dbg = Debuginfo.to_items insn.dbg in + match insn_dbg with + | [] -> None + | _ :: _ -> + Some (Key.Set.Ok (Key.Raw_set.of_list (insn.dbg :: get_parents insn_dbg))) + + let available_across insn = + (* A single [Linear] instruction never spans inlined frames. *) + available_before insn + + let must_restart_ranges_upon_any_change () = false +end + +module Subrange_state = Inlined_frames.Subrange_state +module Subrange_info = Inlined_frames.Subrange_info +module Range_info = Inlined_frames.Range_info +include Compute_ranges.Make (Inlined_frames) diff --git a/backend/emitaux.ml b/backend/emitaux.ml index 307a79cc2d7..45316f91861 100644 --- a/backend/emitaux.ml +++ b/backend/emitaux.ml @@ -493,7 +493,8 @@ module Dwarf_helpers = struct reset_dwarf (); let can_emit_dwarf = !Clflags.debug - && not !Dwarf_flags.restrict_to_upstream_dwarf + && ((not !Dwarf_flags.restrict_to_upstream_dwarf) + || !Dwarf_flags.dwarf_inlined_frames) && not disable_dwarf in match can_emit_dwarf, diff --git a/driver/flambda_backend_args.ml b/driver/flambda_backend_args.ml index adf2361ec78..65a1b0582fc 100644 --- a/driver/flambda_backend_args.ml +++ b/driver/flambda_backend_args.ml @@ -567,6 +567,13 @@ let mk_restrict_to_upstream_dwarf f = let mk_no_restrict_to_upstream_dwarf f = "-gno-upstream-dwarf", Arg.Unit f, " Emit potentially more DWARF information than the upstream compiler" +let mk_dwarf_inlined_frames f = + "-gdwarf-inlined-frames", Arg.Unit f, " Emit DWARF inlined frame information" + +let mk_no_dwarf_inlined_frames f = + "-gno-dwarf-inlined-frames", Arg.Unit f, + " Do not emit DWARF inlined frame information" + let mk_dwarf_for_startup_file f = "-gstartup", Arg.Unit f, " Emit potentially more DWARF information\n\ \ for the startup file than the upstream compiler\n\ @@ -1114,6 +1121,8 @@ end module type Debugging_options = sig val restrict_to_upstream_dwarf : unit -> unit val no_restrict_to_upstream_dwarf : unit -> unit + val dwarf_inlined_frames : unit -> unit + val no_dwarf_inlined_frames : unit -> unit val dwarf_for_startup_file : unit -> unit val no_dwarf_for_startup_file : unit -> unit val gdwarf_may_alter_codegen : unit -> unit @@ -1125,6 +1134,8 @@ module Make_debugging_options (F : Debugging_options) = struct let list3 = [ mk_restrict_to_upstream_dwarf F.restrict_to_upstream_dwarf; mk_no_restrict_to_upstream_dwarf F.no_restrict_to_upstream_dwarf; + mk_dwarf_inlined_frames F.dwarf_inlined_frames; + mk_no_dwarf_inlined_frames F.no_dwarf_inlined_frames; mk_dwarf_for_startup_file F.dwarf_for_startup_file; mk_no_dwarf_for_startup_file F.no_dwarf_for_startup_file; mk_gdwarf_may_alter_codegen F.gdwarf_may_alter_codegen; @@ -1138,6 +1149,10 @@ module Debugging_options_impl = struct Debugging.restrict_to_upstream_dwarf := true let no_restrict_to_upstream_dwarf () = Debugging.restrict_to_upstream_dwarf := false + let dwarf_inlined_frames () = + Debugging.dwarf_inlined_frames := true + let no_dwarf_inlined_frames () = + Debugging.dwarf_inlined_frames := false let dwarf_for_startup_file () = Debugging.dwarf_for_startup_file := true let no_dwarf_for_startup_file () = diff --git a/driver/flambda_backend_args.mli b/driver/flambda_backend_args.mli index 84d74ac6cb1..d6fbc04681f 100644 --- a/driver/flambda_backend_args.mli +++ b/driver/flambda_backend_args.mli @@ -139,6 +139,8 @@ end module type Debugging_options = sig val restrict_to_upstream_dwarf : unit -> unit val no_restrict_to_upstream_dwarf : unit -> unit + val dwarf_inlined_frames : unit -> unit + val no_dwarf_inlined_frames : unit -> unit val dwarf_for_startup_file : unit -> unit val no_dwarf_for_startup_file : unit -> unit val gdwarf_may_alter_codegen : unit -> unit diff --git a/dune b/dune index 5fe27445ea9..674d20b7ceb 100755 --- a/dune +++ b/dune @@ -197,6 +197,7 @@ available_regs compute_ranges compute_ranges_intf + inlined_frame_ranges is_parameter reg_availability_set reg_with_debug_info @@ -205,8 +206,10 @@ ;; This code has a lot of dependencies into ocamloptcomp, so we just ;; build it as part of that library. dwarf + dwarf_abstract_instances dwarf_compilation_unit dwarf_concrete_instances + dwarf_inlined_frames dwarf_name_laundry dwarf_reg_locations dwarf_state diff --git a/ocaml/utils/compilation_unit.ml b/ocaml/utils/compilation_unit.ml index 8f4f1199c2f..2cec30a2df9 100644 --- a/ocaml/utils/compilation_unit.ml +++ b/ocaml/utils/compilation_unit.ml @@ -245,13 +245,14 @@ let create_child parent name_ = let of_string str = let for_pack_prefix, name = - match String.rindex_opt str '.' with - | None -> Prefix.empty, Name.of_string str - | Some 0 -> - (* See [Name.check_as_path_component]; this allows ".cinaps" as a - compilation unit *) - Prefix.empty, Name.of_string str - | Some _ -> Misc.fatal_errorf "[of_string] does not parse qualified names" + (* Also see [Name.check_as_path_component] *) + if String.equal str ".cinaps" || String.equal str "(.cinaps)" + then Prefix.empty, Name.of_string str + else + match String.rindex_opt str '.' with + | None -> Prefix.empty, Name.of_string str + | Some _ -> + Misc.fatal_errorf "[of_string] does not parse qualified names: %s" str in create for_pack_prefix name diff --git a/ocaml/utils/misc.ml b/ocaml/utils/misc.ml index 1b181ad21c2..76ea7c86cff 100644 --- a/ocaml/utils/misc.ml +++ b/ocaml/utils/misc.ml @@ -1443,3 +1443,24 @@ end module type T4 = sig type ('a, 'b, 'c, 'd) t end + +let remove_double_underscores s = + let len = String.length s in + let buf = Buffer.create len in + let skip = ref false in + let rec loop i = + if i < len + then ( + let c = String.get s i in + if c = '.' then skip := true; + if (not !skip) && c = '_' && i + 1 < len && String.get s (i + 1) = '_' + then ( + Buffer.add_char buf '.'; + skip := true; + loop (i + 2)) + else ( + Buffer.add_char buf c; + loop (i + 1))) + in + loop 0; + Buffer.contents buf diff --git a/ocaml/utils/misc.mli b/ocaml/utils/misc.mli index 43526c04cc5..3ee71552236 100644 --- a/ocaml/utils/misc.mli +++ b/ocaml/utils/misc.mli @@ -895,3 +895,5 @@ end type filepath = string type alerts = string Stdlib.String.Map.t + +val remove_double_underscores : string -> string