From a65d8a48f1a200a0e91034fc55d88225541c5e5a Mon Sep 17 00:00:00 2001 From: Matej Urban Date: Fri, 25 Oct 2024 17:51:31 +0100 Subject: [PATCH 01/44] Parse relocations into expressions (WIP) --- .../abi_aarch64_symbolic_relocation.lem | 137 ++++++++++++++++++ src/abis/abi_symbolic_relocation.lem | 66 +++++++++ src/adaptors/harness_interface.lem | 6 +- src/error.lem | 6 + src/lem.mk | 2 + 5 files changed, 215 insertions(+), 2 deletions(-) create mode 100644 src/abis/aarch64/abi_aarch64_symbolic_relocation.lem create mode 100644 src/abis/abi_symbolic_relocation.lem diff --git a/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem b/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem new file mode 100644 index 0000000..62c7c06 --- /dev/null +++ b/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem @@ -0,0 +1,137 @@ +open import Missing_pervasives +open import Error +open import Maybe + +open import Num +open import Basic_classes + +open import Elf_types_native_uint +open import Elf_file +open import Elf_header +open import Elf_relocation + +open import Abi_aarch64_relocation +open import Abi_utilities +open import Abi_symbolic_relocation + +type aarch64_relocation_target + = Data64 + | Data32 + | ADRP + | ADD + | LDST + | CALL + +(* TODO fix sizes and stuff *) +val abi_aarch64_apply_relocation_symbolic : + elf64_relocation_a -> symbolic_expression -> symbolic_expression -> elf64_file -> + error (Map.map elf64_addr (relocation_description symbolic_expression aarch64_relocation_target)) +let abi_aarch64_apply_relocation_symbolic rel s_val p_val ef = + if is_elf64_relocatable_file ef.elf64_file_header then + let (rel_type, _) = parse_elf64_relocation_info rel.elf64_ra_info in + let a_val = Const (integer_of_elf64_sxword rel.elf64_ra_addend) in + (** No width, no calculation *) + if rel_type = r_aarch64_none then + return Map.empty + (** No width, no calculation *) + else if rel_type = r_aarch64_withdrawn then + return Map.empty + (** Signed 64 bit width, calculation: S + A *) + else if rel_type = r_aarch64_abs64 then + let result = Plus(Lift s_val, Lift a_val) in + let addr = rel.elf64_ra_offset in + return (Map.singleton addr + <| rel_desc_operation = (result, I64, CannotFail) + ; rel_desc_mask = (63, 0) + ; rel_desc_target = Data64 + |> + ) + (** Signed 32 bit width, calculation: S + A *) + else if rel_type = r_aarch64_abs32 then + let result = Plus(Lift s_val, Lift a_val) in + let addr = rel.elf64_ra_offset in + return (Map.singleton addr + <| rel_desc_operation = (result, I32, CanFail) + ; rel_desc_mask = (31, 0) + ; rel_desc_target = Data32 + |> + ) + (** Signed 64 bit width, calculation: S + A - P *) + else if rel_type = r_aarch64_prel64 then + let result = Minus(Plus(Lift s_val, Lift a_val), Lift p_val) in + let addr = rel.elf64_ra_offset in + return (Map.singleton addr + <| rel_desc_operation = (result, I64, CannotFail) + ; rel_desc_mask = (63, 0) + ; rel_desc_target = Data64 + |> + ) + (** Signed 32 bit width, calculation: S + A - P *) + else if rel_type = r_aarch64_prel32 then + let result = Minus(Plus(Lift s_val, Lift a_val), Lift p_val) in + let addr = rel.elf64_ra_offset in + return (Map.singleton addr + <| rel_desc_operation = (result, I32, CanFail) + ; rel_desc_mask = (31, 0) + ; rel_desc_target = Data32 + |> + ) + else if rel_type = r_aarch64_adr_prel_pg_hi21 then + let result = Minus(Apply(Page, Plus(Lift s_val, Lift a_val)), Apply(Page, Lift p_val)) in + let addr = rel.elf64_ra_offset in + return (Map.singleton addr + <| rel_desc_operation = (result, I32, CanFail) + ; rel_desc_mask = (32, 12) + ; rel_desc_target = ADRP + |> + ) + else if rel_type = r_aarch64_add_abs_lo12_nc then + let result = Plus(Lift s_val, Lift a_val) in + let addr = rel.elf64_ra_offset in + return (Map.singleton addr + <| rel_desc_operation = (result, I32, CannotFail) + ; rel_desc_mask = (11, 0) + ; rel_desc_target = ADD + |> + ) + else if rel_type = r_aarch64_ldst32_abs_lo12_nc then + let result = Plus(Lift s_val, Lift a_val) in + let addr = rel.elf64_ra_offset in + return (Map.singleton addr + <| rel_desc_operation = (result, I32, CannotFail) + ; rel_desc_mask = (11, 2) + ; rel_desc_target = LDST + |> + ) + else if rel_type = r_aarch64_ldst64_abs_lo12_nc then + let result = Plus(Lift s_val, Lift a_val) in + let addr = rel.elf64_ra_offset in + return (Map.singleton addr + <| rel_desc_operation = (result, I32, CannotFail) + ; rel_desc_mask = (11, 3) + ; rel_desc_target = LDST + |> + ) + else if rel_type = r_aarch64_call26 then + let result = Minus(Plus(Lift s_val, Lift a_val), Lift p_val) in + let addr = rel.elf64_ra_offset in + return (Map.singleton addr + <| rel_desc_operation = (result, I27, CanFail) + ; rel_desc_mask = (27, 2) + ; rel_desc_target = CALL + |> + ) + else + fail "Invalid AARCH64 relocation type" + else + fail "abi_aarch64_apply_relocation: not a relocatable file" + +let abi_aarch64_relocation_to_abstract symtab sidx rel ef = + let p_val = section_with_offset sidx rel.elf64_ra_offset in + let (_, sym) = parse_elf64_relocation_info rel.elf64_ra_info in + match List.index symtab (unsafe_nat_of_natural sym) with + | Just ste -> return (symbolic_address_from_elf64_symbol_table_entry ste) + | Nothing -> fail "Invalid symbol table index" + end >>= fun s_val -> + abi_aarch64_apply_relocation_symbolic rel s_val p_val ef >>= fun rel_desc_map -> + map_mapM eval_relocation rel_desc_map diff --git a/src/abis/abi_symbolic_relocation.lem b/src/abis/abi_symbolic_relocation.lem new file mode 100644 index 0000000..ae98eac --- /dev/null +++ b/src/abis/abi_symbolic_relocation.lem @@ -0,0 +1,66 @@ +open import Num + +open import Error + +open import Abi_utilities + +open import Elf_types_native_uint +open import Elf_symbol_table + +(* TODO *) +type binary_operation + = Add + | Sub + +(* TODO *) +type symbolic_expression + = Section of elf64_half + | Const of integer + | BinOp of (symbolic_expression * binary_operation * symbolic_expression) + | AssertRange of (symbolic_expression * integer * integer) + | Mask of (symbolic_expression * natural * natural) + +let section_with_offset sidx offset = BinOp(Section sidx, Add, Const (integerFromNatural (natural_of_elf64_addr offset))) + +type relocation_description 'res 'tar = + <| rel_desc_operation : (relocation_operator_expression 'res * integer_bit_width * can_fail 'res) + ; rel_desc_mask : (natural * natural) + ; rel_desc_target : 'tar + |> + +type abstract_relocation 'a = + <| arel_value : symbolic_expression + ; arel_target : 'a + |> + + +let rec eval_op_exp op: error symbolic_expression = + match op with + | Lift x -> return x + | Plus (x, y) -> + eval_op_exp x >>= fun a -> + eval_op_exp y >>= fun b -> + return (BinOp (a, Add, b)) + | Minus (x, y) -> + eval_op_exp x >>= fun a -> + eval_op_exp y >>= fun b -> + return (BinOp (a, Sub, b)) + | _ -> fail "Not supported" + end + + +let eval_relocation desc = + let (exp, bit_width, can_fail) = desc.rel_desc_operation in + let (lo, hi) = desc.rel_desc_mask in + + eval_op_exp exp >>= fun value -> + match can_fail with + | CanFail -> return (AssertRange(value, 0, 0)) (*todo*) + | CannotFail -> return value + | CanFailOnTest -> fail "Not supported" + end + >>= fun value -> + return <| arel_value = Mask(value, lo, hi) ; arel_target = desc.rel_desc_target |> + +let symbolic_address_from_elf64_symbol_table_entry ste = + section_with_offset ste.elf64_st_shndx ste.elf64_st_value diff --git a/src/adaptors/harness_interface.lem b/src/adaptors/harness_interface.lem index d8f4020..5837291 100644 --- a/src/adaptors/harness_interface.lem +++ b/src/adaptors/harness_interface.lem @@ -16,6 +16,7 @@ open import Default_printing open import Endianness open import String_table +open import Abi_utilities open import Elf_dynamic open import Elf_file open import Elf_header @@ -514,12 +515,13 @@ let {ocaml} harness_string_of_elf64_reloc_a_entry os symtab sht stbl sechdr_stbl let off = natural_of_elf64_addr rel.elf64_ra_offset in let inf = natural_of_elf64_xword rel.elf64_ra_info in let add = integer_of_elf64_sxword rel.elf64_ra_addend in - let typ = Missing_pervasives.unsafe_string_take 22 (os 0) in (*FIXME *) + let (typ, sym) = parse_elf64_relocation_info rel.elf64_ra_info in + let typ = Missing_pervasives.unsafe_string_take 22 (os typ) in let typs = let len = naturalFromNat (22 - String.stringLength typ) in concatS (replicate len " ") in - let idx = 0 in (* FIXME *) + let idx = sym in let (nm, value, symtyp, secthdr) = match List.index symtab (unsafe_nat_of_natural idx) with | Nothing -> (stn_undef, 0, 0, 0) diff --git a/src/error.lem b/src/error.lem index 57c4165..849b154 100644 --- a/src/error.lem +++ b/src/error.lem @@ -1,5 +1,7 @@ open import Basic_classes open import List +open import Map +open import Map_extra open import Maybe open import Num open import String @@ -128,3 +130,7 @@ let string_of_error e = instance forall 'a. Show 'a => (Show (error 'a)) let show = string_of_error end + +let map_mapM f mp = + mapM (fun (k, v) -> f v >>= fun v -> return (k, v)) (Map_extra.toList mp) >>= fun xs -> + return (Map.fromList xs) diff --git a/src/lem.mk b/src/lem.mk index 127b4b8..a271a46 100644 --- a/src/lem.mk +++ b/src/lem.mk @@ -61,6 +61,7 @@ LEM_ELF_SRC := byte_sequence.lem byte_pattern.lem byte_pattern_extra.lem \ LEM_ABI_SRC := \ abis/abi_classes.lem memory_image.lem memory_image_orderings.lem \ abis/abi_utilities.lem \ + abis/abi_symbolic_relocation.lem \ gnu_extensions/gnu_ext_abi.lem \ abis/power64/abi_power64.lem \ abis/power64/abi_power64_elf_header.lem \ @@ -72,6 +73,7 @@ LEM_ABI_SRC := \ abis/aarch64/abi_aarch64_program_header_table.lem \ abis/aarch64/abi_aarch64_le_serialisation.lem \ abis/aarch64/abi_aarch64_relocation.lem \ + abis/aarch64/abi_aarch64_symbolic_relocation.lem \ abis/aarch64/abi_aarch64_le.lem \ abstract_linker_script.lem \ abis/amd64/abi_amd64_elf_header.lem \ From 0db25c0996b21fd017935db6b5b912f92b2cf480 Mon Sep 17 00:00:00 2001 From: Matej Urban Date: Wed, 6 Nov 2024 18:24:08 +0000 Subject: [PATCH 02/44] replace natural by symbolic --- src/dwarf copy.lem | 6599 ++++++++++++++++++++++++++++++++++++++++++++ src/dwarf.lem | 1684 +++++------ 2 files changed, 7498 insertions(+), 785 deletions(-) create mode 100644 src/dwarf copy.lem diff --git a/src/dwarf copy.lem b/src/dwarf copy.lem new file mode 100644 index 0000000..ce9d432 --- /dev/null +++ b/src/dwarf copy.lem @@ -0,0 +1,6599 @@ +(* -*-tuareg-*- *) +open import Basic_classes +open import Bool +open import Function +open import Maybe +open import Num +open import String + +open import List (* TODO: check why this is not imported in ELF *) + +open import Byte_sequence +open import Error +open import Hex_printing +open import Missing_pervasives +open import Show + +open import Default_printing + +open import Endianness +open import String_table + +open import Elf_dynamic +open import Elf_file +open import Elf_header +open import Elf_program_header_table +open import Elf_relocation +open import Elf_section_header_table +open import Elf_symbol_table +open import Elf_types_native_uint + +(** ***************** experimental DWARF reading *********** *) + +(* + +This defines a representation of some of the DWARF debug information, +with parsing functions to extract it from the byte sequences of the +relevant ELF sections, and pretty-printing function to dump it in a +human-readable form, similar to that of readelf. The main functions +for this are: + + val extract_dwarf : elf64_file -> maybe dwarf + val pp_dwarf : dwarf -> string + +It also defines evaluation of DWARF expressions and analysis functions +to convert the variable location information to a form suitable for +looking up variable names from machine addresses that arise during +execution, including the call frame address calculation. The main +types and functions for this are: + + type analysed_location_data + val analyse_locations : dwarf -> analysed_location_data + + type evaluated_frame_info + val evaluate_frame_info : dwarf -> evaluated_frame_info + + type dwarf_static + val extract_dwarf_static : elf64_file -> maybe dwarf_static + +The last collects all the above - information that can be computed statically. + +Then to do lookup from addresses to source-code names, we have: + + type analysed_location_data_at_pc + val analysed_locations_at_pc : evaluation_context -> dwarf_static -> natural -> analysed_location_data_at_pc + val names_of_address : dwarf -> analysed_location_data_at_pc -> natural -> list string + +The definitions are deliberately simple-minded, to be quick to write, +easy to see the correspondence to the DWARF text specification, and +potentially support generation of theorem-prover definitions in +future. They are in a pure functional style, making the information +dependencies explicit. They are not written for performance, though +they may be efficient enough for small examples as-is. They are +written in Lem, and compiled from that to executable OCaml. + +The development follows the DWARF 4 pdf specification at http://www.dwarfstd.org/ +though tweaked in places where our examples use earlier versions. It doesn't +systematically cover all the DWARF versions. +It doesn't cover the GNU extensions +(at https://fedorahosted.org/elfutils/wiki/DwarfExtensions). +The representation, parsing, and pretty printing are mostly complete for the +data in these DWARF ELF sections: + +.debug_abbrev +.debug_info +.debug_types +.debug_loc +.debug_str +.debug_ranges +.debug_frame (without augmentations) +.debug_line + +The following DWARF ELF sections are not covered: + +.debug_aranges +.debug_macinfo +.debug_pubnames +.debug_pubtypes + +The evaluation of DWARF expressions covers only some of the operations +- probably enough for common cases. + +The analysis of DWARF location data should be enough to look up names +from the addresses of variables and formal parameters. It does not +currently handle the DWARF type data, so will not be useful for accesses +strictly within the extent of a variable or parameter. + +The 'dwarf' type gives a lightly parsed representation of some of the +dwarf information, with the byte sequences of the above .debug_* +sections parsed into a structured representation. That makes the list +and tree structures explicit, and converts the various numeric types +into just natural, integer, and byte sequences. The lem natural and +integer could be replaced by unsigned and signed 64-bit types; that'd +probably be better for execution but not for theorem-prover use. + +*) + +(* some spec ambiguities (more in comments in-line below): *) +(* can a location list be referenced from multiple compilation units, with different base addresses? *) + + +(** debug *) + +(* workaround debug.lem linking *) +val print_endline : string -> unit +declare ocaml target_rep function print_endline = `print_endline` + +let my_debug s= () (*print_endline s*) +let my_debug2 s= () (*print_endline s*) +let my_debug3 s= () (*print_endline s*) +let my_debug4 s= print_endline s +let my_debug5 s= print_endline s + + + +(* Symbolic types *) +type sym_natural = + | Offset of (string * natural) + | Absolute of natural + | Unknown + +let sym_add x y= + match (x, y) with + | (Absolute x, Absolute y) -> Absolute (x + y) + | (Offset (s, x), Absolute y) -> Offset (s, x + y) + | (Absolute x, Offset (s, y)) -> Offset (s, x + y) + | _ -> Unknown + end + +val sym_bind : sym_natural -> (natural -> sym_natural) -> sym_natural +let sym_bind x f = match x with + | Absolute x -> f x + | _ -> Unknown +end + +let sym_map f x = sym_bind x (fun x -> Absolute(f x)) + +let sym_map2 f x y = sym_bind x (fun x -> sym_map (f x) y) + +let sym_unwrap = function + | Absolute x -> x + | _ -> Assert_extra.failwith "sym_unwrap" +end + +instance (NumAdd sym_natural) + let (+) = sym_add +end + +instance (NumMinus sym_natural) + let (-) = sym_map2 (-) +end + +instance (NumRemainder sym_natural) + let (mod) = sym_map2 (mod) +end + +instance (Ord sym_natural) + let compare = (fun x -> fun y -> compare (sym_unwrap x) (sym_unwrap y)) + let (<) = (fun x -> fun y -> (sym_unwrap x) < (sym_unwrap y)) + let (<=) = (fun x -> fun y -> (sym_unwrap x) <= (sym_unwrap y)) + let (>) = (fun x -> fun y -> (sym_unwrap x) > (sym_unwrap y)) + let (>=) = (fun x -> fun y -> (sym_unwrap x) >= (sym_unwrap y)) +end + +instance (Numeral sym_natural) + let fromNumeral = fun x -> Absolute (fromNumeral x) +end + +let pp_sym ppf = function +| Absolute x -> ppf x +| Offset (s, x) -> s ^ "+" ^ ppf x +| Unknown -> "Unknown" +end + +instance (Show sym_natural) + let show = pp_sym show +end + +let sym_natural_land = sym_map2 natural_land +let sym_natural_lxor = sym_map2 natural_lxor +let sym_natural_lor = sym_map2 natural_lor + +let integerFromSymNatural = function + | Absolute x -> integerFromNatural x + | _ -> Assert_extra.failwith "integerFromSymNatural" +end + +let natFromSymNatural = function + | Absolute x -> natFromNatural x + | _ -> Assert_extra.failwith "integerFromSymNatural" +end + +let sym_natural_of_hex x = Absolute(natural_of_hex x) + +(** ************************************************************ *) +(** ** dwarf representation types **************************** *) +(** ************************************************************ *) + + +type dwarf_attribute_classes = + | DWA_7_5_3 + | DWA_address + | DWA_block + | DWA_constant + | DWA_dash + | DWA_exprloc + | DWA_flag + | DWA_lineptr + | DWA_loclistptr + | DWA_macptr + | DWA_rangelistptr + | DWA_reference + | DWA_string + +(* operations and expression evalution *) + +type operation_argument_type = + | OAT_addr + | OAT_dwarf_format_t + | OAT_uint8 + | OAT_uint16 + | OAT_uint32 + | OAT_uint64 + | OAT_sint8 + | OAT_sint16 + | OAT_sint32 + | OAT_sint64 + | OAT_ULEB128 + | OAT_SLEB128 + | OAT_block + +type operation_argument_value = + | OAV_natural of sym_natural + | OAV_integer of integer + | OAV_block of sym_natural * byte_sequence + +type operation_stack = list sym_natural + +type arithmetic_context = + <| + ac_bitwidth: sym_natural; + ac_half: sym_natural; (* 2 ^ (ac_bitwidth -1) *) + ac_all: sym_natural; (* 2 ^ ac_bitwidth *) + ac_max: sym_natural; (* (2 ^ ac_bitwidth) -1 *) (* also the representation of -1 *) +|> + +type operation_semantics = + | OpSem_lit + | OpSem_deref + | OpSem_stack of (arithmetic_context -> operation_stack -> list operation_argument_value -> maybe operation_stack) + | OpSem_not_supported + | OpSem_binary of (arithmetic_context -> sym_natural -> sym_natural -> maybe sym_natural) + | OpSem_unary of (arithmetic_context -> sym_natural -> maybe sym_natural) + | OpSem_opcode_lit of sym_natural + | OpSem_reg + | OpSem_breg + | OpSem_bregx + | OpSem_fbreg + | OpSem_deref_size + | OpSem_nop + | OpSem_piece + | OpSem_bit_piece + | OpSem_implicit_value + | OpSem_stack_value + | OpSem_call_frame_cfa + +type operation = + <| + op_code: sym_natural; + op_string: string; + op_argument_values: list operation_argument_value; + op_semantics: operation_semantics; + |> + + +(* the result of a location expression evaluation is a single_location (or failure) *) + +type simple_location = + | SL_memory_address of sym_natural + | SL_register of sym_natural + | SL_implicit of byte_sequence (* used for implicit and stack values *) + | SL_empty + +type composite_location_piece = + | CLP_piece of sym_natural * simple_location + | CLP_bit_piece of sym_natural * sym_natural * simple_location + +type single_location = + | SL_simple of simple_location + | SL_composite of list composite_location_piece + +(* location expression evaluation is a stack machine operating over the following state *) + +type state = + <| + s_stack: operation_stack; + s_value: simple_location; + s_location_pieces: list composite_location_piece; + |> + +(* location expression evaluation can involve register and memory reads, via the following interface *) + +type register_read_result 'a = + | RRR_result of sym_natural + | RRR_not_currently_available + | RRR_bad_register_number + +type memory_read_result 'a = + | MRR_result of sym_natural + | MRR_not_currently_available + | MRR_bad_address + +type evaluation_context = + <| + read_register: sym_natural -> register_read_result sym_natural; + read_memory: sym_natural -> sym_natural -> memory_read_result sym_natural; + |> + + +(* dwarf sections *) + +type dwarf_format = + | Dwarf32 + | Dwarf64 + +(* .debug_abbrev section *) + +type abbreviation_declaration = + <| + ad_abbreviation_code: natural; + ad_tag: natural; + ad_has_children: bool; + ad_attribute_specifications: list (natural * natural); + |> + +type abbreviations_table = + <| + at_offset: natural; + at_table: list abbreviation_declaration; +|> + +(* .debug_info section *) + +(* TODO byte sequences have relocations *) + +type attribute_value = (* following Figure 3 *) + | AV_addr of sym_natural + | AV_block of natural * byte_sequence + | AV_constantN of sym_natural * byte_sequence + | AV_constant_SLEB128 of integer + | AV_constant_ULEB128 of sym_natural + | AV_exprloc of natural * byte_sequence + | AV_flag of bool + | AV_ref of natural + | AV_ref_addr of natural (* dwarf_format dependent *) + | AV_ref_sig8 of natural + | AV_sec_offset of natural + | AV_string of byte_sequence (* not including terminating null *) + | AV_strp of natural (* dwarf_format dependent *) + + +type die = + <| + die_offset: natural; + die_abbreviation_code: natural; + die_abbreviation_declaration: abbreviation_declaration; + die_attribute_values: list (natural (*pos*) * attribute_value); + die_children: list die; + |> + +type die_index = Map.map natural (list die * die) + +type compilation_unit_header = + <| + cuh_offset: natural; + cuh_dwarf_format: dwarf_format; + cuh_unit_length: natural; + cuh_version: natural; + cuh_debug_abbrev_offset: natural; + cuh_address_size: natural; + |> + +type compilation_unit = + <| + cu_header: compilation_unit_header; + cu_abbreviations_table: abbreviations_table; + cu_die: die; + cu_index: die_index + |> + +type compilation_units = list compilation_unit + +(* .debug_type section *) + +type type_unit_header = + <| + tuh_cuh: compilation_unit_header; + tuh_type_signature: natural; + tuh_type_offset: natural; + |> + +type type_unit = + <| + tu_header: type_unit_header; + tu_abbreviations_table: abbreviations_table; + tu_die: die; + |> + +type type_units = list type_unit + +(* .debug_loc section *) + +type single_location_description = byte_sequence + +type location_list_entry = + <| + lle_beginning_address_offset: natural; + lle_ending_address_offset: natural; + lle_single_location_description: single_location_description; + |> + +type base_address_selection_entry = + <| + base_address: sym_natural; + |> + +type location_list_item = + | LLI_lle of location_list_entry + | LLI_base of base_address_selection_entry + +type location_list = natural (*offset*) * list location_list_item + +type location_list_list = list location_list + +(* .debug_ranges section *) + +type range_list_entry = + <| + rle_beginning_address_offset: natural; + rle_ending_address_offset: natural; + |> + +type range_list_item = + | RLI_rle of range_list_entry + | RLI_base of base_address_selection_entry + +type range_list = natural (*offset (of range_list from start of .debug_ranges section?) *) * list range_list_item + +type range_list_list = list range_list + +(* .debug_frame section: call frame instructions *) + +type cfa_address = sym_natural +type cfa_block = byte_sequence +type cfa_delta = sym_natural +type cfa_offset = sym_natural +type cfa_register = sym_natural +type cfa_sfoffset = integer + +type call_frame_argument_type = + | CFAT_address + | CFAT_delta1 + | CFAT_delta2 + | CFAT_delta4 + | CFAT_delta_ULEB128 + | CFAT_offset (*ULEB128*) + | CFAT_sfoffset (*SLEB128*) + | CFAT_register (*ULEB128*) + | CFAT_block + +type call_frame_argument_value = + | CFAV_address of cfa_address + | CFAV_block of cfa_block + | CFAV_delta of cfa_delta + | CFAV_offset of cfa_offset + | CFAV_register of cfa_register + | CFAV_sfoffset of cfa_sfoffset + +type call_frame_instruction = + | DW_CFA_advance_loc of cfa_delta + | DW_CFA_offset of cfa_register * cfa_offset + | DW_CFA_restore of cfa_register + | DW_CFA_nop + | DW_CFA_set_loc of cfa_address + | DW_CFA_advance_loc1 of cfa_delta + | DW_CFA_advance_loc2 of cfa_delta + | DW_CFA_advance_loc4 of cfa_delta + | DW_CFA_offset_extended of cfa_register * cfa_offset + | DW_CFA_restore_extended of cfa_register + | DW_CFA_undefined of cfa_register + | DW_CFA_same_value of cfa_register + | DW_CFA_register of cfa_register * cfa_register + | DW_CFA_remember_state + | DW_CFA_restore_state + | DW_CFA_def_cfa of cfa_register * cfa_offset + | DW_CFA_def_cfa_register of cfa_register + | DW_CFA_def_cfa_offset of cfa_offset + | DW_CFA_def_cfa_expression of cfa_block + | DW_CFA_expression of cfa_register * cfa_block + | DW_CFA_offset_extended_sf of cfa_register * cfa_sfoffset + | DW_CFA_def_cfa_sf of cfa_register * cfa_sfoffset + | DW_CFA_def_cfa_offset_sf of cfa_sfoffset + | DW_CFA_val_offset of cfa_register * cfa_offset + | DW_CFA_val_offset_sf of cfa_register * cfa_sfoffset + | DW_CFA_val_expression of cfa_register * cfa_block + | DW_CFA_AARCH64_negate_ra_state + | DW_CFA_unknown of byte + +(* .debug_frame section: top-level *) + +type cie = + <| + cie_offset: natural; + cie_length: natural; + cie_id: natural; + cie_version: natural; + cie_augmentation: byte_sequence; (* not including terminating null *) + cie_address_size: maybe natural; + cie_segment_size: maybe natural; + cie_code_alignment_factor: sym_natural; + cie_data_alignment_factor: integer; + cie_return_address_register: cfa_register; + cie_initial_instructions_bytes: byte_sequence; + cie_initial_instructions: list call_frame_instruction; + |> + +type fde = + <| + fde_offset: natural; + fde_length: natural; + fde_cie_pointer: natural; + fde_initial_location_segment_selector: maybe sym_natural; + fde_initial_location_address: sym_natural; + fde_address_range: sym_natural; + fde_instructions_bytes: byte_sequence; + fde_instructions: list call_frame_instruction; + |> + +type frame_info_element = + | FIE_cie of cie + | FIE_fde of fde + +type frame_info = list frame_info_element + + +(* evaluated cfa data *) + +type cfa_rule = + | CR_undefined + | CR_register of cfa_register * integer + | CR_expression of single_location_description + +type register_rule = + | RR_undefined (*A register that has this rule has no recoverable value in the previous frame. + (By convention, it is not preserved by a callee.)*) + | RR_same_value (*This register has not been modified from the previous frame. (By convention, + it is preserved by the callee, but the callee has not modified it.)*) + | RR_offset of integer (* The previous value of this register is saved at the address CFA+N where CFA + is the current CFA value and N is a signed offset.*) + | RR_val_offset of integer (* The previous value of this register is the value CFA+N where CFA is the + current CFA value and N is a signed offset.*) + | RR_register of sym_natural (* The previous value of this register is stored in another register numbered R.*) + | RR_expression of single_location_description (* The previous value of this register is located at the address produced by + executing the DWARF expression E.*) + | RR_val_expression of single_location_description (* The previous value of this register is the value produced by executing the +DWARF expression E.*) + | RR_architectural (*The rule is defined externally to this specification by the augmenter*) + +type register_rule_map = list (cfa_register * register_rule) + +type cfa_table_row = + <| + ctr_loc: sym_natural; + ctr_cfa: cfa_rule; + ctr_regs: register_rule_map; + |> + +type cfa_state = + <| + cs_current_row: cfa_table_row; + cs_previous_rows: list cfa_table_row; + cs_initial_instructions_row: cfa_table_row; + cs_row_stack: list cfa_table_row; + |> + + +type evaluated_frame_info = + list (fde * list cfa_table_row) + + +(* line number *) + +type line_number_argument_type = + | LNAT_address + | LNAT_ULEB128 + | LNAT_SLEB128 + | LNAT_uint16 + | LNAT_string + +type line_number_argument_value = + | LNAV_address of sym_natural + | LNAV_ULEB128 of sym_natural + | LNAV_SLEB128 of integer + | LNAV_uint16 of sym_natural + | LNAV_string of byte_sequence (* not including terminating null *) + +type line_number_operation = + (* standard *) + | DW_LNS_copy + | DW_LNS_advance_pc of sym_natural + | DW_LNS_advance_line of integer + | DW_LNS_set_file of sym_natural + | DW_LNS_set_column of sym_natural + | DW_LNS_negate_stmt + | DW_LNS_set_basic_block + | DW_LNS_const_add_pc + | DW_LNS_fixed_advance_pc of sym_natural + | DW_LNS_set_prologue_end + | DW_LNS_set_epilogue_begin + | DW_LNS_set_isa of sym_natural + (* extended *) + | DW_LNE_end_sequence + | DW_LNE_set_address of sym_natural + | DW_LNE_define_file of byte_sequence * sym_natural * sym_natural * sym_natural + | DW_LNE_set_discriminator of sym_natural + (* special *) + | DW_LN_special of sym_natural (* the adjusted opcode *) + +type line_number_file_entry = + <| + lnfe_path: byte_sequence; + lnfe_directory_index: sym_natural; + lnfe_last_modification: sym_natural; + lnfe_length: sym_natural; + |> + +type line_number_header = + <| + lnh_offset: natural; + lnh_dwarf_format: dwarf_format; + lnh_unit_length: natural; + lnh_version: natural; + lnh_header_length: natural; + lnh_minimum_instruction_length: sym_natural; + lnh_maximum_operations_per_instruction: sym_natural; + lnh_default_is_stmt: bool; + lnh_line_base: integer; + lnh_line_range: sym_natural; + lnh_opcode_base: natural; + lnh_standard_opcode_lengths: list natural; + lnh_include_directories: list (byte_sequence); + lnh_file_entries: list line_number_file_entry; + lnh_comp_dir: maybe string; (* passed down from cu DW_AT_comp_dir *) + |> + +type line_number_program = + <| + lnp_header: line_number_header; + lnp_operations: list line_number_operation; + |> + +(* line number evaluation *) + +type line_number_registers = + <| + lnr_address: sym_natural; + lnr_op_index: sym_natural; + lnr_file: sym_natural; + lnr_line: sym_natural; + lnr_column: sym_natural; + lnr_is_stmt: bool; + lnr_basic_block: bool; + lnr_end_sequence: bool; + lnr_prologue_end: bool; + lnr_epilogue_begin: bool; + lnr_isa: sym_natural; + lnr_discriminator: sym_natural; + |> + +type unpacked_file_entry = (maybe string (*comp_dir*)) * (maybe string (*dir*)) * string (*file*) + +type unpacked_decl = unpacked_file_entry * nat(*line*) * string(*subprogram name*) + + +(* top-level collection of dwarf data *) + +type dwarf = + <| + d_endianness: Endianness.endianness; (* from the ELF *) + d_str: byte_sequence; + d_compilation_units: compilation_units; + d_type_units: type_units; + d_loc: location_list_list; + d_ranges: range_list_list; + d_frame_info: frame_info; + d_line_info: list line_number_program; + |> + +(* analysed location data *) + +type analysed_location_data = list ((compilation_unit * (list die) * die) * maybe (list (sym_natural * sym_natural * single_location_description))) + +type analysed_location_data_at_pc = list ((compilation_unit * (list die) * die) * (sym_natural * sym_natural * single_location_description * error single_location)) + +(* evaluated line data *) + +type evaluated_line_info = list (line_number_header * list line_number_registers) + +(* all dwarf static data *) + +type dwarf_static = + <| + ds_dwarf: dwarf; + ds_analysed_location_data: analysed_location_data; + ds_evaluated_frame_info: evaluated_frame_info; + ds_evaluated_line_info: evaluated_line_info; + ds_subprogram_line_extents: list (unpacked_file_entry * list (string * unpacked_file_entry * sym_natural) ); + |> + +type dwarf_dynamic_at_pc = analysed_location_data_at_pc + +(** context for parsing and pp functions *) + +type p_context = + <| + endianness: Endianness.endianness; + |> + + + +(* type descriptions *) +(* NB these do not cover all the DWARF-expressible types; only some common C cases *) +(* ignore base type DW_endianity and DW_bitsize for now *) +type cupdie = compilation_unit * (list die) * die + +type decl = + <| + decl_file: maybe string; + decl_line: maybe sym_natural; + |> + +type array_dimension 't = maybe sym_natural(*count*) * maybe 't(*subrange type*) + +type struct_union_member 't = cupdie * (maybe string)(*mname*) * 't * maybe sym_natural(*data_member_location, non-Nothing for structs*) + +type struct_union_type_kind = + | Atk_structure + | Atk_union + +type enumeration_member = cupdie * (maybe string)(*mname*) * integer(*const_value*) + +type c_type_top 't = + | CT_missing of cupdie + | CT_base of cupdie * string(*name*) * sym_natural(*encoding*) * (maybe sym_natural)(*byte_size*) + | CT_pointer of cupdie * maybe 't + | CT_const of cupdie * maybe 't + | CT_volatile of cupdie * 't + | CT_restrict of cupdie * 't + | CT_typedef of cupdie * string(*name*) * 't * decl + | CT_array of cupdie * 't * list (array_dimension 't) + | CT_struct_union of cupdie * struct_union_type_kind * (maybe string)(*mname*) * (maybe sym_natural)(*byte_size*) * decl * maybe (list (struct_union_member 't)(*members*)) + | CT_enumeration of cupdie * (maybe string)(*mname*) * (maybe 't)(*mtyp*) * (maybe sym_natural)(*mbyte_size*) * decl * maybe (list (enumeration_member)(*members*)) + | CT_subroutine of cupdie * (bool)(*prototyped*) * (maybe 't)(*mresult_type*) * (list 't)(*parameter_types*) * (bool)(*variable_parameter_list*) + +(* In the CT_struct_union and C_enumeration cases, the final maybe(list(...member)) is Nothing if the analysis has not been recursed into the members, and Just ... if it has - which will typically be only one level deep *) + +type c_type = + | CT of (c_type_top c_type) + +(* simple die tree *) + +(* this unifies variables and formal parameters, and also subprograms + and inlined_subroutines (but not lexical_blocks). Debatable what's + best *) +(* not including DW_AT_low_pc/DW_AT_high_pc or DW_AT_ranges - might want that*) +(* also not including per-instruction line number info *) + +type variable_or_formal_parameter_kind = + | SVPK_var + | SVPK_param + +type sdt_unspecified_parameter = unit + + + +type sdt_variable_or_formal_parameter = + <| + svfp_cupdie : cupdie; + svfp_name : string; + svfp_kind : variable_or_formal_parameter_kind; + svfp_type : maybe c_type; + svfp_abstract_origin : maybe sdt_variable_or_formal_parameter; (* invariant: non-Nothing iff inlined *) + svfp_const_value : maybe integer; + svfp_external : bool; + svfp_declaration : bool; + svfp_locations : maybe (list (sym_natural * sym_natural * list operation (*the parsed single_location_description*))); + svfp_decl : maybe unpacked_decl; +|> + +type sdt_subroutine_kind = + | SSK_subprogram + | SSK_inlined_subroutine + +type sdt_subroutine = (* subprogram or inlined subroutine *) + <| + ss_cupdie : cupdie; + ss_name : maybe string; + ss_kind : sdt_subroutine_kind; + ss_call_site : maybe unpacked_decl; + ss_abstract_origin : maybe sdt_subroutine; (* invariant: non-Nothing iff inlined *) + ss_type : maybe c_type; + ss_vars : list sdt_variable_or_formal_parameter; + ss_pc_ranges : maybe (list (sym_natural*sym_natural)); + ss_entry_address : maybe sym_natural; + ss_unspecified_parameters : list sdt_unspecified_parameter; + ss_subroutines : list sdt_subroutine; (* invariant: all inlined*) + ss_lexical_blocks : list sdt_lexical_block; + ss_decl : maybe unpacked_decl; + ss_noreturn : bool; + ss_external : bool; + |> + +and sdt_lexical_block = + <| + slb_cupdie : cupdie; + slb_vars : list sdt_variable_or_formal_parameter; (* invariant: all variables *) + slb_pc_ranges : maybe (list (sym_natural*sym_natural)); + slb_subroutines : list sdt_subroutine; (* invariant: all inlined*) + slb_lexical_blocks : list sdt_lexical_block; + |> + +type sdt_compilation_unit = + <| + scu_cupdie : cupdie; + scu_name : string; + scu_subroutines : list sdt_subroutine; (* invariant: none inlined(?) *) + scu_vars : list sdt_variable_or_formal_parameter; + scu_pc_ranges : maybe (list (sym_natural*sym_natural)); + |> + +type sdt_dwarf = + <| sd_compilation_units : list sdt_compilation_unit; + |> + + +(* inlined subroutine data *) + +type inlined_subroutine_const_param = + <| + iscp_abstract_origin: compilation_unit * (list die) * die; + iscp_value: integer; + |> + +type inlined_subroutine = + <| + is_inlined_subroutine: compilation_unit * (list die) * die; + is_abstract_origin: compilation_unit * (list die) * die; + is_inlined_subroutine_sdt: sdt_subroutine; + is_inlined_subroutine_sdt_parents: list sdt_subroutine; + is_name : string; + is_call_file: unpacked_file_entry; + is_call_line: sym_natural; + is_pc_ranges: list (sym_natural * sym_natural); + is_const_params : list inlined_subroutine_const_param; + |> + (* ignoring the nesting structure of inlined subroutines for now *) + +type inlined_subroutine_data = list inlined_subroutine + +type inlined_subroutine_data_by_range_entry = (sym_natural*sym_natural)(*range*) * (sym_natural*sym_natural) (*range m-of-n*) * inlined_subroutine + +type inlined_subroutine_data_by_range = list inlined_subroutine_data_by_range_entry + +(*type inlined_subroutine_data_at_pc = list ((compilation_unit * (list die) * die) * (natural * natural * single_location_description * error single_location))*) + + + + + + +(** ************************************************************ *) +(** ** missing pervasives ************************************ *) +(** ************************************************************ *) + +(* natural version of List.index *) +val index_natural : forall 'a. list 'a -> sym_natural -> maybe 'a +let rec index_natural l n= match l with + | [] -> Nothing + | x :: xs -> if n = 0 then Just x else index_natural xs (n-1) +end + +let partialNaturalFromInteger (i:integer) : sym_natural= + if i<0 then Assert_extra.failwith "partialNaturalFromInteger" else Absolute(naturalFromInteger i) + +val natural_nat_shift_left : natural -> nat -> natural +declare ocaml target_rep function natural_nat_shift_left = `Nat_big_num.shift_left` + +let sym_natural_nat_shift_left x y = sym_map (fun x -> natural_nat_shift_left x y) x + +val natural_nat_shift_right : natural -> nat -> natural +declare ocaml target_rep function natural_nat_shift_right = `Nat_big_num.shift_right` + +let sym_natural_nat_shift_right x y = sym_map (fun x -> natural_nat_shift_right x y) x + +(** ************************************************************ *) +(** ** endianness *************************************** *) +(** ************************************************************ *) + +let p_context_of_d (d:dwarf) : p_context= <| endianness = d.d_endianness |> + + + +(** ************************************************************ *) +(** ** dwarf encodings *************************************** *) +(** ************************************************************ *) + +(* these encoding tables are pasted from the DWARF 4 specification *) + +(* tag encoding *) +let tag_encodings= [ + ("DW_TAG_array_type" , natural_of_hex "0x01" ); + ("DW_TAG_class_type" , natural_of_hex "0x02" ); + ("DW_TAG_entry_point" , natural_of_hex "0x03" ); + ("DW_TAG_enumeration_type" , natural_of_hex "0x04" ); + ("DW_TAG_formal_parameter" , natural_of_hex "0x05" ); + ("DW_TAG_imported_declaration" , natural_of_hex "0x08" ); + ("DW_TAG_label" , natural_of_hex "0x0a" ); + ("DW_TAG_lexical_block" , natural_of_hex "0x0b" ); + ("DW_TAG_member" , natural_of_hex "0x0d" ); + ("DW_TAG_pointer_type" , natural_of_hex "0x0f" ); + ("DW_TAG_reference_type" , natural_of_hex "0x10" ); + ("DW_TAG_compile_unit" , natural_of_hex "0x11" ); + ("DW_TAG_string_type" , natural_of_hex "0x12" ); + ("DW_TAG_structure_type" , natural_of_hex "0x13" ); + ("DW_TAG_subroutine_type" , natural_of_hex "0x15" ); + ("DW_TAG_typedef" , natural_of_hex "0x16" ); + ("DW_TAG_union_type" , natural_of_hex "0x17" ); + ("DW_TAG_unspecified_parameters" , natural_of_hex "0x18" ); + ("DW_TAG_variant" , natural_of_hex "0x19" ); + ("DW_TAG_common_block" , natural_of_hex "0x1a" ); + ("DW_TAG_common_inclusion" , natural_of_hex "0x1b" ); + ("DW_TAG_inheritance" , natural_of_hex "0x1c" ); + ("DW_TAG_inlined_subroutine" , natural_of_hex "0x1d" ); + ("DW_TAG_module" , natural_of_hex "0x1e" ); + ("DW_TAG_ptr_to_member_type" , natural_of_hex "0x1f" ); + ("DW_TAG_set_type" , natural_of_hex "0x20" ); + ("DW_TAG_subrange_type" , natural_of_hex "0x21" ); + ("DW_TAG_with_stmt" , natural_of_hex "0x22" ); + ("DW_TAG_access_declaration" , natural_of_hex "0x23" ); + ("DW_TAG_base_type" , natural_of_hex "0x24" ); + ("DW_TAG_catch_block" , natural_of_hex "0x25" ); + ("DW_TAG_const_type" , natural_of_hex "0x26" ); + ("DW_TAG_constant" , natural_of_hex "0x27" ); + ("DW_TAG_enumerator" , natural_of_hex "0x28" ); + ("DW_TAG_file_type" , natural_of_hex "0x29" ); + ("DW_TAG_friend" , natural_of_hex "0x2a" ); + ("DW_TAG_namelist" , natural_of_hex "0x2b" ); + ("DW_TAG_namelist_item" , natural_of_hex "0x2c" ); + ("DW_TAG_packed_type" , natural_of_hex "0x2d" ); + ("DW_TAG_subprogram" , natural_of_hex "0x2e" ); + ("DW_TAG_template_type_parameter" , natural_of_hex "0x2f" ); + ("DW_TAG_template_value_parameter" , natural_of_hex "0x30" ); + ("DW_TAG_thrown_type" , natural_of_hex "0x31" ); + ("DW_TAG_try_block" , natural_of_hex "0x32" ); + ("DW_TAG_variant_part" , natural_of_hex "0x33" ); + ("DW_TAG_variable" , natural_of_hex "0x34" ); + ("DW_TAG_volatile_type" , natural_of_hex "0x35" ); + ("DW_TAG_dwarf_procedure" , natural_of_hex "0x36" ); + ("DW_TAG_restrict_type" , natural_of_hex "0x37" ); + ("DW_TAG_interface_type" , natural_of_hex "0x38" ); + ("DW_TAG_namespace" , natural_of_hex "0x39" ); + ("DW_TAG_imported_module" , natural_of_hex "0x3a" ); + ("DW_TAG_unspecified_type" , natural_of_hex "0x3b" ); + ("DW_TAG_partial_unit" , natural_of_hex "0x3c" ); + ("DW_TAG_imported_unit" , natural_of_hex "0x3d" ); + ("DW_TAG_condition" , natural_of_hex "0x3f" ); + ("DW_TAG_shared_type" , natural_of_hex "0x40" ); + ("DW_TAG_type_unit" , natural_of_hex "0x41" ); + ("DW_TAG_rvalue_reference_type" , natural_of_hex "0x42" ); + ("DW_TAG_template_alias" , natural_of_hex "0x43" ); + ("DW_TAG_lo_user" , natural_of_hex "0x4080"); + ("DW_TAG_hi_user" , natural_of_hex "0xffff") +] + + +(* child determination encoding *) + +let vDW_CHILDREN_no= natural_of_hex "0x00" +let vDW_CHILDREN_yes= natural_of_hex "0x01" + + +(* attribute encoding *) + +let attribute_encodings= [ + ("DW_AT_sibling" , natural_of_hex "0x01", [DWA_reference]) ; + ("DW_AT_location" , natural_of_hex "0x02", [DWA_exprloc; DWA_loclistptr]) ; + ("DW_AT_name" , natural_of_hex "0x03", [DWA_string]) ; + ("DW_AT_ordering" , natural_of_hex "0x09", [DWA_constant]) ; + ("DW_AT_byte_size" , natural_of_hex "0x0b", [DWA_constant; DWA_exprloc; DWA_reference]) ; + ("DW_AT_bit_offset" , natural_of_hex "0x0c", [DWA_constant; DWA_exprloc; DWA_reference]) ; + ("DW_AT_bit_size" , natural_of_hex "0x0d", [DWA_constant; DWA_exprloc; DWA_reference]) ; + ("DW_AT_stmt_list" , natural_of_hex "0x10", [DWA_lineptr]) ; + ("DW_AT_low_pc" , natural_of_hex "0x11", [DWA_address]) ; + ("DW_AT_high_pc" , natural_of_hex "0x12", [DWA_address; DWA_constant]) ; + ("DW_AT_language" , natural_of_hex "0x13", [DWA_constant]) ; + ("DW_AT_discr" , natural_of_hex "0x15", [DWA_reference]) ; + ("DW_AT_discr_value" , natural_of_hex "0x16", [DWA_constant]) ; + ("DW_AT_visibility" , natural_of_hex "0x17", [DWA_constant]) ; + ("DW_AT_import" , natural_of_hex "0x18", [DWA_reference]) ; + ("DW_AT_string_length" , natural_of_hex "0x19", [DWA_exprloc; DWA_loclistptr]) ; + ("DW_AT_common_reference" , natural_of_hex "0x1a", [DWA_reference]) ; + ("DW_AT_comp_dir" , natural_of_hex "0x1b", [DWA_string]) ; + ("DW_AT_const_value" , natural_of_hex "0x1c", [DWA_block; DWA_constant; DWA_string]) ; + ("DW_AT_containing_type" , natural_of_hex "0x1d", [DWA_reference]) ; + ("DW_AT_default_value" , natural_of_hex "0x1e", [DWA_reference]) ; + ("DW_AT_inline" , natural_of_hex "0x20", [DWA_constant]) ; + ("DW_AT_is_optional" , natural_of_hex "0x21", [DWA_flag]) ; + ("DW_AT_lower_bound" , natural_of_hex "0x22", [DWA_constant; DWA_exprloc; DWA_reference]) ; + ("DW_AT_producer" , natural_of_hex "0x25", [DWA_string]) ; + ("DW_AT_prototyped" , natural_of_hex "0x27", [DWA_flag]) ; + ("DW_AT_return_addr" , natural_of_hex "0x2a", [DWA_exprloc; DWA_loclistptr]) ; + ("DW_AT_start_scope" , natural_of_hex "0x2c", [DWA_constant; DWA_rangelistptr]) ; + ("DW_AT_bit_stride" , natural_of_hex "0x2e", [DWA_constant; DWA_exprloc; DWA_reference]) ; + ("DW_AT_upper_bound" , natural_of_hex "0x2f", [DWA_constant; DWA_exprloc; DWA_reference]) ; + ("DW_AT_abstract_origin" , natural_of_hex "0x31", [DWA_reference]) ; + ("DW_AT_accessibility" , natural_of_hex "0x32", [DWA_constant]) ; + ("DW_AT_address_class" , natural_of_hex "0x33", [DWA_constant]) ; + ("DW_AT_artificial" , natural_of_hex "0x34", [DWA_flag]) ; + ("DW_AT_base_types" , natural_of_hex "0x35", [DWA_reference]) ; + ("DW_AT_calling_convention" , natural_of_hex "0x36", [DWA_constant]) ; + ("DW_AT_count" , natural_of_hex "0x37", [DWA_constant; DWA_exprloc; DWA_reference]) ; + ("DW_AT_data_member_location" , natural_of_hex "0x38", [DWA_constant; DWA_exprloc; DWA_loclistptr]) ; + ("DW_AT_decl_column" , natural_of_hex "0x39", [DWA_constant]) ; + ("DW_AT_decl_file" , natural_of_hex "0x3a", [DWA_constant]) ; + ("DW_AT_decl_line" , natural_of_hex "0x3b", [DWA_constant]) ; + ("DW_AT_declaration" , natural_of_hex "0x3c", [DWA_flag]) ; + ("DW_AT_discr_list" , natural_of_hex "0x3d", [DWA_block]) ; + ("DW_AT_encoding" , natural_of_hex "0x3e", [DWA_constant]) ; + ("DW_AT_external" , natural_of_hex "0x3f", [DWA_flag]) ; + ("DW_AT_frame_base" , natural_of_hex "0x40", [DWA_exprloc; DWA_loclistptr]) ; + ("DW_AT_friend" , natural_of_hex "0x41", [DWA_reference]) ; + ("DW_AT_identifier_case" , natural_of_hex "0x42", [DWA_constant]) ; + ("DW_AT_macro_info" , natural_of_hex "0x43", [DWA_macptr]) ; + ("DW_AT_namelist_item" , natural_of_hex "0x44", [DWA_reference]) ; + ("DW_AT_priority" , natural_of_hex "0x45", [DWA_reference]) ; + ("DW_AT_segment" , natural_of_hex "0x46", [DWA_exprloc; DWA_loclistptr]) ; + ("DW_AT_specification" , natural_of_hex "0x47", [DWA_reference]) ; + ("DW_AT_static_link" , natural_of_hex "0x48", [DWA_exprloc; DWA_loclistptr]) ; + ("DW_AT_type" , natural_of_hex "0x49", [DWA_reference]) ; + ("DW_AT_use_location" , natural_of_hex "0x4a", [DWA_exprloc; DWA_loclistptr]) ; + ("DW_AT_variable_parameter" , natural_of_hex "0x4b", [DWA_flag]) ; + ("DW_AT_virtuality" , natural_of_hex "0x4c", [DWA_constant]) ; + ("DW_AT_vtable_elem_location" , natural_of_hex "0x4d", [DWA_exprloc; DWA_loclistptr]) ; + ("DW_AT_allocated" , natural_of_hex "0x4e", [DWA_constant; DWA_exprloc; DWA_reference]) ; + ("DW_AT_associated" , natural_of_hex "0x4f", [DWA_constant; DWA_exprloc; DWA_reference]) ; + ("DW_AT_data_location" , natural_of_hex "0x50", [DWA_exprloc]) ; + ("DW_AT_byte_stride" , natural_of_hex "0x51", [DWA_constant; DWA_exprloc; DWA_reference]) ; + ("DW_AT_entry_pc" , natural_of_hex "0x52", [DWA_address]) ; + ("DW_AT_use_UTF8" , natural_of_hex "0x53", [DWA_flag]) ; + ("DW_AT_extension" , natural_of_hex "0x54", [DWA_reference]) ; + ("DW_AT_ranges" , natural_of_hex "0x55", [DWA_rangelistptr]) ; + ("DW_AT_trampoline" , natural_of_hex "0x56", [DWA_address; DWA_flag; DWA_reference; DWA_string]); + ("DW_AT_call_column" , natural_of_hex "0x57", [DWA_constant]) ; + ("DW_AT_call_file" , natural_of_hex "0x58", [DWA_constant]) ; + ("DW_AT_call_line" , natural_of_hex "0x59", [DWA_constant]) ; + ("DW_AT_description" , natural_of_hex "0x5a", [DWA_string]) ; + ("DW_AT_binary_scale" , natural_of_hex "0x5b", [DWA_constant]) ; + ("DW_AT_decimal_scale" , natural_of_hex "0x5c", [DWA_constant]) ; + ("DW_AT_small" , natural_of_hex "0x5d", [DWA_reference]) ; + ("DW_AT_decimal_sign" , natural_of_hex "0x5e", [DWA_constant]) ; + ("DW_AT_digit_count" , natural_of_hex "0x5f", [DWA_constant]) ; + ("DW_AT_picture_string" , natural_of_hex "0x60", [DWA_string]) ; + ("DW_AT_mutable" , natural_of_hex "0x61", [DWA_flag]) ; + ("DW_AT_threads_scaled" , natural_of_hex "0x62", [DWA_flag]) ; + ("DW_AT_explicit" , natural_of_hex "0x63", [DWA_flag]) ; + ("DW_AT_object_pointer" , natural_of_hex "0x64", [DWA_reference]) ; + ("DW_AT_endianity" , natural_of_hex "0x65", [DWA_constant]) ; + ("DW_AT_elemental" , natural_of_hex "0x66", [DWA_flag]) ; + ("DW_AT_pure" , natural_of_hex "0x67", [DWA_flag]) ; + ("DW_AT_recursive" , natural_of_hex "0x68", [DWA_flag]) ; + ("DW_AT_signature" , natural_of_hex "0x69", [DWA_reference]) ; + ("DW_AT_main_subprogram" , natural_of_hex "0x6a", [DWA_flag]) ; + ("DW_AT_data_bit_offset" , natural_of_hex "0x6b", [DWA_constant]) ; + ("DW_AT_const_expr" , natural_of_hex "0x6c", [DWA_flag]) ; + ("DW_AT_enum_class" , natural_of_hex "0x6d", [DWA_flag]) ; + ("DW_AT_linkage_name" , natural_of_hex "0x6e", [DWA_string]) ; +(* DW_AT_noreturn is a gcc extension to support the C11 _Noreturn keyword*) + ("DW_AT_noreturn" , natural_of_hex "0x87", [DWA_flag]) ; + ("DW_AT_alignment" , natural_of_hex "0x88", [DWA_constant]) ; + ("DW_AT_lo_user" , natural_of_hex "0x2000", [DWA_dash]) ; + ("DW_AT_hi_user" , natural_of_hex "0x3fff", [DWA_dash]) +] + + +(* attribute form encoding *) + +let attribute_form_encodings= [ + ("DW_FORM_addr" , natural_of_hex "0x01", [DWA_address]) ; + ("DW_FORM_block2" , natural_of_hex "0x03", [DWA_block]) ; + ("DW_FORM_block4" , natural_of_hex "0x04", [DWA_block]) ; + ("DW_FORM_data2" , natural_of_hex "0x05", [DWA_constant]) ; + ("DW_FORM_data4" , natural_of_hex "0x06", [DWA_constant]) ; + ("DW_FORM_data8" , natural_of_hex "0x07", [DWA_constant]) ; + ("DW_FORM_string" , natural_of_hex "0x08", [DWA_string]) ; + ("DW_FORM_block" , natural_of_hex "0x09", [DWA_block]) ; + ("DW_FORM_block1" , natural_of_hex "0x0a", [DWA_block]) ; + ("DW_FORM_data1" , natural_of_hex "0x0b", [DWA_constant]) ; + ("DW_FORM_flag" , natural_of_hex "0x0c", [DWA_flag]) ; + ("DW_FORM_sdata" , natural_of_hex "0x0d", [DWA_constant]) ; + ("DW_FORM_strp" , natural_of_hex "0x0e", [DWA_string]) ; + ("DW_FORM_udata" , natural_of_hex "0x0f", [DWA_constant]) ; + ("DW_FORM_ref_addr" , natural_of_hex "0x10", [DWA_reference]); + ("DW_FORM_ref1" , natural_of_hex "0x11", [DWA_reference]); + ("DW_FORM_ref2" , natural_of_hex "0x12", [DWA_reference]); + ("DW_FORM_ref4" , natural_of_hex "0x13", [DWA_reference]); + ("DW_FORM_ref8" , natural_of_hex "0x14", [DWA_reference]); + ("DW_FORM_ref_udata" , natural_of_hex "0x15", [DWA_reference]); + ("DW_FORM_indirect" , natural_of_hex "0x16", [DWA_7_5_3]) ; + ("DW_FORM_sec_offset" , natural_of_hex "0x17", [DWA_lineptr; DWA_loclistptr; DWA_macptr; DWA_rangelistptr]) ; + ("DW_FORM_exprloc" , natural_of_hex "0x18", [DWA_exprloc]) ; + ("DW_FORM_flag_present", natural_of_hex "0x19", [DWA_flag]) ; + ("DW_FORM_ref_sig8" , natural_of_hex "0x20", [DWA_reference]) +] + + +(* operation encoding *) + +let operation_encodings= [ +("DW_OP_addr", natural_of_hex "0x03", [OAT_addr] , OpSem_lit); (*1*) (*constant address (size target specific)*) +("DW_OP_deref", natural_of_hex "0x06", [] , OpSem_deref); (*0*) +("DW_OP_const1u", natural_of_hex "0x08", [OAT_uint8] , OpSem_lit); (*1*) (* 1-byte constant *) +("DW_OP_const1s", natural_of_hex "0x09", [OAT_sint8] , OpSem_lit); (*1*) (* 1-byte constant *) +("DW_OP_const2u", natural_of_hex "0x0a", [OAT_uint16] , OpSem_lit); (*1*) (* 2-byte constant *) +("DW_OP_const2s", natural_of_hex "0x0b", [OAT_sint16] , OpSem_lit); (*1*) (* 2-byte constant *) +("DW_OP_const4u", natural_of_hex "0x0c", [OAT_uint32] , OpSem_lit); (*1*) (* 4-byte constant *) +("DW_OP_const4s", natural_of_hex "0x0d", [OAT_sint32] , OpSem_lit); (*1*) (* 4-byte constant *) +("DW_OP_const8u", natural_of_hex "0x0e", [OAT_uint64] , OpSem_lit); (*1*) (* 8-byte constant *) +("DW_OP_const8s", natural_of_hex "0x0f", [OAT_sint64] , OpSem_lit); (*1*) (* 8-byte constant *) +("DW_OP_constu", natural_of_hex "0x10", [OAT_ULEB128] , OpSem_lit); (*1*) (* ULEB128 constant *) +("DW_OP_consts", natural_of_hex "0x11", [OAT_SLEB128] , OpSem_lit); (*1*) (* SLEB128 constant *) +("DW_OP_dup", natural_of_hex "0x12", [] , OpSem_stack (fun ac vs args -> match vs with v::vs -> Just (v::v::vs) | _ -> Nothing end)); (*0*) +("DW_OP_drop", natural_of_hex "0x13", [] , OpSem_stack (fun ac vs args -> match vs with v::vs -> Just vs | _ -> Nothing end)); (*0*) +("DW_OP_over", natural_of_hex "0x14", [] , OpSem_stack (fun ac vs args -> match vs with v::v'::vs -> Just (v'::v::v'::vs) | _ -> Nothing end)); (*0*) +("DW_OP_pick", natural_of_hex "0x15", [OAT_uint8] , OpSem_stack (fun ac vs args -> match args with [OAV_natural n] -> match index_natural vs n with Just v -> Just (v::vs) | Nothing -> Nothing end | _ -> Nothing end)); (*1*) (* 1-byte stack index *) +("DW_OP_swap", natural_of_hex "0x16", [] , OpSem_stack (fun ac vs args -> match vs with v::v'::vs -> Just (v'::v::vs) | _ -> Nothing end)); (*0*) +("DW_OP_rot", natural_of_hex "0x17", [] , OpSem_stack (fun ac vs args -> match vs with v::v'::v''::vs -> Just (v'::v''::v::vs) | _ -> Nothing end)); (*0*) +("DW_OP_xderef", natural_of_hex "0x18", [] , OpSem_not_supported); (*0*) +("DW_OP_abs", natural_of_hex "0x19", [] , OpSem_unary (fun ac v -> if v < ac.ac_half then Just v else if v=ac.ac_max then Nothing else Just (ac.ac_all-v))); (*0*) +("DW_OP_and", natural_of_hex "0x1a", [] , OpSem_binary (fun ac v1 v2 -> Just (sym_natural_land v1 v2))); (*0*) +("DW_OP_div", natural_of_hex "0x1b", [] , OpSem_not_supported) (*TODO*); (*0*) +("DW_OP_minus", natural_of_hex "0x1c", [] , OpSem_binary (fun ac v1 v2 -> Just (partialNaturalFromInteger ((integerFromSymNatural v1 - integerFromSymNatural v2) mod (integerFromSymNatural ac.ac_all))))); (*0*) +("DW_OP_mod", natural_of_hex "0x1d", [] , OpSem_binary (fun ac v1 v2 -> Just (v1 mod v2))); (*0*) +("DW_OP_mul", natural_of_hex "0x1e", [] , OpSem_binary (fun ac v1 v2 -> Just (partialNaturalFromInteger ((integerFromSymNatural v1 * integerFromSymNatural v2) mod (integerFromSymNatural ac.ac_all))))); (*0*) +("DW_OP_neg", natural_of_hex "0x1f", [] , OpSem_unary (fun ac v -> if v < ac.ac_half then Just (ac.ac_max - v) else if v=ac.ac_half then Nothing else Just (ac.ac_all - v))); (*0*) +("DW_OP_not", natural_of_hex "0x20", [] , OpSem_unary (fun ac v -> Just (sym_natural_lxor v ac.ac_max))); (*0*) +("DW_OP_or", natural_of_hex "0x21", [] , OpSem_binary (fun ac v1 v2 -> Just (sym_natural_lor v1 v2))); (*0*) +("DW_OP_plus", natural_of_hex "0x22", [] , OpSem_binary (fun ac v1 v2 -> Just ((v1 + v2) mod ac.ac_all))); (*0*) +("DW_OP_plus_uconst", natural_of_hex "0x23", [OAT_ULEB128] , OpSem_stack (fun ac vs args -> match args with [OAV_natural n] -> match vs with v::vs' -> let v' = (v+n) mod ac.ac_all in Just (v'::vs) | [] -> Nothing end | _ -> Nothing end)); (*1*) (* ULEB128 addend *) +("DW_OP_shl", natural_of_hex "0x24", [] , OpSem_binary (fun ac v1 v2 -> if v2 >= ac.ac_bitwidth then Just 0 else Just (sym_natural_nat_shift_left v1 (natFromSymNatural v2)))); (*0*) +("DW_OP_shr", natural_of_hex "0x25", [] , OpSem_binary (fun ac v1 v2 -> if v2 >= ac.ac_bitwidth then Just 0 else Just (sym_natural_nat_shift_right v1 (natFromSymNatural v2)))); (*0*) +("DW_OP_shra", natural_of_hex "0x26", [] , OpSem_binary (fun ac v1 v2 -> if v1 < ac.ac_half then (if v2 >= ac.ac_bitwidth then Just 0 else Just (sym_natural_nat_shift_right v1 (natFromSymNatural v2))) else (if v2 >= ac.ac_bitwidth then Just ac.ac_max else Just (ac.ac_max - (sym_natural_nat_shift_right (ac.ac_max - v1) (natFromSymNatural v2)))))); (*0*) +("DW_OP_xor", natural_of_hex "0x27", [] , OpSem_binary (fun ac v1 v2 -> Just (sym_natural_lxor v1 v2))); (*0*) +("DW_OP_skip", natural_of_hex "0x2f", [OAT_sint16] , OpSem_not_supported); (*1*) (* signed 2-byte constant *) +("DW_OP_bra", natural_of_hex "0x28", [OAT_sint16] , OpSem_not_supported); (*1*) (* signed 2-byte constant *) +("DW_OP_eq", natural_of_hex "0x29", [] , OpSem_not_supported); (*0*) +("DW_OP_ge", natural_of_hex "0x2a", [] , OpSem_not_supported); (*0*) +("DW_OP_gt", natural_of_hex "0x2b", [] , OpSem_not_supported); (*0*) +("DW_OP_le", natural_of_hex "0x2c", [] , OpSem_not_supported); (*0*) +("DW_OP_lt", natural_of_hex "0x2d", [] , OpSem_not_supported); (*0*) +("DW_OP_ne", natural_of_hex "0x2e", [] , OpSem_not_supported); (*0*) +("DW_OP_lit0", natural_of_hex "0x30", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) (* literals 0..31 =(DW_OP_lit0 + literal) *) +("DW_OP_lit1", natural_of_hex "0x31", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit2", natural_of_hex "0x32", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit3", natural_of_hex "0x33", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit4", natural_of_hex "0x34", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit5", natural_of_hex "0x35", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit6", natural_of_hex "0x36", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit7", natural_of_hex "0x37", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit8", natural_of_hex "0x38", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit9", natural_of_hex "0x39", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit10", natural_of_hex "0x3a", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit11", natural_of_hex "0x3b", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit12", natural_of_hex "0x3c", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit13", natural_of_hex "0x3d", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit14", natural_of_hex "0x3e", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit15", natural_of_hex "0x3f", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit16", natural_of_hex "0x40", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit17", natural_of_hex "0x41", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit18", natural_of_hex "0x42", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit19", natural_of_hex "0x43", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit20", natural_of_hex "0x44", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit21", natural_of_hex "0x45", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit22", natural_of_hex "0x46", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit23", natural_of_hex "0x47", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit24", natural_of_hex "0x48", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit25", natural_of_hex "0x49", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit26", natural_of_hex "0x4a", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit27", natural_of_hex "0x4b", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit28", natural_of_hex "0x4c", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit29", natural_of_hex "0x4d", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit30", natural_of_hex "0x4e", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit31", natural_of_hex "0x4f", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_reg0", natural_of_hex "0x50", [] , OpSem_reg); (*1*) (* reg 0..31 = (DW_OP_reg0 + regnum) *) +("DW_OP_reg1", natural_of_hex "0x51", [] , OpSem_reg); (*1*) +("DW_OP_reg2", natural_of_hex "0x52", [] , OpSem_reg); (*1*) +("DW_OP_reg3", natural_of_hex "0x53", [] , OpSem_reg); (*1*) +("DW_OP_reg4", natural_of_hex "0x54", [] , OpSem_reg); (*1*) +("DW_OP_reg5", natural_of_hex "0x55", [] , OpSem_reg); (*1*) +("DW_OP_reg6", natural_of_hex "0x56", [] , OpSem_reg); (*1*) +("DW_OP_reg7", natural_of_hex "0x57", [] , OpSem_reg); (*1*) +("DW_OP_reg8", natural_of_hex "0x58", [] , OpSem_reg); (*1*) +("DW_OP_reg9", natural_of_hex "0x59", [] , OpSem_reg); (*1*) +("DW_OP_reg10", natural_of_hex "0x5a", [] , OpSem_reg); (*1*) +("DW_OP_reg11", natural_of_hex "0x5b", [] , OpSem_reg); (*1*) +("DW_OP_reg12", natural_of_hex "0x5c", [] , OpSem_reg); (*1*) +("DW_OP_reg13", natural_of_hex "0x5d", [] , OpSem_reg); (*1*) +("DW_OP_reg14", natural_of_hex "0x5e", [] , OpSem_reg); (*1*) +("DW_OP_reg15", natural_of_hex "0x5f", [] , OpSem_reg); (*1*) +("DW_OP_reg16", natural_of_hex "0x60", [] , OpSem_reg); (*1*) +("DW_OP_reg17", natural_of_hex "0x61", [] , OpSem_reg); (*1*) +("DW_OP_reg18", natural_of_hex "0x62", [] , OpSem_reg); (*1*) +("DW_OP_reg19", natural_of_hex "0x63", [] , OpSem_reg); (*1*) +("DW_OP_reg20", natural_of_hex "0x64", [] , OpSem_reg); (*1*) +("DW_OP_reg21", natural_of_hex "0x65", [] , OpSem_reg); (*1*) +("DW_OP_reg22", natural_of_hex "0x66", [] , OpSem_reg); (*1*) +("DW_OP_reg23", natural_of_hex "0x67", [] , OpSem_reg); (*1*) +("DW_OP_reg24", natural_of_hex "0x68", [] , OpSem_reg); (*1*) +("DW_OP_reg25", natural_of_hex "0x69", [] , OpSem_reg); (*1*) +("DW_OP_reg26", natural_of_hex "0x6a", [] , OpSem_reg); (*1*) +("DW_OP_reg27", natural_of_hex "0x6b", [] , OpSem_reg); (*1*) +("DW_OP_reg28", natural_of_hex "0x6c", [] , OpSem_reg); (*1*) +("DW_OP_reg29", natural_of_hex "0x6d", [] , OpSem_reg); (*1*) +("DW_OP_reg30", natural_of_hex "0x6e", [] , OpSem_reg); (*1*) +("DW_OP_reg31", natural_of_hex "0x6f", [] , OpSem_reg); (*1*) +("DW_OP_breg0", natural_of_hex "0x70", [OAT_SLEB128] , OpSem_breg); (*1*) (* base register 0..31 = (DW_OP_breg0 + regnum) *) +("DW_OP_breg1", natural_of_hex "0x71", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg2", natural_of_hex "0x72", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg3", natural_of_hex "0x73", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg4", natural_of_hex "0x74", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg5", natural_of_hex "0x75", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg6", natural_of_hex "0x76", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg7", natural_of_hex "0x77", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg8", natural_of_hex "0x78", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg9", natural_of_hex "0x79", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg10", natural_of_hex "0x7a", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg11", natural_of_hex "0x7b", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg12", natural_of_hex "0x7c", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg13", natural_of_hex "0x7d", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg14", natural_of_hex "0x7e", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg15", natural_of_hex "0x7f", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg16", natural_of_hex "0x80", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg17", natural_of_hex "0x81", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg18", natural_of_hex "0x82", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg19", natural_of_hex "0x83", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg20", natural_of_hex "0x84", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg21", natural_of_hex "0x85", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg22", natural_of_hex "0x86", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg23", natural_of_hex "0x87", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg24", natural_of_hex "0x88", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg25", natural_of_hex "0x89", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg26", natural_of_hex "0x8a", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg27", natural_of_hex "0x8b", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg28", natural_of_hex "0x8c", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg29", natural_of_hex "0x8d", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg30", natural_of_hex "0x8e", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg31", natural_of_hex "0x8f", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_regx", natural_of_hex "0x90", [OAT_ULEB128] , OpSem_lit); (*1*) (* ULEB128 register *) +("DW_OP_fbreg", natural_of_hex "0x91", [OAT_SLEB128] , OpSem_fbreg); (*1*) (* SLEB128 offset *) +("DW_OP_bregx", natural_of_hex "0x92", [OAT_ULEB128; OAT_SLEB128] , OpSem_bregx); (*2*) (* ULEB128 register followed by SLEB128 offset *) +("DW_OP_piece", natural_of_hex "0x93", [OAT_ULEB128] , OpSem_piece); (*1*) (* ULEB128 size of piece addressed *) +("DW_OP_deref_size", natural_of_hex "0x94", [OAT_uint8] , OpSem_deref_size); (*1*) (* 1-byte size of data retrieved *) +("DW_OP_xderef_size", natural_of_hex "0x95", [OAT_uint8] , OpSem_not_supported); (*1*) (* 1-byte size of data retrieved *) +("DW_OP_nop", natural_of_hex "0x96", [] , OpSem_nop); (*0*) +("DW_OP_push_object_address", natural_of_hex "0x97", [] , OpSem_not_supported); (*0*) +("DW_OP_call2", natural_of_hex "0x98", [OAT_uint16] , OpSem_not_supported); (*1*) (* 2-byte offset of DIE *) +("DW_OP_call4", natural_of_hex "0x99", [OAT_uint32] , OpSem_not_supported); (*1*) (* 4-byte offset of DIE *) +("DW_OP_call_ref", natural_of_hex "0x9a", [OAT_dwarf_format_t] , OpSem_not_supported); (*1*) (* 4- or 8-byte offset of DIE *) +("DW_OP_form_tls_address", natural_of_hex "0x9b", [] , OpSem_not_supported); (*0*) +("DW_OP_call_frame_cfa", natural_of_hex "0x9c", [] , OpSem_call_frame_cfa); (*0*) +("DW_OP_bit_piece", natural_of_hex "0x9d", [OAT_ULEB128; OAT_ULEB128] , OpSem_bit_piece); (*2*) (* ULEB128 size followed by ULEB128 offset *) +("DW_OP_implicit_value", natural_of_hex "0x9e", [OAT_block] , OpSem_implicit_value); (*2*) (* ULEB128 size followed by block of that size *) +("DW_OP_stack_value", natural_of_hex "0x9f", [] , OpSem_stack_value); (*0*) +(* these aren't real operations +("DW_OP_lo_user", natural_of_hex "0xe0", [] , ); +("DW_OP_hi_user", natural_of_hex "0xff", [] , ); +*) + +(* GCC also produces these for our example: +https://fedorahosted.org/elfutils/wiki/DwarfExtensions +http://dwarfstd.org/ShowIssue.php?issue=100909.1 *) +("DW_GNU_OP_entry_value", natural_of_hex "0xf3", [OAT_block], OpSem_not_supported); (*2*) (* ULEB128 size followed by DWARF expression block of that size*) +("DW_OP_GNU_implicit_pointer", natural_of_hex "0xf2", [OAT_dwarf_format_t;OAT_SLEB128], OpSem_not_supported) + +] + + +let vDW_OP_reg0= natural_of_hex "0x50" +let vDW_OP_breg0= natural_of_hex "0x70" + + +(* call frame instruction encoding *) + +let call_frame_instruction_encoding : list (string * natural * natural * list call_frame_argument_type * ((list call_frame_argument_value) -> maybe call_frame_instruction))= [ +(* high-order 2 bits low-order 6 bits uniformly parsed arguments *) + +(* instructions using low-order 6 bits for first argument *) +(* +("DW_CFA_advance_loc", 1, 0,(*delta *) []); +("DW_CFA_offset", 2, 0,(*register*) [CFAT_offset]); +("DW_CFA_restore", 3, 0,(*register*) []); +*) +(* instructions using low-order 6 bits as part of opcode *) +("DW_CFA_nop", 0, natural_of_hex "0x00", [], (* *) + fun avs -> match avs with [] -> Just (DW_CFA_nop) | _ -> Nothing end); +("DW_CFA_set_loc", 0, natural_of_hex "0x01", [CFAT_address], (* address *) + fun avs -> match avs with [CFAV_address a] -> Just (DW_CFA_set_loc a) | _ -> Nothing end); +("DW_CFA_advance_loc1", 0, natural_of_hex "0x02", [CFAT_delta1], (* 1-byte delta *) + fun avs -> match avs with [CFAV_delta d] -> Just (DW_CFA_advance_loc1 d) | _ -> Nothing end); +("DW_CFA_advance_loc2", 0, natural_of_hex "0x03", [CFAT_delta2], (* 2-byte delta *) + fun avs -> match avs with [CFAV_delta d] -> Just (DW_CFA_advance_loc2 d) | _ -> Nothing end); +("DW_CFA_advance_loc4", 0, natural_of_hex "0x04", [CFAT_delta4], (* 4-byte delta *) + fun avs -> match avs with [CFAV_delta d] -> Just (DW_CFA_advance_loc4 d) | _ -> Nothing end); +("DW_CFA_offset_extended", 0, natural_of_hex "0x05", [CFAT_register; CFAT_offset], (* ULEB128 register ULEB128 offset *) + fun avs -> match avs with [CFAV_register r; CFAV_offset n] -> Just (DW_CFA_offset_extended r n) | _ -> Nothing end); +("DW_CFA_restore_extended", 0, natural_of_hex "0x06", [CFAT_register], (* ULEB128 register *) + fun avs -> match avs with [CFAV_register r] -> Just (DW_CFA_restore_extended r) | _ -> Nothing end); +("DW_CFA_undefined", 0, natural_of_hex "0x07", [CFAT_register], (* ULEB128 register *) + fun avs -> match avs with [CFAV_register r] -> Just (DW_CFA_undefined r) | _ -> Nothing end); +("DW_CFA_same_value", 0, natural_of_hex "0x08", [CFAT_register], (* ULEB128 register *) + fun avs -> match avs with [CFAV_register r] -> Just (DW_CFA_same_value r) | _ -> Nothing end); +("DW_CFA_register", 0, natural_of_hex "0x09", [CFAT_register; CFAT_register], (* ULEB128 register ULEB128 register *) + fun avs -> match avs with [CFAV_register r1; CFAV_register r2] -> Just (DW_CFA_register r1 r2) | _ -> Nothing end); +("DW_CFA_remember_state", 0, natural_of_hex "0x0a", [], (* *) + fun avs -> match avs with [] -> Just (DW_CFA_remember_state) | _ -> Nothing end); +("DW_CFA_restore_state", 0, natural_of_hex "0x0b", [], (* *) + fun avs -> match avs with [] -> Just (DW_CFA_restore_state) | _ -> Nothing end); +("DW_CFA_def_cfa", 0, natural_of_hex "0x0c", [CFAT_register; CFAT_offset], (* ULEB128 register ULEB128 offset *) + fun avs -> match avs with [CFAV_register r; CFAV_offset n] -> Just (DW_CFA_def_cfa r n) | _ -> Nothing end); +("DW_CFA_def_cfa_register", 0, natural_of_hex "0x0d", [CFAT_register], (* ULEB128 register *) + fun avs -> match avs with [CFAV_register r] -> Just (DW_CFA_def_cfa_register r) | _ -> Nothing end); +("DW_CFA_def_cfa_offset", 0, natural_of_hex "0x0e", [CFAT_offset], (* ULEB128 offset *) + fun avs -> match avs with [CFAV_offset n] -> Just (DW_CFA_def_cfa_offset n) | _ -> Nothing end); +("DW_CFA_def_cfa_expression", 0, natural_of_hex "0x0f", [CFAT_block], (* BLOCK *) + fun avs -> match avs with [CFAV_block b] -> Just (DW_CFA_def_cfa_expression b) | _ -> Nothing end); +("DW_CFA_expression", 0, natural_of_hex "0x10", [CFAT_register; CFAT_block], (* ULEB128 register BLOCK *) + fun avs -> match avs with [CFAV_register r; CFAV_block b] -> Just (DW_CFA_expression r b) | _ -> Nothing end); +("DW_CFA_offset_extended_sf", 0, natural_of_hex "0x11", [CFAT_register; CFAT_sfoffset], (* ULEB128 register SLEB128 offset *) + fun avs -> match avs with [CFAV_register r; CFAV_sfoffset i] -> Just (DW_CFA_offset_extended_sf r i) | _ -> Nothing end); +("DW_CFA_def_cfa_sf", 0, natural_of_hex "0x12", [CFAT_register; CFAT_sfoffset], (* ULEB128 register SLEB128 offset *) + fun avs -> match avs with [CFAV_register r; CFAV_sfoffset i] -> Just (DW_CFA_def_cfa_sf r i) | _ -> Nothing end); +("DW_CFA_def_cfa_offset_sf", 0, natural_of_hex "0x13", [CFAT_sfoffset], (* SLEB128 offset *) + fun avs -> match avs with [CFAV_sfoffset i] -> Just (DW_CFA_def_cfa_offset_sf i) | _ -> Nothing end); +("DW_CFA_val_offset", 0, natural_of_hex "0x14", [CFAT_register; CFAT_offset], (* ULEB128 ULEB128 *) + fun avs -> match avs with [CFAV_register r; CFAV_offset n] -> Just (DW_CFA_val_offset r n) | _ -> Nothing end); +("DW_CFA_val_offset_sf", 0, natural_of_hex "0x15", [CFAT_register; CFAT_sfoffset], (* ULEB128 SLEB128 *) + fun avs -> match avs with [CFAV_register r; CFAV_sfoffset i] -> Just (DW_CFA_val_offset_sf r i) | _ -> Nothing end); +("DW_CFA_val_expression", 0, natural_of_hex "0x16", [CFAT_register; CFAT_block], (* ULEB128 BLOCK *) + fun avs -> match avs with [CFAV_register r; CFAV_block b] -> Just (DW_CFA_val_expression r b) | _ -> Nothing end); +("DW_CFA_AARCH64_negate_ra_state", 0, natural_of_hex "0x2d", [], (* *) + fun avs -> match avs with [] -> Just (DW_CFA_AARCH64_negate_ra_state) | _ -> Nothing end); +] +(* +0x2d DW_CFA_GNU_window_save is listed in https://sourceware.org/elfutils/DwarfExtensions as "magic shorthand used only by SPARC" +https://elixir.bootlin.com/linux/v4.0/source/arch/arc/kernel/unwind.c#L842 no-ops it +https://refspecs.linuxbase.org/LSB_3.0.0/LSB-PDA/LSB-PDA/dwarfext.html doesn't mention it +https://github.com/gcc-mirror/gcc/blob/master/libgcc/unwind-dw2.c#L1189 says +"This CFA is multiplexed with Sparc. On AArch64 it's used to toggle return address signing status." +fs->regs.reg[DWARF_REGNUM_AARCH64_RA_STATE].loc.offset ^= 1; +https://developer.arm.com/docs/ihi0057/c/dwarf-for-the-arm-64-bit-architecture-aarch64-abi-2018q4 "DWARF for the Arm® 64-bit Architecture (AArch64) - ABI 2018Q4" +calls this "DW_CFA_AARCH64_negate_ra_state" +"The DW_CFA_AARCH64_negate_ra_state operation negates bit[0] of the RA_SIGN_STATE pseudo-register. It does not take any operands." +p10 says "The RA_SIGN_STATE pseudo-register records whether the return address has been signed with aPAC. This information can be used when unwinding. It is an unsigned integer with the same sizeas a general register. Only bit[0] is meaningful and is initialized to zero. A value of 0 indicates the return address has not been signed. A value of 1 indicates the return address has been signed" +For our purposes it seems fine to nop-this. + *) + (* +("DW_CFA_lo_user", 0, natural_of_hex "0x1c", []); (* *) +("DW_CFA_hi_user", 0, natural_of_hex "0x3f", []); (* *) +*) + + +(* line number encodings *) + +let line_number_standard_encodings= [ + ("DW_LNS_copy" , natural_of_hex "0x01", [ ], + fun lnvs -> match lnvs with [] -> Just DW_LNS_copy | _ -> Nothing end); + ("DW_LNS_advance_pc" , natural_of_hex "0x02", [LNAT_ULEB128 ], + fun lnvs -> match lnvs with [LNAV_ULEB128 n] -> Just (DW_LNS_advance_pc n) | _ -> Nothing end); + ("DW_LNS_advance_line" , natural_of_hex "0x03", [LNAT_SLEB128 ], + fun lnvs -> match lnvs with [LNAV_SLEB128 i] -> Just (DW_LNS_advance_line i) | _ -> Nothing end); + ("DW_LNS_set_file" , natural_of_hex "0x04", [LNAT_ULEB128 ], + fun lnvs -> match lnvs with [LNAV_ULEB128 n] -> Just (DW_LNS_set_file n) | _ -> Nothing end); + ("DW_LNS_set_column" , natural_of_hex "0x05", [LNAT_ULEB128 ], + fun lnvs -> match lnvs with [LNAV_ULEB128 n] -> Just (DW_LNS_set_column n) | _ -> Nothing end); + ("DW_LNS_negate_stmt" , natural_of_hex "0x06", [ ], + fun lnvs -> match lnvs with [] -> Just (DW_LNS_negate_stmt) | _ -> Nothing end); + ("DW_LNS_set_basic_block" , natural_of_hex "0x07", [ ], + fun lnvs -> match lnvs with [] -> Just (DW_LNS_set_basic_block) | _ -> Nothing end); + ("DW_LNS_const_add_pc" , natural_of_hex "0x08", [ ], + fun lnvs -> match lnvs with [] -> Just (DW_LNS_const_add_pc) | _ -> Nothing end); + ("DW_LNS_fixed_advance_pc" , natural_of_hex "0x09", [LNAT_uint16 ], + fun lnvs -> match lnvs with [LNAV_uint16 n] -> Just (DW_LNS_fixed_advance_pc n) | _ -> Nothing end); + ("DW_LNS_set_prologue_end" , natural_of_hex "0x0a", [ ], + fun lnvs -> match lnvs with [] -> Just (DW_LNS_set_prologue_end) | _ -> Nothing end); + ("DW_LNS_set_epilogue_begin" , natural_of_hex "0x0b", [ ], + fun lnvs -> match lnvs with [] -> Just (DW_LNS_set_epilogue_begin) | _ -> Nothing end); + ("DW_LNS_set_isa" , natural_of_hex "0x0c", [LNAT_ULEB128 ], + fun lnvs -> match lnvs with [LNAV_ULEB128 n] -> Just (DW_LNS_set_isa n) | _ -> Nothing end) +] + +let line_number_extended_encodings= [ + ("DW_LNE_end_sequence" , natural_of_hex "0x01", [], + fun lnvs -> match lnvs with [] -> Just (DW_LNE_end_sequence) | _ -> Nothing end); + ("DW_LNE_set_address" , natural_of_hex "0x02", [LNAT_address], + fun lnvs -> match lnvs with [LNAV_address n] -> Just (DW_LNE_set_address n) | _ -> Nothing end); + ("DW_LNE_define_file" , natural_of_hex "0x03", [LNAT_string; LNAT_ULEB128; LNAT_ULEB128; LNAT_ULEB128], + fun lnvs -> match lnvs with [LNAV_string s; LNAV_ULEB128 n1; LNAV_ULEB128 n2; LNAV_ULEB128 n3] -> Just (DW_LNE_define_file s n1 n2 n3) | _ -> Nothing end); + ("DW_LNE_set_discriminator" , natural_of_hex "0x04", [LNAT_ULEB128], + fun lnvs -> match lnvs with [LNAV_ULEB128 n] -> Just (DW_LNE_set_discriminator n) | _ -> Nothing end) (* new in Dwarf 4*) +] + + +(* +(DW_LNE_lo_user , natural_of_hex "0x80", "DW_LNE_lo_user"); +(DW_LNE_hi_user , natural_of_hex "0xff", "DW_LNE_hi_user"); +*) + + + +(* booleans encoded as a single byte containing the value 0 for “false,” and a non-zero value for “true.” *) + +(* base type attribute encoding *) +let base_type_attribute_encodings= [ + ("DW_ATE_address" , natural_of_hex "0x01"); + ("DW_ATE_boolean" , natural_of_hex "0x02"); + ("DW_ATE_complex_float" , natural_of_hex "0x03"); + ("DW_ATE_float" , natural_of_hex "0x04"); + ("DW_ATE_signed" , natural_of_hex "0x05"); + ("DW_ATE_signed_char" , natural_of_hex "0x06"); + ("DW_ATE_unsigned" , natural_of_hex "0x07"); + ("DW_ATE_unsigned_char" , natural_of_hex "0x08"); + ("DW_ATE_imaginary_float" , natural_of_hex "0x09"); + ("DW_ATE_packed_decimal" , natural_of_hex "0x0a"); + ("DW_ATE_numeric_string" , natural_of_hex "0x0b"); + ("DW_ATE_edited" , natural_of_hex "0x0c"); + ("DW_ATE_signed_fixed" , natural_of_hex "0x0d"); + ("DW_ATE_unsigned_fixed" , natural_of_hex "0x0e"); + ("DW_ATE_decimal_float" , natural_of_hex "0x0f"); + ("DW_ATE_UTF" , natural_of_hex "0x10"); + ("DW_ATE_lo_user" , natural_of_hex "0x80"); + ("DW_ATE_signed_capability_hack_a0" , natural_of_hex "0xa0"); + ("DW_ATE_unsigned_capability_hack_a1" , natural_of_hex "0xa1"); + ("DW_ATE_hi_user" , natural_of_hex "0xff") + ] + +(** ************************************************************ *) +(** ** more missing pervasives and bits *********************** *) +(** ************************************************************ *) + + +(* quick hacky workaround: this is in String.lem, in src_lem_library, but the linker doesn't find it *) +val myconcat : string -> list string -> string +let rec myconcat sep ss= + match ss with + | [] -> "" + | s :: ss' -> + match ss' with + | [] -> s + | _ -> s ^ sep ^ myconcat sep ss' + end + end + +val myhead : forall 'a. list 'a -> 'a +let myhead l= match l with | x::xs -> x | [] -> Assert_extra.failwith "myhead of empty list" end + + +val myfindNonPure : forall 'a. ('a -> bool) -> list 'a -> 'a +let myfindNonPure P l= match (List.find P l) with + | Just e -> e + | Nothing -> Assert_extra.failwith "myfindNonPure" +end + +val myfindmaybe : forall 'a 'b. ('a -> maybe 'b) -> list 'a -> maybe 'b +let rec myfindmaybe f xs= + match xs with + | [] -> Nothing + | x::xs' -> match f x with Just y -> Just y | Nothing -> myfindmaybe f xs' end + end + +val myfind : forall 'a. ('a -> bool) -> list 'a -> maybe 'a +let rec myfind f xs= + match xs with + | [] -> Nothing + | x::xs' -> match f x with true -> Just x | false -> myfind f xs' end + end + +val myfiltermaybe : forall 'a 'b. ('a -> maybe 'b) -> list 'a -> list 'b +let rec myfiltermaybe f xs= + match xs with + | [] -> [] + | x::xs' -> match f x with Just y -> y::myfiltermaybe f xs'| Nothing -> myfiltermaybe f xs' end + end + + + +val bytes_of_natural: endianness -> natural (*size*) -> natural (*value*) -> byte_sequence +let bytes_of_natural en size n= + byte_sequence_of_byte_list ( + if size = 8 then + bytes_of_elf64_xword en (elf64_xword_of_natural n) + else if size = 4 then + bytes_of_elf32_word en (elf32_word_of_natural n) + else + Assert_extra.failwith "bytes_of_natural given size that is not 4 or 8") + +let rec natural_of_bytes_little bs : natural= + match read_char bs with + | Fail _ -> 0 + | Success (b, bs') -> natural_of_byte b + 256 * natural_of_bytes_little bs' + end + +let rec natural_of_bytes_big acc bs= + match read_char bs with + | Fail _ -> acc + | Success (b, bs') -> natural_of_bytes_big (natural_of_byte b + 256 * acc) bs' +end + +val natural_of_bytes: endianness -> byte_sequence -> natural +let natural_of_bytes en bs= + match en with + | Little -> natural_of_bytes_little bs + | Big -> natural_of_bytes_big 0 bs + end + + +(* TODO: generalise *) +(* + match bs with + | b0::b1::b2::b3::b4::b5::b6::b7::[] -> + let v = if en=Little then + natural_of_byte b0 + 256*natural_of_byte b1 + 256*256*natural_of_byte b2 + 256*256*256*natural_of_byte b3 + + (256*256*256*256*(natural_of_byte b4 + 256*natural_of_byte b5 + 256*256*natural_of_byte b6 + 256*256*256*natural_of_byte b7)) + else + natural_of_byte b7 + 256*natural_of_byte b6 + 256*256*natural_of_byte b5 + 256*256*256*natural_of_byte b4 + + (256*256*256*256*(natural_of_byte b3 + 256*natural_of_byte b2 + 256*256*natural_of_byte b1 + 256*256*256*natural_of_byte b0)) + in + v + | b0::b1::b2::b3::[] -> + let v = if en=Little then + natural_of_byte b0 + 256*natural_of_byte b1 + 256*256*natural_of_byte b2 + 256*256*256*natural_of_byte b3 + else + natural_of_byte b3 + 256*natural_of_byte b2 + 256*256*natural_of_byte b1 + 256*256*256*natural_of_byte b0 + + in + v + | b0::b1::[] -> + let v = if en=Little then + natural_of_byte b0 + 256*natural_of_byte b1 + else + natural_of_byte b1 + 256*natural_of_byte b0 + + in + v + | b0::[] -> + natural_of_byte b0 + | _ -> Assert_extra.failwith "natural_of_bytes given not-8/4/2/1 bytes" + end +*) + +val bigunionListMap : forall 'a 'b. SetType 'b => ('a -> set 'b) -> list 'a -> set 'b +let rec bigunionListMap f xs= + match xs with + | [] -> {} + | x::xs' -> Set.(union) (f x) (bigunionListMap f xs') + end + +let rec mytake' (n:sym_natural) acc xs= + match (n,xs) with + | (0, _) -> Just (List.reverse acc, xs) + | (_, []) -> Nothing + | (_, x::xs') -> mytake' (n-1) (x::acc) xs' + end + +val mytake : forall 'a. sym_natural -> (list 'a) -> maybe (list 'a * list 'a) +let mytake n xs= mytake' n [] xs + +val mynth : forall 'a. sym_natural -> (list 'a) -> maybe 'a +let rec mynth (n:sym_natural) xs= + match (n,xs) with + | (0, x::xs') -> Just x + | (0, []) -> Nothing (*Assert_extra.failwith "mynth"*) + | (_, x::xs') -> mynth (n-1) xs' + end + + +(** basic pretty printing *) + +let pphexplain n= unsafe_hex_string_of_natural 0 n +let pphex n= "0x" ^ pphexplain n + +let pphex_sym = pp_sym pphex + +val abs : integer -> natural +(*declare hol target_rep function abs = `int_of_num` *) +declare ocaml target_rep function abs = `Nat_big_num.abs` +(*declare isabelle target_rep function abs = `int` +declare coq target_rep function abs n = (`Zpred` (`Zpos` (`P_of_succ_nat` n))) (* TODO: check*) +*) + +let pphex_integer n= if n<0 then "-" ^ pphex (abs n) else pphex (abs n) + +let ppbytes bs= show (List.map (fun x -> show x) (byte_list_of_byte_sequence bs)) + +let rec ppbytes2 n bs= + match read_char bs with + | Fail _ -> "" + | Success (x,xs') -> "<" ^ pphex n ^ "> " ^ show x ^ "\n" ^ ppbytes2 (n+1) xs' + end + +let rec ppbytesplain (c:p_context) (n:natural) bs= show (natural_of_bytes c.endianness bs) +(* + unsafe_hex_string_of_uc_list (List.map unsigned_char_of_byte xs) (*match xs with | [] -> "" | x::xs' -> pphexplain x ^ ppbytesplain (n+1) xs' end*) +*) + +(* workaround: from String *) +val mytoString : list char -> string +declare ocaml target_rep function mytoString = `Xstring.implode` + +let string_of_bytes bs= mytoString (List.map Missing_pervasives.char_of_byte bs) + + +let just_one s xs= + match xs with + | [] -> Assert_extra.failwith ("no " ^ s) + | x1::x2::_ -> Assert_extra.failwith ("more than one " ^ s) + | [x] -> x + end + + + + +let max_address (as': natural) : natural= + match as' with + | 4 -> natural_of_hex "0xffffffff" + | 8 -> natural_of_hex "0xffffffffffffffff" + | _ -> Assert_extra.failwith "max_address size not 4 or 8" + end + +let range_address (as': natural) : natural= + match as' with + | 4 -> natural_of_hex "0x100000000" + | 8 -> natural_of_hex "0x10000000000000000" + | _ -> Assert_extra.failwith "range_address size not 4 or 8" + end + + + +(** lookup of encodings *) + +val lookup_Ab_b : forall 'a 'b. Eq 'a => 'a -> list ('a * 'b) -> maybe 'b +let rec lookup_Ab_b x0 xys= + match xys with + | [] -> Nothing + | (x,y)::xys' -> if x=x0 then Just y else lookup_Ab_b x0 xys' + end + +val lookup_aB_a : forall 'a 'b. Eq 'b => 'b -> list ('a * 'b) -> maybe 'a +let rec lookup_aB_a y0 xys= + match xys with + | [] -> Nothing + | (x,y)::xys' -> if y=y0 then Just x else lookup_aB_a y0 xys' + end + + +val lookup_aBc_a : forall 'a 'b 'c. Eq 'b => 'b -> list ('a * 'b * 'c) -> maybe 'a +let rec lookup_aBc_a y0 xyzs= + match xyzs with + | [] -> Nothing + | (x,y,_)::xyzs' -> if y=y0 then Just x else lookup_aBc_a y0 xyzs' + end + +val lookup_aBc_ac : forall 'a 'b 'c. Eq 'b => 'b -> list ('a * 'b * 'c) -> maybe ('a*'c) +let rec lookup_aBc_ac y0 xyzs= + match xyzs with + | [] -> Nothing + | (x,y,z)::xyzs' -> if y=y0 then Just (x,z) else lookup_aBc_ac y0 xyzs' + end + +val lookup_Abc_b : forall 'a 'b 'c. Eq 'a => 'a -> list ('a * 'b * 'c) -> maybe 'b +let rec lookup_Abc_b x0 xyzs= + match xyzs with + | [] -> Nothing + | (x,y,_)::xyzs' -> if x=x0 then Just y else lookup_Abc_b x0 xyzs' + end + + + +val lookup_aBcd_a : forall 'a 'b 'c 'd. Eq 'b => 'b -> list ('a * 'b * 'c * 'd) -> maybe 'a +let rec lookup_aBcd_a y0 xyzws= + match xyzws with + | [] -> Nothing + | (x,y,_,_)::xyzws' -> if y=y0 then Just x else lookup_aBcd_a y0 xyzws' + end + +val lookup_aBcd_acd : forall 'a 'b 'c 'd. Eq 'b => 'b -> list ('a * 'b * 'c * 'd) -> maybe ('a * 'c * 'd) +let rec lookup_aBcd_acd y0 xyzws= + match xyzws with + | [] -> Nothing + | (x,y,z,w)::xyzws' -> if y=y0 then Just (x,z,w) else lookup_aBcd_acd y0 xyzws' + end + +val lookup_abCde_de : forall 'a 'b 'c 'd 'e. Eq 'c => 'c -> list ('a * 'b * 'c * 'd * 'e) -> maybe ('d * 'e) +let rec lookup_abCde_de z0 xyzwus= + match xyzwus with + | [] -> Nothing + | (x,y,z,w,u)::xyzwus' -> if z=z0 then Just (w,u) else lookup_abCde_de z0 xyzwus' + end + + +let pp_maybe ppf n= match ppf n with Just s -> s | Nothing -> "Unknown AT value: " ^ pphexplain n (*encoding not found: "" ^ pphex n*) end + +let pp_tag_encoding n= pp_maybe (fun n -> lookup_aB_a n tag_encodings) n +let pp_attribute_encoding n= pp_maybe (fun n -> lookup_aBc_a n attribute_encodings) n +let pp_attribute_form_encoding n= pp_maybe (fun n -> lookup_aBc_a n attribute_form_encodings) n +let pp_operation_encoding n= pp_maybe (fun n -> lookup_aBcd_a n operation_encodings) n + +let tag_encode (s: string) : natural= + match lookup_Ab_b s tag_encodings with + | Just n -> n + | Nothing -> Assert_extra.failwith ("tag_encode: \""^s^"\"") + end + +let attribute_encode (s: string) : natural= + match lookup_Abc_b s attribute_encodings with + | Just n -> n + | Nothing -> Assert_extra.failwith ("attribute_encode: \""^s^"\"") + end + +let attribute_form_encode (s: string) : natural= + match lookup_Abc_b s attribute_form_encodings with + | Just n -> n + | Nothing -> Assert_extra.failwith "attribute_form_encode" + end + +let base_type_attribute_encode (s: string) : natural= + match lookup_Ab_b s base_type_attribute_encodings with + | Just n -> n + | Nothing -> Assert_extra.failwith "base_type_attribute_encode" + end + + + +(** ************************************************************ *) +(** ** parser combinators and primitives ********************* *) +(** ************************************************************ *) + +(* parsing combinators *) + +type parse_context = <| pc_bytes: byte_sequence; pc_offset: natural |> + +type parse_result 'a = + | PR_success of 'a * parse_context + | PR_fail of string * parse_context + +type parser 'a = parse_context -> parse_result 'a + +let pp_parse_context pc= "pc_offset = " ^ pphex pc.pc_offset + +let pp_parse_fail s pc= + "Parse fail\n" ^ s ^ " at " ^ pp_parse_context pc ^ "\n" + +let pp_parse_result ppa pr= + match pr with + | PR_success x pc -> "Parse success\n" ^ ppa x ^ "\n" ^ pp_parse_context pc ^ "\n" + | PR_fail s pc -> pp_parse_fail s pc + end + +(* [(>>=)] should be the monadic binding function for [parse_result]. *) +(* but there's a type clash if we use >>=, and lem seems to output bad ocaml for >>>=. So we just use a non-infix version for now *) + +val pr_bind : forall 'a 'b. parse_result 'a -> ('a -> parser 'b) -> parse_result 'b +let pr_bind x f= + match x with + | PR_success v pc -> f v pc + | PR_fail err pc -> PR_fail err pc + end + +val pr_return : forall 'a. 'a -> (parser 'a) +let pr_return x pc= PR_success x pc + +val pr_map : forall 'a 'b. ('a -> 'b) -> parse_result 'a -> parse_result 'b +let pr_map f x= + match x with + | PR_success v pc -> PR_success (f v) pc + | PR_fail err pc -> PR_fail err pc + end + +val pr_map2 : forall 'a 'b. ('a -> 'b) -> (parser 'a) -> (parser 'b) +let pr_map2 f p= fun pc -> pr_map f (p pc) + +val pr_post_map1 : forall 'a 'b. (parse_result 'a) -> ('a -> 'b) -> (parse_result 'b) +let pr_post_map1 x f= pr_map f x + +(* +val pr_post_map : forall 'a 'b 'c. ('c -> parse_result 'a) -> ('a -> 'b) -> ('c -> parse_result 'b) +let pr_post_map g f = fun x -> pr_map f (g x) +*) +val pr_post_map : forall 'a 'b. (parser 'a) -> ('a -> 'b) -> (parser 'b) +let pr_post_map p f= fun (pc: parse_context) -> pr_map f (p pc) + + +val pr_with_pos : forall 'a. (parser 'a) -> (parser (natural * 'a)) +let pr_with_pos p= fun pc -> pr_map (fun x -> (pc.pc_offset,x)) (p pc) + + +val parse_pair : forall 'a 'b. (parser 'a) -> (parser 'b) -> (parser ('a * 'b)) +let parse_pair p1 p2= + fun pc -> + let _ = my_debug "pair " in + pr_bind (p1 pc) (fun x pc' -> match p2 pc' with + | PR_success y pc'' -> PR_success (x,y) pc'' + | PR_fail s pc'' -> PR_fail s pc'' + end) + +val parse_triple : forall 'a 'b 'c. (parser 'a) -> (parser 'b) -> (parser 'c) -> parser ('a * ('b * 'c)) +let parse_triple p1 p2 p3= + parse_pair p1 (parse_pair p2 p3) + +val parse_quadruple : forall 'a 'b 'c 'd. (parser 'a) -> (parser 'b) -> (parser 'c) -> (parser 'd) -> parser ('a * ('b * ('c * 'd))) +let parse_quadruple p1 p2 p3 p4= + parse_pair p1 (parse_pair p2 (parse_pair p3 p4)) + +val parse_pentuple : forall 'a 'b 'c 'd 'e. (parser 'a) -> (parser 'b) -> (parser 'c) -> (parser 'd) -> (parser 'e) -> parser ('a * ('b * ('c * ('d * 'e)))) +let parse_pentuple p1 p2 p3 p4 p5= + parse_pair p1 (parse_pair p2 (parse_pair p3 (parse_pair p4 p5))) + +val parse_sextuple : forall 'a 'b 'c 'd 'e 'f. (parser 'a) -> (parser 'b) -> (parser 'c) -> (parser 'd) -> (parser 'e) -> (parser 'f) -> parser ('a * ('b * ('c * ('d * ('e * 'f))))) +let parse_sextuple p1 p2 p3 p4 p5 p6= + parse_pair p1 (parse_pair p2 (parse_pair p3 (parse_pair p4 (parse_pair p5 p6)))) + +val parse_dependent_pair : forall 'a 'b. (parser 'a) -> ('a -> parser 'b) -> (parser ('a * 'b)) +let parse_dependent_pair p1 p2= + fun pc -> + pr_bind (p1 pc) (fun x pc' -> match p2 x pc' with + | PR_success y pc'' -> PR_success (x,y) pc'' + | PR_fail s pc'' -> PR_fail s pc'' + end) + +val parse_dependent : forall 'a 'b. (parser 'a) -> ('a -> parser 'b) -> (parser 'b) +let parse_dependent p1 p2= + fun pc -> + pr_bind (p1 pc) (fun x pc' -> p2 x pc') + + + +val parse_list' : forall 'a. (parser (maybe 'a)) -> (list 'a -> parser (list 'a)) +let rec parse_list' p1= + fun acc pc -> let _ = my_debug "list' " in pr_bind (p1 pc) (fun mx pc' -> + match mx with + | Nothing -> PR_success acc pc' + | Just x -> parse_list' p1 (x :: acc) pc' + end) + +val parse_list : forall 'a. (parser (maybe 'a)) -> (parser (list 'a)) +let parse_list p1= + pr_post_map + (parse_list' p1 []) + (List.reverse) + +val parse_parser_list : forall 'a. (list (parser 'a)) -> (parser (list 'a)) +let rec parse_parser_list ps= + match ps with + | [] -> pr_return [] + | p::ps' -> + (fun pc -> pr_bind (p pc) (fun x pc' -> + match parse_parser_list ps' pc' with + | PR_success xs pc'' -> PR_success (x::xs) pc'' + | PR_fail s pc'' -> PR_fail s pc'' + end)) + end + +val parse_maybe : forall 'a. parser 'a -> parser (maybe 'a) +let parse_maybe p= + fun pc -> + match Byte_sequence.length pc.pc_bytes with + | 0 -> pr_return Nothing pc + | _ -> + match p pc with + | PR_success v pc'' -> PR_success (Just v) pc'' + | PR_fail s pc'' -> PR_fail s pc'' + end + end + +val parse_demaybe : forall 'a. string ->parser (maybe 'a) -> parser 'a +let parse_demaybe s p= + fun pc -> + match p pc with + | PR_success (Just v) pc'' -> PR_success v pc'' + | PR_success (Nothing) pc'' -> PR_fail s pc'' + | PR_fail s pc'' -> PR_fail s pc'' + + end + + +val parse_restrict_length : forall 'a. natural -> parser 'a -> parser 'a +let parse_restrict_length n p= + fun pc -> + match partition n pc.pc_bytes with + | Fail _ -> Assert_extra.failwith "parse_restrict_length not given enough bytes" + | Success (xs,ys) -> + let pc' = <| pc_bytes = xs; pc_offset = pc.pc_offset |> in + p pc' + end + + +(* parsing of basic types *) + +let parse_byte : parser(byte)= + fun (pc:parse_context) -> + match read_char pc.pc_bytes with + | Fail _ -> PR_fail "parse_byte" pc + | Success (b,bs) -> PR_success b (<|pc_bytes=bs; pc_offset= pc.pc_offset + 1 |> ) + end + +let parse_n_bytes (n:natural) : parser (byte_sequence)= + fun (pc:parse_context) -> + match partition n pc.pc_bytes with + | Fail _ -> PR_fail ("parse_n_bytes n=" ^ pphex n) pc + | Success (xs,bs) -> + PR_success xs (<|pc_bytes=bs; pc_offset= pc.pc_offset + (Byte_sequence.length xs) |> ) + end + +let bzero= byte_of_natural 0 + +let parse_string : parser (byte_sequence)= + fun (pc:parse_context) -> + match find_byte pc.pc_bytes bzero with + | Nothing -> PR_fail "parse_string" pc + | Just n -> + pr_bind (parse_n_bytes n pc) (fun res pc -> + pr_bind (parse_byte pc) (fun _ pc -> + pr_return res pc)) + end + +(* parse a null-terminated string; return Nothing if it is empty, Just s otherwise *) +let parse_non_empty_string : parser (maybe byte_sequence)= + fun (pc:parse_context) -> + pr_bind (parse_string pc) (fun str pc -> + if Byte_sequence.length str = 0 then + pr_return Nothing pc + else + pr_return (Just str) pc) + +(* TODO relocations *) +let parse_uint8 : parser sym_natural= + fun (pc:parse_context) -> + let _ = my_debug "uint8 " in + match read_char pc.pc_bytes with + | Success (b, bytes) -> + let v = natural_of_byte b in + PR_success (Absolute v) (<| pc_bytes = bytes; pc_offset = pc.pc_offset + 1 |>) + | _ -> PR_fail "parse_uint32 not given enough bytes" pc + end + +let parse_uint8_constant (v:sym_natural) : parser sym_natural= + fun (pc:parse_context) -> + let _ = my_debug "uint8_constant " in + PR_success v pc + + +(* TODO relocations *) +let parse_uint16 c : parser sym_natural= + fun (pc:parse_context) -> + let _ = my_debug "uint16 " in + match read_2_bytes_be pc.pc_bytes with + | Success ((b0,b1),bytes') -> + let v = if c.endianness=Little then + natural_of_byte b0 + 256*natural_of_byte b1 + else + natural_of_byte b1 + 256*natural_of_byte b0 in + PR_success (Absolute v) (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 2 |>) + | _ -> PR_fail "parse_uint32 not given enough bytes" pc + end + +(* TODO relocations *) +let parse_uint32 c : parser sym_natural= + fun (pc:parse_context) -> + let _ = my_debug "uint32 " in + match read_4_bytes_be pc.pc_bytes with + | Success ((b0,b1,b2,b3),bytes') -> + let v = if c.endianness=Little then + natural_of_byte b0 + 256*natural_of_byte b1 + 256*256*natural_of_byte b2 + 256*256*256*natural_of_byte b3 + else + natural_of_byte b3 + 256*natural_of_byte b2 + 256*256*natural_of_byte b1 + 256*256*256*natural_of_byte b0 in + PR_success (Absolute v) (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 4 |>) + | _ -> PR_fail "parse_uint32 not given enough bytes" pc + end + +(* TODO relocations *) +let parse_uint64 c : parser sym_natural= + fun (pc:parse_context) -> + let _ = my_debug "uint64 " in + match read_8_bytes_be pc.pc_bytes with + | Success ((b0,b1,b2,b3,b4,b5,b6,b7),bytes') -> + let v = if c.endianness=Little then + natural_of_byte b0 + 256*natural_of_byte b1 + 256*256*natural_of_byte b2 + 256*256*256*natural_of_byte b3 + + (256*256*256*256*(natural_of_byte b4 + 256*natural_of_byte b5 + 256*256*natural_of_byte b6 + 256*256*256*natural_of_byte b7)) + else + natural_of_byte b7 + 256*natural_of_byte b6 + 256*256*natural_of_byte b5 + 256*256*256*natural_of_byte b4 + + (256*256*256*256*(natural_of_byte b3 + 256*natural_of_byte b2 + 256*256*natural_of_byte b1 + 256*256*256*natural_of_byte b0)) + in + PR_success (Absolute v) (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 8 |>) + | _ -> PR_fail "parse_uint64 not given enough bytes" pc + end + +let integerFromTwosComplementNatural (n:natural) (half: natural) (all:integer) : integer= + if n < half then integerFromNatural n else integerFromNatural n - all + +let partialTwosComplementNaturalFromInteger (i:integer) (half: sym_natural) (all:integer) : sym_natural= + if i >=0 && i < integerFromSymNatural half then partialNaturalFromInteger i + else if i >= (0-integerFromSymNatural half) && i < 0 then partialNaturalFromInteger (all + i) + else Assert_extra.failwith "partialTwosComplementNaturalFromInteger" + + +let parse_sint8 : parser integer= + pr_post_map (parse_uint8) (fun n -> integerFromTwosComplementNatural (sym_unwrap n) 128 256) + +let parse_sint16 c : parser integer= + pr_post_map (parse_uint16 c) (fun n -> integerFromTwosComplementNatural (sym_unwrap n) (128*256) (256*256)) + +let parse_sint32 c : parser integer= + pr_post_map (parse_uint32 c) (fun n -> integerFromTwosComplementNatural (sym_unwrap n) (128*256*256*256) (256*256*256*256)) + +let parse_sint64 c : parser integer= + pr_post_map (parse_uint64 c) (fun n -> integerFromTwosComplementNatural (sym_unwrap n) (128*256*256*256*256*256*256*256) (256*256*256*256*256*256*256*256)) + +let rec parse_ULEB128' (acc: natural) (shift_factor: natural) : parser natural= + fun (pc:parse_context) -> + let _ = my_debug "ULEB128' " in + match read_char pc.pc_bytes with + | Success (b,bytes') -> + let n = natural_of_byte b in + let acc' = (natural_land n 127) * shift_factor + acc in + let finished = ((natural_land n 128) = 0) in + let pc' = <| pc_bytes = bytes'; pc_offset = pc.pc_offset + 1 |> in + if finished then + PR_success acc' pc' + else + parse_ULEB128' acc' (shift_factor * 128) pc' + | _ -> + PR_fail "parse_ULEB128' not given enough bytes" pc + end + +let parse_ULEB128 : parser sym_natural= + fun (pc:parse_context) -> + pr_map (fun x -> Absolute x) (parse_ULEB128' 0 1 pc) + +let rec parse_SLEB128' (acc: natural) (shift_factor: natural) : parser (bool * natural * natural)= + fun (pc:parse_context) -> + let _ = my_debug "SLEB128' " in + match read_char pc.pc_bytes with + | Success (b,bytes') -> + let n = natural_of_byte b in + let acc' = acc + (natural_land n 127) * shift_factor in + let shift_factor' = shift_factor * 128 in + let finished = ((natural_land n 128) = 0) in + let positive = ((natural_land n 64) = 0) in + let pc' = <| pc_bytes = bytes'; pc_offset = pc.pc_offset + 1 |> in + if finished then + PR_success (positive, shift_factor', acc') pc' + else + parse_SLEB128' acc' shift_factor' pc' + | _ -> + PR_fail "parse_SLEB128' not given enough bytes" pc + end + +let parse_SLEB128 : parser integer= + pr_post_map (parse_SLEB128' 0 1) (fun (positive, shift_factor, acc) -> + if positive then integerFromNatural acc else integerFromNatural acc - integerFromNatural shift_factor) + +let parse_nonzero_ULEB128_pair : parser (maybe (sym_natural*sym_natural))= + let _ = my_debug "nonzero_ULEB128_pair " in + pr_post_map + (parse_pair parse_ULEB128 parse_ULEB128) + (fun (n1,n2) -> if n1=0 && n2=0 then Nothing else Just (n1,n2)) + +let parse_zero_terminated_ULEB128_pair_list : parser (list (sym_natural*sym_natural))= + let _ = my_debug "zero_terminated_ULEB128_pair_list " in + parse_list parse_nonzero_ULEB128_pair + +let parse_uintDwarfN c (df: dwarf_format) : parser sym_natural= + match df with + | Dwarf32 -> (parse_uint32 c) + | Dwarf64 -> (parse_uint64 c) + end + +let parse_uint_address_size c (as': natural) : parser sym_natural= + match as' with + | 4 -> (parse_uint32 c) + | 8 -> (parse_uint64 c) + | _ -> Assert_extra.failwith ("cuh_address_size not 4 or 8: " ^ show as') + end + +let parse_uint_segment_selector_size c (ss: natural) : parser (maybe sym_natural)= + match ss with + | 0 -> pr_return Nothing + | 1 -> pr_post_map (parse_uint8) (fun n -> Just n) + | 2 -> pr_post_map (parse_uint16 c) (fun n -> Just n) + | 4 -> pr_post_map (parse_uint32 c) (fun n -> Just n) + | 8 -> pr_post_map (parse_uint64 c) (fun n -> Just n) + | _ -> Assert_extra.failwith "cuh_address_size not 4 or 8" + end + + + +(** ************************************************************ *) +(** ** parsing and pretty printing of .debug_* sections ****** *) +(** ************************************************************ *) + + +(** abbreviations table: pp and parsing *) + +let pp_abbreviation_declaration (x:abbreviation_declaration)= + " " + ^ show x.ad_abbreviation_code ^ " " + ^ pp_tag_encoding x.ad_tag ^ " " + ^ (if x.ad_has_children then "[has children]" else "[no children]") + ^ "\n" +(* ^ " "^show (List.length x.ad_attribute_specifications) ^ " attributes\n"*) + ^ String.concat "" + (List.map + (fun (n1,n2) -> + " " ^ right_space_padded_to 18 (pp_attribute_encoding n1) ^ " " ^ pp_attribute_form_encoding n2 ^ "\n") + x.ad_attribute_specifications) + ^ " DW_AT value: 0 DW_FORM value: 0\n" + + +let pp_abbreviations_table (x:abbreviations_table)= + "offset: "^pphex x.at_offset^"\n" + ^ String.concat "" (List.map (pp_abbreviation_declaration) x.at_table) + +(* print the distinct abbreviation tables used by all compilation units *) +let rec remove_duplicates xys xys_acc= + match xys with + | [] -> List.reverse xys_acc + | (x,y)::xys' -> + if List.any (fun (x',y') -> x'=x) xys_acc then + remove_duplicates xys' xys_acc + else + remove_duplicates xys' ((x,y)::xys_acc) + end + +let pp_abbreviations_tables (d:dwarf)= + let xs : list (natural * abbreviations_table) = + List.map + (fun cu -> (cu.cu_header.cuh_debug_abbrev_offset, cu.cu_abbreviations_table)) + d.d_compilation_units in + let ys = remove_duplicates xs [] in + String.concat "*********************\n" (List.map (fun (x,y)->pp_abbreviations_table y) ys) + + + + +let parse_abbreviation_declaration c : parser (maybe abbreviation_declaration)= + fun (pc: parse_context) -> + pr_bind (parse_ULEB128 pc) (fun n1 pc' -> + if n1 = 0 then + PR_success Nothing pc' + else + pr_bind (parse_ULEB128 pc') (fun n2 pc'' -> + pr_bind (parse_uint8 pc'') (fun c pc''' -> + pr_post_map1 + (parse_zero_terminated_ULEB128_pair_list pc''') + (fun l -> + Just ( let ad = + <| + ad_abbreviation_code = (sym_unwrap n1); + ad_tag = (sym_unwrap n2); + ad_has_children = (c<>0); + ad_attribute_specifications = List.map (fun (x, y) -> (sym_unwrap x, sym_unwrap y)) l; + |> in (* let _ = my_debug2 (pp_abbreviation_declaration ad) in *) ad) + )))) + +let parse_abbreviations_table c= + parse_list (parse_abbreviation_declaration c) + + +(** debug_str entry *) + +let rec null_terminated_bs (bs: byte_sequence) : byte_sequence= + match find_byte bs bzero with + | Just i -> + match takebytes i bs with + | Success bs' -> bs' + | Fail _ -> Assert_extra.failwith "find_byte or take_byte is broken" + end + | Nothing -> bs + end + +let pp_debug_str_entry (str: byte_sequence) (n: natural) : string= + match dropbytes n str with + | Fail _ -> "strp beyond .debug_str extent" + | Success bs -> string_of_byte_sequence (null_terminated_bs bs) + end + +(** operations: pp and parsing *) + +let pp_operation_argument_value (oav:operation_argument_value) : string= + match oav with + | OAV_natural n -> pphex_sym n + | OAV_integer n -> pphex_integer n (* show n*) + | OAV_block n bs -> pphex_sym n ^ " " ^ ppbytes bs + end + +let pp_operation_semantics (os: operation_semantics) : string= + match os with + | OpSem_lit -> "OpSem_lit" + | OpSem_deref -> "OpSem_deref" + | OpSem_stack _ -> "OpSem_stack ..." + | OpSem_not_supported -> "OpSem_not_supported" + | OpSem_binary _ -> "OpSem_binary ..." + | OpSem_unary _ -> "OpSem_unary ..." + | OpSem_opcode_lit _ -> "OpSem_opcode_lit ..." + | OpSem_reg -> "OpSem_reg" + | OpSem_breg -> "OpSem_breg" + | OpSem_bregx -> "OpSem_bregx" + | OpSem_fbreg -> "OpSem_fbreg" + | OpSem_deref_size -> "OpSem_deref_size" + | OpSem_nop -> "OpSem_nop" + | OpSem_piece -> "OpSem_piece" + | OpSem_bit_piece -> "OpSem_bitpiece" + | OpSem_implicit_value -> "OpSem_implicit_value" + | OpSem_stack_value -> "OpSem_stack_value" + | OpSem_call_frame_cfa -> "OpSem_call_frame_cfa" + end + +let pp_operation_semantics_brief (os: operation_semantics) : string= + match os with + | OpSem_not_supported -> " (OpSem_not_supported)" + | _ -> "" + end + +let pp_operation (op: operation) : string= + op.op_string ^ (match op.op_argument_values with [] -> "" | _ -> " " ^ String.concat " " (List.map pp_operation_argument_value op.op_argument_values) end) ^ pp_operation_semantics_brief op.op_semantics + +let pp_operations (ops: list operation) : string= + String.concat "; " (List.map pp_operation ops) + +val parser_of_operation_argument_type : p_context -> compilation_unit_header -> operation_argument_type -> (parser operation_argument_value) +let parser_of_operation_argument_type c cuh oat= + match oat with + | OAT_addr -> + pr_map2 (fun n -> OAV_natural n) (parse_uint_address_size c cuh.cuh_address_size) + | OAT_dwarf_format_t -> + pr_map2 (fun n -> OAV_natural n) (parse_uintDwarfN c cuh.cuh_dwarf_format) + | OAT_uint8 -> pr_map2 (fun n -> OAV_natural n) (parse_uint8) + | OAT_uint16 -> pr_map2 (fun n -> OAV_natural n) (parse_uint16 c) + | OAT_uint32 -> pr_map2 (fun n -> OAV_natural n) (parse_uint32 c) + | OAT_uint64 -> pr_map2 (fun n -> OAV_natural n) (parse_uint64 c) + | OAT_sint8 -> pr_map2 (fun n -> OAV_integer n) (parse_sint8) + | OAT_sint16 -> pr_map2 (fun n -> OAV_integer n) (parse_sint16 c) + | OAT_sint32 -> pr_map2 (fun n -> OAV_integer n) (parse_sint32 c) + | OAT_sint64 -> pr_map2 (fun n -> OAV_integer n) (parse_sint64 c) + | OAT_ULEB128 -> pr_map2 (fun n -> OAV_natural n) parse_ULEB128 + | OAT_SLEB128 -> pr_map2 (fun n -> OAV_integer n) parse_SLEB128 + | OAT_block -> + (fun pc -> pr_bind (parse_ULEB128 pc) (fun n pc' -> + pr_map (fun bs -> OAV_block n bs) (parse_n_bytes (sym_unwrap n) pc'))) + end + +val parse_operation : p_context -> compilation_unit_header -> parser (maybe operation) +let parse_operation c cuh pc= + match parse_uint8 pc with + | PR_fail s pc' -> PR_success Nothing pc + | PR_success code pc' -> + match lookup_aBcd_acd (sym_unwrap code) operation_encodings with + | Nothing -> PR_fail ("encoding not found: " ^ pphex_sym code) pc + | Just (s,oats,opsem) -> + let ps = List.map (parser_of_operation_argument_type c cuh) oats in + (pr_post_map + (parse_parser_list ps) + (fun oavs -> Just <| op_code = code; op_string = s; op_argument_values = oavs; op_semantics = opsem |>) + ) + pc' + end + end + +val parse_operations : p_context -> compilation_unit_header -> parser (list operation) +let parse_operations c cuh= + parse_list (parse_operation c cuh) + +let parse_operations_bs c cuh bs : list operation= + let pc = <|pc_bytes = bs; pc_offset = 0 |> in + match parse_operations c cuh pc with + | PR_fail s pc' -> Assert_extra.failwith ("parse_operations_bs fail: " ^ pp_parse_fail s pc') + | PR_success ops pc' -> + let _ = if Byte_sequence.length pc'.pc_bytes <> 0 then Assert_extra.failwith ("parse_operations_bs extra non-parsed bytes") else () in + ops + end + + + +val parse_and_pp_operations : p_context -> compilation_unit_header -> byte_sequence -> string +let parse_and_pp_operations c cuh bs= + let pc = <|pc_bytes = bs; pc_offset = 0 |> in + match parse_operations c cuh pc with + | PR_fail s pc' -> "parse_operations fail: " ^ pp_parse_fail s pc' + | PR_success ops pc' -> + pp_operations ops + ^ if Byte_sequence.length pc'.pc_bytes <> 0 then " Warning: extra non-parsed bytes" else "" + end + + +(** attribute values: pp and parsing *) + +val pp_attribute_value_plain : attribute_value -> string +let pp_attribute_value_plain av= + match av with + | AV_addr x -> "AV_addr " ^ pphex_sym x + | AV_block n bs -> "AV_block " ^ show n ^ " " ^ ppbytes bs + | AV_constantN n bs -> "AV_constantN " ^ show n ^ " " ^ ppbytes bs + | AV_constant_SLEB128 i -> "AV_constant_SLEB128 " ^ show i + | AV_constant_ULEB128 n -> "AV_constant_ULEB128 " ^ show n + | AV_exprloc n bs -> + String.concat " " ["AV_exprloc"; show n; ppbytes bs] + | AV_flag b -> "AV_flag " ^ show b + | AV_ref n -> "AV_ref " ^ pphex n + | AV_ref_addr n -> "AV_ref_addr " ^ pphex n + | AV_ref_sig8 n -> "AV_ref_sig8 " ^ pphex n + | AV_sec_offset n -> "AV_sec_offset " ^ pphex n + | AV_string bs -> string_of_byte_sequence bs + | AV_strp n -> "AV_sec_offset " ^ pphex n ^ " " + end + + +val pp_attribute_value : p_context -> compilation_unit_header -> byte_sequence -> natural (*attribute tag*) -> attribute_value -> string +let pp_attribute_value c cuh str at av= + match av with + | AV_addr x -> "AV_addr " ^ pphex_sym x + | AV_block n bs -> "AV_block " ^ show n ^ " " ^ ppbytes bs + ^ if at = attribute_encode "DW_AT_location" then " " ^ parse_and_pp_operations c cuh bs else "" + | AV_constantN n bs -> "AV_constantN " ^ show n ^ " " ^ ppbytes bs + | AV_constant_SLEB128 i -> "AV_constant_SLEB128 " ^ show i + | AV_constant_ULEB128 n -> "AV_constant_ULEB128 " ^ show n + | AV_exprloc n bs -> + String.concat " " ["AV_exprloc"; show n; ppbytes bs; parse_and_pp_operations c cuh bs] + | AV_flag b -> "AV_flag " ^ show b + | AV_ref n -> "AV_ref " ^ pphex n + | AV_ref_addr n -> "AV_ref_addr " ^ pphex n + | AV_ref_sig8 n -> "AV_ref_sig8 " ^ pphex n + | AV_sec_offset n -> "AV_sec_offset " ^ pphex n + | AV_string bs -> string_of_byte_sequence bs + | AV_strp n -> "AV_sec_offset " ^ pphex n ^ " " + ^ pp_debug_str_entry str n + end + +val pp_attribute_value_like_objdump : p_context -> compilation_unit_header -> byte_sequence -> natural (*attribute tag*) -> attribute_value -> string +let pp_attribute_value_like_objdump c cuh str at av= + match av with + | AV_addr x -> (*"AV_addr " ^*) pphex_sym x + | AV_block n bs -> (*"AV_block " ^ show n ^ " " ^ ppbytes bs + ^ if at = attribute_encode "DW_AT_location" then " " ^ parse_and_pp_operations c cuh bs else ""*) + (* show n ^ " byte block: " *) ppbytesplain c n bs + ^ if at = attribute_encode "DW_AT_location" then " " ^ parse_and_pp_operations c cuh bs else "" + | AV_constantN n bs -> ppbytes bs (*"AV_constantN " ^ show n ^ " " ^ ppbytes bs*) + | AV_constant_SLEB128 i -> (*"AV_constant_SLEB128 " ^*) show i + | AV_constant_ULEB128 n -> (*"AV_constant_ULEB128 " ^*) show n + | AV_exprloc n bs -> (*"AV_exprloc " ^ show n ^ " " ^*) ppbytes bs + ^ " " ^ parse_and_pp_operations c cuh bs + | AV_flag b -> (*"AV_flag " ^*)if b then "1" else "0" + | AV_ref n -> (*"AV_ref " ^*) "<"^pphex (n + cuh.cuh_offset)^">" + | AV_ref_addr n -> (*"AV_ref_addr " ^*) "<"^pphex n^">" + | AV_ref_sig8 n -> "AV_ref_sig8 " ^ pphex n + | AV_sec_offset n -> (*"AV_sec_offset " ^*) pphex n + ^ if at = attribute_encode "DW_AT_location" then " (location list)" else "" + | AV_string bs -> string_of_byte_sequence bs + | AV_strp n -> (*"AV_sec_offset " ^ pphex n ^ " " + ^ pp_debug_str_entry str n*) + "(indirect string, offset: "^pphex n ^ "): " ^ pp_debug_str_entry str n + end + + + + +val parser_of_attribute_form_non_indirect : p_context -> compilation_unit_header -> natural -> parser attribute_value +let parser_of_attribute_form_non_indirect c cuh n= +(* address*) + if n = attribute_form_encode "DW_FORM_addr" then + pr_map2 (fun n -> AV_addr n) (parse_uint_address_size c cuh.cuh_address_size) +(* block *) + else if n = attribute_form_encode "DW_FORM_block1" then + (fun pc -> pr_bind (parse_uint8 pc) (fun n pc' -> + let n = sym_unwrap n in + pr_map (fun bs -> AV_block n bs) (parse_n_bytes n pc'))) + else if n = attribute_form_encode "DW_FORM_block2" then + (fun pc -> pr_bind (parse_uint16 c pc) (fun n pc' -> + let n = sym_unwrap n in + pr_map (fun bs -> AV_block n bs) (parse_n_bytes n pc'))) + else if n = attribute_form_encode "DW_FORM_block4" then + (fun pc -> pr_bind (parse_uint32 c pc) (fun n pc' -> + let n = sym_unwrap n in + pr_map (fun bs -> AV_block n bs) (parse_n_bytes n pc'))) + else if n = attribute_form_encode "DW_FORM_block" then + (fun pc -> pr_bind (parse_ULEB128 pc) (fun n pc' -> + let n = sym_unwrap n in + pr_map (fun bs -> AV_block n bs) (parse_n_bytes n pc'))) +(* constant *) + else if n = attribute_form_encode "DW_FORM_data1" then + pr_map2 (fun bs -> AV_block 1 bs) (parse_n_bytes 1) + else if n = attribute_form_encode "DW_FORM_data2" then + pr_map2 (fun bs -> AV_block 2 bs) (parse_n_bytes 2) + else if n = attribute_form_encode "DW_FORM_data4" then + pr_map2 (fun bs -> AV_block 4 bs) (parse_n_bytes 4) + else if n = attribute_form_encode "DW_FORM_data8" then + pr_map2 (fun bs -> AV_block 8 bs) (parse_n_bytes 8) + else if n = attribute_form_encode "DW_FORM_sdata" then + pr_map2 (fun i -> AV_constant_SLEB128 i) parse_SLEB128 + else if n = attribute_form_encode "DW_FORM_udata" then + pr_map2 (fun n -> AV_constant_ULEB128 n) parse_ULEB128 +(* exprloc *) + else if n = attribute_form_encode "DW_FORM_exprloc" then + (fun pc -> pr_bind (parse_ULEB128 pc) (fun n pc' -> + let n = sym_unwrap n in + pr_map (fun bs -> AV_exprloc n bs) (parse_n_bytes n pc'))) +(* flag *) + else if n = attribute_form_encode "DW_FORM_flag" then + pr_map2 (fun n -> AV_flag (n<>0)) (parse_uint8) + else if n = attribute_form_encode "DW_FORM_flag_present" then + pr_map2 (fun () -> AV_flag true) (pr_return ()) +(* lineptr, loclistptr, macptr, rangelistptr *) + else if n = attribute_form_encode "DW_FORM_sec_offset" then + pr_map2 (fun n -> AV_sec_offset (sym_unwrap n)) (parse_uintDwarfN c cuh.cuh_dwarf_format) +(* reference - first type *) + else if n = attribute_form_encode "DW_FORM_ref1" then + pr_map2 (fun n -> AV_ref (sym_unwrap n)) (parse_uint8) + else if n = attribute_form_encode "DW_FORM_ref2" then + pr_map2 (fun n -> AV_ref (sym_unwrap n)) (parse_uint16 c) + else if n = attribute_form_encode "DW_FORM_ref4" then + pr_map2 (fun n -> AV_ref (sym_unwrap n)) (parse_uint32 c) + else if n = attribute_form_encode "DW_FORM_ref8" then + pr_map2 (fun n -> AV_ref (sym_unwrap n)) (parse_uint64 c) + else if n = attribute_form_encode "DW_FORM_ref_udata" then + pr_map2 (fun n -> AV_ref (sym_unwrap n)) parse_ULEB128 +(* reference - second type *) + else if n = attribute_form_encode "DW_FORM_ref_addr" then + pr_map2 (fun n -> AV_ref_addr (sym_unwrap n)) (parse_uintDwarfN c cuh.cuh_dwarf_format) +(* reference - third type *) + else if n = attribute_form_encode "DW_FORM_ref_sig8" then + pr_map2 (fun n -> AV_ref_sig8 (sym_unwrap n)) (parse_uint64 c) +(* string *) + else if n = attribute_form_encode "DW_FORM_string" then + pr_map2 (fun bs -> AV_string bs) parse_string + else if n = attribute_form_encode "DW_FORM_strp" then + pr_map2 (fun n -> AV_strp (sym_unwrap n)) (parse_uintDwarfN c cuh.cuh_dwarf_format) +(* indirect (cycle detection) *) + else if n = attribute_form_encode "DW_FORM_indirect" then + Assert_extra.failwith "DW_FORM_INDIRECT cycle" +(* unknown *) + else + Assert_extra.failwith "parser_of_attribute_form_non_indirect: unknown attribute form" + + +let parser_of_attribute_form c cuh n= + if n = attribute_form_encode "DW_FORM_indirect" then + (fun pc -> pr_bind (parse_ULEB128 pc) (fun n -> + let n = sym_unwrap n in + parser_of_attribute_form_non_indirect c cuh n) ) + else + parser_of_attribute_form_non_indirect c cuh n + + +(* *** where to put this? *) + +let pp_pos pos= "<" ^ pphexplain pos ^">" + +let pp_cupdie (cu,parents,die)= pp_pos cu.cu_header.cuh_offset ^ "/" ^ pp_pos die.die_offset + +let pp_cupdie3 (cu,parents,die)= pp_pos die.die_offset ^ "/" ^ String.concat "/" (List.map (fun p -> pp_pos p.die_offset) parents) ^ "/" ^ pp_pos cu.cu_header.cuh_offset + + +(** ************************************************************ *) +(** ** finding things in the die tree *) +(** ************************************************************ *) + +val find_maybe : forall 'a 'b. ('a -> maybe 'b) -> list 'a -> maybe 'b +let rec find_maybe f l= + match l with + | [] -> Nothing + | x :: xs -> + match f x with + | Just y -> Just y + | Nothing -> find_maybe f xs + end + end + +let rec find_die_by_offset_in_cu offset cu : maybe cupdie= + match Map.lookup offset cu.cu_index with + | Just (parents,die) -> Just (cu, parents,die) + | Nothing -> Nothing + end + +let find_die_by_offset_in_all offset d : maybe cupdie= + find_maybe + (fun cu -> find_die_by_offset_in_cu offset cu) + d.d_compilation_units + +val find_dies_in_die : (die->bool) -> compilation_unit -> list die -> die -> list cupdie +let rec find_dies_in_die (p:die->bool) (cu:compilation_unit) (parents: list die) (d: die)= + let ds = List.concatMap (find_dies_in_die p cu (d::parents)) d.die_children in + if p d then (cu,parents,d)::ds else ds + +let find_dies (p:die->bool) (d: dwarf) : list cupdie= + List.concatMap + (fun cu -> find_dies_in_die p cu [] cu.cu_die) + d.d_compilation_units + + +(** convert attribute values to usable Lem types *) + + +let string_of_string_attribute_value str av : string= + match av with + | AV_string bs -> string_of_byte_sequence bs + | AV_strp n -> pp_debug_str_entry str n + | _ -> "find_string_attribute_value_of_die AV not understood" + end + +let maybe_natural_of_constant_attribute_value die1 c av : maybe sym_natural= + match av with + | AV_constantN n bs -> Just n + | AV_constant_ULEB128 n -> Just n + | AV_block n bs -> Just (Absolute (natural_of_bytes c.endianness bs)) + | _ -> Nothing + end + +let natural_of_constant_attribute_value die1 c av : sym_natural= + match maybe_natural_of_constant_attribute_value die1 c av with + | Just n -> n + | Nothing -> Assert_extra.failwith ("natural_of_constant_attribute_value fail at " ^ (pp_pos die1.die_offset ^ (" with av= " ^ pp_attribute_value_plain av))) + end + +let integer_of_constant_attribute_value c av : integer= + match av with + | AV_constantN n bs -> integerFromSymNatural n + | AV_constant_ULEB128 n -> integerFromSymNatural n + | AV_constant_SLEB128 n -> n + | AV_block n bs -> integerFromNatural (natural_of_bytes c.endianness bs) + | _ -> Assert_extra.failwith ("integer_of_constant_attribute_value fail") + end + +let bool_of_flag_attribute_value av : bool= + match av with + | AV_flag b -> b + | _ -> Assert_extra.failwith ("bool_of_maybe_flag_attribute_value fail") + end + +let reference_of_reference_attribute_value c d cu str av : maybe (compilation_unit * (list die) * die)= + match av with + (* "offset from the first byte of the compilation header for the compilation unit containing the reference" *) + | AV_ref n -> + let n' = n+cu.cu_header.cuh_offset in + match find_die_by_offset_in_all n' d (*cu.cu_die*) with + | Just (cu',parents',die') -> Just (cu',parents',die') + | Nothing -> Nothing (* Fail ("find_reference_attribute_of_die AV_ref failed (cuh="^pphex cu.cu_header.cuh_offset ^" n'="^pphex n'^")"^"\n"^ppd())*) + end + (* offset in .debug_info *) + | AV_ref_addr n -> + match find_die_by_offset_in_all n d with + | Just (cu',parents',die') -> Just (cu',parents',die') + | Nothing -> Nothing (*Fail ("find_reference_attribute_of_die AV_ref_addr failed\n"^ppd())*) + end + | _ -> + Nothing (*Fail ("reference_of_reference_attribute AV ("^pp_attribute_value c cu.cu_header str (attribute_encode an) av^") not supported\n"^ppd() )*) + (* TODO: handle the AV_ref_sig8 case for type signature references *) + end + +(** attribute find *) + +let find_attribute_value (an: string) (die:die) : maybe attribute_value= + let at = attribute_encode an in + let ats = List.zip + die.die_abbreviation_declaration.ad_attribute_specifications + die.die_attribute_values in + myfindmaybe + (fun (((at': natural), (af: natural)), ((pos: natural),(av:attribute_value))) -> + if at' = at then Just av else Nothing) + ats + + +let find_string_attribute_value_of_die (an: string) str (die:die) : maybe string= + match find_attribute_value an die with + | Just av -> + let s = string_of_string_attribute_value str av in + Just s + | Nothing -> + Nothing + end + +let find_natural_attribute_value_of_die c (an: string) (die:die) : maybe sym_natural= + match find_attribute_value an die with + | Just av -> + let n = natural_of_constant_attribute_value die c av in + Just n + | Nothing -> + Nothing + end + +let find_integer_attribute_value_of_die c (an: string) (die:die) : maybe integer= + match find_attribute_value an die with + | Just av -> + let n = integer_of_constant_attribute_value c av in + Just n + | Nothing -> + Nothing + end + +let find_flag_attribute_value_of_die (an: string) (die:die) : maybe bool= + Maybe.map bool_of_flag_attribute_value (find_attribute_value an die) + + +let find_flag_attribute_value_of_die_default_false (an: string) (die:die) : bool= + match find_flag_attribute_value_of_die an die with + | Just b -> b + | Nothing -> false + end + + + +let find_name_of_die str die : maybe string= + find_string_attribute_value_of_die "DW_AT_name" str die + + + + +let find_reference_attribute_of_die c d cu str an die : maybe (compilation_unit * (list die) * die)= + let ppd ()= pp_pos die.die_offset (*pp_die c cuh str true 0 false die ^ "\n"*) in + match find_attribute_value an die with + | Nothing -> + Nothing (*Fail ("find_reference_attribute_of_die found no " ^ an ^ "\n" ^ ppd())*) + | Just av -> + reference_of_reference_attribute_value c d cu str av + end + +let find_DW_AT_type_of_die c d cu str die : maybe (compilation_unit * (list die) * die)= + find_reference_attribute_of_die c d cu str "DW_AT_type" die + +(* look up "an" in die. If not found, see if die has an abstract origin, and if so, look up "an" in that. Return the relevant cu, too *) +let find_attribute_value_using_abstract_origin c d cu str an die : maybe (compilation_unit * attribute_value)= + match find_attribute_value an die with + | Just av -> Just (cu,av) + | Nothing -> + match find_reference_attribute_of_die c d cu str "DW_AT_abstract_origin" die with + | Nothing -> + Nothing (*s ^ " and no DW_AT_abstract_origin"*) + | Just (cu',parents',die') -> + match find_attribute_value an die' with + | Just av -> Just (cu',av) + | Nothing -> Nothing + end + end + end + +let find_name_of_die_using_abstract_origin c d cu str die : maybe string= + match find_attribute_value_using_abstract_origin c d cu str "DW_AT_name" die with + | Nothing -> Nothing + | Just (cu',av) -> Just (string_of_string_attribute_value str av) + end + +(* TODO: not sure how DW_AT_specification should interact with abstract origins *) +let find_name_of_die_using_abstract_origin_and_spec c d cu str die mcupdie_spec : maybe string= + match find_name_of_die_using_abstract_origin c d cu str die with + | Just name -> Just name + | Nothing -> + match mcupdie_spec with + | Just ((cu_spec,parents_spec,die_spec) as cupdie_spec) -> + find_name_of_die_using_abstract_origin c d cu_spec str die_spec + | Nothing -> + Nothing + end +end + +let find_reference_attribute_using_abstract_origin c d cu str an die : maybe (compilation_unit * (list die) * die)= + match find_attribute_value_using_abstract_origin c d cu str an die with + | Nothing -> Nothing + | Just (cu',av) -> + reference_of_reference_attribute_value c d cu' str av + end + +let find_DW_AT_type_of_die_using_abstract_origin c d cu str die : maybe (compilation_unit * (list die) * die)= + find_reference_attribute_using_abstract_origin c d cu str "DW_AT_type" die + +let find_flag_attribute_value_of_die_using_abstract_origin d (an: string) ((cu,parents,die):cupdie) : maybe bool= + let c = p_context_of_d d in + match find_attribute_value_using_abstract_origin c d cu d.d_str an die with + | Nothing -> Nothing + | Just (cu',av) -> + Just (bool_of_flag_attribute_value av) + end + + +(** compilation unit header: pp and parsing *) + +let pp_dwarf_format df= match df with Dwarf32 -> "(32-bit)" | Dwarf64 -> "(64-bit)" end + +let pp_unit_header (s:string) (x:compilation_unit_header) : string= + "**" ^ s ^ " Unit @ offset " ^ pphex x.cuh_offset ^ "\n" + ^ " " ^ s ^ " Unit @ offset " ^ pphex x.cuh_offset ^ ":\n" + ^ " Length: " ^ pphex x.cuh_unit_length ^ " " ^ pp_dwarf_format x.cuh_dwarf_format ^ "\n" + ^ " Version: " ^ show x.cuh_version ^ "\n" + ^ " Abbrev Offset: " ^ pphex x.cuh_debug_abbrev_offset ^ "\n" + ^ " Pointer Size: " ^ show x.cuh_address_size ^ "\n" + +let pp_compilation_unit_header (x:compilation_unit_header) : string= + pp_unit_header "Compilation" x + +let parse_unit_length c : parser (dwarf_format * natural)= + fun (pc: parse_context) -> + pr_bind (parse_uint32 c pc) (fun x pc' -> + let x = sym_unwrap x in + if x < natural_of_hex "0xfffffff0" then PR_success (Dwarf32,x) pc' + else if x <> natural_of_hex "0xffffffff" then PR_fail "bad unit_length" pc + else + pr_bind (parse_uint64 c pc') (fun x' pc'' -> + PR_success (Dwarf64, sym_unwrap x') pc')) + + +let parse_compilation_unit_header c : parser compilation_unit_header= + pr_post_map + (pr_with_pos + (parse_dependent_pair + (parse_unit_length c) + (fun (df,ul) -> + parse_triple + (parse_uint16 c) (* version *) + (parse_uintDwarfN c df) (* debug abbrev offset *) + (parse_uint8) (* address_size *)))) + (fun (offset,((df,ul), (v, (dao, as')))) -> + (*let _ = my_debug4 ("dao " ^ pphex dao) in *) + <| + cuh_offset = offset; + cuh_dwarf_format = df; + cuh_unit_length = ul; + cuh_version = (sym_unwrap v); + cuh_debug_abbrev_offset = (sym_unwrap dao); + cuh_address_size = (sym_unwrap as'); + |>) + + +(** type unit header: pp and parsing *) + +(* the test binaries don't have a .debug_types section, so this isn't tested *) + +let pp_type_unit_header (x:type_unit_header) : string= + pp_unit_header "Type" x.tuh_cuh + ^ " Type Signature: " ^ pphex x.tuh_type_signature ^ "\n" + ^ " Type Offset: " ^ pphex x.tuh_type_offset ^ "\n" + + +let parse_type_unit_header c : parser type_unit_header= + pr_post_map + (parse_dependent_pair + (parse_compilation_unit_header c) + (fun cuh -> + parse_pair + (parse_uint64 c) (* type signature *) + (parse_uintDwarfN c cuh.cuh_dwarf_format) (* type offset *) )) + (fun (cuh, (ts, to')) -> + <| + tuh_cuh = cuh; + tuh_type_signature = (sym_unwrap ts); + tuh_type_offset = (sym_unwrap to'); + |>) + + +(** debugging information entries: pp and parsing *) + +(* example pp from readelf + <2><51>: Abbrev Number: 3 (DW_TAG_variable) + <52> DW_AT_name : x + <54> DW_AT_decl_file : 1 + <55> DW_AT_decl_line : 2 + <56> DW_AT_type : <0x6a> + <5a> DW_AT_location : 2 byte block: 91 6c (DW_OP_fbreg: -20) +*) + + + + + + + +(** debugging information entries: pp and parsing *) + +let indent_level (indent: bool) (level: natural)= + if indent then + (toString (replicate (3 * level) #' ')) + else + " " +let indent_level_plus_one indent level= + if indent then + indent_level indent (level+1) + else + " "^" " + +let pp_die_attribute c (cuh:compilation_unit_header) (str : byte_sequence) (indent:bool) (level: natural) (((at: natural), (af: natural)), ((pos: natural),(av:attribute_value))) : string= + indent_level_plus_one indent level ^ pp_pos pos ^ " " + ^ right_space_padded_to 18 (pp_attribute_encoding at) ^ ": " + ^ + if indent then + "(" ^ pp_attribute_form_encoding af ^ ") " + ^ pp_attribute_value c cuh str at av + ^ "\n" + else + pp_attribute_value_like_objdump c cuh str at av + ^ "\n" + +val pp_die : p_context -> compilation_unit_header -> byte_sequence -> bool -> natural -> bool -> die -> string +let rec pp_die c cuh str indent level (pp_children:bool) die= + indent_level indent level ^ "<" ^ show level ^ ">" + ^ pp_pos die.die_offset + ^ ": Abbrev Number: " ^ show die.die_abbreviation_code + ^ " (" ^ pp_tag_encoding die.die_abbreviation_declaration.ad_tag ^")\n" + ^ + let ats = List.zip + die.die_abbreviation_declaration.ad_attribute_specifications + die.die_attribute_values in + (String.concat "" (List.map (pp_die_attribute c cuh str indent level) ats)) + ^ + if pp_children then String.concat "" (List.map (pp_die c cuh str indent (level +1) pp_children) die.die_children) else "" + +val pp_die_abbrev : p_context -> compilation_unit_header -> byte_sequence -> natural -> bool -> (list die) -> die -> string +let rec pp_die_abbrev c cuh str level (pp_children:bool) parents die= + indent_level true level + ^ pp_tag_encoding die.die_abbreviation_declaration.ad_tag + ^ " (" ^ pp_pos die.die_offset ^ ") " +(* ^ ": Abbrev Number: " ^ show die.die_abbreviation_code *) + ^ + (match find_name_of_die str die with Just s -> s | Nothing -> "-" end) + ^ " : " ^ String.concat " : " (List.map (fun die' -> pp_tag_encoding die'.die_abbreviation_declaration.ad_tag) parents) + ^ "\n" + ^ (*(String.concat "" (List.map (pp_die_abbrev_attribute c cuh str) ats))*) + + if pp_children then String.concat "" (List.map (pp_die_abbrev c cuh str (level +1) pp_children (die::parents)) die.die_children) else "" + + +(* condensed pp for variables *) +val pp_die_abbrev_var : p_context -> dwarf -> compilation_unit -> byte_sequence -> bool -> (list die) -> die -> (string (*name*) * string (*offset*) * string (*kind*)) +let rec pp_die_abbrev_var c d cu str (pp_children:bool) parents die= + (* (indent_level true level*) + (* ^ pp_tag_encoding die.die_abbreviation_declaration.ad_tag*) +(* ^ ": Abbrev Number: " ^ show die.die_abbreviation_code *) + ((match find_name_of_die_using_abstract_origin c d cu str die with + | Just s -> s + | Nothing -> "?" + end) + , + pp_pos die.die_offset, + (if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_variable" then "var" + else if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_formal_parameter" then "param" + else "other") + ) + +(* condensed pp for variable parents *) +val pp_die_abbrev_var_parent : p_context -> dwarf -> compilation_unit -> byte_sequence -> die -> string +let pp_die_abbrev_var_parent c d cu str die= + (* (indent_level true level*) + (* ^ pp_tag_encoding die.die_abbreviation_declaration.ad_tag*) +(* ^ ": Abbrev Number: " ^ show die.die_abbreviation_code *) + let name = (match find_name_of_die_using_abstract_origin c d cu str die with Just s -> s | Nothing -> "" end) in + let offset = pp_pos die.die_offset in + (if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_compile_unit" then name + else if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_subprogram" then name (*"subprogram"*) + else if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_inlined_subroutine" then name ^ "(inlined)" + else if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_lexical_block" then "block" + else name ^ "(" ^ pp_tag_encoding die.die_abbreviation_declaration.ad_tag ^ ")") + + + +val pp_die_abbrev_var_parents : p_context -> dwarf -> compilation_unit -> byte_sequence -> list die -> string +let pp_die_abbrev_var_parents c d cu str parents= + String.concat ":" (List.map (fun die -> pp_die_abbrev_var_parent c d cu str die) parents) + + + + (* ^ " : " ^ String.concat " : " (List.map (fun die' -> pp_tag_encoding die'.die_abbreviation_declaration.ad_tag) parents)*) + (* ^ "\n"*) +(* ^ (*(String.concat "" (List.map (pp_die_abbrev_attribute c cuh str) ats))*)*) + +(* if pp_children then String.concat "" (List.map (pp_die_abbrev c cuh str (level +1) pp_children (die::parents)) die.die_children) else ""*) + + + +val parse_die : p_context -> byte_sequence -> compilation_unit_header -> (natural->abbreviation_declaration) -> parser (maybe die) +let rec parse_die c str cuh find_abbreviation_declaration= + fun (pc: parse_context) -> + (* let _ = my_debug3 ("parse_die called at " ^ pp_parse_context pc ^ "\n") in *) + pr_bind (parse_ULEB128 pc) (fun abbreviation_code' pc' -> + let abbreviation_code = sym_unwrap abbreviation_code' in + if abbreviation_code = 0 then PR_success Nothing pc' + else + (* let _ = my_debug3 ("parse_die abbreviation code "^pphex abbreviation_code ^"\n") in *) + let ad = find_abbreviation_declaration abbreviation_code in + let attribute_value_parsers = List.map (fun (at,af) -> pr_with_pos (parser_of_attribute_form c cuh af)) ad.ad_attribute_specifications in + pr_bind (parse_parser_list attribute_value_parsers pc') (fun avs pc'' -> + +(* + let die_header = + <| + die_offset = pc.pc_offset; + die_abbreviation_code = abbreviation_code; + die_abbreviation_declaration = ad; + die_attribute_values = avs; + die_children = []; + |> in let _ = my_debug3 ("die_header " ^ pp_die cuh str true 999 die_header) in + *) + pr_bind + (if ad.ad_has_children then parse_list (parse_die c str cuh find_abbreviation_declaration) pc'' else pr_return [] pc'') + (fun dies pc''' -> + PR_success (Just ( let die = + <| + die_offset = pc.pc_offset; + die_abbreviation_code = abbreviation_code; + die_abbreviation_declaration = ad; + die_attribute_values = avs; + die_children = dies; + |> in + let _ = my_debug3 ("die entire " ^ pp_die c cuh str true 0 false die) in + die)) pc'''))) + +let has_attribute (an: string) (die: die) : bool= + List.elem + (attribute_encode an) + (List.map Tuple.fst die.die_abbreviation_declaration.ad_attribute_specifications) + + +(** compilation units: pp and parsing *) + +let pp_compilation_unit c (indent:bool) (debug_str_section_body: byte_sequence) cu= + "" +(* "*** compilation unit header ***\n"*) + ^ pp_compilation_unit_header cu.cu_header + ^ "\n*** compilation unit abbreviation table\n" + ^ pp_abbreviations_table cu.cu_abbreviations_table + ^ "\n" + ^ "*** compilation unit die tree\n" + ^ pp_die c cu.cu_header debug_str_section_body indent 0 true cu.cu_die + ^ "\n" + +let pp_compilation_units c (indent:bool) debug_string_section_body (compilation_units: list compilation_unit) : string= + String.concat "" (List.map (pp_compilation_unit c indent debug_string_section_body) compilation_units) + + +let pp_compilation_unit_abbrev c (debug_str_section_body: byte_sequence) cu= + pp_compilation_unit_header cu.cu_header +(* ^ pp_abbreviations_table cu.cu_abbreviations_table*) + ^ pp_die_abbrev c cu.cu_header debug_str_section_body 0 true [] cu.cu_die + +let pp_compilation_units_abbrev c debug_string_section_body (compilation_units: list compilation_unit) : string= + String.concat "" (List.map (pp_compilation_unit_abbrev c debug_string_section_body) compilation_units) + +val add_die_to_index : die_index -> list die -> die -> die_index +let rec add_die_to_index acc parents die= + let nacc : die_index = Map.insert die.die_offset (parents,die) acc in + List.foldl (fun acc ndie -> add_die_to_index acc (die::parents) ndie) nacc die.die_children + +let parse_compilation_unit c (debug_str_section_body: byte_sequence) (debug_abbrev_section_body: byte_sequence) : parser (maybe compilation_unit)= + fun (pc:parse_context) -> + + if Byte_sequence.length pc.pc_bytes = 0 then PR_success Nothing pc else + + let (cuh, pc') = + + match parse_compilation_unit_header c pc with + | PR_fail s pc' -> Assert_extra.failwith ("parse_cuh_header fail: " ^ pp_parse_fail s pc') + | PR_success cuh pc' -> (cuh,pc') + end in + +let _ = my_debug4 (pp_compilation_unit_header cuh) in + + if cuh.cuh_unit_length = 0 then PR_success Nothing pc' else + + let pc_abbrev = <|pc_bytes = match dropbytes cuh.cuh_debug_abbrev_offset debug_abbrev_section_body with Success bs -> bs | Fail _ -> Assert_extra.failwith "mydrop of debug_abbrev" end; pc_offset = cuh.cuh_debug_abbrev_offset |> in + + (* todo: this is reparsing the abbreviations table for each cu *) + let abbreviations_table = + match parse_abbreviations_table c pc_abbrev with + | PR_fail s pc_abbrev' -> Assert_extra.failwith ("parse_abbrevations_table fail: " ^ pp_parse_fail s pc_abbrev') + | PR_success at pc_abbrev' -> <| at_offset=pc_abbrev.pc_offset; at_table= at|> + end in + + (* let _ = my_debug4 (pp_abbreviations_table abbreviations_table) in *) + + let find_abbreviation_declaration (ac:natural) : abbreviation_declaration= + (* let _ = my_debug4 ("find_abbreviation_declaration "^pphex ac) in *) + myfindNonPure (fun ad -> ad.ad_abbreviation_code = ac) abbreviations_table.at_table in + + (* let _ = my_debug3 (pp_abbreviations_table abbreviations_table) in *) + + match parse_die c debug_str_section_body cuh find_abbreviation_declaration pc' with + | PR_fail s pc'' -> Assert_extra.failwith ("parse_die fail: " ^ pp_parse_fail s pc'') + | PR_success (Nothing) pc'' -> Assert_extra.failwith ("parse_die returned Nothing: " ^ pp_parse_context pc'') + | PR_success (Just die) pc'' -> + let cu = + <| + cu_header = cuh; + cu_abbreviations_table = abbreviations_table; + cu_die = die; + cu_index = add_die_to_index Map.empty [] die + |> in + PR_success (Just cu) pc'' + end + +let parse_compilation_units c (debug_str_section_body: byte_sequence) (debug_abbrev_section_body: byte_sequence): parser (list compilation_unit)= + + parse_list (parse_compilation_unit c debug_str_section_body debug_abbrev_section_body) + + +(** type units: pp and parsing *) + +let pp_type_unit c (debug_str_section_body: byte_sequence) tu= + pp_type_unit_header tu.tu_header + ^ pp_abbreviations_table tu.tu_abbreviations_table + ^ pp_die c tu.tu_header.tuh_cuh debug_str_section_body true 0 true tu.tu_die + +let pp_type_units c debug_string_section_body (type_units: list type_unit) : string= + String.concat "" (List.map (pp_type_unit c debug_string_section_body) type_units) + + +let parse_type_unit c (debug_str_section_body: byte_sequence) (debug_abbrev_section_body: byte_sequence) : parser (maybe type_unit)= + fun (pc:parse_context) -> + + if Byte_sequence.length pc.pc_bytes = 0 then PR_success Nothing pc else + + let (tuh, pc') = + match parse_type_unit_header c pc with + | PR_fail s pc' -> Assert_extra.failwith ("parse_tuh_header fail: " ^ pp_parse_fail s pc') + | PR_success tuh pc' -> (tuh,pc') + end in + + (* let _ = my_debug4 (pp_type_unit_header tuh) in *) + + let pc_abbrev = let n = tuh.tuh_cuh.cuh_debug_abbrev_offset in <|pc_bytes = match dropbytes n debug_abbrev_section_body with Success bs -> bs | Fail _ -> Assert_extra.failwith "mydrop of debug_abbrev" end; pc_offset = n |> in + + let abbreviations_table = + match parse_abbreviations_table c pc_abbrev with + | PR_fail s pc_abbrev' -> Assert_extra.failwith ("parse_abbrevations_table fail: " ^ pp_parse_fail s pc_abbrev') + | PR_success at pc_abbrev' -> <| at_offset=pc_abbrev.pc_offset; at_table= at|> + end in + + (* let _ = my_debug4 (pp_abbreviations_table abbreviations_table) in *) + + let find_abbreviation_declaration (ac:natural) : abbreviation_declaration= + (* let _ = my_debug4 ("find_abbreviation_declaration "^pphex ac) in *) + myfindNonPure (fun ad -> ad.ad_abbreviation_code = ac) abbreviations_table.at_table in + + (* let _ = my_debug3 (pp_abbreviations_table abbreviations_table) in *) + + match parse_die c debug_str_section_body tuh.tuh_cuh find_abbreviation_declaration pc' with + | PR_fail s pc'' -> Assert_extra.failwith ("parse_die fail: " ^ pp_parse_fail s pc'') + | PR_success (Nothing) pc'' -> Assert_extra.failwith ("parse_die returned Nothing: " ^ pp_parse_context pc'') + | PR_success (Just die) pc'' -> + let tu = + <| + tu_header = tuh; + tu_abbreviations_table = abbreviations_table; + tu_die = die; + |> in + PR_success (Just tu) pc'' + end + +let parse_type_units c (debug_str_section_body: byte_sequence) (debug_abbrev_section_body: byte_sequence): parser (list type_unit)= + + parse_list (parse_type_unit c debug_str_section_body debug_abbrev_section_body) + +(** location lists, pp and parsing *) + +(* readelf example +Contents of the .debug_loc section: + + Offset Begin End Expression + 00000000 0000000000400168 0000000000400174 (DW_OP_reg0 (r0)) + 00000000 0000000000400174 0000000000400184 (DW_OP_GNU_entry_value: (DW_OP_reg0 (r0)); DW_OP_stack_value) + 00000000 + 00000039 000000000040017c 0000000000400180 (DW_OP_lit1; DW_OP_stack_value) +*) + + + + +let pp_location_list_entry c (cuh:compilation_unit_header) (offset:natural) (x:location_list_entry) : string= + " " ^ pphex offset + ^ " " ^ pphex x.lle_beginning_address_offset + ^ " " ^ pphex x.lle_ending_address_offset + ^ " (" ^ parse_and_pp_operations c cuh x.lle_single_location_description ^")" + ^ "\n" + +let pp_base_address_selection_entry c (cuh:compilation_unit_header) (offset:natural) (x:base_address_selection_entry) : string= + " " ^ pphex offset + ^ " " ^ pphex_sym x.base_address + ^ "\n" + +let pp_location_list_item c (cuh: compilation_unit_header) (offset: natural) (x:location_list_item)= + match x with + | LLI_lle lle -> pp_location_list_entry c cuh offset lle + | LLI_base base -> pp_base_address_selection_entry c cuh offset base + end + +let pp_location_list c (cuh: compilation_unit_header) ((offset:natural), (llis: list location_list_item))= + String.concat "" (List.map (pp_location_list_item c cuh offset) llis) +(* ^ " " ^ pphex offset ^ " \n"*) + +let pp_loc c (cuh: compilation_unit_header) (lls: list location_list)= + " Offset Begin End Expression\n" + ^ String.concat "" (List.map (pp_location_list c cuh) lls) + +(* Note that this is just pp'ing the raw location list data - Section +3.1.1 says: The applicable base address of a location list entry is +determined by the closest preceding base address selection entry in +the same location list. If there is no such selection entry, then the +applicable base address defaults to the base address of the +compilation unit. That is handled by the interpret_location_list below *) + + + +let parse_location_list_item c (cuh: compilation_unit_header) : parser (maybe location_list_item)= + fun (pc:parse_context) -> + pr_bind + (parse_pair + (parse_uint_address_size c cuh.cuh_address_size) + (parse_uint_address_size c cuh.cuh_address_size) + pc) + (fun ((a1: sym_natural),(a2:sym_natural)) pc' -> + let a1 = sym_unwrap a1 in + (* let _ = my_debug4 ("offset="^pphex pc.pc_offset ^ " begin=" ^ pphex a1 ^ " end=" ^ pphex a2) in *) + if a1=0 && a2=Absolute 0 then + PR_success Nothing pc' + else if a1 = max_address cuh.cuh_address_size then + let x = LLI_base <| (*base_offset=pc.pc_offset;*) base_address=a2 |> in (* BUGFIX a1 -> a2 *) + PR_success (Just x (*(pc.pc_offset, x)*)) pc' + else + pr_bind (parse_uint16 c pc') (fun n pc'' -> + pr_post_map1 + (parse_n_bytes (sym_unwrap n) pc'') + (fun bs -> + let x = + LLI_lle <| + (*lle_offset = pc.pc_offset;*) + lle_beginning_address_offset = a1; + lle_ending_address_offset = (sym_unwrap a2); + lle_single_location_description = bs; + |> in + Just x (*(pc.pc_offset, x)*)) + ) + ) + +let parse_location_list c cuh : parser (maybe location_list)= + fun (pc: parse_context) -> + if Byte_sequence.length pc.pc_bytes = 0 then + PR_success Nothing pc + else + pr_post_map1 + (parse_list (parse_location_list_item c cuh) pc) + (fun llis -> (Just (pc.pc_offset, llis))) + +let parse_location_list_list c cuh : parser location_list_list= + parse_list (parse_location_list c cuh) + +let find_location_list dloc n : location_list= + myfindNonPure (fun (n',_)-> n'=n) dloc + (* fails if location list not found *) + +(* interpretation of a location list applies the base_address and LLI_base offsets to give a list indexed by concrete address ranges *) + +let rec interpret_location_list (base_address: sym_natural) (llis: list location_list_item) : list (sym_natural * sym_natural * single_location_description)= + match llis with + | [] -> [] + | LLI_base base::llis' -> interpret_location_list base.base_address llis' + | LLI_lle lle :: llis' -> (base_address+(Absolute lle.lle_beginning_address_offset), base_address+(Absolute lle.lle_ending_address_offset), lle.lle_single_location_description) :: interpret_location_list base_address llis' + end + + +(** range lists, pp and parsing *) + +(* example output from: aarch64-linux-gnu-objdump --dwarf=Ranges + +Contents of the .debug_ranges section: + + Offset Begin End + 00000000 00000000004000fc 0000000000400114 + 00000000 000000000040011c 0000000000400128 + 00000000 +... + 00000380 0000000000400598 000000000040059c + 00000380 00000000004005a0 00000000004005a4 + 00000380 00000000004005b4 00000000004005b8 + 00000380 00000000004005bc 00000000004005bc (start == end) + 00000380 00000000004005c0 00000000004005c4 + 00000380 + +*) + +let pp_range_list_entry c (cuh:compilation_unit_header) (offset:natural) (x:range_list_entry) : string= + " " ^ pphex offset + ^ " " ^ pphex x.rle_beginning_address_offset + ^ " " ^ pphex x.rle_ending_address_offset + ^ (if x.rle_beginning_address_offset = x.rle_ending_address_offset then " (start == end)" else "") + ^ "\n" + +let pp_range_list_item c (cuh: compilation_unit_header) (offset: natural) (x:range_list_item)= + match x with + | RLI_rle rle -> pp_range_list_entry c cuh offset rle + | RLI_base base -> pp_base_address_selection_entry c cuh offset base + end + +let pp_range_list c (cuh: compilation_unit_header) ((offset:natural), (rlis: list range_list_item))= + String.concat "" (List.map (pp_range_list_item c cuh offset) rlis) + ^ " " ^ pphex offset ^ " \n" + +let pp_ranges c (cuh: compilation_unit_header) (rls: list range_list)= + " Offset Begin End\n" + ^ String.concat "" (List.map (pp_range_list c cuh) rls) + +(* Note that this is just pp'ing the raw range list data - see also +the interpret_range_list below *) + + +let parse_range_list_item c (cuh: compilation_unit_header) : parser (maybe range_list_item)= + fun (pc:parse_context) -> + pr_bind + (parse_pair + (parse_uint_address_size c cuh.cuh_address_size) + (parse_uint_address_size c cuh.cuh_address_size) + pc) + (fun ((a1: sym_natural),(a2:sym_natural)) pc' -> + let a1 = sym_unwrap a1 in + (* let _ = my_debug4 ("offset="^pphex pc.pc_offset ^ " begin=" ^ pphex a1 ^ " end=" ^ pphex a2) in *) + if a1=0 && a2=(Absolute 0) then + PR_success Nothing pc' + else if a1 = max_address cuh.cuh_address_size then + let x = RLI_base <| base_address=a2 |> in + PR_success (Just x) pc' + else + let x = + RLI_rle <| + rle_beginning_address_offset = a1; + rle_ending_address_offset = (sym_unwrap a2); + |> in + PR_success (Just x (*(pc.pc_offset, x)*)) pc' + ) + +(* compiler output includes DW_AT_ranges attributes that point to proper suffixes of range lists. We support that by explicitly including each suffix - though one could be more efficient *) + +let rec expand_range_list_suffixes cuh (offset,(rlis: list range_list_item)) : list range_list= + match rlis with + | [] -> [] + | [rli] -> [(offset,rlis)] + | rli::rlis' -> (offset,rlis) :: expand_range_list_suffixes cuh ((offset + 2*cuh.cuh_address_size),rlis') + end + +let parse_range_list c cuh : parser (maybe (list range_list))= + fun (pc: parse_context) -> + if Byte_sequence.length pc.pc_bytes = 0 then + PR_success Nothing pc + else + pr_post_map1 + (parse_list (parse_range_list_item c cuh) pc) + (fun rlis -> (Just (expand_range_list_suffixes cuh (pc.pc_offset, rlis)))) + +let parse_range_list_list c cuh : parser range_list_list= + pr_map2 List.concat (parse_list (parse_range_list c cuh)) + +let find_range_list dranges n : maybe range_list= + List.find (fun (n',_)-> n'=n) dranges + (* fails if range list not found *) + +(* interpretation of a range list applies the base_address and RLI_base offsets to give a list of concrete address ranges *) + +let rec interpret_range_list (base_address: sym_natural) (rlis: list range_list_item) : list (sym_natural * sym_natural)= + match rlis with + | [] -> [] + | RLI_base base::rlis' -> interpret_range_list base.base_address rlis' + | RLI_rle rle :: rlis' -> (base_address+(Absolute rle.rle_beginning_address_offset), base_address+(Absolute rle.rle_ending_address_offset)) :: interpret_range_list base_address rlis' + end + +(** frame information, pp and parsing *) + +(* readelf example + +Contents of the .debug_frame section: + +00000000 0000000c ffffffff CIE + Version: 1 + Augmentation: "" + Code alignment factor: 4 + Data alignment factor: -8 + Return address column: 65 + + DW_CFA_def_cfa: r1 ofs 0 + +00000010 00000024 00000000 FDE cie=00000000 pc=100000b0..10000120 + DW_CFA_advance_loc: 8 to 100000b8 + DW_CFA_def_cfa_offset: 80 + DW_CFA_offset: r31 at cfa-8 + DW_CFA_advance_loc: 4 to 100000bc + DW_CFA_def_cfa_register: r31 + DW_CFA_advance_loc: 80 to 1000010c + DW_CFA_def_cfa: r1 ofs 0 + DW_CFA_nop + DW_CFA_nop + DW_CFA_nop + DW_CFA_nop + +00000038 00000024 00000000 FDE cie=00000000 pc=10000120..100001a4 + DW_CFA_advance_loc: 16 to 10000130 + DW_CFA_def_cfa_offset: 144 + DW_CFA_offset_extended_sf: r65 at cfa+16 + DW_CFA_offset: r31 at cfa-8 + DW_CFA_advance_loc: 4 to 10000134 + DW_CFA_def_cfa_register: r31 + DW_CFA_advance_loc: 84 to 10000188 + DW_CFA_def_cfa: r1 ofs 0 +*) + + + +let pp_cfa_address a= pphex_sym a +let pp_cfa_block b= ppbytes b +let pp_cfa_delta d= pphex_sym d +(*let pp_cfa_offset n = pphex n +let pp_cfa_register r = show r*) +let pp_cfa_sfoffset i= show i + +let pp_cfa_register r= "r"^show r (*TODO: arch-specific register names *) + +let pp_cfa_offset (i:integer)= if i=0 then "" else if i<0 then show i else "+" ^ show i + +let pp_cfa_rule (cr:cfa_rule) : string= + match cr with + | CR_undefined -> "u" + | CR_register r i -> pp_cfa_register r ^ pp_cfa_offset i + | CR_expression bs -> "exp" + end + +let pp_register_rule (rr:register_rule) : string= (*TODO make this more readelf-like *) + match rr with + | RR_undefined -> "u" + | RR_same_value -> "s" + | RR_offset i -> "c" ^ pp_cfa_offset i + | RR_val_offset i -> "val(c" ^ pp_cfa_offset i ^ ")" + | RR_register r -> pp_cfa_register r + | RR_expression bs -> "exp" + | RR_val_expression bs -> "val(exp)" + | RR_architectural -> "" + end + + + +let pp_call_frame_instruction i= + match i with + | DW_CFA_advance_loc d -> "DW_CFA_advance_loc" ^ " " ^ pp_cfa_delta d + | DW_CFA_offset r n -> "DW_CFA_offset" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_offset (integerFromSymNatural n) + | DW_CFA_restore r -> "DW_CFA_restore" ^ " " ^ pp_cfa_register r + | DW_CFA_nop -> "DW_CFA_nop" + | DW_CFA_set_loc a -> "DW_CFA_set_loc" ^ " " ^ pp_cfa_address a + | DW_CFA_advance_loc1 d -> "DW_CFA_advance_loc1" ^ " " ^ pp_cfa_delta d + | DW_CFA_advance_loc2 d -> "DW_CFA_advance_loc2" ^ " " ^ pp_cfa_delta d + | DW_CFA_advance_loc4 d -> "DW_CFA_advance_loc4" ^ " " ^ pp_cfa_delta d + | DW_CFA_offset_extended r n -> "DW_CFA_offset_extended" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_offset (integerFromSymNatural n) + | DW_CFA_restore_extended r -> "DW_CFA_restore_extended" ^ " " ^ pp_cfa_register r + | DW_CFA_undefined r -> "DW_CFA_undefined" ^ " " ^ pp_cfa_register r + | DW_CFA_same_value r -> "DW_CFA_same_value" ^ " " ^ pp_cfa_register r + | DW_CFA_register r1 r2 -> "DW_CFA_register" ^ " " ^ pp_cfa_register r1 ^ " " ^ pp_cfa_register r2 + | DW_CFA_remember_state -> "DW_CFA_remember_state" + | DW_CFA_restore_state -> "DW_CFA_restore_state" + | DW_CFA_def_cfa r n -> "DW_CFA_def_cfa" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_offset (integerFromSymNatural n) + | DW_CFA_def_cfa_register r -> "DW_CFA_def_cfa_register" ^ " " ^ pp_cfa_register r + | DW_CFA_def_cfa_offset n -> "DW_CFA_def_cfa_offset" ^ " " ^ pp_cfa_offset (integerFromSymNatural n) + | DW_CFA_def_cfa_expression b -> "DW_CFA_def_cfa_expression" ^ " " ^ pp_cfa_block b + | DW_CFA_expression r b -> "DW_CFA_expression" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_block b + | DW_CFA_offset_extended_sf r i -> "DW_CFA_offset_extended_sf" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_sfoffset i + | DW_CFA_def_cfa_sf r i -> "DW_CFA_def_cfa_sf" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_sfoffset i + | DW_CFA_def_cfa_offset_sf i -> "DW_CFA_def_cfa_offset_sf" ^ " " ^ pp_cfa_sfoffset i + | DW_CFA_val_offset r n -> "DW_CFA_val_offset" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_offset (integerFromSymNatural n) + | DW_CFA_val_offset_sf r i -> "DW_CFA_val_offset_sf" ^ pp_cfa_register r ^ " " ^ pp_cfa_sfoffset i + | DW_CFA_val_expression r b -> "DW_CFA_val_expression" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_block b + | DW_CFA_AARCH64_negate_ra_state -> "DW_CFA_AARCH64_negate_ra_state" + | DW_CFA_unknown bt -> "DW_CFA_unknown" ^ " " ^ show bt + end + +let pp_call_frame_instructions is= String.concat "" (List.map (fun i -> " " ^ pp_call_frame_instruction i ^ "\n") is) + + +let parser_of_call_frame_argument_type c cuh (cfat: call_frame_argument_type) : parser call_frame_argument_value= + match cfat with + | CFAT_address -> pr_map2 (fun n -> CFAV_address n) (parse_uint_address_size c cuh.cuh_address_size) + | CFAT_delta1 -> pr_map2 (fun n -> CFAV_delta n) (parse_uint8) + | CFAT_delta2 -> pr_map2 (fun n -> CFAV_delta n) (parse_uint16 c) + | CFAT_delta4 -> pr_map2 (fun n -> CFAV_delta n) (parse_uint32 c) + | CFAT_delta_ULEB128 -> pr_map2 (fun n -> CFAV_delta n) (parse_ULEB128) + | CFAT_offset -> pr_map2 (fun n -> CFAV_offset n) (parse_ULEB128) + | CFAT_sfoffset -> pr_map2 (fun n -> CFAV_sfoffset n) (parse_SLEB128) + | CFAT_register -> pr_map2 (fun n -> CFAV_register n) (parse_ULEB128) + | CFAT_block -> + (fun pc -> pr_bind (parse_ULEB128 pc) (fun n pc' -> + pr_map (fun bs -> CFAV_block bs) (parse_n_bytes (sym_unwrap n) pc'))) + end + +let parse_call_frame_instruction c cuh : parser (maybe call_frame_instruction)= + fun pc -> + match read_char pc.pc_bytes with + | Fail _ -> PR_success Nothing pc + | Success (b,bs') -> + let pc' = <| pc_bytes = bs'; pc_offset = pc.pc_offset + 1 |> in + let ch = unsigned_char_of_byte b in + let high_bits = unsigned_char_land ch (unsigned_char_of_natural 192) in + let low_bits = natural_of_unsigned_char (unsigned_char_land ch (unsigned_char_of_natural 63)) in + if high_bits = unsigned_char_of_natural 0 then + match lookup_abCde_de low_bits call_frame_instruction_encoding with + | Just ((args: list call_frame_argument_type), result) -> + let ps = List.map (parser_of_call_frame_argument_type c cuh) args in + let p = + pr_post_map + (parse_parser_list ps) + result in + match p pc' with + | PR_success (Just cfi) pc'' -> PR_success (Just cfi) pc'' + | PR_success (Nothing) pc'' -> Assert_extra.failwith "bad call frame instruction argument 1" + | PR_fail s pc'' -> Assert_extra.failwith "bad call frame instruction argument 2" + end + | Nothing -> + (*Assert_extra.failwith ("can't parse " ^ show b ^ " as call frame instruction")*) + PR_success (Just (DW_CFA_unknown b)) pc' + end + else + if high_bits = unsigned_char_of_natural 64 then + PR_success (Just (DW_CFA_advance_loc (Absolute low_bits))) pc' + else if high_bits = unsigned_char_of_natural 192 then + PR_success (Just (DW_CFA_restore (Absolute low_bits))) pc' + else + let p = parser_of_call_frame_argument_type c cuh CFAT_offset in + match p pc' with + | PR_success (CFAV_offset n) pc'' -> PR_success (Just (DW_CFA_offset (Absolute low_bits) n)) pc'' + | PR_success _ pc'' -> Assert_extra.failwith "bad call frame instruction argument 3" + | PR_fail s pc'' -> Assert_extra.failwith "bad call frame instruction argument 4" + end + end + +let parse_call_frame_instructions c cuh : parser (list call_frame_instruction)= + parse_list (parse_call_frame_instruction c cuh) + +val parse_and_pp_call_frame_instructions : p_context -> compilation_unit_header -> byte_sequence -> string +let parse_and_pp_call_frame_instructions c cuh bs= + let pc = <|pc_bytes = bs; pc_offset = 0 |> in + match parse_call_frame_instructions c cuh pc with + | PR_fail s pc' -> "parse_call_frame_instructions fail: " ^ pp_parse_fail s pc' + | PR_success is pc' -> + pp_call_frame_instructions is + ^ if Byte_sequence.length pc'.pc_bytes <> 0 then " Warning: extra non-parsed bytes" else "" + end + + + +let pp_call_frame_instructions' c cuh bs= + (* ppbytes bs ^ "\n" *) + parse_and_pp_call_frame_instructions c cuh bs + + + +let pp_cie c cuh cie= + pphex cie.cie_offset + ^ " " ^ pphex cie.cie_length + ^ " " ^ pphex cie.cie_id + ^ " CIE\n" + ^ " Version: " ^ show cie.cie_version ^ "\n" + ^ " Augmentation: \""^ show (string_of_byte_sequence cie.cie_augmentation) ^ "\"\n" + ^ " Code alignment factor: " ^ show cie.cie_code_alignment_factor ^ "\n" + ^ " Data alignment factor: " ^ show cie.cie_data_alignment_factor ^ "\n" + ^ " Return address column: " ^ show cie.cie_return_address_register ^ "\n" + ^ "\n" + ^ ppbytes cie.cie_initial_instructions_bytes ^ "\n" + ^ pp_call_frame_instructions cie.cie_initial_instructions + +(* cie_address_size: natural; (* not shown by readelf - must match compilation unit *)*) +(* cie_segment_size: natural; (* not shown by readelf *)*) +(* readelf says "Return address column", but the DWARF spec says "Return address register" *) + + +let pp_fde c cuh fde= + pphex fde.fde_offset + ^ " " ^ pphex fde.fde_length + ^ " " ^ pphex fde.fde_cie_pointer (* not what this field of readelf output is *) + ^ " FDE" + ^ " cie=" ^ pphex fde.fde_cie_pointer (* duplicated?? *) + ^ " pc=" ^ match fde.fde_initial_location_segment_selector with Nothing -> "" | Just segment_selector -> "("^pphex_sym segment_selector^")" end ^ pphex_sym fde.fde_initial_location_address ^ ".." ^ pphex_sym (fde.fde_initial_location_address + fde.fde_address_range) ^ "\n" + ^ ppbytes fde.fde_instructions_bytes ^ "\n" + ^ pp_call_frame_instructions fde.fde_instructions + +let pp_frame_info_element c cuh fie= + match fie with + | FIE_cie cie -> pp_cie c cuh cie + | FIE_fde fde -> pp_fde c cuh fde + end + +let pp_frame_info c cuh fi= + "Contents of the .debug_frame section:\n\n" + ^ String.concat "\n" (List.map (pp_frame_info_element c cuh) fi) + ^ "\n" + + + +let rec find_cie fi cie_id= + match fi with + | [] -> Assert_extra.failwith "find_cie: cie_id not found" + | FIE_fde _ :: fi' -> find_cie fi' cie_id + | FIE_cie cie :: fi' -> if cie_id = cie.cie_offset then cie else find_cie fi' cie_id + end + +let parse_initial_location c cuh mss mas' : parser ((maybe sym_natural) * sym_natural)= (*(segment selector and target address)*) + (* assume segment selector size is zero unless given explicitly. Probably we need to do something architecture-specific for earlier dwarf versions?*) + parse_pair + (parse_uint_segment_selector_size c (match mss with Just n -> n | Nothing -> 0 end)) + (parse_uint_address_size c (match mas' with Just n -> n | Nothing -> cuh.cuh_address_size end)) + + +let parse_call_frame_instruction_bytes offset' ul= + fun (pc: parse_context) -> + parse_n_bytes (ul - (pc.pc_offset - offset')) pc + +let parse_frame_info_element c cuh (fi: list frame_info_element) : parser frame_info_element= + parse_dependent + (pr_with_pos + (parse_dependent_pair + (parse_unit_length c) + (fun (df,ul) -> + pr_with_pos + (pr_post_map (parse_uintDwarfN c df) sym_unwrap) (* CIE_id (cie) or CIE_pointer (fde) *) + ))) + (fun (offset,((df,ul),(offset',cie_id))) -> + if (cie_id = + match df with + | Dwarf32 -> natural_of_hex "0xffffffff" + | Dwarf64 -> natural_of_hex "0xffffffffffffffff" + end) + then + (* parse cie *) + pr_post_map + (parse_pair + (parse_dependent_pair + (pr_post_map parse_uint8 sym_unwrap) (* version *) + (fun v -> + parse_triple + parse_string (* augmentation *) + (if v=4 || v=46 then pr_post_map parse_uint8 (fun i->Just (sym_unwrap i)) else pr_return Nothing) (* address_size *) + (if v=4 || v=46 then pr_post_map parse_uint8 (fun i->Just (sym_unwrap i)) else pr_return Nothing))) (* segment_size *) + (parse_quadruple + parse_ULEB128 (* code_alignment_factor *) + parse_SLEB128 (* data_alignment_factor *) + parse_ULEB128 (* return address register *) + (parse_call_frame_instruction_bytes offset' ul))) + (fun ( (v,(aug,(mas',mss))), (caf,(daf,(rar,bs))) ) -> + let pc = <|pc_bytes = bs; pc_offset = 0 |> in + match parse_call_frame_instructions c cuh pc with + | PR_success is _ -> + FIE_cie + ( + <| + cie_offset = offset; + cie_length = ul; + cie_id = cie_id; + cie_version = v; + cie_augmentation = aug; + cie_address_size = mas'; + cie_segment_size = mss; + cie_code_alignment_factor = caf; + cie_data_alignment_factor = daf; + cie_return_address_register = rar; + cie_initial_instructions_bytes = bs; + cie_initial_instructions = is; + |>) + | PR_fail s _ -> Assert_extra.failwith s + end + ) + + else + (* parse fde *) + let cie = find_cie fi cie_id in + (* let _ = my_debug4 (pp_cie c cuh cie) in *) + pr_post_map + (parse_triple + (parse_initial_location c cuh cie.cie_segment_size cie.cie_address_size) (*(segment selector and target address)*) + (parse_uint_address_size c (match cie.cie_address_size with Just n -> n | Nothing -> cuh.cuh_address_size end)) (* address_range (target address) *) + (parse_call_frame_instruction_bytes offset' ul) + ) + (fun ( (ss,adr), (ar, bs)) -> + let pc = <|pc_bytes = bs; pc_offset = 0 |> in + match parse_call_frame_instructions c cuh pc with + | PR_success is _ -> + FIE_fde + ( + <| + fde_offset = offset; + fde_length = ul; + fde_cie_pointer = cie_id; + fde_initial_location_segment_selector = ss; + fde_initial_location_address = adr; + fde_address_range = ar; + fde_instructions_bytes = bs; + fde_instructions = is; + |> ) + | PR_fail s _ -> Assert_extra.failwith s + end + ) + ) + +(* you can't even parse an fde without accessing the cie it refers to +(to determine the segment selector size). Gratuitous complexity or what? +Hence the following, which should be made more tail-recursive. *) + +val parse_dependent_list' : forall 'a. (list 'a -> parser 'a) -> list 'a -> parser (list 'a) +let rec parse_dependent_list' p1 acc= + fun pc -> + if Byte_sequence.length pc.pc_bytes = 0 then + PR_success (List.reverse acc) pc + else + pr_bind + (p1 acc pc) + (fun x pc' -> + parse_dependent_list' p1 (x::acc) pc') + +val parse_dependent_list : forall 'a. (list 'a -> parser 'a) -> parser (list 'a) +let parse_dependent_list p1= parse_dependent_list' p1 [] + + +let parse_frame_info c cuh : parser frame_info= + + parse_dependent_list (parse_frame_info_element c cuh) + + +(** line numbers .debug_line, pp and parsing *) + +let pp_line_number_file_entry lnfe= + "lnfe_path = " ^ string_of_byte_sequence lnfe.lnfe_path ^ "\n" +^ "lnfe_directory_index " ^ show lnfe.lnfe_directory_index ^ "\n" +^ "lnfe_last_modification = " ^ show lnfe.lnfe_last_modification ^ "\n" +^ "lnfe_length = " ^ show lnfe.lnfe_length ^ "\n" + + +let pp_line_number_header lnh= + "offset = " ^ pphex lnh.lnh_offset ^ "\n" +^ "dwarf_format = " ^ pp_dwarf_format lnh.lnh_dwarf_format ^ "\n" +^ "unit_length = " ^ show lnh.lnh_unit_length ^ "\n" +^ "version = " ^ show lnh.lnh_version ^ "\n" +^ "header_length = " ^ show lnh.lnh_header_length ^ "\n" +^ "minimum_instruction_length = " ^ show lnh.lnh_minimum_instruction_length ^ "\n" +^ "maximum_operations_per_instruction = " ^ show lnh.lnh_maximum_operations_per_instruction ^ "\n" +^ "default_is_stmt = " ^ show lnh.lnh_default_is_stmt ^ "\n" +^ "line_base = " ^ show lnh.lnh_line_base ^ "\n" +^ "line_range = " ^ show lnh.lnh_line_range ^ "\n" +^ "opcode_base = " ^ show lnh.lnh_opcode_base ^ "\n" +^ "standard_opcode_lengths = " ^ show lnh.lnh_standard_opcode_lengths ^ "\n" +^ "comp_dir = " ^ show lnh.lnh_comp_dir ^ "\n" +^ "include_directories = " ^ String.concat ", " (List.map string_of_byte_sequence lnh.lnh_include_directories) ^ "\n" +^ "file_entries = \n\n" ^ String.concat "\n" (List.map pp_line_number_file_entry lnh.lnh_file_entries) ^ "\n" + + +let pp_line_number_operation lno= + match lno with + | DW_LNS_copy -> "DW_LNS_copy" + | DW_LNS_advance_pc n -> "DW_LNS_advance_pc" ^ " " ^ show n + | DW_LNS_advance_line i -> "DW_LNS_advance_line" ^ " " ^ show i + | DW_LNS_set_file n -> "DW_LNS_set_file" ^ " " ^ show n + | DW_LNS_set_column n -> "DW_LNS_set_column" ^ " " ^ show n + | DW_LNS_negate_stmt -> "DW_LNS_negate_stmt" + | DW_LNS_set_basic_block -> "DW_LNS_set_basic_block" + | DW_LNS_const_add_pc -> "DW_LNS_const_add_pc" + | DW_LNS_fixed_advance_pc n -> "DW_LNS_fixed_advance_pc" ^ " " ^ show n + | DW_LNS_set_prologue_end -> "DW_LNS_set_prologue_end" + | DW_LNS_set_epilogue_begin -> "DW_LNS_set_epilogue_begin" + | DW_LNS_set_isa n -> "DW_LNS_set_isa" ^ " " ^ show n + | DW_LNE_end_sequence -> "DW_LNE_end_sequence" + | DW_LNE_set_address n -> "DW_LNE_set_address" ^ " " ^ pphex_sym n + | DW_LNE_define_file s n1 n2 n3 -> "DW_LNE_define_file" ^ " " ^ show s ^ " " ^ show n1 ^ " " ^ show n2 ^ " " ^ show n3 + | DW_LNE_set_discriminator n -> "DW_LNE_set_discriminator" ^ " " ^ show n + | DW_LN_special n -> "DW_LN_special" ^ " " ^ show n + end + +let pp_line_number_program lnp= + pp_line_number_header lnp.lnp_header + ^ "[" ^ String.concat ", " (List.map pp_line_number_operation lnp.lnp_operations) ^ "]\n" + + + +let parse_line_number_file_entry : parser (maybe line_number_file_entry)= + + parse_dependent + (parse_non_empty_string) + (fun ms -> + match ms with + | Nothing -> + pr_return Nothing + | Just s -> + pr_post_map + (parse_triple + parse_ULEB128 + parse_ULEB128 + parse_ULEB128 + ) + (fun (n1,(n2,n3)) -> + (Just + <| + lnfe_path = s; + lnfe_directory_index = n1; + lnfe_last_modification = n2; + lnfe_length = n3; + |> ) + ) + end + ) + +let parse_line_number_header c (comp_dir:maybe string) : parser line_number_header= + (parse_dependent + ((pr_with_pos + (parse_unit_length c) )) + (fun (pos,(df,ul)) -> + (* + parse_dependent_pair + (parse_pair + (parse_triple + (parse_uint16 c) (* version *) + (parse_uintDwarfN c df) (* header_length *) + (parse_uint8) (* minimum_instruction_length *) + (* (parse_uint8) (* maximum_operations_per_instruction NOT IN DWARF 2*)*) + ) + (parse_quadruple + (parse_uint8) (* default_is_stmt *) + (parse_sint8) (* line_base *) + (parse_uint8) (* line_range *) + (parse_uint8) (* opcode_base *) + )) + (fun ((v,(hl,(minil(*,maxopi*)))),(dis,(lb,(lr,ob)))) -> + + *) + (parse_dependent + (parse_dependent_pair + (pr_post_map (parse_uint16 c) sym_unwrap) (* version *) + (fun v -> + (parse_pair + (parse_triple + (pr_post_map (parse_uintDwarfN c df) sym_unwrap) (* header_length *) + (parse_uint8) (* minimum_instruction_length *) + (if v<4 then (* maximum_operations_per_instruction*)(* NOT IN DWARF 2 or 3; in DWARF 4*) + (parse_uint8_constant 1) + else + (parse_uint8) + )) + (parse_quadruple + (parse_uint8) (* default_is_stmt *) + (parse_sint8) (* line_base *) + (parse_uint8) (* line_range *) + (pr_post_map parse_uint8 sym_unwrap) (* opcode_base *) + )))) + (fun ((v,(((hl,(minil,maxopi))),(dis,(lb,(lr,ob)))))) -> + pr_post_map + (parse_triple + (pr_post_map (parse_n_bytes (ob-1)) (fun bs -> List.map natural_of_byte (byte_list_of_byte_sequence bs))) (* standard_opcode_lengths *) + ((*pr_return [[]]*) parse_list parse_non_empty_string) (* include_directories *) + (parse_list parse_line_number_file_entry) (* file names *) + ) + (fun (sols, (ids, fns)) -> + <| + lnh_offset = pos; + lnh_dwarf_format = df; + lnh_unit_length = ul; + lnh_version = v; + lnh_header_length = hl; + lnh_minimum_instruction_length = minil; + lnh_maximum_operations_per_instruction = maxopi; + lnh_default_is_stmt = (dis<>0); + lnh_line_base = lb; + lnh_line_range = lr; + lnh_opcode_base = ob; + lnh_standard_opcode_lengths = sols; + lnh_include_directories = ids; + lnh_file_entries = fns; + lnh_comp_dir = comp_dir; + |> + ) + ) + ) + ) + ) +let parser_of_line_number_argument_type c (cuh: compilation_unit_header) (lnat: line_number_argument_type) : parser line_number_argument_value= + match lnat with + | LNAT_address -> pr_map2 (fun n -> LNAV_address n) (parse_uint_address_size c cuh.cuh_address_size) + | LNAT_ULEB128 -> pr_map2 (fun n -> LNAV_ULEB128 n) (parse_ULEB128) + | LNAT_SLEB128 -> pr_map2 (fun i -> LNAV_SLEB128 i) (parse_SLEB128) + | LNAT_uint16 -> pr_map2 (fun n -> LNAV_uint16 n) (parse_uint16 c) + | LNAT_string -> pr_map2 (fun s -> LNAV_string s) (parse_string) + end + +let parse_line_number_operation c (cuh: compilation_unit_header) (lnh: line_number_header) : parser line_number_operation= + parse_dependent + (pr_post_map parse_uint8 sym_unwrap) + (fun opcode -> + if opcode=0 then + (* parse extended opcode *) + parse_dependent + (parse_pair + parse_ULEB128 + parse_uint8) + (fun (size,opcode') -> + match lookup_aBcd_acd opcode' line_number_extended_encodings with + | Just (_, arg_types, result) -> + let ps = List.map (parser_of_line_number_argument_type c cuh) arg_types in + parse_demaybe ("parse_line_number_operation fail") + (pr_post_map + (parse_parser_list ps) + result ) + | Nothing -> + Assert_extra.failwith ("parse_line_number_operation extended opcode not found: " ^ show opcode') + end) + (* it's not clear what the ULEB128 size field is for, as the extended opcides all seem to have well-defined sizes. perhaps there can be extra padding that needs to be absorbed? *) + else if opcode >= lnh.lnh_opcode_base then + (* parse special opcode *) + let adjusted_opcode = opcode - lnh.lnh_opcode_base in + pr_return (DW_LN_special adjusted_opcode) + else + (* parse standard opcode *) + match lookup_aBcd_acd opcode line_number_standard_encodings with + | Just (_, arg_types, result) -> + let ps = List.map (parser_of_line_number_argument_type c cuh) arg_types in + parse_demaybe ("parse_line_number_operation fail") + (pr_post_map + (parse_parser_list ps) + result) + | Nothing -> + Assert_extra.failwith ("parse_line_number_operation standard opcode not found: " ^ show opcode) + (* the standard_opcode_lengths machinery is intended to allow vendor specific extension instructions to be parsed and ignored, but here we couldn't usefully process such instructions in any case, so we just fail *) + end) + + +let parse_line_number_operations c (cuh:compilation_unit_header) (lnh:line_number_header) : parser (list line_number_operation)= + parse_list (parse_maybe (parse_line_number_operation c cuh lnh)) + + + (* assume operations start immediately after the header - not completely clear in DWARF whether the header_length is just an optimisation or whether it's intended to allow the operations to start later *) + (* line number operations have no no-op and no termination operation, so we have to cut down the available bytes to the right length *) + +let parse_line_number_program c (cuh:compilation_unit_header) (comp_dir:maybe string) : parser line_number_program= + parse_dependent + (parse_line_number_header c comp_dir) + (fun lnh -> + let byte_count_of_operations = + lnh.lnh_unit_length - (lnh.lnh_header_length + 2 + (match lnh.lnh_dwarf_format with Dwarf32 -> 4 | Dwarf64 -> 8 end)) in + pr_post_map + (parse_restrict_length + byte_count_of_operations + (parse_line_number_operations c cuh lnh) + ) + (fun ops -> + <| + lnp_header = lnh; + lnp_operations = ops; + |>) + ) + +(*TODO: this should use find_natural_attribute_value_of_die *) +let line_number_offset_of_compilation_unit c cu= + match find_attribute_value "DW_AT_stmt_list" cu.cu_die with + | Just (AV_sec_offset n) -> n + | Just (AV_block n bs) -> natural_of_bytes c.endianness bs + (* a 32-bit MIPS example used a 4-byte AV_block not AV_sec_offset *) + | Just _ -> (Assert_extra.failwith ("compilation unit DW_AT_stmt_list attribute was not an AV_sec_offset" ^ pp_compilation_unit_header cu.cu_header)) + | _ -> Assert_extra.failwith ("compilation unit did not have a DW_AT_stmt_list attribute\n" ^ pp_compilation_unit_header cu.cu_header ^ "\n") + end + +let line_number_program_of_compilation_unit d cu= + let c = p_context_of_d d in + let offset = line_number_offset_of_compilation_unit c cu in + match List.find (fun lnp -> lnp.lnp_header.lnh_offset = offset) d.d_line_info with + | Nothing -> Assert_extra.failwith "compilation unit line number offset not found" + | Just lnp ->lnp + end + +let filename d cu n= + let lnp = line_number_program_of_compilation_unit d cu in + if n=0 then Nothing else + match mynth (n - 1) lnp.lnp_header.lnh_file_entries with + | Just lnfe -> + Just (string_of_byte_sequence lnfe.lnfe_path) + | Nothing -> + Assert_extra.failwith ("line number file entry not found") + end + +let unpack_file_entry lnh file : unpacked_file_entry= + match mynth (file - 1) lnh.lnh_file_entries with + | Just lnfe -> + let directory = + if lnfe.lnfe_directory_index = 0 then + Nothing + else + match mynth (lnfe.lnfe_directory_index - 1) lnh.lnh_include_directories with + | Just d -> Just (string_of_byte_sequence d) + | Nothing -> Just "" + end + in + (lnh.lnh_comp_dir, directory, string_of_byte_sequence lnfe.lnfe_path) + | Nothing -> + (Nothing,Nothing,"") + end + + +let pp_ufe (((mcomp_dir,mdir,file) as ufe) : unpacked_file_entry) : string= + file + ^ " dir=" ^ match mdir with | Just s->s|Nothing->"" end + ^ " comp_dir=" ^ match mcomp_dir with | Just s->s|Nothing->"" end + +let pp_ud (((((mcomp_dir,mdir,file) as ufe) : unpacked_file_entry), (line:nat), (subprogram_name:string)) : unpacked_decl) : string= + file + ^ ":" ^ show line + ^ " " ^ subprogram_name + ^ " dir=" ^ match mdir with | Just s->s|Nothing->"" end + ^ " comp_dir=" ^ match mcomp_dir with | Just s->s|Nothing->"" end + + +let pp_ufe_brief (((mcomp_dir,mdir,file) as ufe) : unpacked_file_entry) : string= + file + (* + ^ " dir=" ^ match mdir with | Just s->s|Nothing->"" end + ^ " comp_dir=" ^ match mcomp_dir with | Just s->s|Nothing->"" end + *) + +let parse_line_number_info c str (d_line: byte_sequence) (cu: compilation_unit) : line_number_program= + let comp_dir = find_string_attribute_value_of_die "DW_AT_comp_dir" str cu.cu_die in + let f n= + let d_line' = match dropbytes n d_line with Success xs -> xs | Fail _ -> Assert_extra.failwith "parse_line_number_info drop" end in + let pc = <| pc_bytes = d_line'; pc_offset = n|> in + match parse_line_number_program c cu.cu_header comp_dir pc with + | PR_success lnp pc' -> + (*let _ = print_endline (pp_line_number_program lnp) in*) + lnp + | PR_fail s pc' -> Assert_extra.failwith ("parse_line_number_header failed: " ^ s) + end in + f (line_number_offset_of_compilation_unit c cu) + +let parse_line_number_infos c str debug_line_section_body compilation_units= + + List.map (parse_line_number_info c str debug_line_section_body) compilation_units + +let pp_line_info li= + + String.concat "\n" (List.map (pp_line_number_program) li) + + +(** all dwarf info: pp and parsing *) + +(* roughly matching objdump --dwarf=abbrev,info *) +let pp_dwarf_like_objdump d= + let c = p_context_of_d d in + "" + +(* ^ "\n*** compilation unit abbreviation table ***\n" *) + ^ "Contents of the .debug_abbrev section:\n\n" + ^ " Number TAG (0x0)\n" + ^ pp_abbreviations_tables d +(* ^ "\n*** compilation unit die tree ***\n"*) + +(* "\n************** .debug_info section - abbreviated *****************\n" + ^ pp_compilation_units_abbrev c d.d_str d.d_compilation_units + ^*) +(* ^"\n************** .debug_info section - full ************************\n"*) + ^ "\nContents of the .debug_info section:\n\n" + ^ pp_compilation_units c false (*false for no indent, like objdump; true for nice indent *) d.d_str d.d_compilation_units + + + +let pp_dwarf d= + let c = p_context_of_d d in + +(* "\n************** .debug_info section - abbreviated *****************\n" + ^ pp_compilation_units_abbrev c d.d_str d.d_compilation_units + ^*) "\n************** .debug_info section - full ************************\n" + ^ pp_compilation_units c true d.d_str d.d_compilation_units + ^ "\n************** .debug_loc section: location lists ****************\n" + ^ let (cuh_default : compilation_unit_header) = let cu = myhead d.d_compilation_units in cu.cu_header in + pp_loc c cuh_default d.d_loc + ^ "\n************** .debug_ranges section: range lists ****************\n" + ^ pp_ranges c cuh_default d.d_ranges + ^ "\n************** .debug_frame section: frame info ****************\n" + ^ pp_frame_info c cuh_default d.d_frame_info + ^ "\n************** .debug_line section: line number info ****************\n" + ^ pp_line_info d.d_line_info + + +(* TODO: don't use lists of bytes here! *) +let parse_dwarf c + (debug_info_section_body: byte_sequence) + (debug_abbrev_section_body: byte_sequence) + (debug_str_section_body: byte_sequence) + (debug_loc_section_body: byte_sequence) + (debug_ranges_section_body: byte_sequence) + (debug_frame_section_body: byte_sequence) + (debug_line_section_body: byte_sequence) + : dwarf= + + let pc_info = <|pc_bytes = debug_info_section_body; pc_offset = 0 |> in + + let compilation_units = + match parse_compilation_units c debug_str_section_body debug_abbrev_section_body pc_info with + | PR_fail s pc_info' -> Assert_extra.failwith ("parse_compilation_units: " ^ pp_parse_fail s pc_info') + | PR_success cus pc_info' -> cus + end in + + (*let _ = my_debug5 (pp_compilation_units c debug_str_section_body compilation_units) in*) + + +(* the DWARF4 spec doesn't seem to specify the address size used in the .debug_loc section, so we (hackishly) take it from the first compilation unit *) + let (cuh_default : compilation_unit_header) = let cu = myhead compilation_units in cu.cu_header in + + let pc_loc = <|pc_bytes = debug_loc_section_body; pc_offset = 0 |> in + + let loc = + match parse_location_list_list c cuh_default pc_loc with + | PR_fail s pc_info' -> Assert_extra.failwith ("parse_location_list: " ^ pp_parse_fail s pc_info') + | PR_success loc pc_loc' -> loc + end in + + let pc_ranges = <|pc_bytes = debug_ranges_section_body; pc_offset = 0 |> in + + let ranges = + match parse_range_list_list c cuh_default pc_ranges with + | PR_fail s pc_info' -> Assert_extra.failwith ("parse_range_list: " ^ pp_parse_fail s pc_info') + | PR_success r pc_loc' -> r + end in + + let pc_frame = <|pc_bytes = debug_frame_section_body; pc_offset = 0 |> in + + let fi = + (* let _ = my_debug5 ("debug_frame_section_body:\n" ^ ppbytes2 0 debug_frame_section_body) in *) + + match parse_frame_info c cuh_default pc_frame with + | PR_fail s pc_info' -> Assert_extra.failwith ("parse_frame_info: " ^ pp_parse_fail s pc_info') + | PR_success fi pc_loc' -> fi + end in + + let li = parse_line_number_infos c debug_str_section_body debug_line_section_body compilation_units in + + <| + d_endianness = c.endianness; + d_str = debug_str_section_body; + d_compilation_units = compilation_units; + d_type_units = []; + d_loc = loc; + d_ranges = ranges; + d_frame_info = fi; + d_line_info = li; + |> + +val extract_section_body : elf_file -> string -> bool -> p_context * sym_natural * byte_sequence +let extract_section_body (f:elf_file) (section_name:string) (strict: bool)= + let (en: Endianness.endianness) = + match f with + | ELF_File_32 f32 -> Elf_header.get_elf32_header_endianness f32.Elf_file.elf32_file_header + | ELF_File_64 f64 -> Elf_header.get_elf64_header_endianness f64.Elf_file.elf64_file_header + end in + let (c: p_context) = <| endianness = en |> in + match f with + | ELF_File_32 f32 -> + let sections = + List.filter + (fun x -> + x.Elf_interpreted_section.elf32_section_name_as_string = section_name + ) f32.elf32_file_interpreted_sections in + match sections with + | [section] -> + let section_addr = section.Elf_interpreted_section.elf32_section_addr in + let section_body = section.Elf_interpreted_section.elf32_section_body in + (* let _ = my_debug4 (section_name ^ (": \n" ^ (Elf_interpreted_section.string_of_elf32_interpreted_section section ^ "\n" + * ^ " body = " ^ ppbytes2 0 section_body ^ "\n"))) in *) + (c,section_addr,section_body) + | [] -> + if strict then + Assert_extra.failwith ("" ^ section_name ^ " section not present") + else + (c,0,Byte_sequence.empty) + | _ -> Assert_extra.failwith ("multiple " ^ section_name ^ " sections present") + end + + + | ELF_File_64 f64 -> + let sections = + List.filter + (fun x -> + x.Elf_interpreted_section.elf64_section_name_as_string = section_name + ) f64.elf64_file_interpreted_sections in + match sections with + | [section] -> + let section_addr = section.Elf_interpreted_section.elf64_section_addr in + let section_body = section.Elf_interpreted_section.elf64_section_body in + (c,section_addr,section_body) + | [] -> + if strict then + Assert_extra.failwith ("" ^ section_name ^ " section not present") + else + (c,0,Byte_sequence.empty) + | _ -> Assert_extra.failwith ("multiple " ^ section_name ^ " sections present") + end + end + +val extract_dwarf : elf_file -> maybe dwarf +let extract_dwarf f= + let (c, _, debug_info_section_body) = extract_section_body f ".debug_info" true in + let (c, _, debug_abbrev_section_body) = extract_section_body f ".debug_abbrev" false in + let (c, _, debug_str_section_body) = extract_section_body f ".debug_str" false in + let (c, _, debug_loc_section_body) = extract_section_body f ".debug_loc" false in + let (c, _, debug_ranges_section_body) = extract_section_body f ".debug_ranges" false in + let (c, _, debug_frame_section_body) = extract_section_body f ".debug_frame" false in + let (c, _, debug_line_section_body) = extract_section_body f ".debug_line" false in + + let d = parse_dwarf c debug_info_section_body debug_abbrev_section_body debug_str_section_body debug_loc_section_body debug_ranges_section_body debug_frame_section_body debug_line_section_body in + + Just d + +val extract_text : elf_file -> p_context * sym_natural * byte_sequence (* (p_context, elf32/64_section_addr, elf32/64_section_body) *) +let extract_text f= extract_section_body f ".text" true + + +(** ************************************************************ *) +(** ****** location evaluation ******************************** *) +(** ************************************************************ *) + + +(** pp of locations *) + +val pp_simple_location : simple_location -> string +let pp_simple_location sl= + match sl with + | SL_memory_address n -> pphex n + | SL_register n -> "reg" ^ show n + | SL_implicit bs -> "value: " ^ ppbytes bs + | SL_empty -> "" + end + +val pp_composite_location_piece : composite_location_piece -> string +let pp_composite_location_piece clp= + match clp with + | CLP_piece n sl -> "piece (" ^ show n ^ ") " ^ pp_simple_location sl + | CLP_bit_piece n1 n2 sl -> "bit_piece (" ^ show n1 ^ "," ^ show n2 ^ ") " ^ pp_simple_location sl + end + +val pp_single_location: single_location -> string +let pp_single_location sl= + match sl with + | SL_simple sl -> pp_simple_location sl + | SL_composite clps -> "composite: " ^ String.concat ", " (List.map pp_composite_location_piece clps) + end + + +(** evaluation of location expressions *) + +(* cf dwarflist, btw: https://fedorahosted.org/elfutils/wiki/DwarfLint?format=txt *) + +(* + +location description ::= +| single location description +| location list + +single location description ::= +| simple location description +| composite location description + +simple location description ::= +| memory location description : non-empty dwarf expr, value is address of all or part of object in memory +| register location description : single DW_OP_regN or DW_OP_regx, naming a register in which all the object is +| implicit location description : single DW_OP_implicit_value or a non-empty dwarf expr ending in DW_OP_stack_value, giving the value of all/part of object +| empty location description : an empty dwarf expr, indicating a part or all of an object that is not represented + +composite location description : a list of simple location descriptions, each followed by a DW_OP_piece or DW_OP_bitpiece + +(the simple location description can be a register location description: https://www.mail-archive.com/dwarf-discuss@lists.dwarfstd.org/msg00271.html) +(contradicting "A register location description must stand alone as the entire description of an object or a piece of an object.") + +location list entry : a list of address ranges (possibly overlapping), each with a single location description + +Dwarf expressions can include data-dependent control flow choices +(though we don't see that in the examples?), so we can't statically +determine which kind of single location description or simple location +description we have. We can distinguish: + +- empty -> simple.empty +- DW_OP_regN/DW_OP_regx -> simple.register +- DW_OP_implicit_value -> simple.implicit +- any of those followed by DW_OP_piece or DW_OP_bitpiece, perhaps followed by more composite parts -> composite part :: composite + +otherwise run to the end, or a DW_OP_stack_value at the end, or to +anything (except a DO_OP_regN/DW_OP_regx) followed by a +DW_OP_piece/DW_OP_bitpiece. Pfeh. + + +actually used in our examples (ignoring GNU extentions): + +DW_OP_addr literal +DW_OP_lit1 literal +DW_OP_const4u literal + +DW_OP_breg3 (r3) read register value and add offset + +DW_OP_and bitwise and +DW_OP_plus addition (mod whatever) + +DW_OP_deref_size +DW_OP_fbreg evaluate location description from DW_AT_frame_base attribute of the current function (which is DW_OP_call_frame_cfa in our examples) and add offset + +DW_OP_implicit_value the argument block is the actual value (not location) of the entity in question +DW_OP_stack_value use the value at top of stack as the actual value (not location) of the entity in question + +DW_OP_reg0 (r0)) read register value + +DW_OP_call_frame_cfa go off to 6.4 and pull info out of .debug_frame (possibly involving other location expressions) + +*) + + + +let initial_state= + <| + s_stack = []; + s_value = SL_empty; + s_location_pieces = []; +|> + +(* the main location expression evaluation function *) + +(* location expression evaluation is basically a recursive function +down a list of operations, maintaining an operation_stack (a list of +naturals representing machine-address-size words), the current +simple_location, and a list of any composite_location_piece's +accumulated so far *) + + + +let arithmetic_context_of_cuh cuh= + match cuh.cuh_address_size with + | 8 -> + <| + ac_bitwidth = 64; + ac_half = naturalPow 2 32; + ac_all = naturalPow 2 64; + ac_max = (naturalPow 2 64) - 1; + |> + | 4 -> + <| + ac_bitwidth = 32; + ac_half = naturalPow 2 16; + ac_all = naturalPow 2 32; + ac_max = (naturalPow 2 32) - 1; + |> + | _ -> Assert_extra.failwith "arithmetic_context_of_cuh given non-4/8 size" + end + +let find_cfa_table_row_for_pc (evaluated_frame_info: evaluated_frame_info) (pc: sym_natural) : cfa_table_row= + match + myfind + (fun (fde,rows) -> pc >= fde.fde_initial_location_address && pc < fde.fde_initial_location_address + fde.fde_address_range) + evaluated_frame_info + with + | Just (fde,rows) -> + match myfind (fun row -> pc >= row.ctr_loc) rows with + | Just row -> row + | Nothing -> Assert_extra.failwith "evaluate_cfa: no matchine row" + end + | Nothing -> Assert_extra.failwith "evaluate_cfa: no fde encloding pc" + end + + +let rec evaluate_operation_list (c:p_context) (dloc: location_list_list) (evaluated_frame_info: evaluated_frame_info) (cuh: compilation_unit_header) (ac: arithmetic_context) (ev: evaluation_context) (mfbloc: maybe attribute_value) (pc: sym_natural) (s: state) (ops: list operation) : error single_location= + + let push_memory_address v vs'= Success <| s with s_stack = v :: vs'; s_value = SL_memory_address v |> in + + let push_memory_address_maybe (mv: maybe sym_natural) vs' (err:string) op= + match mv with + | Just v -> push_memory_address v vs' + | Nothing -> Fail (err ^ pp_operation op) + end in + + let bregxi r i= + match ev.read_register r with + | RRR_result v -> push_memory_address (partialNaturalFromInteger ((integerFromSymNatural v+i) mod (integerFromSymNatural ac.ac_all))) s.s_stack + | RRR_not_currently_available -> Fail "RRR_not_currently_available" + | RRR_bad_register_number -> Fail ("RRR_bad_register_number " ^ show r) + end in + + let deref_size n= + match s.s_stack with + | v::vs' -> + match ev.read_memory v n with + | MRR_result v' -> push_memory_address v' vs' + | MRR_not_currently_available -> Fail "MRR_not_currently_available" + | MRR_bad_address -> Fail "MRR_bad_address" + end + | _ -> Fail "OpSem unary not given an element on stack" + end in + + match ops with + | [] -> + if s.s_location_pieces = [] then + Success (SL_simple s.s_value) + else if s.s_value = SL_empty then + Success (SL_composite s.s_location_pieces) + else + (* unclear what's supposed to happen in this case *) + Fail "unfinished part of composite expression" + + | op::ops' -> + let es' = + match (op.op_semantics, op.op_argument_values) with + | (OpSem_nop, []) -> + Success s + | (OpSem_lit, [OAV_natural n]) -> + push_memory_address n s.s_stack + | (OpSem_lit, [OAV_integer i]) -> + push_memory_address (partialTwosComplementNaturalFromInteger i ac.ac_half (integerFromSymNatural ac.ac_all)) s.s_stack + | (OpSem_stack f, []) -> + match f ac s.s_stack op.op_argument_values with + | Just stack' -> + let value' : simple_location = match stack' with [] -> SL_empty | v'::_ -> SL_memory_address v' end in + Success <| s with s_stack = stack'; s_value = value' |> + | Nothing -> Fail "OpSem_stack failed" + end + | (OpSem_not_supported, []) -> + Fail ("OpSem_not_supported: " ^ pp_operation op) + | (OpSem_binary f, []) -> + match s.s_stack with + | v1::v2::vs' -> push_memory_address_maybe (f ac v1 v2) vs' "OpSem_binary error: " op + | _ -> Fail "OpSem binary not given two elements on stack" + end + | (OpSem_unary f, []) -> + match s.s_stack with + | v1::vs' -> push_memory_address_maybe (f ac v1) vs' "OpSem_unary error: " op + | _ -> Fail "OpSem unary not given an element on stack" + end + | (OpSem_opcode_lit base, []) -> + if op.op_code >= base && op.op_code < base + 32 then + push_memory_address (op.op_code - base) s.s_stack + else + Fail "OpSem_opcode_lit opcode not within [base,base+32)" + | (OpSem_reg, []) -> + (* TODO: unclear whether this should push the register id or not *) + let r = op.op_code - vDW_OP_reg0 in + Success <| s with s_stack = r :: s.s_stack; s_value = SL_register r |> + | (OpSem_breg, [OAV_integer i]) -> + let r = op.op_code - vDW_OP_breg0 in + bregxi r i + | (OpSem_bregx, [OAV_natural r; OAV_integer i]) -> + bregxi r i + | (OpSem_deref, []) -> + deref_size cuh.cuh_address_size + | (OpSem_deref_size, [OAV_natural n]) -> + deref_size n + | (OpSem_fbreg, [OAV_integer i]) -> + match mfbloc with + | Just fbloc -> + (*let _ = my_debug5 ("OpSem_fbreg (" ^ show i ^ ")\n") in*) + match evaluate_location_description c dloc evaluated_frame_info cuh ac ev (*mfbloc*)Nothing pc fbloc with + (* what to do if the recursive call also uses fbreg? for now assume that's not allowed *) + | Success l -> + match l with + | SL_simple (SL_memory_address a) -> + (*let _ = my_debug5 ("OpSem_fbreg: a = "^ pphex a ^ "\n") in*) + let vi = ((integerFromSymNatural a) + i) mod (integerFromSymNatural ac.ac_all) in + (*let _ = my_debug5 ("OpSem_fbreg: v = "^ show vi ^ "\n") in*) + let v = partialNaturalFromInteger vi (*ac.ac_half (integerFromSymNatural ac.ac_all)*) in + push_memory_address v s.s_stack + | _ -> + Fail "OpSem_fbreg got a non-SL_simple (SL_memory_address _) result" + (* "The DW_OP_fbreg operation provides a signed LEB128 + offset from the address specified by the location + description in the DW_AT_frame_base attribute of the + current function. " + - so what to do if the location description returns a non-memory-address location? *) + end + | Fail e -> + Fail ("OpSem_fbreg failure: " ^ e) + end + | Nothing -> + Fail "OpSem_fbreg: no frame base location description given" + end + + | (OpSem_piece, [OAV_natural size_bytes]) -> + let piece = CLP_piece size_bytes s.s_value in + (* we allow a piece (or bit_piece) to be any simple_location, including implicit and stack values. Unclear if this is intended, esp. the latter *) + let stack' = [] in + let value' = SL_empty in + Success <| s_stack = stack'; s_value = value'; s_location_pieces = s.s_location_pieces ++ [piece] |> + | (OpSem_bit_piece, [OAV_natural size_bits; OAV_natural offset_bits]) -> + let piece = CLP_bit_piece size_bits offset_bits s.s_value in + let stack' = [] in + let value' = SL_empty in + Success <| s_stack = stack'; s_value = value'; s_location_pieces = s.s_location_pieces ++ [piece] |> + | (OpSem_implicit_value, [OAV_block size bs]) -> + let stack' = [] in + let value' = SL_implicit bs in + Success <| s with s_stack = stack'; s_value = value' |> + | (OpSem_stack_value, []) -> + (* "The DW_OP_stack_value operation terminates the expression." - does + this refer to just the subexpression, ie allowing a stack value to be + a piece of a composite location, or necessarily the whole expression? + Why does DW_OP_stack_value have this clause while DW_OP_implicit_value + does not? *) + (* why doesn't DW_OP_stack_value have a size argument? *) + match s.s_stack with + | v::vs' -> + let stack' = [] in + let value' = SL_implicit (bytes_of_natural c.endianness cuh.cuh_address_size v) in + Success <| s with s_stack = stack'; s_value = value' |> + + | _ -> Fail "OpSem_stack_value not given an element on stack" + end + | (OpSem_call_frame_cfa, []) -> + let row = find_cfa_table_row_for_pc evaluated_frame_info pc in + match row.ctr_cfa with + | CR_undefined -> + Assert_extra.failwith "evaluate_cfa of CR_undefined" + | CR_register r i -> + bregxi r i (* same behaviour as an OpSem_bregx *) + | CR_expression bs -> + Assert_extra.failwith "CR_expression" + (*TODO: fix result type - not this evaluate_location_description_bytes c dloc evaluated_frame_info cuh ac ev mfbloc pc bs*) + (* TODO: restrict allowed OpSem_* in that recursive call *) + end + | (_, _) -> + Fail ("bad OpSem invocation: op=" ^ pp_operation op ^ " arguments=" ^ String.concat "" (List.map pp_operation_argument_value op.op_argument_values)) + end + in + match es' with + | Success s' -> + evaluate_operation_list c dloc evaluated_frame_info cuh ac ev mfbloc pc s' ops' + | Fail e -> + Fail e + end + end + +and evaluate_location_description_bytes (c:p_context) (dloc: location_list_list) (evaluated_frame_info: evaluated_frame_info) (cuh: compilation_unit_header) (ac: arithmetic_context) (ev: evaluation_context) (mfbloc: maybe attribute_value) (pc: sym_natural) (bs: byte_sequence) : error single_location= + let parse_context = <|pc_bytes = bs; pc_offset = 0 |> in + match parse_operations c cuh parse_context with + | PR_fail s pc' -> Fail ("evaluate_location_description_bytes: parse_operations fail: " ^ pp_parse_fail s pc') + | PR_success ops pc' -> + if Byte_sequence.length pc'.pc_bytes <> 0 then + Fail "evaluate_location_description_bytes: extra non-parsed bytes" + else + evaluate_operation_list c dloc evaluated_frame_info cuh ac ev mfbloc pc initial_state ops + end + +and evaluate_location_description (c:p_context) (dloc: location_list_list) (evaluated_frame_info: evaluated_frame_info) (cuh: compilation_unit_header) (ac: arithmetic_context) (ev: evaluation_context) (mfbloc: maybe attribute_value) (pc: sym_natural) (loc:attribute_value) : error single_location= + match loc with + | AV_exprloc n bs -> + evaluate_location_description_bytes c dloc evaluated_frame_info cuh ac ev mfbloc pc bs + | AV_block n bs -> + evaluate_location_description_bytes c dloc evaluated_frame_info cuh ac ev mfbloc pc bs + | AV_sec_offset n -> + let location_list = find_location_list dloc n in + let (offset,(llis:list location_list_item)) = location_list in + let f (lli:location_list_item) : maybe single_location_description= + match lli with + | LLI_lle lle -> + if pc >= lle.lle_beginning_address_offset && pc < lle.lle_ending_address_offset then Just lle.lle_single_location_description else Nothing + | LLI_base _ -> + Nothing (* TODO: either refactor to do offset during parsing or update base offsets here. Should refactor to use "interpreted". *) + end in + match myfindmaybe f llis with + | Just bs -> + evaluate_location_description_bytes c dloc evaluated_frame_info cuh ac ev mfbloc pc bs + | Nothing -> + Fail "evaluate_location_description didn't find pc in location list ranges" + end + | _ -> Fail "evaluate_location_description av_location not understood" + end + + + + + +(** ************************************************************ *) +(** **** evaluation of frame information ********************** *) +(** ************************************************************ *) + +(** register maps *) + +val rrp_update : register_rule_map -> cfa_register -> register_rule -> register_rule_map +let rrp_update rrp r rr= (r,rr)::rrp + +val rrp_lookup : cfa_register -> register_rule_map -> register_rule +let rrp_lookup r rrp= + match List.lookup r rrp with + | Just rr -> rr + | Nothing -> RR_undefined + end + +val rrp_empty : register_rule_map +let rrp_empty= [] + + + +(** pp of evaluated cfa information from .debug_frame *) +(* readelf --debug-dump=frames-interp test/a.out + +Contents of the .eh_frame section: + +00000000 00000014 00000000 CIE "zR" cf=1 df=-8 ra=16 + LOC CFA ra +0000000000000000 rsp+8 c-8 + +00000018 00000024 0000001c FDE cie=00000000 pc=004003b0..004003d0 + LOC CFA ra +00000000004003b0 rsp+16 c-8 +00000000004003b6 rsp+24 c-8 +00000000004003c0 exp c-8 + +00000040 0000001c 00000044 FDE cie=00000000 pc=004004b4..004004ba + LOC CFA rbp ra +00000000004004b4 rsp+8 u c-8 +00000000004004b5 rsp+16 c-16 c-8 +00000000004004b8 rbp+16 c-16 c-8 +00000000004004b9 rsp+8 c-16 c-8 + +00000060 00000024 00000064 FDE cie=00000000 pc=004004c0..00400549 + LOC CFA rbx rbp r12 r13 r14 r15 ra +00000000004004c0 rsp+8 u u u u u u c-8 +00000000004004d1 rsp+8 u c-48 c-40 u u u c-8 +00000000004004f0 rsp+64 c-56 c-48 c-40 c-32 c-24 c-16 c-8 +0000000000400548 rsp+8 c-56 c-48 c-40 c-32 c-24 c-16 c-8 + +00000088 00000014 0000008c FDE cie=00000000 pc=00400550..00400552 + LOC CFA ra +0000000000400550 rsp+8 c-8 + +000000a0 ZERO terminator +*) + + + +val mytoList : forall 'a. SetType 'a => set 'a -> list 'a +declare ocaml target_rep function mytoList = `Pset.elements` + +let register_footprint_rrp (rrp: register_rule_map) : set cfa_register= + Set.fromList (List.map Tuple.fst rrp) + +let register_footprint (rows: list cfa_table_row) : list cfa_register= + mytoList (bigunionListMap (fun row -> register_footprint_rrp row.ctr_regs) rows) + + +val max_lengths : list (list string) -> list sym_natural +let rec max_lengths xss= + match xss with + | [] -> Assert_extra.failwith "max_lengths" + | xs::xss' -> + let lens = List.map (fun x -> naturalFromNat (String.stringLength x)) xs in + if xss' = [] then lens + else + let lens' = max_lengths xss' in + let z = List.zip lens lens' in + let lens'' = List.map (fun (l1,l2)-> max l1 l2) z in + lens'' + end + +let rec pad_row xs lens= + match (xs,lens) with + | ([],[]) -> [] + | ([x],[len]) -> [x] + | (x::((_::_) as xs'), len::((_::_) as lens')) -> right_space_padded_to len x :: pad_row xs' lens' + end + +let pad_rows (xss : list (list string)) : string= + match xss with + | [] -> "" + | _ -> + let lens = max_lengths xss in + String.concat "" (List.map (fun xs -> String.concat " " (pad_row xs lens) ^ "\n") xss) + end + +let pp_evaluated_fde (fde, (rows: list cfa_table_row)) : string= + let regs = register_footprint rows in + let header : list string = "LOC" :: "CFA" :: List.map pp_cfa_register regs in + let ppd_rows : list (list string) = + List.map (fun row -> pphex row.ctr_loc :: pp_cfa_rule row.ctr_cfa :: List.map (fun r -> pp_register_rule (rrp_lookup r row.ctr_regs)) regs) rows in + pad_rows (header :: ppd_rows) + +let semi_pp_evaluated_fde (fde, (rows: list cfa_table_row)) : list (sym_natural (*address*) * string (*cfa*) * list (string*string) (*register rules*) )= + let regs = register_footprint rows in + let ppd_rows = + List.map + (fun row -> + (row.ctr_loc, + pp_cfa_rule row.ctr_cfa, + List.map (fun r -> (pp_cfa_register r, pp_register_rule (rrp_lookup r row.ctr_regs))) regs)) + rows in + ppd_rows + +val semi_pp_evaluated_frame_info : evaluated_frame_info -> list (sym_natural (*address*) * string (*cfa*) * list (string*string) (*register rules*) ) +let semi_pp_evaluated_frame_info efi= + List.concat (List.map semi_pp_evaluated_fde efi) + + + +(** evaluation of cfa information from .debug_frame *) + +let evaluate_call_frame_instruction (fi: frame_info) (cie: cie) (state: cfa_state) (cfi: call_frame_instruction) : cfa_state= + + let create_row (loc: sym_natural)= + let row = <| state.cs_current_row with ctr_loc = loc |> in + <| state with cs_current_row = row; cs_previous_rows = state.cs_current_row::state.cs_previous_rows |> in + + let update_cfa (cr:cfa_rule)= + let row = <| state.cs_current_row with ctr_cfa = cr |> in + <| state with cs_current_row = row |> in + + let update_reg r rr= + let row = <| state.cs_current_row with ctr_regs = rrp_update state.cs_current_row.ctr_regs r rr |> in + <| state with cs_current_row = row |> in + + match cfi with + (* Row Creation Instructions *) + | DW_CFA_set_loc a -> + create_row a + | DW_CFA_advance_loc d -> + create_row (state.cs_current_row.ctr_loc + d * cie.cie_code_alignment_factor) + | DW_CFA_advance_loc1 d -> + create_row (state.cs_current_row.ctr_loc + d * cie.cie_code_alignment_factor) + | DW_CFA_advance_loc2 d -> + create_row (state.cs_current_row.ctr_loc + d * cie.cie_code_alignment_factor) + | DW_CFA_advance_loc4 d -> + create_row (state.cs_current_row.ctr_loc + d * cie.cie_code_alignment_factor) + + (* CFA Definition Instructions *) + | DW_CFA_def_cfa r n -> + update_cfa (CR_register r (integerFromSymNatural n)) + | DW_CFA_def_cfa_sf r i -> + update_cfa (CR_register r (i * cie.cie_data_alignment_factor)) + | DW_CFA_def_cfa_register r -> + match state.cs_current_row.ctr_cfa with + | CR_register r' i -> + update_cfa (CR_register r i) + | CR_undefined -> + (* FIXME: this is to handle a bug in riscv64-gcc. + gcc generates "DW_CFA_def_cfa_register: r2 (sp)" as the first instruction. + Dwarf5 documentation seems to suggest this is not valid. + We think what gcc meant to generate is "DW_CFA_def_cfa: r2 (sp) ofs 0" *) + update_cfa (CR_register r 0) + | CR_expression _ -> + Assert_extra.failwith "DW_CFA_def_cfa_register: current rule is CR_expression" + end + | DW_CFA_def_cfa_offset n -> + match state.cs_current_row.ctr_cfa with + | CR_register r i -> + update_cfa (CR_register r (integerFromSymNatural n)) + | _ -> Assert_extra.failwith "DW_CFA_def_cfa_offset: current rule is not CR_register" + end + | DW_CFA_def_cfa_offset_sf i -> + match state.cs_current_row.ctr_cfa with + | CR_register r i' -> + update_cfa (CR_register r (i' * cie.cie_data_alignment_factor)) + | _ -> Assert_extra.failwith "DW_CFA_def_cfa_offset_sf: current rule is not CR_register" + end + | DW_CFA_def_cfa_expression b -> + update_cfa (CR_expression b) + + (* Register Rule Instrutions *) + | DW_CFA_undefined r -> + update_reg r (RR_undefined) + | DW_CFA_same_value r -> + update_reg r (RR_same_value) + | DW_CFA_offset r n -> + update_reg r (RR_offset ((integerFromSymNatural n) * cie.cie_data_alignment_factor)) + | DW_CFA_offset_extended r n -> + update_reg r (RR_offset ((integerFromSymNatural n) * cie.cie_data_alignment_factor)) + | DW_CFA_offset_extended_sf r i -> + update_reg r (RR_offset (i * cie.cie_data_alignment_factor)) + | DW_CFA_val_offset r n -> + update_reg r (RR_val_offset ((integerFromSymNatural n) * cie.cie_data_alignment_factor)) + | DW_CFA_val_offset_sf r i -> + update_reg r (RR_val_offset (i * cie.cie_data_alignment_factor)) + | DW_CFA_register r1 r2 -> + update_reg r1 (RR_register r2) + | DW_CFA_expression r b -> + update_reg r (RR_expression b) + | DW_CFA_val_expression r b -> + update_reg r (RR_val_expression b) + | DW_CFA_restore r -> + update_reg r (rrp_lookup r state.cs_initial_instructions_row.ctr_regs) +(* RR_undefined if the lookup fails? *) + | DW_CFA_restore_extended r -> + update_reg r (rrp_lookup r state.cs_initial_instructions_row.ctr_regs) + +(* Row State Instructions *) +(* do these also push and restore the CFA rule? *) + | DW_CFA_remember_state -> + <| state with cs_row_stack = state.cs_current_row :: state.cs_row_stack |> + | DW_CFA_restore_state -> + match state.cs_row_stack with + | r::rs -> <| state with cs_current_row = r; cs_row_stack = rs |> + | [] -> Assert_extra.failwith "DW_CFA_restore_state: empty row stack" + end +(* Padding Instruction *) + | DW_CFA_nop -> + state + +(* DW_CFA_AARCH64_negate_ra_state Instruction *) + | DW_CFA_AARCH64_negate_ra_state -> + state + +(* Unknown *) + | DW_CFA_unknown b -> + Assert_extra.failwith ("evaluate_call_frame_instruction: DW_CFA_unknown " ^ show b) + + end + + + +let rec evaluate_call_frame_instructions (fi: frame_info) (cie: cie) (state: cfa_state) (cfis: list call_frame_instruction) : cfa_state= + match cfis with + | [] -> state + | cfi::cfis' -> + let state' = evaluate_call_frame_instruction fi cie state cfi in + evaluate_call_frame_instructions fi cie state' cfis' + end + + +let evaluate_fde (fi: frame_info) (fde:fde) : list cfa_table_row= + let cie = find_cie fi fde.fde_cie_pointer in + let final_location = fde.fde_initial_location_address + fde.fde_address_range in + let initial_cfa_state = + let initial_row = + <| + ctr_loc = fde.fde_initial_location_address; + ctr_cfa = CR_undefined; + ctr_regs = rrp_empty; + |> in + <| + cs_current_row = initial_row; + cs_previous_rows = []; + cs_initial_instructions_row = initial_row; + cs_row_stack = []; + |> + in + let state' = + evaluate_call_frame_instructions fi cie initial_cfa_state cie.cie_initial_instructions in + let initial_row' = state'.cs_current_row in + let state'' = <| initial_cfa_state with cs_current_row = initial_row'; cs_initial_instructions_row = initial_row' |> in + let state''' = + evaluate_call_frame_instructions fi cie (*final_location*) state'' fde.fde_instructions in + List.reverse (state'''.cs_current_row:: state'''.cs_previous_rows) + + + +val evaluate_frame_info : dwarf -> evaluated_frame_info +let evaluate_frame_info (d: dwarf) : evaluated_frame_info= + List.mapMaybe (fun fie -> match fie with FIE_fde fde -> Just (fde, (evaluate_fde d.d_frame_info fde)) | FIE_cie _ -> Nothing end) d.d_frame_info + +let pp_evaluated_frame_info (efi: evaluated_frame_info)= + String.concat "\n" (List.map pp_evaluated_fde efi) + + + + +(** ************************************************************ *) +(** ** pp of type info *) +(** ************************************************************ *) + +(* partial analysis and pp of type info - incomplete, but enough for some C code *) + +(* analyse top level of C type structure, without recursing into type subterms *) +let strict s x= + match x with + | Just y -> y + | Nothing -> + Assert_extra.failwith ("analyse_type_info_die strict failure on \n" ^ s () + ^ "\n") + end + + +let analyse_type_info_top c (d: dwarf) (r:bool(*recurse into members*)) (cupdie: cupdie) : c_type_top cupdie= + let (cu,parents,die) = cupdie in + let mname = find_name_of_die d.d_str die in + let mtyp = find_DW_AT_type_of_die c d cu d.d_str die in + let s ()= pp_die c cu.cu_header d.d_str true 0 false die in + + if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_base_type" then + let encoding = + let n = strict s (find_natural_attribute_value_of_die c "DW_AT_encoding" die) in + if not(List.any (fun (s,n')->n=n') base_type_attribute_encodings) then strict s Nothing else n in + (* TODO: handle user encodings correctly *) + let mbyte_size = find_natural_attribute_value_of_die c "DW_AT_byte_size" die in + CT_base cupdie (strict s mname) encoding mbyte_size + + else if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_pointer_type" then + CT_pointer cupdie mtyp + + else if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_const_type" then + CT_const cupdie mtyp + + else if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_volatile_type" then +(* CT_volatile cupdie (strict s mtyp')*) + (* TODO: this is a temporary hack, while we figure out what DW_TAG_volatile without a DW_AT_type is supposed to mean *) + match mtyp with + | Just typ -> CT_volatile cupdie typ + | Nothing -> CT_missing cupdie + end + + + else if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_restrict_type" then + CT_restrict cupdie (strict s mtyp) + + else if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_typedef" then + let decl = + <| + decl_file = Nothing; (* TODO *) + decl_line = Nothing; (* TODO *) + |> in + CT_typedef cupdie (strict s mname) (strict s mtyp) decl + + else if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_array_type" then + let dims = + let subranges = List.filter (fun die' -> die'.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_subrange_type") die.die_children in + List.map + (fun die' -> + (*WAS: let mcount = find_natural_attribute_value_of_die c "DW_AT_count" die' in*) + let mcount = + match find_attribute_value "DW_AT_count" die' with + | Nothing -> Nothing + | Just av -> + match maybe_natural_of_constant_attribute_value die' c av with + | Nothing -> Nothing + (* DWARF seems to sometimes use an AV_ref* attribute value for DW_AT_count, referring to a variable die, for a VLA length. In this case for the moment we will just forget the length information, which is what this clause does *) + | Just n -> Just n + end + end in + let msubrange_type = find_DW_AT_type_of_die c d cu d.d_str die' in + (mcount, msubrange_type)) + subranges in + CT_array cupdie (strict s mtyp) dims + + else if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_structure_type" || die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_union_type" then + let atk = if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_structure_type" then Atk_structure else Atk_union in + let mbyte_size = find_natural_attribute_value_of_die c "DW_AT_byte_size" die in + let decl = + (<| + decl_file = Nothing; (* TODO *) + decl_line = Nothing; (* TODO *) + |>) in + + let members = + if r then + let members_raw = List.filter (fun die' -> die'.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_member") die.die_children in + Just (List.map + (fun die' -> + let cupdie' = (cu,die::parents,die') in + let mname' = find_name_of_die d.d_str die' in + let typ' = strict s (find_DW_AT_type_of_die c d cu d.d_str die') in + let mdata_member_location' = + match atk with + | Atk_structure -> Just (strict s (find_natural_attribute_value_of_die c "DW_AT_data_member_location" die')) + | Atk_union -> (find_natural_attribute_value_of_die c "DW_AT_data_member_location" die') + end in + (cupdie',mname',typ',mdata_member_location')) + members_raw) + else + Nothing in + + CT_struct_union cupdie atk mname mbyte_size decl members + + else if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_enumeration_type" then + let mbyte_size = find_natural_attribute_value_of_die c "DW_AT_byte_size" die in + let decl = + <| + decl_file = Nothing; (* TODO *) + decl_line = Nothing; (* TODO *) + |> in + let members = + if r then + let members_raw = List.filter (fun die' -> die'.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_enumerator") die.die_children in + Just (List.map + (fun die' -> + let cupdie' = (cu,die::parents,die') in + let mname' = find_name_of_die d.d_str die' in + (*let _ = my_debug5 (s ()) in *) + let const_value = strict s (find_integer_attribute_value_of_die c "DW_AT_const_value" die') in (*let _ = my_debug5 "ok" in*) + (cupdie',mname',const_value)) + members_raw) + else + Nothing + in + + CT_enumeration cupdie mname mtyp mbyte_size decl members + + else if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_subroutine_type" then + + (* let prototyped = strict s (find_flag_attribute_value_of_die "DW_AT_prototyped" die) in*) + let prototyped = find_flag_attribute_value_of_die_default_false "DW_AT_prototyped" die in + + let mresult_type = mtyp in + + let parameter_types = + let parameter_types_raw = List.filter (fun die' -> die'.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_formal_parameter") die.die_children in + (List.map + (fun die' -> + let cupdie' = (cu,die::parents,die') in + let mname' = find_name_of_die d.d_str die' in + let typ' = strict s (find_DW_AT_type_of_die c d cu d.d_str die') in + typ') + parameter_types_raw) in + + let (variable_parameter_list: bool) = List.any (fun die' -> die'.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_unspecified_parameters") die.die_children in + + CT_subroutine cupdie prototyped mresult_type parameter_types variable_parameter_list + + else + + Assert_extra.failwith ("analyse_type_info_top didn't recognise tag: " ^ pphex die.die_abbreviation_declaration.ad_tag ^ " for DIE " ^ pp_cupdie3 cupdie) + + +let rec analyse_type_info_deep (d: dwarf) (r:bool(*recurse_into_members*)) cupdie : c_type= + let c = p_context_of_d d in + let (cu,parents,die) = cupdie in + let (typ:c_type_top cupdie) = analyse_type_info_top c (d: dwarf) r cupdie in + match typ with + | CT_missing cupdie -> CT (CT_missing cupdie) + | CT_base cupdie name encoding mbyte_size -> CT (CT_base cupdie name encoding mbyte_size) + | CT_pointer cupdie mtyp' -> CT (CT_pointer cupdie (Maybe.map (analyse_type_info_deep d r) mtyp')) + | CT_const cupdie mtyp' -> CT (CT_const cupdie (Maybe.map (analyse_type_info_deep d r) mtyp')) + | CT_volatile cupdie typ' -> CT (CT_volatile cupdie (analyse_type_info_deep d r typ')) + | CT_restrict cupdie typ' -> CT (CT_restrict cupdie (analyse_type_info_deep d r typ')) + | CT_typedef cupdie name typ' decl -> CT (CT_typedef cupdie name (analyse_type_info_deep d r typ') decl) + | CT_array cupdie typ' dims -> CT (CT_array cupdie (analyse_type_info_deep d r typ') + (List.map (fun (mcount,msubrange_typ) -> (mcount, (Maybe.map (analyse_type_info_deep d r) msubrange_typ))) dims)) + | CT_struct_union cupdie atk mname mbyte_size decl mmembers -> + CT (CT_struct_union cupdie atk mname mbyte_size decl (Maybe.map (fun members -> (List.map (fun ((cupdie,mname,typ,mdata_member_location) as am) -> (cupdie,mname,(analyse_type_info_deep d false typ),mdata_member_location))members)) mmembers)) + | CT_enumeration cupdie mname mtyp' mbyte_size decl mmembers -> + CT(CT_enumeration cupdie mname (Maybe.map (analyse_type_info_deep d r) mtyp') mbyte_size decl mmembers) + | CT_subroutine cupdie prototyped mresult_type parameter_types variable_parameter_list -> + CT (CT_subroutine cupdie prototyped (Maybe.map (analyse_type_info_deep d r) mresult_type) + (List.map (fun typ -> analyse_type_info_deep d r typ) parameter_types) variable_parameter_list) + end + +let find_DW_AT_type_of_die_deep d cupdie : maybe c_type= + let c = p_context_of_d d in + let (cu,parents,die) = cupdie in + match find_reference_attribute_of_die c d cu d.d_str "DW_AT_type" die with + | Nothing -> Nothing + | Just cupdie' -> + Just (analyse_type_info_deep d false cupdie') + end + +let find_DW_AT_type_of_die_deep_using_abstract_origin d cupdie : maybe c_type= + let c = p_context_of_d d in + let (cu,parents,die) = cupdie in + match find_reference_attribute_using_abstract_origin c d cu d.d_str "DW_AT_type" die with + | Nothing -> Nothing + | Just cupdie' -> + Just (analyse_type_info_deep d false cupdie') + end + + +(* analyse and pp C type structure, but without going into the definitions of struct_union or enumeration types *) +let pp_struct_union_type_kind atk= + match atk with + | Atk_structure -> "struct" + | Atk_union -> "union" + end + +let pp_mbyte_size mbyte_size= "size:" ^ match mbyte_size with | Just n -> show n | Nothing -> "?" end + +(* pp the top-level structure of a C type, omitting struct_union-type and enum member definitions*) +let pp_type_info_top (ppa:'a->string) (typ:c_type_top 'a) : string= + match typ with + | CT_missing cupdie -> "missing at " ^ pp_cupdie cupdie + | CT_base cupdie name encoding mbyte_size -> + name ^ " (base type, " ^ match lookup_aB_a encoding base_type_attribute_encodings with Just s -> s | Nothing -> show encoding end ^ " " ^ pp_mbyte_size mbyte_size ^ ")" + | CT_pointer cupdie mtyp' -> "pointer(" ^ match mtyp' with | Just typ' -> ppa typ' | Nothing -> "no type" end ^ ")" + | CT_const cupdie mtyp' -> "const(" ^ match mtyp' with Just typ'->ppa typ' | Nothing -> "no type" end ^ ")" + | CT_volatile cupdie typ' -> "volatile(" ^ ppa typ' ^ ")" + | CT_restrict cupdie typ' -> "restrict(" ^ ppa typ' ^ ")" + | CT_typedef cupdie name typ' decl -> "typedef("^name^"="^ppa typ' ^ ")" + | CT_array cupdie typ' dims -> + ppa typ' ^ String.concat "" (List.map (fun (mcount,msubrange_typ) -> "["^match mcount with | Just count -> show count | Nothing -> "no count" end ^"]") dims) + | CT_struct_union cupdie atk mname mbyte_size decl mmembers -> pp_struct_union_type_kind atk ^ " " ^ (match mname with | Just s -> s | Nothing -> "noname" end) ^ pp_cupdie cupdie + | CT_enumeration cupdie mname mtyp' mbyte_size decl mmembers -> "enum" ^ " " ^ (match mname with | Just s -> s | Nothing -> "noname" end) ^ pp_cupdie cupdie + | CT_subroutine cupdie prototyped mresult_type parameter_types variable_parameter_list -> + "subroutine(" ^ (if prototyped then "prototyped" else "not-prototyped") ^ " " ^ (match mresult_type with Nothing -> "no type" | Just result_type -> ppa result_type end) ^ "(" ^ String.concat "," ((List.map ppa parameter_types) ++ (if variable_parameter_list then ["..."] else [])) ^ ")" + end + + +let rec pp_type_info_deep (ctyp:c_type) : string= + let ppa = pp_type_info_deep in + match ctyp with + | CT typ -> + pp_type_info_top ppa typ + end + +let rec pp_type_info_die c (d: dwarf) cupdie : string= + let (typ:c_type_top cupdie) = analyse_type_info_top c (d: dwarf) false cupdie in + let ppa = pp_type_info_die c d in + pp_type_info_top ppa typ + + +let pp_struct_union_type_member c d (am:struct_union_member cupdie) : list string= + let (cupdie,mname,typ,mdata_member_location) = am in + [ " "; + (match mname with | Just s -> s | Nothing -> "noname" end); + " @ " ^ (match mdata_member_location with Nothing -> "nodatamemberlocation" | Just data_member_location -> show data_member_location end); + " : " ^ pp_type_info_die c d typ + ] + +let pp_struct_union_type_defn c d cupdie= + let (typ:c_type_top cupdie) = analyse_type_info_top c (d: dwarf) true cupdie in + match typ with + | CT_struct_union cupdie atk mname mbyte_size decl mmembers -> + (match mname with | Just s -> s | Nothing -> "noname" end) + ^ " " ^ pp_cupdie cupdie + ^ " " ^ pp_mbyte_size mbyte_size ^ "\n" + ^ pad_rows (match mmembers with Just members -> (List.map (pp_struct_union_type_member c d) members) | Nothing -> [] end) + | _ -> + Assert_extra.failwith "pp_struct_union_type_defn called on non-struct_union" + end + + +let pp_struct_union_type_member' (am:struct_union_member c_type) : list string= + let (cupdie,mname,ctyp,mdata_member_location) = am in + [ " "; + (match mname with | Just s -> s | Nothing -> "noname" end); + " @ " ^ (match mdata_member_location with Nothing -> "nodatamemberlocation" | Just data_member_location -> show data_member_location end); + " : " ^ pp_type_info_deep ctyp + ] + +let pp_enum_type_member' (em:enumeration_member) : list string= + let (cupdie,mname,const_value) = em in + [ " "; + (match mname with | Just s -> s | Nothing -> "noname" end); + " = " ^ show const_value + ] + +let pp_struct_union_type_defn' (ctyp: c_type) :string= + let preamble mname kind cupdie mbyte_size= + (match mname with | Just s -> s | Nothing -> "noname" end) + ^ " " ^ kind + ^ " " ^ pp_cupdie cupdie + ^ " " ^ pp_mbyte_size mbyte_size in + match ctyp with + | CT(CT_struct_union cupdie atk mname mbyte_size decl mmembers) -> + preamble mname (pp_struct_union_type_kind atk) cupdie mbyte_size ^ "\n" + ^ pad_rows (match mmembers with Just members -> (List.map (pp_struct_union_type_member') members) | Nothing -> [["warning: no members list"]] end) + | CT(CT_enumeration cupdie mname mtyp mbyte_size decl mmembers) -> + preamble mname "enum" cupdie mbyte_size + ^ " " ^ (match mtyp with Just typ -> pp_type_info_deep typ | Nothing -> "no representation type" end) + ^ "\n" + ^ pad_rows (match mmembers with Just members -> (List.map (pp_enum_type_member') members) | Nothing -> [["warning: no members list"]] end) + | _ -> + Assert_extra.failwith "pp_struct_union_type_defn called on non-struct_union" + end + + + +(* + match typ with + | CT_base cupdie name encoding mbyte_size -> + name ^ " (base type, " ^ match lookup_aB_a encoding base_type_attribute_encodings with Just s -> s | Nothing -> show encoding end ^ " " ^ pp_mbyte_size mbyte_size ^ ")" + | CT_pointer cupdie mtyp' -> "pointer(" ^ match mtyp' with | Just typ' -> pp_type_info_die c d typ' | Nothing -> "no type" end ^ ")" + | CT_const cupdie mtyp' -> "const(" ^ match mtyp' with Just typ'->pp_type_info_die c d typ' | Nothing -> "no type" end ^ ")" + | CT_volatile cupdie typ' -> "volatile(" ^ pp_type_info_die c d typ' ^ ")" + | CT_restrict cupdie typ' -> "restrict(" ^ pp_type_info_die c d typ' ^ ")" + | CT_typedef cupdie name typ' decl -> "typedef("^name^"="^pp_type_info_die c d typ' ^ ")" + | CT_array cupdie typ' dims -> + pp_type_info_die c d typ' ^ String.concat "" (List.map (fun (mcount,subrange_typ) -> "["^match mcount with | Just count -> show count | Nothing -> "no count" end ^"]") dims) + | CT_struct_union cupdie atk mname mbyte_size decl members -> pp_struct_union_type_kind atk ^ " " ^ (match mname with | Just s -> s | Nothing -> "noname" end) ^ pp_cupdie cupdie + | CT_enumeration cupdie mname mtyp' mbyte_size decl members -> "enum" ^ " " ^ (match mname with | Just s -> s | Nothing -> "noname" end) ^ pp_cupdie cupdie + end + *) + + +(* expect the die to have a DW_AT_type, and pp it *) + +let pp_type_info_die_DW_AT_type c (d: dwarf) cu str die= + match find_DW_AT_type_of_die_using_abstract_origin c d cu str die with + | Just (cu',parents',die') -> pp_type_info_die c (d: dwarf) (cu',parents',die') + | Nothing -> "DW_AT_abstract origin failed" + end + + + +let struct_union_enum_types (d:dwarf) : list c_type= + let cupdies = find_dies (fun die -> List.elem die.die_abbreviation_declaration.ad_tag [tag_encode "DW_TAG_structure_type"; tag_encode "DW_TAG_union_type"; tag_encode "DW_TAG_enumeration_type"]) d in + List.map (analyse_type_info_deep (d: dwarf) true) cupdies + + +(* +let pp_all_struct_union_enum_types c d : string = + String.concat "\n\n" (List.map ((fun (cu,parents,die) -> pp_struct_union_type_defn c d (cu,parents,die))) (struct_union_type_dies d)) + *) + +let pp_all_struct_union_enum_types' d : string= + let ctyps : list c_type = struct_union_enum_types d in + String.concat "" ((List.map pp_struct_union_type_defn') ctyps) + + + + +(** ************************************************************ *) +(** ** analysis of location and frame data for reverse mapping *) +(** ************************************************************ *) + +(** analysis *) + +(** simple-minded analysis of location *) + +let analyse_locations_raw c (d: dwarf)= + + let (cuh_default : compilation_unit_header) = let cu = myhead d.d_compilation_units in cu.cu_header in + + (* find all DW_TAG_variable and DW_TAG_formal_parameter dies with a DW_AT_name attribute *) + let tags = List.map tag_encode ["DW_TAG_variable"; "DW_TAG_formal_parameter"] in + let dies : list (compilation_unit * (list die) * die) = + find_dies + (fun die -> + List.elem die.die_abbreviation_declaration.ad_tag tags + && has_attribute "DW_AT_name" die) + d in + + String.concat "" + (List.map + (fun (cu,parents,die) -> + + let ats = List.zip + die.die_abbreviation_declaration.ad_attribute_specifications + die.die_attribute_values in + + let find_ats (s:string)= myfindNonPure (fun (((at: sym_natural), (af: sym_natural)), ((pos: sym_natural),(av:attribute_value))) -> attribute_encode s = at) ats in + + let ((_,_),(_,av_name)) = find_ats "DW_AT_name" in + + let name = + match av_name with + | AV_string bs -> string_of_byte_sequence bs + | AV_strp n -> pp_debug_str_entry d.d_str n + | _ -> "av_name AV not understood" + end in + + + let ((_,_),(_,av_location)) = find_ats "DW_AT_location" in + + let ppd_location = + match av_location with + | AV_exprloc n bs -> " "^parse_and_pp_operations c cuh_default bs^"\n" + | AV_block n bs -> " "^parse_and_pp_operations c cuh_default bs^"\n" + | AV_sec_offset n -> + let location_list = myfindNonPure (fun (n',_)-> n'=n) d.d_loc in + pp_location_list c cuh_default location_list + | _ -> "av_location AV not understood" + end in + + pp_tag_encoding die.die_abbreviation_declaration.ad_tag ^ " " ^ name ^ ":\n" ^ ppd_location ^ "\n" ) + + dies) + + +(** more proper analysis of locations *) + +(* TODO: handle this: +In a variable entry representing the definition of a variable (that is, with no +DW_AT_declaration attribute) if no location attribute is present, or if the location attribute is +present but has an empty location description (as described in Section 2.6), the variable is +assumed to exist in the source code but not in the executable program (but see number 10, +below). +In a variable entry representing a non-defining declaration of a variable, the location +specified modifies the location specified by the defining declaration and only applies for the +scope of the variable entry; if no location is specified, then the location specified in the +defining declaration applies. +The location of a variable may be further specified with a DW_AT_segment attribute, if +appropriate. +*) + + +(* +if there's a DW_AT_location that's a location list (DW_FORM_sec_offset/AV_sec_offset) : use that for both the range(s) and location; interpret the range(s) wrt the applicable base address of the compilation unit + +if there's a DW_AT_location that's a location expression (DW_FORM_exprloc/AV_exprloc or DW_block/AV_block), look for the closest enclosing range: + - DW_AT_low_pc (AV_addr) and no DW_AT_high_pc or DW_AT_ranges: just the singleton address + - DW_AT_low_pc (AV_addr) and DW_AT_high_pc (either an absolute AV_addr or an offset AV_constantN/AV_constant_SLEB128/AV_constantULEB128) : that range + - DW_AT_ranges (DW_FORM_sec_offset/AV_sec_offset) : get a range list from .debug_ranges; interpret wrt the applicable base address of the compilation unit + - for compilation units: a DW_AT_ranges together with a DW_AT_low_pc to specify the default base address to use in interpeting location and range lists + +DW_OP_fbreg in location expressions evaluate the DW_AT_frame_base of +the closest enclosing function - which is either a location expression +or a location list (what happens if the ranges of that location list +don't cover where we are?) + +For each variable and formal parameter that has a DW_AT_name, we'll calculate a list of pairs of a concrete (low,high) range and a location expression. +*) +let cu_base_address cu= + match find_attribute_value "DW_AT_low_pc" cu.cu_die with + | Just (AV_addr n) -> n + | _ -> 0 (*Nothing*) (*Assert_extra.failwith "no cu DW_AT_low_pc"*) + end + + + +let range_of_die c cuh str (dranges: range_list_list) (cu_base_address: sym_natural) (die: die) : maybe (list (sym_natural * sym_natural))= + match (find_attribute_value "DW_AT_low_pc" die, find_attribute_value "DW_AT_high_pc" die, find_attribute_value "DW_AT_ranges" die) with + | (Just (AV_addr n), Nothing, Nothing ) -> Just [(n,n+1)] (* unclear if this case is used? *) + | (Just (AV_addr n1), Just (AV_addr n2), Nothing ) -> Just [(n1,n2)] + | (Just (AV_addr n1), Just (AV_constant_ULEB128 n2), Nothing ) -> Just [(n1, n1+n2)] (* should be mod all? *) + | (Just (AV_addr n1), Just (AV_constant_SLEB128 i2), Nothing ) -> Just [(n1, naturalFromInteger (integerFromSymNatural n1 + i2))] (* should be mod all? *) + | (Just (AV_addr n1), Just (AV_constantN _ _), Nothing ) -> Assert_extra.failwith "AV_constantN in range_of_die" + + | (Just (AV_addr n1), Just (AV_block n bs), Nothing ) -> let n2 = natural_of_bytes c.endianness bs in Just [(n1, n1+n2)] (* should be mod all? *) (* signed or unsigned interp? *) + | (_, Nothing, Just (AV_sec_offset n)) -> + let rlis = Tuple.snd (match find_range_list dranges n with Just rlis->rlis | None -> Assert_extra.failwith ("find_range_list failed on AV_sec_offset n=" ^ show n ^ " for die\n" ^ pp_die c cuh str false 0 false die) end) in + let nns = interpret_range_list cu_base_address rlis in + Just nns + | (Nothing, Nothing, Nothing ) -> Nothing + | (_, _, _ ) -> Just [] (*Assert_extra.failwith "unexpected attribute values in closest_enclosing_range"*) +end + +let range_of_die_d (d:dwarf) cu (die: die) : maybe (list (sym_natural * sym_natural))= + let c = p_context_of_d d in + range_of_die c cu.cu_header d.d_str d.d_ranges (cu_base_address cu) die + +let entry_address (die:die) : maybe sym_natural= + match (find_attribute_value "DW_AT_low_pc" die, find_attribute_value "DW_AT_entry_pc" die) with + | (_, Just (AV_addr n)) -> Just n + | (Just (AV_addr n), _) -> Just n + | (Nothing,Nothing) -> Nothing + end + +let rec closest_enclosing_range c cuh str (dranges: range_list_list) (cu_base_address: sym_natural) (parents: list die) : maybe (list (sym_natural * sym_natural))= + match parents with + | [] -> Nothing + | die::parents' -> + match range_of_die c cuh str dranges cu_base_address die with + | ((Just x) as y) -> y + | Nothing -> + closest_enclosing_range c cuh str dranges cu_base_address parents' + end + end + +(* +If one of the DW_FORM_data forms is used to represent a signed or unsigned integer, it +can be hard for a consumer to discover the context necessary to determine which +interpretation is intended. Producers are therefore strongly encouraged to use +DW_FORM_sdata or DW_FORM_udata for signed and unsigned integers respectively, +rather than DW_FORM_data. +no kidding - if we get an AV_constantN for DW_AT_high_pc, should it be interpreted as signed or unsigned? *) + + +let rec closest_enclosing_frame_base dloc (base_address: sym_natural) (parents: list die) : maybe attribute_value= + match parents with + | [] -> Nothing + | die::parents' -> + match find_attribute_value "DW_AT_frame_base" die with + | Just av -> Just av + | Nothing -> closest_enclosing_frame_base dloc base_address parents' + end + end + + + + +let interpreted_location_of_die c cuh str (dloc: location_list_list) (dranges: range_list_list) (base_address: sym_natural) (parents: list die) (die: die) : maybe (list (sym_natural * sym_natural * single_location_description))= + + (* for a simple location expression bs, we look in the enclosing die + tree to find the associated pc range *) + let location bs= + match closest_enclosing_range c cuh str dranges base_address (die::parents) with + | Just nns -> + Just (List.map (fun (n1,n2) -> (n1,n2,bs)) nns) + | Nothing -> + (* if there is no such range, we take the full 0 - 0xfff.fff range*) + Just [(0,(arithmetic_context_of_cuh cuh).ac_max,bs)] + end in + + match find_attribute_value "DW_AT_location" die with + | Just (AV_exprloc n bs) -> location bs + | Just (AV_block n bs) -> location bs + (* while for a location list, we take the associated pc range from + each element of the list *) + | Just (AV_sec_offset n) -> + let (_,llis) = find_location_list dloc n in + Just (interpret_location_list base_address llis) + | Nothing -> Nothing + end + + + +val analyse_locations : dwarf -> analysed_location_data +let analyse_locations (d: dwarf) : analysed_location_data= + + let c = p_context_of_d d in + + (* let (cuh_default : compilation_unit_header) = let cu = myhead d.d_compilation_units in cu.cu_header in*) + + (* find all DW_TAG_variable and DW_TAG_formal_parameter dies with a DW_AT_location attribute and either a DW_AT_name or a DW_abstract_origin *) + (* (leaving formal parameters of inlined routines with a DW_AT_const_value to the future) *) + let tags = List.map tag_encode ["DW_TAG_variable"; "DW_TAG_formal_parameter"] in + let dies : list (compilation_unit * (list die) * die) = + find_dies + (fun die -> + List.elem die.die_abbreviation_declaration.ad_tag tags + && (has_attribute "DW_AT_name" die || has_attribute "DW_AT_abstract_origin" die) + && has_attribute "DW_AT_location" die) + d in + + List.map + (fun (((cu:compilation_unit), (parents: list die), (die: die)) as x) -> + let base_address = cu_base_address cu in + let interpreted_locations : maybe (list (sym_natural * sym_natural * single_location_description)) = + interpreted_location_of_die c cu.cu_header d.d_str d.d_loc d.d_ranges base_address parents die in + (x,interpreted_locations) + ) + dies + + + +let pp_analysed_locations1 c cuh (nnls: list (sym_natural * sym_natural * single_location_description)) : string= + String.concat "" + (List.map + (fun (n1,n2,bs) -> " " ^ pphex n1 ^ " " ^ pphex n2 ^ " " ^ parse_and_pp_operations c cuh bs) + nnls) + +let pp_analysed_locations2 c cuh mnnls= + match mnnls with + | Just nnls -> pp_analysed_locations1 c cuh nnls + | Nothing -> " " + end + + +(* +let pp_analysed_locations3 c d str (als: analysed_location_data) : string = + pad_rows + (List.map + (fun ((cu,parents,die),mnnls) -> + [" ";pp_die_abbrev_var c cu.cu_header str 0 false parents die + ^ pp_type_info_die_DW_AT_type c d cu cu.cu_header str die; + pp_analysed_locations2 c cu.cu_header mnnls] + ) + als + ) + +let pp_analysed_location_data (d: dwarf) (als: analysed_location_data) : string = + let c = p_context_of_d d in +(* let cu = myhead d.d_compilation_units in + let (cuh_default : compilation_unit_header) = cu.cu_header in + *) + pp_analysed_locations3 c (*HACK*) d d.d_str als + *) + + +let pp_analysed_locations3 c d str (removed:bool) (als: analysed_location_data) : list (bool(*removed?*) * (string(*name*) * string(*offset*) * string(*kind*)) * (unit->string)(*string*)(*type*) * string(*locations*) * (unit->string)(*parents*))= + List.map + (fun ((cu,parents,die1),mnnls) -> + (removed, + pp_die_abbrev_var c d cu str false parents die1, (*4.5s for only this*) + (fun () -> pp_type_info_die_DW_AT_type c d cu str die1), (*12.2s for this and above*) + pp_analysed_locations2 c cu.cu_header mnnls, (*12.4s for this and above*) + (fun () -> pp_die_abbrev_var_parents c d cu str parents)) (*14.4s for this and above*) + ) + als + +let pp_analysed_locations3_diff c d str (als_old: analysed_location_data) (als_new: analysed_location_data) : list (bool(*removed?*) * (string(*name*) * string(*offset*) * string(*kind*)) * (unit->string)(*type*) * string(*locations*) *(unit->string)(*parents*))= + (* maybe alpha sort these? *) + let ppd_old = pp_analysed_locations3 c d str true als_old in + let ppd_new = pp_analysed_locations3 c d str false als_new in + + (* the old entries that don't have a same-name new entry *) + let ppd_gone = List.filter (fun (removed,(name,offset,kind),typ,locs,parents) -> not (List.any (fun (removed',(name',offset',kind'),typ',locs',parents') -> name=name') ppd_new)) ppd_old in + + (* the new entries, each preceded by any same-name old entries (this will display strangely if there's any variable shadowing...) *) + let ppd_upd = + List.concat + (List.mapMaybe + (fun ((removed,((name,offset,kind) as y),typ,locs,parents) as x) -> + let same_name_old = (List.filter (fun (removed',(name',offset',kind'),typ',locs',parents') -> (name,offset)=(name',offset')) ppd_old) in + match same_name_old with + | [((removed',((name',offset',kind') as y'),typ',locs',parents') as x')] -> + if (y,(*typ,*)locs) = (y',(*typ',*)locs') then + Nothing + else + Just (same_name_old ++ [x]) + | _ -> + Just (same_name_old ++ [x]) + end) + ppd_new) in + + ppd_gone ++ ppd_upd + +let pp_analysed_location_format (xs : list (bool(*removed?*) * (string(*name*) * string(*offset*) * string(*kind*)) * (unit->string)(*string*)(*type*) * string(*locations*) * (unit->string)(*parents*)))= + pad_rows + (List.map + (fun ((removed,(name,offset,kind),typ,locs,parents) as x) -> + [ (if removed then "-" else " ") ^ name + ^ " (" ^ offset ^ "," ^ kind ^ ") " + ^ typ (); + locs; + parents ()] + ) + xs + ) + +let pp_analysed_location_data (d: dwarf) (als: analysed_location_data) : string= + let c = p_context_of_d d in +(* let cu = myhead d.d_compilation_units in + let (cuh_default : compilation_unit_header) = cu.cu_header in + *) + pp_analysed_location_format (pp_analysed_locations3 c (*HACK*) d d.d_str false als) + +let pp_analysed_location_data_diff (d: dwarf) (als_old: analysed_location_data) (als_new: analysed_location_data) : string= + let c = p_context_of_d d in +(* let cu = myhead d.d_compilation_units in + let (cuh_default : compilation_unit_header) = cu.cu_header in + *) + pp_analysed_location_format (pp_analysed_locations3_diff c (*HACK*) d d.d_str als_old als_new) + + + +let pp_analysed_location_data_at_pc (d: dwarf) (alspc: analysed_location_data_at_pc) : string= + String.concat "" (List.map + (fun ((cu,parents,die),(n1,n2,sld,esl)) -> + " " ^ + let name = + match find_name_of_die d.d_str die with + | Just s -> s + | Nothing -> "\n" + end in + match esl with + | Success sl -> + name ^ " @ " ^ pp_single_location sl ^"\n" + + | Fail e -> name ^ " @ " ^ "\n" + end + ) + alspc) + + + + +val analysed_locations_at_pc : evaluation_context -> dwarf_static -> sym_natural -> analysed_location_data_at_pc +let analysed_locations_at_pc + (ev) + (ds: dwarf_static) + (pc: sym_natural) + : analysed_location_data_at_pc= + + let c : p_context = (<| endianness = ds.ds_dwarf.d_endianness |>) in + + let xs = + List.mapMaybe + (fun (cupd,mnns) -> + match mnns with + | Nothing -> Nothing + | Just nns -> + let nns' = List.filter (fun (n1,n2,sld) -> pc >= n1 && pc < n2) nns in + match nns' with + | [] -> Nothing + | _ -> Just (cupd,nns') + end + end) + ds.ds_analysed_location_data + in + + List.concat + (List.map + (fun ((cu,parents,die),nns) -> + let ac = arithmetic_context_of_cuh cu.cu_header in + let base_address = cu_base_address cu in + let mfbloc : maybe attribute_value = + closest_enclosing_frame_base ds.ds_dwarf.d_loc base_address parents in + List.map + (fun (n1,n2,sld) -> + let el : error single_location = + evaluate_location_description_bytes c ds.ds_dwarf.d_loc ds.ds_evaluated_frame_info cu.cu_header ac ev mfbloc pc sld in + ((cu,parents,die),(n1,n2,sld,el)) + ) + nns + ) + xs) + +val names_of_address : dwarf -> analysed_location_data_at_pc -> sym_natural -> list string +let names_of_address + (d: dwarf) + (alspc: analysed_location_data_at_pc) + (address: sym_natural) + : list string= + + List.mapMaybe + (fun ((cu,parents,die),(n1,n2,sld,esl)) -> + match esl with + | Success (SL_simple (SL_memory_address a)) -> + if a=address then + match find_name_of_die d.d_str die with + | Just s -> Just s + | Nothing -> Nothing + end + else + Nothing + | Success _ -> Nothing (* just suppress? *) + | Fail e -> Nothing (* just suppress? *) + end + ) + alspc + + +val filtered_analysed_location_data : dwarf_static -> sym_natural -> analysed_location_data +let filtered_analysed_location_data ds pc= + List.mapMaybe + (fun (cupd,mnns) -> + match mnns with + | Nothing -> Nothing + | Just nns -> + let nns' = List.filter (fun (n1,n2,sld) -> pc >= n1 && pc < n2) nns in + match nns' with + | [] -> Nothing (*Just (cupd,Nothing)*) + | _::_ -> Just (cupd,Just nns') + end + end) + ds.ds_analysed_location_data + +(** ********************************************************************** *) +(** ** estimate source-file line extents of each (non-inlined) subprogram *) +(** ********************************************************************** *) + +(* The line number info associates source-file line numbers to + instruction addresses, but doesn't identify which subprogram those + line numbers come from. To recover that, we can use the + DW_TAG_subprogram die DW_AT_decl_file and DW_AT_decl_line info, + which gives the start of each subprogram. For C, function + definitions cannot be nested, so we can estimate their line-number + extents as from their start to the start of the next. Note that + this might be wrong if there are (eg) macro definitions between C + functions. Because of the lack of nesting, for C, just taking the + top-level DW_TAG_subprogram dies of each compilation unit should be + basically ok, and seems also to exclude inlined instances of + subprograms (which otherwise we could exclude by discarding any + with an abstract origin). However, those top-level subprograms are + not necessarily all from the "primary" file of the subprogram, and + conceivably some functions in the file might not be included in + that compilation unit but appear in another. We'll therefore take + all top-level subprograms from all compilation units, partition by + file (up to equality of (compilation directory, include directory, + and path)), and then sort. This assumes that the directory and + path strings from the line number info for different compilation + units are nicely comparable. + + We also have to identify the compilation unit referred to by a line + number file entry that's been reported from the line-number + info. The DW_TAG_compile_unit DW_AT_name appears to be the path + concatentation (inserting a "/", not just the string concatenation) + of the lnfe_directory_index's string and the lnfe_path of one the + lnfe's of the line number header pointed to by the compilation + unit's DW_AT_stmt_list, but not necessarily any particular such + lnfe.*) + + + +let subprogram_line_extents_compilation_unit d cu : list (string * unpacked_file_entry * sym_natural)= + let c = p_context_of_d d in + let subprogram_dies = List.filter (fun die' -> die'.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_subprogram") cu.cu_die.die_children in + + let lnp = line_number_program_of_compilation_unit d cu in + let lnh = lnp.lnp_header in + + List.mapMaybe + (fun die -> + match (find_name_of_die d.d_str die, + find_natural_attribute_value_of_die c "DW_AT_decl_file" die, + find_natural_attribute_value_of_die c "DW_AT_decl_line" die) with + | (Just name, Just file, Just line) -> + Just (name, unpack_file_entry lnh file, line) + | (_,_,_) -> + Nothing + end) + subprogram_dies + +(* lookup in an association list and also return the list with that entry (if any) removed *) +val extract : forall 'b 'c. Eq 'b => 'b -> list ('b * 'c) -> (maybe 'c) * list ('b * 'c) +let rec extract y yzs= + match yzs with + | [] -> (Nothing, []) + | (y',z')::yzs' -> + if y'=y then + (Just z', yzs') + else + let (result,yzs'') = extract y yzs' in + (result, (y',z')::yzs'') + end + +(* partition a list by the result of f, removing duplicates and sorting each partition by lt *) +val partitionby: forall 'a 'b. Eq 'a , Eq 'b => ('a -> 'b) -> ('a -> 'a -> bool) -> list 'a -> list ('b * list 'a) -> list ('b * list 'a) +let rec partitionby f lt xs acc= + match xs with + | [] -> acc + | x::xs' -> + let y = f x in + let (result, acc') = extract y acc in + let acc'' = + match result with + | Just xs'' -> + if List.elem x xs'' then acc else ((y, Sorting.insertBy lt x xs'')::acc') + | Nothing -> + (y,[x])::acc + end in + partitionby f lt xs' acc'' + end + +let subprogram_line_extents d : list (unpacked_file_entry * list (string * unpacked_file_entry * sym_natural) )= + let subprograms : list (string * unpacked_file_entry * sym_natural) = + List.concatMap (subprogram_line_extents_compilation_unit d) d.d_compilation_units in + partitionby (fun (name, ufe, line) -> ufe) (fun (name,ufe,line) -> fun (name',ufe',line') -> line < line') subprograms [] + +let pp_subprograms sles= + String.concat "\n" + (List.map + (fun (ufe,sles') -> + pp_ufe ufe ^ "\n" + ^ String.concat "" (List.map (fun (name, ufe, line) -> " " ^ show line ^ " " ^ name ^ "\n") sles')) + sles) + +let rec find_by_line line sles line_last name_last= + match sles with + | [] -> name_last + | (name',ufe',line') :: sles' -> + if line >= line_last && line < line' then name_last else find_by_line line sles' line' name' + end + +let subprogram_at_line subprogram_line_extents (ufe:unpacked_file_entry) (line:sym_natural) : string= + match List.lookup ufe subprogram_line_extents with + | Nothing -> "no matching unpacked_file_entry" + | Just sles -> find_by_line line sles 0 "file preamble" + end + + + + + +(** ************************************************************ *) +(** ** pull out subprograms *) +(** ************************************************************ *) +(* +val analyse_subprograms : dwarf -> analysed_location_data +let analyse_subprograms (d: dwarf) : analysed_location_data = + + let c = p_context_of_d d in + + let (cuh_default : compilation_unit_header) = let cu = myhead d.d_compilation_units in cu.cu_header in + + (* find all DW_TAG_subprogram dies *) + let tags = List.map tag_encode ["DW_TAG_subprogram"] in + let dies : list (compilation_unit * (list die) * die) = + find_dies + (fun die -> + List.elem die.die_abbreviation_declaration.ad_tag tags + && has_attribute "DW_AT_name" die + && has_attribute "DW_AT_location" die) + d in + + List.map + (fun (((cu:compilation_unit), (parents: list die), (die: die)) as x) -> + + let name = + match find_name_of_die d.d_str die with + | Just s -> s + | Nothing -> "\n" + end in + + let entry_point : maybe attribute_value = + match find_attribute_value "DW_AT_entry_pc" die with + | Nothing -> Nothing + | + + let base_address = cu_base_address cu in + let interpreted_locations : maybe (list (natural * natural * single_location_description)) = + interpreted_location_of_die c cuh_default d.d_loc d.d_ranges base_address parents die in + (x,interpreted_locations) + ) + dies + *) + + +(** ************************************************************ *) +(** ** evaluation of line-number info *) +(** ************************************************************ *) + +let initial_line_number_registers (lnh: line_number_header) : line_number_registers= + <| + lnr_address = 0; + lnr_op_index = 0; + lnr_file = 1; + lnr_line = 1; + lnr_column = 0; + lnr_is_stmt = lnh.lnh_default_is_stmt; + lnr_basic_block = false; + lnr_end_sequence = false; + lnr_prologue_end = false; + lnr_epilogue_begin = false; + lnr_isa = 0; + lnr_discriminator =0; + |> + +let evaluate_line_number_operation + (lnh: line_number_header) + ((s: line_number_registers), (lnrs: list line_number_registers)) + (lno: line_number_operation) + : line_number_registers * list line_number_registers= + + let new_address s operation_advance= (s.lnr_address + + lnh.lnh_minimum_instruction_length * + ((s.lnr_op_index + operation_advance)/lnh.lnh_maximum_operations_per_instruction)) mod (range_address 8) (* TODO: this should be taken from the compilation unit header address_size for DWARF<=4 or the line number header for DWARF5*) in + let new_op_index s operation_advance= + (s.lnr_op_index + operation_advance) mod lnh.lnh_maximum_operations_per_instruction in + + match lno with + | DW_LN_special adjusted_opcode -> + let operation_advance = adjusted_opcode / lnh.lnh_line_range in + let line_increment = lnh.lnh_line_base + integerFromSymNatural (adjusted_opcode mod lnh.lnh_line_range) in + let s' = + <| s with + lnr_line = partialNaturalFromInteger ((integerFromSymNatural s.lnr_line) + line_increment); + lnr_address = new_address s operation_advance; + lnr_op_index = new_op_index s operation_advance; + |> in + let lnrs' = s'::lnrs in + let s'' = + <| s' with + lnr_basic_block = false; + lnr_prologue_end = false; + lnr_epilogue_begin = false; + lnr_discriminator = 0; + |> in + (s'', lnrs') + | DW_LNS_copy -> + let lnrs' = s::lnrs in + let s' = + <| s with + lnr_basic_block = false; + lnr_prologue_end = false; + lnr_epilogue_begin = false; + lnr_discriminator = 0; + |> in + (s', lnrs') + | DW_LNS_advance_pc operation_advance -> + let s' = + <| s with + lnr_address = new_address s operation_advance; + lnr_op_index = new_op_index s operation_advance; + |> in + (s', lnrs) + | DW_LNS_advance_line line_increment -> + let s' = <| s with lnr_line = partialNaturalFromInteger ((integerFromSymNatural s.lnr_line) + line_increment) |> in (s', lnrs) + | DW_LNS_set_file n -> + let s' = <| s with lnr_file = n |> in (s', lnrs) + | DW_LNS_set_column n -> + let s' = <| s with lnr_column = n |> in (s', lnrs) + | DW_LNS_negate_stmt -> + let s' = <| s with lnr_is_stmt = not s.lnr_is_stmt |> in (s', lnrs) + | DW_LNS_set_basic_block -> + let s' = <| s with lnr_basic_block = true |> in (s', lnrs) + | DW_LNS_const_add_pc -> + let opcode = 255 in + let adjusted_opcode = opcode - lnh.lnh_opcode_base in + let operation_advance = adjusted_opcode / lnh.lnh_line_range in + let s' = + <| s with + lnr_address = new_address s operation_advance; + lnr_op_index = new_op_index s operation_advance; + |> in + (s', lnrs) + | DW_LNS_fixed_advance_pc n -> + let s' = + <| s with + lnr_address = s.lnr_address + n; + lnr_op_index = 0; + |> in + (s', lnrs) + | DW_LNS_set_prologue_end -> + let s' = <| s with lnr_prologue_end = true |> in (s', lnrs) + | DW_LNS_set_epilogue_begin -> + let s' = <| s with lnr_epilogue_begin = true |> in (s', lnrs) + | DW_LNS_set_isa n -> + let s' = <| s with lnr_isa = n |> in (s', lnrs) + | DW_LNE_end_sequence -> + let s' = <| s with lnr_end_sequence = true |> in + let lnrs' = s' :: lnrs in + let s'' = initial_line_number_registers lnh in + (s'', lnrs') + | DW_LNE_set_address n -> + let s' = + <| s with + lnr_address = n; + lnr_op_index = 0; + |> in + (s', lnrs) + | DW_LNE_define_file s n1 n2 n3 -> + Assert_extra.failwith "DW_LNE_define_file not implemented" (*TODO: add to file list in header - but why is this in the spec? *) + | DW_LNE_set_discriminator n -> + let s' = <| s with lnr_discriminator = n |> in (s', lnrs) + end + +let rec evaluate_line_number_operations + (lnh: line_number_header) + ((s: line_number_registers), (lnrs: list line_number_registers)) + (lnos: list line_number_operation) + : line_number_registers * list line_number_registers= + match lnos with + | [] -> (s,lnrs) + | lno :: lnos' -> + let (s',lnrs') = + evaluate_line_number_operation lnh (s,lnrs) lno in + evaluate_line_number_operations lnh (s',lnrs') lnos' + end + +let evaluate_line_number_program + (lnp:line_number_program) + : list line_number_registers= + List.reverse (Tuple.snd (evaluate_line_number_operations lnp.lnp_header ((initial_line_number_registers lnp.lnp_header),[]) lnp.lnp_operations)) + + +let evaluated_line_info_of_compilation_unit d cu evaluated_line_info= + let c = p_context_of_d d in + let offset = line_number_offset_of_compilation_unit c cu in + match List.find (fun (lnh,lnrs) -> lnh.lnh_offset = offset) evaluated_line_info with + | Nothing -> Assert_extra.failwith "compilation unit line number offset not found" + | Just (lnh,lnrs) ->lnrs + end + + +let pp_line_number_registers lnr= + "" + ^ "address = " ^ pphex lnr.lnr_address ^ "\n" + ^ "op_index = " ^ show lnr.lnr_op_index ^ "\n" + ^ "file = " ^ show lnr.lnr_file ^ "\n" + ^ "line = " ^ show lnr.lnr_line ^ "\n" + ^ "column = " ^ show lnr.lnr_column ^ "\n" + ^ "is_stmt = " ^ show lnr.lnr_is_stmt ^ "\n" + ^ "basic_block = " ^ show lnr.lnr_basic_block ^ "\n" + ^ "end_sequence = " ^ show lnr.lnr_end_sequence ^ "\n" + ^ "prologue_end = " ^ show lnr.lnr_prologue_end ^ "\n" + ^ "epilogue_begin = " ^ show lnr.lnr_epilogue_begin ^ "\n" + ^ "isa = " ^ show lnr.lnr_isa ^ "\n" + ^ "discriminator = " ^ pphex lnr.lnr_discriminator ^ "\n" + +let pp_line_number_registers_tight lnr : list string= + [ + pphex lnr.lnr_address ; + show lnr.lnr_op_index ; + show lnr.lnr_file ; + show lnr.lnr_line ; + show lnr.lnr_column ; + show lnr.lnr_is_stmt ; + show lnr.lnr_basic_block ; + show lnr.lnr_end_sequence ; + show lnr.lnr_prologue_end ; + show lnr.lnr_epilogue_begin ; + show lnr.lnr_isa ; + pphex lnr.lnr_discriminator + ] + +let pp_line_number_registerss lnrs= + pad_rows + ( + ["address"; "op_index"; "file"; "line"; "column"; "is_stmt"; "basic_block"; "end_sequence"; "prologue_end"; "epilogue_begin"; "isa"; "discriminator"] + :: + (List.map pp_line_number_registers_tight lnrs) + ) + +let pp_evaluated_line_info (eli: evaluated_line_info) : string= + String.concat "\n" (List.map (fun (lnh,lnrs) -> pp_line_number_header lnh ^ "\n" ^ pp_line_number_registerss lnrs) eli) + +(* readef example: +Decoded dump of debug contents of section .debug_line: + +CU: /var/local/stephen/work/devel/rsem/ppcmem2/system/tests-adhoc/simple-malloc/test-concurrent.c: +File name Line number Starting address +test-concurrent.c 11 0x400144 + +test-concurrent.c 12 0x40014c +test-concurrent.c 13 0x400154 +test-concurrent.c 14 0x400158 +test-concurrent.c 17 0x400160 + +/var/local/stephen/work/devel/rsem/ppcmem2/system/tests-adhoc/simple-malloc/../thread_start_aarch64.h: +thread_start_aarch64.h 34 0x400168 +thread_start_aarch64.h 36 0x400174 + +/var/local/stephen/work/devel/rsem/ppcmem2/system/tests-adhoc/simple-malloc/test-concurrent.c: +test-concurrent.c 19 0x400174 + +test-concurrent.c 20 0x40017c +test-concurrent.c 22 0x400180 + +CU: /var/local/stephen/work/devel/rsem/ppcmem2/system/tests-adhoc/simple-malloc/malloc.c: +... +*) + + + +let source_lines_of_address (ds:dwarf_static) (a: sym_natural) : list ( unpacked_file_entry * sym_natural * line_number_registers * string (*function*))= + List.concat + (List.map + (fun (lnh, lnrs) -> + myfiltermaybe + (fun lnr -> + if a = lnr.lnr_address && not lnr.lnr_end_sequence then + Just (unpack_file_entry lnh lnr.lnr_file, lnr.lnr_line, lnr, subprogram_at_line ds.ds_subprogram_line_extents (unpack_file_entry lnh lnr.lnr_file) lnr.lnr_line) + else + Nothing) + lnrs + ) + ds.ds_evaluated_line_info + ) + + + + +(** ************************************************************ *) +(** ** collecting all the statically calculated analysis info *) +(** ************************************************************ *) + +val extract_dwarf_static : elf_file -> maybe dwarf_static +let extract_dwarf_static f1= + match extract_dwarf f1 with + | Nothing -> Nothing + | Just dwarf -> + (*let _ = my_debug5 (pp_dwarf dwarf) in *) + + let ald : analysed_location_data = + analyse_locations dwarf in + let efi : evaluated_frame_info = + evaluate_frame_info dwarf in + let eli : evaluated_line_info = + List.map (fun lnp -> (lnp.lnp_header, evaluate_line_number_program lnp)) dwarf.d_line_info in + let sle = subprogram_line_extents dwarf in + let ds = + <| + ds_dwarf = dwarf; + ds_analysed_location_data = ald; + ds_evaluated_frame_info = efi; + ds_evaluated_line_info = eli; + ds_subprogram_line_extents = sle; + |> in + Just ds + end + + + +(** ************************************************************ *) +(** ** collect simple die tree view *) +(** ************************************************************ *) + +let decl_of_die d subprogram_line_extents cu die : maybe (unpacked_file_entry * nat (*line*) * string (*subprogram name*))= + let c = p_context_of_d d in + let lnp = line_number_program_of_compilation_unit d cu in + let lnh = lnp.lnp_header in + match (find_natural_attribute_value_of_die c "DW_AT_decl_file" die, + find_natural_attribute_value_of_die c "DW_AT_decl_line" die) with + | (Just file, Just line) -> + let ufe = unpack_file_entry lnh file in + let subprogram_name = subprogram_at_line subprogram_line_extents ufe line in + Just (ufe, natFromSymNatural line, subprogram_name) + | (_,_) -> + Nothing + end + +let call_site_of_die d subprogram_line_extents cu die : maybe (unpacked_file_entry * nat (*line*) * string (*subprogram name*))= + let c = p_context_of_d d in + let lnp = line_number_program_of_compilation_unit d cu in + let lnh = lnp.lnp_header in + match (find_natural_attribute_value_of_die c "DW_AT_call_file" die, + find_natural_attribute_value_of_die c "DW_AT_call_line" die) with + | (Just file, Just line) -> + let ufe = unpack_file_entry lnh file in + let subprogram_name = subprogram_at_line subprogram_line_extents ufe line in + Just (ufe, natFromSymNatural line, subprogram_name) + | (_,_) -> + Nothing + end + + +let mk_sdt_unspecified_parameter (d:dwarf) subprogram_line_extents cu parents die : maybe sdt_unspecified_parameter= + if not(List.elem die.die_abbreviation_declaration.ad_tag [tag_encode "DW_TAG_unspecified_parameters"]) + then Nothing + else Just () + + +(* +let strict_msvfp x e s z = + match x with + | Just y -> y + | Nothing -> + Assert_extra.failwith ("mk_sdt_variable_or_formal_parameter strict failure " ^ e ^ " on \n" ^ s z ^ "\n") + end + *) +let rec mk_sdt_variable_or_formal_parameter (d:dwarf) subprogram_line_extents cu parents die : maybe sdt_variable_or_formal_parameter= + if not(List.elem die.die_abbreviation_declaration.ad_tag [tag_encode "DW_TAG_variable"; tag_encode "DW_TAG_formal_parameter"]) + then Nothing + else + + let c = p_context_of_d d in + (* let s (cu,parents,die) = pp_die c cu.cu_header d.d_str true 0 false die in*) + + let cupdie = (cu,parents,die) in + let kind = if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_variable" then SVPK_var else if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_formal_parameter" then SVPK_param else Assert_extra.failwith ("unreachable bad kind") in + + (* find aDW_AT_specification die, if it exists. TODO: how should this interact with abstract origins? *) + let mcupdie_spec = find_reference_attribute_of_die c d cu d.d_str "DW_AT_specification" die in + + Just ( + <| + svfp_cupdie = cupdie; + svfp_kind = kind; + (* svfp_name = strict_msvfp (find_name_of_die_using_abstract_origin_and_spec c d cu d.d_str die mcupdie_spec) "no name" s cupdie;*) + svfp_name = match (find_name_of_die_using_abstract_origin_and_spec c d cu d.d_str die mcupdie_spec) with Just name -> name | Nothing -> "no name" end; + svfp_type = (*strict_msvfp*) (find_DW_AT_type_of_die_deep_using_abstract_origin d cupdie) (*"no type" s cupdie*); + svfp_abstract_origin = + match find_reference_attribute_of_die c d cu d.d_str "DW_AT_abstract_origin" die with + | Nothing -> + Nothing + | Just ((cu',parents',die') as cupdie') -> + mk_sdt_variable_or_formal_parameter d subprogram_line_extents cu' parents' die' + end; + svfp_const_value = find_integer_attribute_value_of_die c "DW_AT_const_value" die; + svfp_external = match find_flag_attribute_value_of_die_using_abstract_origin d "DW_AT_external" cupdie with Just b -> b | Nothing -> false end; + svfp_declaration = match find_flag_attribute_value_of_die_using_abstract_origin d "DW_AT_declaration" cupdie with Just b -> b | Nothing -> false end; + svfp_locations = + let base_address = cu_base_address cu in + let interpreted_locations : maybe (list (sym_natural * sym_natural * single_location_description)) = + interpreted_location_of_die c cu.cu_header d.d_str d.d_loc d.d_ranges base_address parents die in + Maybe.map (fun nnbss -> List.map (fun (n1,n2,bs) -> (n1,n2,parse_operations_bs c cu.cu_header bs)) nnbss) interpreted_locations; + svfp_decl = decl_of_die d subprogram_line_extents cu die; + |> ) + +let strict_mss x e s z= + match x with + | Just y -> y + | Nothing -> + Assert_extra.failwith ("mk_sdt_subroutine strict failure " ^ e ^ " on \n" ^ s z ^ "\n") + end + +let rec mk_sdt_subroutine (d:dwarf) subprogram_line_extents (cu:compilation_unit) parents (die:die) : maybe sdt_subroutine= + if not(List.elem die.die_abbreviation_declaration.ad_tag [tag_encode "DW_TAG_subprogram"; tag_encode "DW_TAG_inlined_subroutine"]) + then Nothing + else + let c = p_context_of_d d in + (* let s (cu,parents,die) : string = pp_die c cu.cu_header d.d_str true 0 false die in*) + + let cupdie = (cu, parents, die) in + let parents' = die::parents in + let kind = if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_subprogram" then SSK_subprogram else if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_inlined_subroutine" then SSK_inlined_subroutine else Assert_extra.failwith ("unreachable bad kind") in + Just ( + <| + ss_cupdie = cupdie; + ss_name = (*strict_mss ( *)find_name_of_die_using_abstract_origin c d cu d.d_str die(* ) "no name" s cupdie;*); + ss_kind = kind; + ss_call_site = call_site_of_die d subprogram_line_extents cu die; + ss_abstract_origin = + match find_reference_attribute_of_die c d cu d.d_str "DW_AT_abstract_origin" die with + | Nothing -> + Nothing + | Just ((cu',parents',die') as cupdie') -> + mk_sdt_subroutine d subprogram_line_extents cu' parents' die' + end; + ss_type = find_DW_AT_type_of_die_deep(*_using_abstract_origin*) d cupdie; + ss_vars = List.mapMaybe (mk_sdt_variable_or_formal_parameter d subprogram_line_extents cu parents') die.die_children; + ss_unspecified_parameters = List.mapMaybe (mk_sdt_unspecified_parameter d subprogram_line_extents cu parents') die.die_children; + ss_entry_address = entry_address die; + ss_pc_ranges = range_of_die_d d cu die; + ss_subroutines = List.mapMaybe (mk_sdt_subroutine d subprogram_line_extents cu parents') die.die_children; + ss_lexical_blocks = List.mapMaybe (mk_sdt_lexical_block d subprogram_line_extents cu parents') die.die_children; + ss_decl = decl_of_die d subprogram_line_extents cu die; + ss_noreturn = match find_flag_attribute_value_of_die_using_abstract_origin d "DW_AT_noreturn" cupdie with Just b -> b | Nothing -> false end; + ss_external = match find_flag_attribute_value_of_die_using_abstract_origin d "DW_AT_external" cupdie with Just b -> b | Nothing -> false end; + |> ) + + and mk_sdt_lexical_block (d:dwarf) subprogram_line_extents (cu:compilation_unit) parents (die:die) : maybe sdt_lexical_block= + if not (die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_lexical_block") + then Nothing + else + let c = p_context_of_d d in + (*let s (cu,parents,die) : string = pp_die c cu.cu_header d.d_str true 0 false die in*) + + let cupdie = (cu, parents, die) in + let parents' = die::parents in + Just ( + <| + slb_cupdie = cupdie; + slb_vars = List.mapMaybe (mk_sdt_variable_or_formal_parameter d subprogram_line_extents cu parents') die.die_children; + slb_pc_ranges = range_of_die_d d cu die; + slb_subroutines = List.mapMaybe (mk_sdt_subroutine d subprogram_line_extents cu parents') die.die_children; + slb_lexical_blocks = List.mapMaybe (mk_sdt_lexical_block d subprogram_line_extents cu parents') die.die_children; + |> ) + + +let strict_mscu x e s z= + match x with + | Just y -> y + | Nothing -> + Assert_extra.failwith ("mk_sdt_compilation_unit strict failure " ^ e ^ " on \n" ^ s z ^ "\n") + end + +let mk_sdt_compilation_unit (d:dwarf) subprogram_line_extents (cu:compilation_unit) : sdt_compilation_unit= + let c = p_context_of_d d in + let s (cu,(parents:list die),die) : string= pp_die c cu.cu_header d.d_str true 0 false die in + let cupdie = (cu, [], cu.cu_die) in + + let parents' = [cu.cu_die] in + <| + scu_cupdie = (cu, [], cu.cu_die); + scu_name = strict_mscu (find_name_of_die d.d_str cu.cu_die) "no name" s cupdie; + scu_subroutines = List.mapMaybe (mk_sdt_subroutine d subprogram_line_extents cu parents') cu.cu_die.die_children; + scu_vars = List.mapMaybe (mk_sdt_variable_or_formal_parameter d subprogram_line_extents cu parents') cu.cu_die.die_children; + scu_pc_ranges = range_of_die_d d cu cu.cu_die; + |> + + +let mk_sdt_dwarf (d:dwarf) subprogram_line_extents : sdt_dwarf= + <| sd_compilation_units = List.map (mk_sdt_compilation_unit d subprogram_line_extents) d.d_compilation_units; +|> + +(* **** verbose pp of simple die tree view *************** *) + +let pp_sdt_unspecified_parameter (level:sym_natural) (sup:sdt_unspecified_parameter) : string= + indent_level true level ^ "unspecified parameters" ^ "\n" + +let pp_parsed_single_location_description (level:sym_natural) ((n1:sym_natural), (n2:sym_natural), (ops:list operation)) : string= + let indent = indent_level true level in + indent + ^ pphex n1 + ^ " " ^ pphex n2 + ^ " (" ^ pp_operations ops ^")" + ^"\n" + +let pp_pc_ranges (level:sym_natural) (rso:maybe (list (sym_natural*sym_natural)))= + match rso with + | Nothing -> "none\n" + | Just rs -> + let indent = indent_level true level in + "\n" ^ String.concat "" (List.map (fun (n1,n2) -> indent ^ pphex n1 ^ " " ^ pphex n2 ^ "\n") rs) + end + +let pp_sdt_maybe x f= match x with Nothing -> "none\n" | Just y -> f y end +let pp_sdt_maybe' f x= pp_sdt_maybe x f +let pp_sdt_list xs f= match xs with [] -> "none\n" | _ -> "\n" ^ String.concat "" ((List.map f) xs) end + +let pp_sdt_variable_or_formal_parameter (level:sym_natural) (svfp: sdt_variable_or_formal_parameter) : string= + let indent = indent_level true level in + "" + ^ indent ^ "name:" ^ svfp.svfp_name ^ "\n" + ^ indent ^ "cupdie:" ^ pp_cupdie3 svfp.svfp_cupdie ^ "\n" + ^ indent ^ "kind:" ^ (match svfp.svfp_kind with SVPK_var -> "var" | SVPK_param -> "param" end) ^ "\n" + ^ indent ^ "type:" ^ pp_sdt_maybe' pp_type_info_deep svfp.svfp_type ^ "\n" + ^ indent ^ "const_value:" ^ show svfp.svfp_const_value ^ "\n" + ^ indent ^ "external:" ^ show svfp.svfp_external ^ "\n" + ^ indent ^ "declaration:" ^ show svfp.svfp_declaration ^ "\n" + ^ indent ^ "locations:" ^ pp_sdt_maybe svfp.svfp_locations (fun locs -> "\n" ^ String.concat "" (List.map (pp_parsed_single_location_description (level+1)) locs)) + ^ indent ^ "decl:" ^ pp_sdt_maybe svfp.svfp_decl (fun ud -> "\n" ^ indent_level true (level+1) ^ pp_ud ud ^ "\n") + ^ "\n" + +let rec pp_sdt_subroutine (level:sym_natural) (ss:sdt_subroutine) : string= + let indent = indent_level true level in + "" + ^ indent ^ "name:" ^ pp_sdt_maybe ss.ss_name (fun name -> name ^ "\n") + ^ indent ^ "cupdie:" ^ pp_cupdie3 ss.ss_cupdie ^ "\n" + ^ indent ^ "kind:" ^ (match ss.ss_kind with SSK_subprogram -> "subprogram" | SSK_inlined_subroutine -> "inlined subroutine" end) ^ "\n" + ^ indent ^ "call site:" ^ pp_sdt_maybe ss.ss_call_site (fun ud -> "\n" ^ indent_level true (level+1) ^ pp_ud ud ^ "\n") + ^ indent ^ "abstract origin:" ^ pp_sdt_maybe ss.ss_abstract_origin (pp_sdt_subroutine (level+1)) + ^ indent ^ "type:" ^ pp_sdt_maybe ss.ss_type (fun typ -> pp_type_info_deep typ ^"\n") + ^ indent ^ "vars:" ^ pp_sdt_list ss.ss_vars (pp_sdt_variable_or_formal_parameter (level+1)) + ^ indent ^ "unspecified_parameters:" ^ pp_sdt_list ss.ss_unspecified_parameters (pp_sdt_unspecified_parameter (level+1)) + ^ indent ^ "entry address: " ^ pp_sdt_maybe ss.ss_entry_address (fun n -> pphex n^"\n") + ^ indent ^ "pc ranges:" ^ pp_pc_ranges (level+1) ss.ss_pc_ranges + ^ indent ^ "subroutines:" ^ pp_sdt_list ss.ss_subroutines (pp_sdt_subroutine (level+1)) + ^ indent ^ "lexical_blocks:" ^ pp_sdt_list ss.ss_lexical_blocks (pp_sdt_lexical_block (level+1)) + ^ indent ^ "decl:" ^ pp_sdt_maybe ss.ss_decl (fun ud -> "\n" ^ indent_level true (level+1) ^ pp_ud ud ^ "\n") + ^ indent ^ "noreturn:" ^ show ss.ss_noreturn ^ "\n" + ^ indent ^ "external:" ^ show ss.ss_external ^"\n" + ^ "\n" + +and pp_sdt_lexical_block (level:sym_natural) (lb:sdt_lexical_block) : string= + let indent = indent_level true level in + "" + ^ indent ^ "cupdie:" ^ pp_cupdie3 lb.slb_cupdie ^ "\n" + ^ indent ^ "pc ranges:" ^ pp_pc_ranges (level+1) lb.slb_pc_ranges + ^ indent ^ "vars:" ^ pp_sdt_list lb.slb_vars (pp_sdt_variable_or_formal_parameter (level+1)) + ^ indent ^ "subroutines :" ^ pp_sdt_list lb.slb_subroutines (pp_sdt_subroutine (level+1)) + ^ indent ^ "lexical_blocks:" ^ pp_sdt_list lb.slb_lexical_blocks (pp_sdt_lexical_block (level+1)) + ^ "\n" + +let pp_sdt_compilation_unit (level:sym_natural) (cu:sdt_compilation_unit) : string= + let indent = indent_level true level in + "" + ^ indent ^ "name:" ^ cu.scu_name ^ "\n" + ^ indent ^ "cupdie:" ^ pp_cupdie3 cu.scu_cupdie ^ "\n" + ^ indent ^ "pc ranges:" ^ pp_pc_ranges (level+1) cu.scu_pc_ranges + ^ indent ^ "vars:" ^ pp_sdt_list cu.scu_vars (pp_sdt_variable_or_formal_parameter (level+1)) + ^ indent ^ "subroutines :" ^ pp_sdt_list cu.scu_subroutines (pp_sdt_subroutine (level+1)) + ^ "\n" + +let pp_sdt_dwarf (sdt_d:sdt_dwarf) : string= + let indent_level = 0 in + String.concat "" (List.map (pp_sdt_compilation_unit indent_level) sdt_d.sd_compilation_units) + +(* **** concise pp of simple die tree view *************** *) + +(* **************** global vars ************* *) + +let pp_sdt_concise_variable_or_formal_parameter (level:sym_natural) (svfp: sdt_variable_or_formal_parameter) : string= + let indent = indent_level true level in + "" + ^ indent + (* ^ indent ^ "cupdie:" ^ pp_cupdie3 svfp.svfp_cupdie ^ "\n"*) + (*^ indent ^ "name:" ^*) ^ svfp.svfp_name ^ " " + (*^ indent ^ "kind:" *) ^ (match svfp.svfp_kind with SVPK_var -> "var" | SVPK_param -> "param" end) ^ " " + (*^ indent ^ "type:" *) ^ pp_sdt_maybe' pp_type_info_deep svfp.svfp_type ^ " " + (*^ indent ^ "const_value:"*) ^ match svfp.svfp_const_value with | Nothing -> "" | Just v -> "const:"^show v ^ " " end + (*^ indent ^ "external:" ^ show svfp.svfp_external ^ "\n"*) + (*^ indent ^ "declaration:" ^ show svfp.svfp_declaration ^ "\n"*) +(*^ indent ^ "locations:" *) ^ (match svfp.svfp_locations with Nothing -> "no locations\n" | Just locs -> "\n" ^ String.concat "" (List.map (pp_parsed_single_location_description (level+1)) locs) end) +(* ^ indent ^ "decl:" ^ (match svfp.svfp_decl with Nothing -> "none\n" | Just ((ufe,line) as ud) -> "\n" ^ indent_level true (level+1) ^ pp_ufe ufe ^ " " ^ show line ^ "\n" end)*) + +let pp_sdt_globals_compilation_unit (level:sym_natural) (cu:sdt_compilation_unit) : string= + let indent = indent_level true level in + "" + (* ^ indent ^ "cupdie:" ^ pp_cupdie3 cu.scu_cupdie ^ "\n"*) + ^ indent ^ (*"name:" ^*) cu.scu_name ^ "\n" + (* ^ indent ^ "vars:" ^ "\n"*) ^ String.concat "" (List.map (pp_sdt_concise_variable_or_formal_parameter (level+1)) cu.scu_vars) +(* ^ indent ^ "subroutines :" ^ (match cu.scu_subroutines with | [] -> "none\n" | sus -> "\n" ^ String.concat "\n" (List.map (pp_sdt_subroutine (level+1)) sus) end) *) + +let pp_sdt_globals_dwarf (sdt_d:sdt_dwarf) : string= + let indent_level = 0 in + String.concat "" (List.map (pp_sdt_globals_compilation_unit indent_level) sdt_d.sd_compilation_units) + +(* ****************** local vars *************** *) + +let rec pp_sdt_locals_subroutine (level:sym_natural) (ss:sdt_subroutine) : string= + let indent = indent_level true level in + "" + ^ indent (*^ "name:" ^*) ^ pp_sdt_maybe ss.ss_name (fun name -> name ^ "\n") + (* ^ indent ^ "cupdie:" ^ pp_cupdie3 ss.ss_cupdie ^ "\n"*) + ^ indent ^ "kind:" ^ (match ss.ss_kind with SSK_subprogram -> "subprogram" | SSK_inlined_subroutine -> "inlined subroutine" end) ^ "\n" + ^ indent ^ "entry address: " ^ pp_sdt_maybe ss.ss_entry_address (fun n -> pphex n^"\n") + ^ indent ^ "call site:" ^ pp_sdt_maybe ss.ss_call_site (fun ud -> "\n" ^ indent_level true (level+1) ^ pp_ud ud ^ "\n") + ^ indent ^ "abstract origin:" ^ pp_sdt_maybe ss.ss_abstract_origin (fun s -> "\n" ^ pp_sdt_locals_subroutine (level+1) s) + (* ^ indent ^ "type:" ^ pp_sdt_maybe ss.ss_type (fun typ -> pp_type_info_deep typ ^"\n" end)*) + ^ indent ^ "vars:" ^ pp_sdt_list ss.ss_vars (pp_sdt_concise_variable_or_formal_parameter (level+1)) + ^ indent ^ "unspecified_parameters:" ^ pp_sdt_list ss.ss_unspecified_parameters (pp_sdt_unspecified_parameter (level+1)) + (* ^ indent ^ "pc ranges:" ^ pp_pc_ranges (level+1) ss.ss_pc_ranges*) + ^ indent ^ "subroutines:" ^ pp_sdt_list ss.ss_subroutines (pp_sdt_locals_subroutine (level+1)) + ^ indent ^ "lexical_blocks:" ^ pp_sdt_list ss.ss_lexical_blocks (pp_sdt_locals_lexical_block (level+1)) + (* ^ indent ^ "decl:" ^ pp_sdt_maybe ss.ss_decl (fun ((ufe,line) as ud) -> "\n" ^ indent_level true (level+1) ^ pp_ufe ufe ^ " " ^ show line ^ "\n" end)*) + (* ^ indent ^ "noreturn:" ^ show ss.ss_noreturn ^ "\n"*) + (* ^ indent ^ "external:" ^ show ss.ss_external ^"\n"*) + ^ "\n" + +and pp_sdt_locals_lexical_block (level:sym_natural) (lb:sdt_lexical_block) : string= + let indent = indent_level true level in + "" + (* ^ indent ^ "cupdie:" ^ pp_cupdie3 lb.slb_cupdie ^ "\n"*) + ^ indent ^ "vars:" ^ pp_sdt_list lb.slb_vars (pp_sdt_concise_variable_or_formal_parameter (level+1)) + (* ^ indent ^ "pc ranges:" ^ pp_pc_ranges (level+1) lb.slb_pc_ranges*) + ^ indent ^ "subroutines :" ^ pp_sdt_list lb.slb_subroutines (pp_sdt_locals_subroutine (level+1)) + ^ indent ^ "lexical_blocks:" ^ pp_sdt_list lb.slb_lexical_blocks (pp_sdt_locals_lexical_block (level+1)) + ^ "\n" + +let pp_sdt_locals_compilation_unit (level:sym_natural) (cu:sdt_compilation_unit) : string= + let indent = indent_level true level in + "" + ^ indent (*^ "name:" *) ^ cu.scu_name ^ "\n" + (* ^ indent ^ "cupdie:" ^ pp_cupdie3 cu.scu_cupdie ^ "\n"*) + ^ indent ^ "vars:" ^ pp_sdt_list cu.scu_vars (pp_sdt_concise_variable_or_formal_parameter (level+1)) + ^ indent ^ "subroutines :" ^ pp_sdt_list cu.scu_subroutines (pp_sdt_locals_subroutine (level+1)) + +let pp_sdt_locals_dwarf (sdt_d:sdt_dwarf) : string= + let indent_level = 0 in + String.concat "" (List.map (pp_sdt_locals_compilation_unit indent_level) sdt_d.sd_compilation_units) + +(** ************************************************************ *) +(** ** analysis of inlined_subroutine data *) +(** ************************************************************ *) + +(* old version, directly over die tree *) +(* +let strict_ais x e s z = + match x with + | Just y -> y + | Nothing -> + Assert_extra.failwith ("analyse_inlined_subroutine strict failure " ^ e ^ " on \n" ^ s z ^ "\n") + end + +val analyse_inlined_subroutines : dwarf -> inlined_subroutine_data +let analyse_inlined_subroutines (d: dwarf) : inlined_subroutine_data = + + let c = p_context_of_d d in + + let s (cu,parents,die) = pp_die c cu.cu_header d.d_str true 0 false die in + + let inlined_subroutines : list (compilation_unit * (list die) * die) = + find_dies + (fun die -> + die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_inlined_subroutine") + d in + + List.map + (fun (((cu:compilation_unit), (parents: list die), (die: die)) as inlined_subroutine) -> + + let ((cu',parents,die') as abstract_origin) : compilation_unit * (list die) * die = + strict_ais (find_reference_attribute_of_die c d cu d.d_str "DW_AT_abstract_origin" die) + "no abstract origin" s inlined_subroutine in + let name : string = + strict_ais (find_name_of_die d.d_str die') + "no abstract origin name" s abstract_origin in + let call_file : unpacked_file_entry = + let file_index = strict_ais (find_natural_attribute_value_of_die c "DW_AT_call_file" die) "no DW_AT_call_file" s inlined_subroutine in + unpack_file_entry (line_number_program_of_compilation_unit d cu).lnp_header file_index in + (* match filename d cu file_index with | Just s -> s | Nothing -> "none" end in*) + let call_line : natural = strict_ais (find_natural_attribute_value_of_die c "DW_AT_call_line" die) "no DW_AT_call_line" s inlined_subroutine in + let pc_ranges : list (natural*natural) = + strict_ais (closest_enclosing_range c d.d_ranges (cu_base_address cu) [die](*deliberately ignore parents*)) + "no pc ranges" s inlined_subroutine in + let const_params = + List.mapMaybe (fun die'' -> + if die''.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_formal_parameter" then + match find_reference_attribute_of_die c d cu d.d_str "DW_AT_abstract_origin" die'' with + | Nothing -> Nothing + | Just abstract_origin' -> + match find_integer_attribute_value_of_die c "DW_AT_const_value" die'' with + | Nothing -> Nothing + | Just n -> + Just (<| + iscp_abstract_origin = abstract_origin'; + iscp_value = n; + |>) + end + end + else + Nothing + ) die.die_children in + <| + is_inlined_subroutine = inlined_subroutine; + is_abstract_origin = abstract_origin; + is_name = name; + is_call_file = call_file; + is_call_line = call_line; + is_pc_ranges = pc_ranges; + is_const_params = const_params; + |> + ) + inlined_subroutines + *) + +(* new version, over simple-die-tree view, but still producing the previous old-style datastructure *) + +let analyse_inlined_subroutines_sdt_const_param (svfp:sdt_variable_or_formal_parameter) : maybe inlined_subroutine_const_param= + match (svfp.svfp_kind, svfp.svfp_abstract_origin, svfp.svfp_const_value) with + | (SVPK_param, Just svfp', Just n) -> + Just (<| + iscp_abstract_origin = svfp'.svfp_cupdie; + iscp_value = n; + |>) + | _ -> + Nothing + end + +let rec analyse_inlined_subroutines_sdt_subroutine (sdt_parents: list sdt_subroutine) (ss:sdt_subroutine) : list inlined_subroutine= + let this : list inlined_subroutine = + match (ss.ss_kind, ss.ss_abstract_origin) with + | (SSK_inlined_subroutine, Just ss') -> + let ((call_file:unpacked_file_entry),(call_line:sym_natural)) = + match ss.ss_call_site with + | Just (((ufe,line,subprogram_name) as ud):unpacked_decl) -> + (ufe,naturalFromNat line) + | Nothing -> + Assert_extra.failwith "analyse_inlined_subroutines_sdt_subroutine found no ss_call_site" + end in + let pc_ranges = match ss.ss_pc_ranges with | Just pc_ranges -> pc_ranges | Nothing -> Assert_extra.failwith "analyse_inlined_subroutines_sdt_subroutine found no ss_pc_ranges" end in + let const_params = List.mapMaybe analyse_inlined_subroutines_sdt_const_param ss.ss_vars in + [ (<| + is_inlined_subroutine = ss.ss_cupdie; + is_abstract_origin = ss'.ss_cupdie; + is_inlined_subroutine_sdt = ss; + is_inlined_subroutine_sdt_parents = sdt_parents; + is_name = match ss.ss_name with Just name->name | Nothing -> "no name" end; + is_call_file = call_file; + is_call_line = call_line; + is_pc_ranges = pc_ranges; + is_const_params = const_params; + |> + )] + | (SSK_inlined_subroutine, Nothing) -> + Assert_extra.failwith "analyse_inlined_subroutines_sdt_subroutine found SSK_inlined_subroutine without ss_abstract_origin" + | _ -> + [] + end in + let sdt_parents' = ss::sdt_parents in + + this + ++ List.concatMap (analyse_inlined_subroutines_sdt_subroutine sdt_parents') ss.ss_subroutines + ++ List.concatMap (analyse_inlined_subroutines_sdt_lexical_block sdt_parents') ss.ss_lexical_blocks + + +and analyse_inlined_subroutines_sdt_lexical_block sdt_parents (lb:sdt_lexical_block) : list inlined_subroutine= + List.concatMap (analyse_inlined_subroutines_sdt_subroutine sdt_parents) lb.slb_subroutines + ++ List.concatMap (analyse_inlined_subroutines_sdt_lexical_block sdt_parents) lb.slb_lexical_blocks + +let analyse_inlined_subroutines_sdt_compilation_unit (cu:sdt_compilation_unit) : list inlined_subroutine= + List.concatMap (analyse_inlined_subroutines_sdt_subroutine []) cu.scu_subroutines + +let analyse_inlined_subroutines_sdt_dwarf (sd: sdt_dwarf) : list inlined_subroutine= + List.concatMap analyse_inlined_subroutines_sdt_compilation_unit sd.sd_compilation_units + + +let analyse_inlined_subroutine_by_range (is:inlined_subroutine) : inlined_subroutine_data_by_range= + let n_ranges = List.length is.is_pc_ranges in + List.mapi (fun i -> fun (n1,n2) -> ((n1,n2),(naturalFromNat i, naturalFromNat n_ranges),is)) is.is_pc_ranges + + +let is_lt ((n1,n2),(m,n),is) ((n1',n2'),(m',n'),is')= n1 < n1' || (n1 = n1' && n2 > n2') + +let analyse_inlined_subroutines_by_range (iss:inlined_subroutine_data) : inlined_subroutine_data_by_range= + Sorting.sortBy is_lt (List.concat (List.map analyse_inlined_subroutine_by_range iss)) + +(* pp the inlined_subroutine tree structure. Technically these die offsets each also need the compilation-unit offset to be globally unique, but that's locally constant *) +let rec pp_inlined_subroutine_parents (ds:list die) : string= + match ds with + | [] -> "" + | die::ds' -> + if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_inlined_subroutine" then + pp_pos die.die_offset ^ ":" ^ pp_inlined_subroutine_parents ds' + else if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_lexical_block" then ":" ^ pp_inlined_subroutine_parents ds' + else if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_subprogram" then "" + else "" + end + + +let pp_inlined_subroutine_header ds is= + is.is_name + ^ " inlined from " ^ (subprogram_at_line ds.ds_subprogram_line_extents is.is_call_file is.is_call_line) ^ ":" ^ show is.is_call_line ^ " (" ^ (pp_ufe_brief is.is_call_file) ^ ")" + ^ " " + ^ let (cu,parents,die) = is.is_inlined_subroutine in + pp_inlined_subroutine_parents (die::parents) + +let pp_inlined_subroutine_const_params d is= + let c = p_context_of_d d in + match is.is_const_params with + | [] -> "" + | _ -> + String.concat "" + (List.map + (fun iscp -> + let fake_als : analysed_location_data = [(iscp.iscp_abstract_origin,Nothing)] in + let fake_diff = pp_analysed_locations3_diff c (*HACK*) d d.d_str [] fake_als in + let const_in_place_of_locs = + List.map + (fun (removed,(name,offset,kind),typ,locs,parents) -> + (removed,(name,offset,kind),typ,"const="^show iscp.iscp_value,parents)) + fake_diff in + pp_analysed_location_format const_in_place_of_locs + ) + is.is_const_params) + end + +let pp_inlined_subroutine ds is= + pp_inlined_subroutine_header ds is ^ "\n" + ^ String.concat "" (List.map (fun (n1,n2) -> " " ^ pphex n1 ^ " " ^ pphex n2 ^ "\n") is.is_pc_ranges) + ^ pp_inlined_subroutine_const_params ds.ds_dwarf is + +let pp_inlined_subroutines ds iss= + String.concat "" (List.map (pp_inlined_subroutine ds) iss) + + +let pp_inlined_subroutine_by_range ds ((n1,n2),((m:sym_natural),(n:sym_natural)),is)= + pphex n1 ^ " " ^ pphex n2 ^ " " + ^ (if n<>1 then "("^show m^" of "^show n^") " else "") + ^ pp_inlined_subroutine_header ds is + ^"\n" + ^ (if m=0 then pp_inlined_subroutine_const_params ds.ds_dwarf is else "") + +let pp_inlined_subroutines_by_range ds iss= + String.concat "" (List.map (pp_inlined_subroutine_by_range ds) iss) + +(** ************************************************************ *) +(** ** pp of text section *) +(** ************************************************************ *) + +(* assume 4-byte ARM instructions *) + + +let rec words_of_byte_sequence (addr:sym_natural) (bs:byte_sequence) (acc:list (sym_natural * sym_natural)) : list (sym_natural * sym_natural)= + match read_4_bytes_be bs with + | Success ((b0,b1,b2,b3), bs') -> + let i : sym_natural = natural_of_byte b0 + 256*natural_of_byte b1 + 65536*natural_of_byte b2 + 65536*256*natural_of_byte b3 in + words_of_byte_sequence (addr+4) bs' ((addr,i)::acc) + | Fail _ -> List.reverse acc + end + +let pp_instruction ((addr:sym_natural),(i:sym_natural))= + hex_string_of_big_int_pad8 addr ^ " " ^ hex_string_of_big_int_pad8 i ^ "\n" + +val pp_text_section : elf_file -> string +let pp_text_section f= + let (p_context, addr, bs) = extract_text f in + let instructions : list (sym_natural * sym_natural) = words_of_byte_sequence addr bs [] in + String.concat "" (List.map pp_instruction instructions) + +(** ************************************************************ *) +(** ** top level for main_elf ******************************** *) +(** ************************************************************ *) + +val harness_string_of_elf_like_objdump : elf_file -> byte_sequence -> string +let harness_string_of_elf_like_objdump f1 bs= + let mds = extract_dwarf_static f1 in + match mds with + | Nothing -> "" + | Just ds -> + "" (*pp_text_section f1*) + ^ pp_dwarf_like_objdump ds.ds_dwarf + end + + +val harness_string_of_elf : elf_file -> byte_sequence -> string +let harness_string_of_elf f1 bs= + let mds = extract_dwarf_static f1 in + match mds with + | Nothing -> "" + | Just ds -> + let sdt_d = mk_sdt_dwarf ds.ds_dwarf ds.ds_subprogram_line_extents in + + "* emacs outline-mode configuration -*-outline-*- C-c C-{t,a,d,e}" + ^ "" (*pp_text_section f1*) + ^ pp_dwarf ds.ds_dwarf + (* ^ analyse_locations_raw c d *) + + ^ "************** evaluation of frame data *************************\n" + ^ pp_evaluated_frame_info ds.ds_evaluated_frame_info + ^ "************** analysis of location data *************************\n" + ^ pp_analysed_location_data ds.ds_dwarf ds.ds_analysed_location_data + ^ "************** line info *************************\n" + ^ pp_evaluated_line_info ds.ds_evaluated_line_info + + ^ "************** inlined subroutine info *************************\n" + ^ let iss = analyse_inlined_subroutines_sdt_dwarf sdt_d in + pp_inlined_subroutines ds iss + ^ "************** inlined subroutine info by range *************************\n" + ^ pp_inlined_subroutines_by_range ds (analyse_inlined_subroutines_by_range iss) + ^ "************** subprogram line-number extent info *************************\n" + ^ pp_subprograms ds.ds_subprogram_line_extents + ^ "************** simple die tree *************************\n" + ^ pp_sdt_dwarf sdt_d + ^ "************** simple die tree globals *************************\n" + ^ pp_sdt_globals_dwarf sdt_d + ^ "************** simple die tree locals *************************\n" + ^ pp_sdt_locals_dwarf sdt_d + + +end + + +val harness_string_of_elf64_debug_info_section : elf64_file -> byte_sequence -> (*(natural -> string) -> (natural -> string) -> (natural -> string) -> elf64_header -> elf64_section_header_table -> string_table -> *) string +let {ocaml} harness_string_of_elf64_debug_info_section f1 bs0= + (*os proc usr hdr sht stbl*) harness_string_of_elf (ELF_File_64 f1) bs0 + +val harness_string_of_elf32_debug_info_section : elf32_file -> byte_sequence -> (* (natural -> string) -> (natural -> string) -> (natural -> string) -> elf32_header -> elf32_section_header_table -> string_table ->*) string +let {ocaml} harness_string_of_elf32_debug_info_section f1 bs0= + (*os proc usr hdr sht stbl*) harness_string_of_elf (ELF_File_32 f1) bs0 + + + +val harness_string_of_elf64_like_objdump : elf64_file -> byte_sequence -> (*(natural -> string) -> (natural -> string) -> (natural -> string) -> elf64_header -> elf64_section_header_table -> string_table -> *) string +let {ocaml} harness_string_of_elf64_like_objdump f1 bs0= + (*os proc usr hdr sht stbl*) harness_string_of_elf_like_objdump (ELF_File_64 f1) bs0 + +val harness_string_of_elf32_like_objdump : elf32_file -> byte_sequence -> (* (natural -> string) -> (natural -> string) -> (natural -> string) -> elf32_header -> elf32_section_header_table -> string_table ->*) string +let {ocaml} harness_string_of_elf32_like_objdump f1 bs0= + (*os proc usr hdr sht stbl*) harness_string_of_elf_like_objdump (ELF_File_32 f1) bs0 + + diff --git a/src/dwarf.lem b/src/dwarf.lem index 070c228..0611a28 100644 --- a/src/dwarf.lem +++ b/src/dwarf.lem @@ -62,8 +62,8 @@ The last collects all the above - information that can be computed statically. Then to do lookup from addresses to source-code names, we have: type analysed_location_data_at_pc - val analysed_locations_at_pc : evaluation_context -> dwarf_static -> natural -> analysed_location_data_at_pc - val names_of_address : dwarf -> analysed_location_data_at_pc -> natural -> list string + val analysed_locations_at_pc : evaluation_context -> dwarf_static -> sym_natural -> analysed_location_data_at_pc + val names_of_address : dwarf -> analysed_location_data_at_pc -> sym_natural -> list string The definitions are deliberately simple-minded, to be quick to write, easy to see the correspondence to the DWARF text specification, and @@ -109,7 +109,7 @@ The 'dwarf' type gives a lightly parsed representation of some of the dwarf information, with the byte sequences of the above .debug_* sections parsed into a structured representation. That makes the list and tree structures explicit, and converts the various numeric types -into just natural, integer, and byte sequences. The lem natural and +into just sym_natural, integer, and byte sequences. The lem sym_natural and integer could be replaced by unsigned and signed 64-bit types; that'd probably be better for execution but not for theorem-prover use. @@ -132,6 +132,101 @@ let my_debug4 s = print_endline s let my_debug5 s = print_endline s +(* Symbolic types *) +type sym_natural = + | Offset of (string * natural) + | Absolute of natural + | Unknown + +let sym_add x y= + match (x, y) with + | (Absolute x, Absolute y) -> Absolute (x + y) + | (Offset (s, x), Absolute y) -> Offset (s, x + y) + | (Absolute x, Offset (s, y)) -> Offset (s, x + y) + | _ -> Unknown + end + +val sym_bind : sym_natural -> (natural -> sym_natural) -> sym_natural +let sym_bind x f = match x with + | Absolute x -> f x + | _ -> Unknown +end + +let sym_map f x = sym_bind x (fun x -> Absolute(f x)) + +let sym_map2 f x y = sym_bind x (fun x -> sym_map (f x) y) + +let sym_unwrap = function + | Absolute x -> x + | _ -> Assert_extra.failwith "sym_unwrap" +end + +instance (NumAdd sym_natural) + let (+) = sym_add +end + +instance (NumMinus sym_natural) + let (-) = sym_map2 (-) +end + +instance (NumMult sym_natural) + let ( * ) = sym_map2 ( * ) +end + +instance (NumDivision sym_natural) + let (/) = sym_map2 (/) +end + +instance (NumRemainder sym_natural) + let (mod) = sym_map2 (mod) +end + +instance (Ord sym_natural) + let compare = (fun x -> fun y -> compare (sym_unwrap x) (sym_unwrap y)) + let (<) = (fun x -> fun y -> (sym_unwrap x) < (sym_unwrap y)) + let (<=) = (fun x -> fun y -> (sym_unwrap x) <= (sym_unwrap y)) + let (>) = (fun x -> fun y -> (sym_unwrap x) > (sym_unwrap y)) + let (>=) = (fun x -> fun y -> (sym_unwrap x) >= (sym_unwrap y)) +end + +instance (Numeral sym_natural) + let fromNumeral = fun x -> Absolute (fromNumeral x) +end + +let pp_sym ppf = function +| Absolute x -> ppf x +| Offset (s, x) -> s ^ "+" ^ ppf x +| Unknown -> "Unknown" +end + +instance (Show sym_natural) + let show = pp_sym show +end + +let sym_natural_land = sym_map2 natural_land +let sym_natural_lxor = sym_map2 natural_lxor +let sym_natural_lor = sym_map2 natural_lor + +let integerFromSymNatural = function + | Absolute x -> integerFromNatural x + | _ -> Assert_extra.failwith "integerFromSymNatural" +end + +let natFromSymNatural = function + | Absolute x -> natFromNatural x + | _ -> Assert_extra.failwith "integerFromSymNatural" +end + +let symNaturalFromNat x = Absolute (naturalFromNat x) + +let sym_natural_of_hex x = Absolute(natural_of_hex x) + +let sym_natural_of_byte x = Absolute(natural_of_byte x) + +let symNaturalPow x y = sym_map (fun x -> naturalPow x y) x + +let symNaturalFromInteger x = Absolute(naturalFromInteger x) + (** ************************************************************ *) (** ** dwarf representation types **************************** *) (** ************************************************************ *) @@ -170,18 +265,18 @@ type operation_argument_type = | OAT_block type operation_argument_value = - | OAV_natural of natural + | OAV_natural of sym_natural | OAV_integer of integer - | OAV_block of natural * byte_sequence + | OAV_block of sym_natural * byte_sequence -type operation_stack = list natural +type operation_stack = list sym_natural type arithmetic_context = <| - ac_bitwidth: natural; - ac_half: natural; (* 2 ^ (ac_bitwidth -1) *) - ac_all: natural; (* 2 ^ ac_bitwidth *) - ac_max: natural; (* (2 ^ ac_bitwidth) -1 *) (* also the representation of -1 *) + ac_bitwidth: sym_natural; + ac_half: sym_natural; (* 2 ^ (ac_bitwidth -1) *) + ac_all: sym_natural; (* 2 ^ ac_bitwidth *) + ac_max: sym_natural; (* (2 ^ ac_bitwidth) -1 *) (* also the representation of -1 *) |> type operation_semantics = @@ -189,9 +284,9 @@ type operation_semantics = | OpSem_deref | OpSem_stack of (arithmetic_context -> operation_stack -> list operation_argument_value -> maybe operation_stack) | OpSem_not_supported - | OpSem_binary of (arithmetic_context -> natural -> natural -> maybe natural) - | OpSem_unary of (arithmetic_context -> natural -> maybe natural) - | OpSem_opcode_lit of natural + | OpSem_binary of (arithmetic_context -> sym_natural -> sym_natural -> maybe sym_natural) + | OpSem_unary of (arithmetic_context -> sym_natural -> maybe sym_natural) + | OpSem_opcode_lit of sym_natural | OpSem_reg | OpSem_breg | OpSem_bregx @@ -206,7 +301,7 @@ type operation_semantics = type operation = <| - op_code: natural; + op_code: sym_natural; op_string: string; op_argument_values: list operation_argument_value; op_semantics: operation_semantics; @@ -216,14 +311,14 @@ type operation = (* the result of a location expression evaluation is a single_location (or failure) *) type simple_location = - | SL_memory_address of natural - | SL_register of natural + | SL_memory_address of sym_natural + | SL_register of sym_natural | SL_implicit of byte_sequence (* used for implicit and stack values *) | SL_empty type composite_location_piece = - | CLP_piece of natural * simple_location - | CLP_bit_piece of natural * natural * simple_location + | CLP_piece of sym_natural * simple_location + | CLP_bit_piece of sym_natural * sym_natural * simple_location type single_location = | SL_simple of simple_location @@ -241,19 +336,19 @@ type state = (* location expression evaluation can involve register and memory reads, via the following interface *) type register_read_result 'a = - | RRR_result of natural + | RRR_result of sym_natural | RRR_not_currently_available | RRR_bad_register_number type memory_read_result 'a = - | MRR_result of natural + | MRR_result of sym_natural | MRR_not_currently_available | MRR_bad_address type evaluation_context = <| - read_register: natural -> register_read_result natural; - read_memory: natural -> natural -> memory_read_result natural; + read_register: sym_natural -> register_read_result sym_natural; + read_memory: sym_natural -> sym_natural -> memory_read_result sym_natural; |> @@ -267,55 +362,55 @@ type dwarf_format = type abbreviation_declaration = <| - ad_abbreviation_code: natural; - ad_tag: natural; + ad_abbreviation_code: sym_natural; + ad_tag: sym_natural; ad_has_children: bool; - ad_attribute_specifications: list (natural * natural); + ad_attribute_specifications: list (sym_natural * sym_natural); |> type abbreviations_table = <| - at_offset: natural; + at_offset: sym_natural; at_table: list abbreviation_declaration; |> (* .debug_info section *) type attribute_value = (* following Figure 3 *) - | AV_addr of natural - | AV_block of natural * byte_sequence - | AV_constantN of natural * byte_sequence + | AV_addr of sym_natural + | AV_block of sym_natural * byte_sequence + | AV_constantN of sym_natural * byte_sequence | AV_constant_SLEB128 of integer - | AV_constant_ULEB128 of natural - | AV_exprloc of natural * byte_sequence + | AV_constant_ULEB128 of sym_natural + | AV_exprloc of sym_natural * byte_sequence | AV_flag of bool - | AV_ref of natural - | AV_ref_addr of natural (* dwarf_format dependent *) - | AV_ref_sig8 of natural - | AV_sec_offset of natural + | AV_ref of sym_natural + | AV_ref_addr of sym_natural (* dwarf_format dependent *) + | AV_ref_sig8 of sym_natural + | AV_sec_offset of sym_natural | AV_string of byte_sequence (* not including terminating null *) - | AV_strp of natural (* dwarf_format dependent *) + | AV_strp of sym_natural (* dwarf_format dependent *) type die = <| - die_offset: natural; - die_abbreviation_code: natural; + die_offset: sym_natural; + die_abbreviation_code: sym_natural; die_abbreviation_declaration: abbreviation_declaration; - die_attribute_values: list (natural (*pos*) * attribute_value); + die_attribute_values: list (sym_natural (*pos*) * attribute_value); die_children: list die; |> -type die_index = Map.map natural (list die * die) +type die_index = Map.map sym_natural (list die * die) type compilation_unit_header = <| - cuh_offset: natural; + cuh_offset: sym_natural; cuh_dwarf_format: dwarf_format; - cuh_unit_length: natural; - cuh_version: natural; - cuh_debug_abbrev_offset: natural; - cuh_address_size: natural; + cuh_unit_length: sym_natural; + cuh_version: sym_natural; + cuh_debug_abbrev_offset: sym_natural; + cuh_address_size: sym_natural; |> type compilation_unit = @@ -333,8 +428,8 @@ type compilation_units = list compilation_unit type type_unit_header = <| tuh_cuh: compilation_unit_header; - tuh_type_signature: natural; - tuh_type_offset: natural; + tuh_type_signature: sym_natural; + tuh_type_offset: sym_natural; |> type type_unit = @@ -352,21 +447,21 @@ type single_location_description = byte_sequence type location_list_entry = <| - lle_beginning_address_offset: natural; - lle_ending_address_offset: natural; + lle_beginning_address_offset: sym_natural; + lle_ending_address_offset: sym_natural; lle_single_location_description: single_location_description; |> type base_address_selection_entry = <| - base_address: natural; + base_address: sym_natural; |> type location_list_item = | LLI_lle of location_list_entry | LLI_base of base_address_selection_entry -type location_list = natural (*offset*) * list location_list_item +type location_list = sym_natural (*offset*) * list location_list_item type location_list_list = list location_list @@ -374,25 +469,25 @@ type location_list_list = list location_list type range_list_entry = <| - rle_beginning_address_offset: natural; - rle_ending_address_offset: natural; + rle_beginning_address_offset: sym_natural; + rle_ending_address_offset: sym_natural; |> type range_list_item = | RLI_rle of range_list_entry | RLI_base of base_address_selection_entry -type range_list = natural (*offset (of range_list from start of .debug_ranges section?) *) * list range_list_item +type range_list = sym_natural (*offset (of range_list from start of .debug_ranges section?) *) * list range_list_item type range_list_list = list range_list (* .debug_frame section: call frame instructions *) -type cfa_address = natural +type cfa_address = sym_natural type cfa_block = byte_sequence -type cfa_delta = natural -type cfa_offset = natural -type cfa_register = natural +type cfa_delta = sym_natural +type cfa_offset = sym_natural +type cfa_register = sym_natural type cfa_sfoffset = integer type call_frame_argument_type = @@ -448,14 +543,14 @@ type call_frame_instruction = type cie = <| - cie_offset: natural; - cie_length: natural; - cie_id: natural; - cie_version: natural; + cie_offset: sym_natural; + cie_length: sym_natural; + cie_id: sym_natural; + cie_version: sym_natural; cie_augmentation: byte_sequence; (* not including terminating null *) - cie_address_size: maybe natural; - cie_segment_size: maybe natural; - cie_code_alignment_factor: natural; + cie_address_size: maybe sym_natural; + cie_segment_size: maybe sym_natural; + cie_code_alignment_factor: sym_natural; cie_data_alignment_factor: integer; cie_return_address_register: cfa_register; cie_initial_instructions_bytes: byte_sequence; @@ -464,12 +559,12 @@ type cie = type fde = <| - fde_offset: natural; - fde_length: natural; - fde_cie_pointer: natural; - fde_initial_location_segment_selector: maybe natural; - fde_initial_location_address: natural; - fde_address_range: natural; + fde_offset: sym_natural; + fde_length: sym_natural; + fde_cie_pointer: sym_natural; + fde_initial_location_segment_selector: maybe sym_natural; + fde_initial_location_address: sym_natural; + fde_address_range: sym_natural; fde_instructions_bytes: byte_sequence; fde_instructions: list call_frame_instruction; |> @@ -497,7 +592,7 @@ type register_rule = is the current CFA value and N is a signed offset.*) | RR_val_offset of integer (* The previous value of this register is the value CFA+N where CFA is the current CFA value and N is a signed offset.*) - | RR_register of natural (* The previous value of this register is stored in another register numbered R.*) + | RR_register of sym_natural (* The previous value of this register is stored in another register numbered R.*) | RR_expression of single_location_description (* The previous value of this register is located at the address produced by executing the DWARF expression E.*) | RR_val_expression of single_location_description (* The previous value of this register is the value produced by executing the @@ -508,7 +603,7 @@ type register_rule_map = list (cfa_register * register_rule) type cfa_table_row = <| - ctr_loc: natural; + ctr_loc: sym_natural; ctr_cfa: cfa_rule; ctr_regs: register_rule_map; |> @@ -536,56 +631,56 @@ type line_number_argument_type = | LNAT_string type line_number_argument_value = - | LNAV_address of natural - | LNAV_ULEB128 of natural + | LNAV_address of sym_natural + | LNAV_ULEB128 of sym_natural | LNAV_SLEB128 of integer - | LNAV_uint16 of natural + | LNAV_uint16 of sym_natural | LNAV_string of byte_sequence (* not including terminating null *) type line_number_operation = (* standard *) | DW_LNS_copy - | DW_LNS_advance_pc of natural + | DW_LNS_advance_pc of sym_natural | DW_LNS_advance_line of integer - | DW_LNS_set_file of natural - | DW_LNS_set_column of natural + | DW_LNS_set_file of sym_natural + | DW_LNS_set_column of sym_natural | DW_LNS_negate_stmt | DW_LNS_set_basic_block | DW_LNS_const_add_pc - | DW_LNS_fixed_advance_pc of natural + | DW_LNS_fixed_advance_pc of sym_natural | DW_LNS_set_prologue_end | DW_LNS_set_epilogue_begin - | DW_LNS_set_isa of natural + | DW_LNS_set_isa of sym_natural (* extended *) | DW_LNE_end_sequence - | DW_LNE_set_address of natural - | DW_LNE_define_file of byte_sequence * natural * natural * natural - | DW_LNE_set_discriminator of natural + | DW_LNE_set_address of sym_natural + | DW_LNE_define_file of byte_sequence * sym_natural * sym_natural * sym_natural + | DW_LNE_set_discriminator of sym_natural (* special *) - | DW_LN_special of natural (* the adjusted opcode *) + | DW_LN_special of sym_natural (* the adjusted opcode *) type line_number_file_entry = <| lnfe_path: byte_sequence; - lnfe_directory_index: natural; - lnfe_last_modification: natural; - lnfe_length: natural; + lnfe_directory_index: sym_natural; + lnfe_last_modification: sym_natural; + lnfe_length: sym_natural; |> type line_number_header = <| - lnh_offset: natural; + lnh_offset: sym_natural; lnh_dwarf_format: dwarf_format; - lnh_unit_length: natural; - lnh_version: natural; - lnh_header_length: natural; - lnh_minimum_instruction_length: natural; - lnh_maximum_operations_per_instruction: natural; + lnh_unit_length: sym_natural; + lnh_version: sym_natural; + lnh_header_length: sym_natural; + lnh_minimum_instruction_length: sym_natural; + lnh_maximum_operations_per_instruction: sym_natural; lnh_default_is_stmt: bool; lnh_line_base: integer; - lnh_line_range: natural; - lnh_opcode_base: natural; - lnh_standard_opcode_lengths: list natural; + lnh_line_range: sym_natural; + lnh_opcode_base: sym_natural; + lnh_standard_opcode_lengths: list sym_natural; lnh_include_directories: list (byte_sequence); lnh_file_entries: list line_number_file_entry; lnh_comp_dir: maybe string; (* passed down from cu DW_AT_comp_dir *) @@ -601,18 +696,18 @@ type line_number_program = type line_number_registers = <| - lnr_address: natural; - lnr_op_index: natural; - lnr_file: natural; - lnr_line: natural; - lnr_column: natural; + lnr_address: sym_natural; + lnr_op_index: sym_natural; + lnr_file: sym_natural; + lnr_line: sym_natural; + lnr_column: sym_natural; lnr_is_stmt: bool; lnr_basic_block: bool; lnr_end_sequence: bool; lnr_prologue_end: bool; lnr_epilogue_begin: bool; - lnr_isa: natural; - lnr_discriminator: natural; + lnr_isa: sym_natural; + lnr_discriminator: sym_natural; |> type unpacked_file_entry = (maybe string (*comp_dir*)) * (maybe string (*dir*)) * string (*file*) @@ -636,9 +731,9 @@ type dwarf = (* analysed location data *) -type analysed_location_data = list ((compilation_unit * (list die) * die) * maybe (list (natural * natural * single_location_description))) +type analysed_location_data = list ((compilation_unit * (list die) * die) * maybe (list (sym_natural * sym_natural * single_location_description))) -type analysed_location_data_at_pc = list ((compilation_unit * (list die) * die) * (natural * natural * single_location_description * error single_location)) +type analysed_location_data_at_pc = list ((compilation_unit * (list die) * die) * (sym_natural * sym_natural * single_location_description * error single_location)) (* evaluated line data *) @@ -652,7 +747,7 @@ type dwarf_static = ds_analysed_location_data: analysed_location_data; ds_evaluated_frame_info: evaluated_frame_info; ds_evaluated_line_info: evaluated_line_info; - ds_subprogram_line_extents: list (unpacked_file_entry * list (string * unpacked_file_entry * natural) ); + ds_subprogram_line_extents: list (unpacked_file_entry * list (string * unpacked_file_entry * sym_natural) ); |> type dwarf_dynamic_at_pc = analysed_location_data_at_pc @@ -674,12 +769,12 @@ type cupdie = compilation_unit * (list die) * die type decl = <| decl_file: maybe string; - decl_line: maybe natural; + decl_line: maybe sym_natural; |> -type array_dimension 't = maybe natural(*count*) * maybe 't(*subrange type*) +type array_dimension 't = maybe sym_natural(*count*) * maybe 't(*subrange type*) -type struct_union_member 't = cupdie * (maybe string)(*mname*) * 't * maybe natural(*data_member_location, non-Nothing for structs*) +type struct_union_member 't = cupdie * (maybe string)(*mname*) * 't * maybe sym_natural(*data_member_location, non-Nothing for structs*) type struct_union_type_kind = | Atk_structure @@ -689,15 +784,15 @@ type enumeration_member = cupdie * (maybe string)(*mname*) * integer(*const_valu type c_type_top 't = | CT_missing of cupdie - | CT_base of cupdie * string(*name*) * natural(*encoding*) * (maybe natural)(*byte_size*) + | CT_base of cupdie * string(*name*) * sym_natural(*encoding*) * (maybe sym_natural)(*byte_size*) | CT_pointer of cupdie * maybe 't | CT_const of cupdie * maybe 't | CT_volatile of cupdie * 't | CT_restrict of cupdie * 't | CT_typedef of cupdie * string(*name*) * 't * decl | CT_array of cupdie * 't * list (array_dimension 't) - | CT_struct_union of cupdie * struct_union_type_kind * (maybe string)(*mname*) * (maybe natural)(*byte_size*) * decl * maybe (list (struct_union_member 't)(*members*)) - | CT_enumeration of cupdie * (maybe string)(*mname*) * (maybe 't)(*mtyp*) * (maybe natural)(*mbyte_size*) * decl * maybe (list (enumeration_member)(*members*)) + | CT_struct_union of cupdie * struct_union_type_kind * (maybe string)(*mname*) * (maybe sym_natural)(*byte_size*) * decl * maybe (list (struct_union_member 't)(*members*)) + | CT_enumeration of cupdie * (maybe string)(*mname*) * (maybe 't)(*mtyp*) * (maybe sym_natural)(*mbyte_size*) * decl * maybe (list (enumeration_member)(*members*)) | CT_subroutine of cupdie * (bool)(*prototyped*) * (maybe 't)(*mresult_type*) * (list 't)(*parameter_types*) * (bool)(*variable_parameter_list*) (* In the CT_struct_union and C_enumeration cases, the final maybe(list(...member)) is Nothing if the analysis has not been recursed into the members, and Just ... if it has - which will typically be only one level deep *) @@ -731,7 +826,7 @@ type sdt_variable_or_formal_parameter = svfp_const_value : maybe integer; svfp_external : bool; svfp_declaration : bool; - svfp_locations : maybe (list (natural * natural * list operation (*the parsed single_location_description*))); + svfp_locations : maybe (list (sym_natural * sym_natural * list operation (*the parsed single_location_description*))); svfp_decl : maybe unpacked_decl; |> @@ -748,8 +843,8 @@ type sdt_subroutine = (* subprogram or inlined subroutine *) ss_abstract_origin : maybe sdt_subroutine; (* invariant: non-Nothing iff inlined *) ss_type : maybe c_type; ss_vars : list sdt_variable_or_formal_parameter; - ss_pc_ranges : maybe (list (natural*natural)); - ss_entry_address : maybe natural; + ss_pc_ranges : maybe (list (sym_natural*sym_natural)); + ss_entry_address : maybe sym_natural; ss_unspecified_parameters : list sdt_unspecified_parameter; ss_subroutines : list sdt_subroutine; (* invariant: all inlined*) ss_lexical_blocks : list sdt_lexical_block; @@ -762,7 +857,7 @@ and sdt_lexical_block = <| slb_cupdie : cupdie; slb_vars : list sdt_variable_or_formal_parameter; (* invariant: all variables *) - slb_pc_ranges : maybe (list (natural*natural)); + slb_pc_ranges : maybe (list (sym_natural*sym_natural)); slb_subroutines : list sdt_subroutine; (* invariant: all inlined*) slb_lexical_blocks : list sdt_lexical_block; |> @@ -773,7 +868,7 @@ type sdt_compilation_unit = scu_name : string; scu_subroutines : list sdt_subroutine; (* invariant: none inlined(?) *) scu_vars : list sdt_variable_or_formal_parameter; - scu_pc_ranges : maybe (list (natural*natural)); + scu_pc_ranges : maybe (list (sym_natural*sym_natural)); |> type sdt_dwarf = @@ -797,19 +892,19 @@ type inlined_subroutine = is_inlined_subroutine_sdt_parents: list sdt_subroutine; is_name : string; is_call_file: unpacked_file_entry; - is_call_line: natural; - is_pc_ranges: list (natural * natural); + is_call_line: sym_natural; + is_pc_ranges: list (sym_natural * sym_natural); is_const_params : list inlined_subroutine_const_param; |> (* ignoring the nesting structure of inlined subroutines for now *) type inlined_subroutine_data = list inlined_subroutine -type inlined_subroutine_data_by_range_entry = (natural*natural)(*range*) * (natural*natural) (*range m-of-n*) * inlined_subroutine +type inlined_subroutine_data_by_range_entry = (sym_natural*sym_natural)(*range*) * (sym_natural*sym_natural) (*range m-of-n*) * inlined_subroutine type inlined_subroutine_data_by_range = list inlined_subroutine_data_by_range_entry -(*type inlined_subroutine_data_at_pc = list ((compilation_unit * (list die) * die) * (natural * natural * single_location_description * error single_location))*) +(*type inlined_subroutine_data_at_pc = list ((compilation_unit * (list die) * die) * (sym_natural * sym_natural * single_location_description * error single_location))*) @@ -822,7 +917,7 @@ type inlined_subroutine_data_by_range = list inlined_subroutine_data_by_range_en (** ** missing pervasives ************************************ *) (** ************************************************************ *) -(* natural version of List.index *) +(* sym_natural version of List.index *) val index_natural : forall 'a. list 'a -> natural -> maybe 'a let rec index_natural l n = match l with | [] -> Nothing @@ -838,6 +933,12 @@ declare ocaml target_rep function natural_nat_shift_left = `Nat_big_num.shift val natural_nat_shift_right : natural -> nat -> natural declare ocaml target_rep function natural_nat_shift_right = `Nat_big_num.shift_right` +let index_sym_natural l n = index_natural l (sym_unwrap n) + +let partialSymNaturalFromInteger i = Absolute (partialNaturalFromInteger i) + +let sym_natural_nat_shift_left x sh = sym_map (fun x -> natural_nat_shift_left x sh) x +let sym_natural_nat_shift_right x sh = sym_map (fun x -> natural_nat_shift_right x sh) x (** ************************************************************ *) (** ** endianness *************************************** *) @@ -855,389 +956,389 @@ let p_context_of_d (d:dwarf) : p_context = <| endianness = d.d_endianness |> (* tag encoding *) let tag_encodings = [ - ("DW_TAG_array_type" , natural_of_hex "0x01" ); - ("DW_TAG_class_type" , natural_of_hex "0x02" ); - ("DW_TAG_entry_point" , natural_of_hex "0x03" ); - ("DW_TAG_enumeration_type" , natural_of_hex "0x04" ); - ("DW_TAG_formal_parameter" , natural_of_hex "0x05" ); - ("DW_TAG_imported_declaration" , natural_of_hex "0x08" ); - ("DW_TAG_label" , natural_of_hex "0x0a" ); - ("DW_TAG_lexical_block" , natural_of_hex "0x0b" ); - ("DW_TAG_member" , natural_of_hex "0x0d" ); - ("DW_TAG_pointer_type" , natural_of_hex "0x0f" ); - ("DW_TAG_reference_type" , natural_of_hex "0x10" ); - ("DW_TAG_compile_unit" , natural_of_hex "0x11" ); - ("DW_TAG_string_type" , natural_of_hex "0x12" ); - ("DW_TAG_structure_type" , natural_of_hex "0x13" ); - ("DW_TAG_subroutine_type" , natural_of_hex "0x15" ); - ("DW_TAG_typedef" , natural_of_hex "0x16" ); - ("DW_TAG_union_type" , natural_of_hex "0x17" ); - ("DW_TAG_unspecified_parameters" , natural_of_hex "0x18" ); - ("DW_TAG_variant" , natural_of_hex "0x19" ); - ("DW_TAG_common_block" , natural_of_hex "0x1a" ); - ("DW_TAG_common_inclusion" , natural_of_hex "0x1b" ); - ("DW_TAG_inheritance" , natural_of_hex "0x1c" ); - ("DW_TAG_inlined_subroutine" , natural_of_hex "0x1d" ); - ("DW_TAG_module" , natural_of_hex "0x1e" ); - ("DW_TAG_ptr_to_member_type" , natural_of_hex "0x1f" ); - ("DW_TAG_set_type" , natural_of_hex "0x20" ); - ("DW_TAG_subrange_type" , natural_of_hex "0x21" ); - ("DW_TAG_with_stmt" , natural_of_hex "0x22" ); - ("DW_TAG_access_declaration" , natural_of_hex "0x23" ); - ("DW_TAG_base_type" , natural_of_hex "0x24" ); - ("DW_TAG_catch_block" , natural_of_hex "0x25" ); - ("DW_TAG_const_type" , natural_of_hex "0x26" ); - ("DW_TAG_constant" , natural_of_hex "0x27" ); - ("DW_TAG_enumerator" , natural_of_hex "0x28" ); - ("DW_TAG_file_type" , natural_of_hex "0x29" ); - ("DW_TAG_friend" , natural_of_hex "0x2a" ); - ("DW_TAG_namelist" , natural_of_hex "0x2b" ); - ("DW_TAG_namelist_item" , natural_of_hex "0x2c" ); - ("DW_TAG_packed_type" , natural_of_hex "0x2d" ); - ("DW_TAG_subprogram" , natural_of_hex "0x2e" ); - ("DW_TAG_template_type_parameter" , natural_of_hex "0x2f" ); - ("DW_TAG_template_value_parameter" , natural_of_hex "0x30" ); - ("DW_TAG_thrown_type" , natural_of_hex "0x31" ); - ("DW_TAG_try_block" , natural_of_hex "0x32" ); - ("DW_TAG_variant_part" , natural_of_hex "0x33" ); - ("DW_TAG_variable" , natural_of_hex "0x34" ); - ("DW_TAG_volatile_type" , natural_of_hex "0x35" ); - ("DW_TAG_dwarf_procedure" , natural_of_hex "0x36" ); - ("DW_TAG_restrict_type" , natural_of_hex "0x37" ); - ("DW_TAG_interface_type" , natural_of_hex "0x38" ); - ("DW_TAG_namespace" , natural_of_hex "0x39" ); - ("DW_TAG_imported_module" , natural_of_hex "0x3a" ); - ("DW_TAG_unspecified_type" , natural_of_hex "0x3b" ); - ("DW_TAG_partial_unit" , natural_of_hex "0x3c" ); - ("DW_TAG_imported_unit" , natural_of_hex "0x3d" ); - ("DW_TAG_condition" , natural_of_hex "0x3f" ); - ("DW_TAG_shared_type" , natural_of_hex "0x40" ); - ("DW_TAG_type_unit" , natural_of_hex "0x41" ); - ("DW_TAG_rvalue_reference_type" , natural_of_hex "0x42" ); - ("DW_TAG_template_alias" , natural_of_hex "0x43" ); - ("DW_TAG_lo_user" , natural_of_hex "0x4080"); - ("DW_TAG_hi_user" , natural_of_hex "0xffff") + ("DW_TAG_array_type" , sym_natural_of_hex "0x01" ); + ("DW_TAG_class_type" , sym_natural_of_hex "0x02" ); + ("DW_TAG_entry_point" , sym_natural_of_hex "0x03" ); + ("DW_TAG_enumeration_type" , sym_natural_of_hex "0x04" ); + ("DW_TAG_formal_parameter" , sym_natural_of_hex "0x05" ); + ("DW_TAG_imported_declaration" , sym_natural_of_hex "0x08" ); + ("DW_TAG_label" , sym_natural_of_hex "0x0a" ); + ("DW_TAG_lexical_block" , sym_natural_of_hex "0x0b" ); + ("DW_TAG_member" , sym_natural_of_hex "0x0d" ); + ("DW_TAG_pointer_type" , sym_natural_of_hex "0x0f" ); + ("DW_TAG_reference_type" , sym_natural_of_hex "0x10" ); + ("DW_TAG_compile_unit" , sym_natural_of_hex "0x11" ); + ("DW_TAG_string_type" , sym_natural_of_hex "0x12" ); + ("DW_TAG_structure_type" , sym_natural_of_hex "0x13" ); + ("DW_TAG_subroutine_type" , sym_natural_of_hex "0x15" ); + ("DW_TAG_typedef" , sym_natural_of_hex "0x16" ); + ("DW_TAG_union_type" , sym_natural_of_hex "0x17" ); + ("DW_TAG_unspecified_parameters" , sym_natural_of_hex "0x18" ); + ("DW_TAG_variant" , sym_natural_of_hex "0x19" ); + ("DW_TAG_common_block" , sym_natural_of_hex "0x1a" ); + ("DW_TAG_common_inclusion" , sym_natural_of_hex "0x1b" ); + ("DW_TAG_inheritance" , sym_natural_of_hex "0x1c" ); + ("DW_TAG_inlined_subroutine" , sym_natural_of_hex "0x1d" ); + ("DW_TAG_module" , sym_natural_of_hex "0x1e" ); + ("DW_TAG_ptr_to_member_type" , sym_natural_of_hex "0x1f" ); + ("DW_TAG_set_type" , sym_natural_of_hex "0x20" ); + ("DW_TAG_subrange_type" , sym_natural_of_hex "0x21" ); + ("DW_TAG_with_stmt" , sym_natural_of_hex "0x22" ); + ("DW_TAG_access_declaration" , sym_natural_of_hex "0x23" ); + ("DW_TAG_base_type" , sym_natural_of_hex "0x24" ); + ("DW_TAG_catch_block" , sym_natural_of_hex "0x25" ); + ("DW_TAG_const_type" , sym_natural_of_hex "0x26" ); + ("DW_TAG_constant" , sym_natural_of_hex "0x27" ); + ("DW_TAG_enumerator" , sym_natural_of_hex "0x28" ); + ("DW_TAG_file_type" , sym_natural_of_hex "0x29" ); + ("DW_TAG_friend" , sym_natural_of_hex "0x2a" ); + ("DW_TAG_namelist" , sym_natural_of_hex "0x2b" ); + ("DW_TAG_namelist_item" , sym_natural_of_hex "0x2c" ); + ("DW_TAG_packed_type" , sym_natural_of_hex "0x2d" ); + ("DW_TAG_subprogram" , sym_natural_of_hex "0x2e" ); + ("DW_TAG_template_type_parameter" , sym_natural_of_hex "0x2f" ); + ("DW_TAG_template_value_parameter" , sym_natural_of_hex "0x30" ); + ("DW_TAG_thrown_type" , sym_natural_of_hex "0x31" ); + ("DW_TAG_try_block" , sym_natural_of_hex "0x32" ); + ("DW_TAG_variant_part" , sym_natural_of_hex "0x33" ); + ("DW_TAG_variable" , sym_natural_of_hex "0x34" ); + ("DW_TAG_volatile_type" , sym_natural_of_hex "0x35" ); + ("DW_TAG_dwarf_procedure" , sym_natural_of_hex "0x36" ); + ("DW_TAG_restrict_type" , sym_natural_of_hex "0x37" ); + ("DW_TAG_interface_type" , sym_natural_of_hex "0x38" ); + ("DW_TAG_namespace" , sym_natural_of_hex "0x39" ); + ("DW_TAG_imported_module" , sym_natural_of_hex "0x3a" ); + ("DW_TAG_unspecified_type" , sym_natural_of_hex "0x3b" ); + ("DW_TAG_partial_unit" , sym_natural_of_hex "0x3c" ); + ("DW_TAG_imported_unit" , sym_natural_of_hex "0x3d" ); + ("DW_TAG_condition" , sym_natural_of_hex "0x3f" ); + ("DW_TAG_shared_type" , sym_natural_of_hex "0x40" ); + ("DW_TAG_type_unit" , sym_natural_of_hex "0x41" ); + ("DW_TAG_rvalue_reference_type" , sym_natural_of_hex "0x42" ); + ("DW_TAG_template_alias" , sym_natural_of_hex "0x43" ); + ("DW_TAG_lo_user" , sym_natural_of_hex "0x4080"); + ("DW_TAG_hi_user" , sym_natural_of_hex "0xffff") ] (* child determination encoding *) -let vDW_CHILDREN_no = natural_of_hex "0x00" -let vDW_CHILDREN_yes = natural_of_hex "0x01" +let vDW_CHILDREN_no = sym_natural_of_hex "0x00" +let vDW_CHILDREN_yes = sym_natural_of_hex "0x01" (* attribute encoding *) let attribute_encodings = [ - ("DW_AT_sibling" , natural_of_hex "0x01", [DWA_reference]) ; - ("DW_AT_location" , natural_of_hex "0x02", [DWA_exprloc; DWA_loclistptr]) ; - ("DW_AT_name" , natural_of_hex "0x03", [DWA_string]) ; - ("DW_AT_ordering" , natural_of_hex "0x09", [DWA_constant]) ; - ("DW_AT_byte_size" , natural_of_hex "0x0b", [DWA_constant; DWA_exprloc; DWA_reference]) ; - ("DW_AT_bit_offset" , natural_of_hex "0x0c", [DWA_constant; DWA_exprloc; DWA_reference]) ; - ("DW_AT_bit_size" , natural_of_hex "0x0d", [DWA_constant; DWA_exprloc; DWA_reference]) ; - ("DW_AT_stmt_list" , natural_of_hex "0x10", [DWA_lineptr]) ; - ("DW_AT_low_pc" , natural_of_hex "0x11", [DWA_address]) ; - ("DW_AT_high_pc" , natural_of_hex "0x12", [DWA_address; DWA_constant]) ; - ("DW_AT_language" , natural_of_hex "0x13", [DWA_constant]) ; - ("DW_AT_discr" , natural_of_hex "0x15", [DWA_reference]) ; - ("DW_AT_discr_value" , natural_of_hex "0x16", [DWA_constant]) ; - ("DW_AT_visibility" , natural_of_hex "0x17", [DWA_constant]) ; - ("DW_AT_import" , natural_of_hex "0x18", [DWA_reference]) ; - ("DW_AT_string_length" , natural_of_hex "0x19", [DWA_exprloc; DWA_loclistptr]) ; - ("DW_AT_common_reference" , natural_of_hex "0x1a", [DWA_reference]) ; - ("DW_AT_comp_dir" , natural_of_hex "0x1b", [DWA_string]) ; - ("DW_AT_const_value" , natural_of_hex "0x1c", [DWA_block; DWA_constant; DWA_string]) ; - ("DW_AT_containing_type" , natural_of_hex "0x1d", [DWA_reference]) ; - ("DW_AT_default_value" , natural_of_hex "0x1e", [DWA_reference]) ; - ("DW_AT_inline" , natural_of_hex "0x20", [DWA_constant]) ; - ("DW_AT_is_optional" , natural_of_hex "0x21", [DWA_flag]) ; - ("DW_AT_lower_bound" , natural_of_hex "0x22", [DWA_constant; DWA_exprloc; DWA_reference]) ; - ("DW_AT_producer" , natural_of_hex "0x25", [DWA_string]) ; - ("DW_AT_prototyped" , natural_of_hex "0x27", [DWA_flag]) ; - ("DW_AT_return_addr" , natural_of_hex "0x2a", [DWA_exprloc; DWA_loclistptr]) ; - ("DW_AT_start_scope" , natural_of_hex "0x2c", [DWA_constant; DWA_rangelistptr]) ; - ("DW_AT_bit_stride" , natural_of_hex "0x2e", [DWA_constant; DWA_exprloc; DWA_reference]) ; - ("DW_AT_upper_bound" , natural_of_hex "0x2f", [DWA_constant; DWA_exprloc; DWA_reference]) ; - ("DW_AT_abstract_origin" , natural_of_hex "0x31", [DWA_reference]) ; - ("DW_AT_accessibility" , natural_of_hex "0x32", [DWA_constant]) ; - ("DW_AT_address_class" , natural_of_hex "0x33", [DWA_constant]) ; - ("DW_AT_artificial" , natural_of_hex "0x34", [DWA_flag]) ; - ("DW_AT_base_types" , natural_of_hex "0x35", [DWA_reference]) ; - ("DW_AT_calling_convention" , natural_of_hex "0x36", [DWA_constant]) ; - ("DW_AT_count" , natural_of_hex "0x37", [DWA_constant; DWA_exprloc; DWA_reference]) ; - ("DW_AT_data_member_location" , natural_of_hex "0x38", [DWA_constant; DWA_exprloc; DWA_loclistptr]) ; - ("DW_AT_decl_column" , natural_of_hex "0x39", [DWA_constant]) ; - ("DW_AT_decl_file" , natural_of_hex "0x3a", [DWA_constant]) ; - ("DW_AT_decl_line" , natural_of_hex "0x3b", [DWA_constant]) ; - ("DW_AT_declaration" , natural_of_hex "0x3c", [DWA_flag]) ; - ("DW_AT_discr_list" , natural_of_hex "0x3d", [DWA_block]) ; - ("DW_AT_encoding" , natural_of_hex "0x3e", [DWA_constant]) ; - ("DW_AT_external" , natural_of_hex "0x3f", [DWA_flag]) ; - ("DW_AT_frame_base" , natural_of_hex "0x40", [DWA_exprloc; DWA_loclistptr]) ; - ("DW_AT_friend" , natural_of_hex "0x41", [DWA_reference]) ; - ("DW_AT_identifier_case" , natural_of_hex "0x42", [DWA_constant]) ; - ("DW_AT_macro_info" , natural_of_hex "0x43", [DWA_macptr]) ; - ("DW_AT_namelist_item" , natural_of_hex "0x44", [DWA_reference]) ; - ("DW_AT_priority" , natural_of_hex "0x45", [DWA_reference]) ; - ("DW_AT_segment" , natural_of_hex "0x46", [DWA_exprloc; DWA_loclistptr]) ; - ("DW_AT_specification" , natural_of_hex "0x47", [DWA_reference]) ; - ("DW_AT_static_link" , natural_of_hex "0x48", [DWA_exprloc; DWA_loclistptr]) ; - ("DW_AT_type" , natural_of_hex "0x49", [DWA_reference]) ; - ("DW_AT_use_location" , natural_of_hex "0x4a", [DWA_exprloc; DWA_loclistptr]) ; - ("DW_AT_variable_parameter" , natural_of_hex "0x4b", [DWA_flag]) ; - ("DW_AT_virtuality" , natural_of_hex "0x4c", [DWA_constant]) ; - ("DW_AT_vtable_elem_location" , natural_of_hex "0x4d", [DWA_exprloc; DWA_loclistptr]) ; - ("DW_AT_allocated" , natural_of_hex "0x4e", [DWA_constant; DWA_exprloc; DWA_reference]) ; - ("DW_AT_associated" , natural_of_hex "0x4f", [DWA_constant; DWA_exprloc; DWA_reference]) ; - ("DW_AT_data_location" , natural_of_hex "0x50", [DWA_exprloc]) ; - ("DW_AT_byte_stride" , natural_of_hex "0x51", [DWA_constant; DWA_exprloc; DWA_reference]) ; - ("DW_AT_entry_pc" , natural_of_hex "0x52", [DWA_address]) ; - ("DW_AT_use_UTF8" , natural_of_hex "0x53", [DWA_flag]) ; - ("DW_AT_extension" , natural_of_hex "0x54", [DWA_reference]) ; - ("DW_AT_ranges" , natural_of_hex "0x55", [DWA_rangelistptr]) ; - ("DW_AT_trampoline" , natural_of_hex "0x56", [DWA_address; DWA_flag; DWA_reference; DWA_string]); - ("DW_AT_call_column" , natural_of_hex "0x57", [DWA_constant]) ; - ("DW_AT_call_file" , natural_of_hex "0x58", [DWA_constant]) ; - ("DW_AT_call_line" , natural_of_hex "0x59", [DWA_constant]) ; - ("DW_AT_description" , natural_of_hex "0x5a", [DWA_string]) ; - ("DW_AT_binary_scale" , natural_of_hex "0x5b", [DWA_constant]) ; - ("DW_AT_decimal_scale" , natural_of_hex "0x5c", [DWA_constant]) ; - ("DW_AT_small" , natural_of_hex "0x5d", [DWA_reference]) ; - ("DW_AT_decimal_sign" , natural_of_hex "0x5e", [DWA_constant]) ; - ("DW_AT_digit_count" , natural_of_hex "0x5f", [DWA_constant]) ; - ("DW_AT_picture_string" , natural_of_hex "0x60", [DWA_string]) ; - ("DW_AT_mutable" , natural_of_hex "0x61", [DWA_flag]) ; - ("DW_AT_threads_scaled" , natural_of_hex "0x62", [DWA_flag]) ; - ("DW_AT_explicit" , natural_of_hex "0x63", [DWA_flag]) ; - ("DW_AT_object_pointer" , natural_of_hex "0x64", [DWA_reference]) ; - ("DW_AT_endianity" , natural_of_hex "0x65", [DWA_constant]) ; - ("DW_AT_elemental" , natural_of_hex "0x66", [DWA_flag]) ; - ("DW_AT_pure" , natural_of_hex "0x67", [DWA_flag]) ; - ("DW_AT_recursive" , natural_of_hex "0x68", [DWA_flag]) ; - ("DW_AT_signature" , natural_of_hex "0x69", [DWA_reference]) ; - ("DW_AT_main_subprogram" , natural_of_hex "0x6a", [DWA_flag]) ; - ("DW_AT_data_bit_offset" , natural_of_hex "0x6b", [DWA_constant]) ; - ("DW_AT_const_expr" , natural_of_hex "0x6c", [DWA_flag]) ; - ("DW_AT_enum_class" , natural_of_hex "0x6d", [DWA_flag]) ; - ("DW_AT_linkage_name" , natural_of_hex "0x6e", [DWA_string]) ; + ("DW_AT_sibling" , sym_natural_of_hex "0x01", [DWA_reference]) ; + ("DW_AT_location" , sym_natural_of_hex "0x02", [DWA_exprloc; DWA_loclistptr]) ; + ("DW_AT_name" , sym_natural_of_hex "0x03", [DWA_string]) ; + ("DW_AT_ordering" , sym_natural_of_hex "0x09", [DWA_constant]) ; + ("DW_AT_byte_size" , sym_natural_of_hex "0x0b", [DWA_constant; DWA_exprloc; DWA_reference]) ; + ("DW_AT_bit_offset" , sym_natural_of_hex "0x0c", [DWA_constant; DWA_exprloc; DWA_reference]) ; + ("DW_AT_bit_size" , sym_natural_of_hex "0x0d", [DWA_constant; DWA_exprloc; DWA_reference]) ; + ("DW_AT_stmt_list" , sym_natural_of_hex "0x10", [DWA_lineptr]) ; + ("DW_AT_low_pc" , sym_natural_of_hex "0x11", [DWA_address]) ; + ("DW_AT_high_pc" , sym_natural_of_hex "0x12", [DWA_address; DWA_constant]) ; + ("DW_AT_language" , sym_natural_of_hex "0x13", [DWA_constant]) ; + ("DW_AT_discr" , sym_natural_of_hex "0x15", [DWA_reference]) ; + ("DW_AT_discr_value" , sym_natural_of_hex "0x16", [DWA_constant]) ; + ("DW_AT_visibility" , sym_natural_of_hex "0x17", [DWA_constant]) ; + ("DW_AT_import" , sym_natural_of_hex "0x18", [DWA_reference]) ; + ("DW_AT_string_length" , sym_natural_of_hex "0x19", [DWA_exprloc; DWA_loclistptr]) ; + ("DW_AT_common_reference" , sym_natural_of_hex "0x1a", [DWA_reference]) ; + ("DW_AT_comp_dir" , sym_natural_of_hex "0x1b", [DWA_string]) ; + ("DW_AT_const_value" , sym_natural_of_hex "0x1c", [DWA_block; DWA_constant; DWA_string]) ; + ("DW_AT_containing_type" , sym_natural_of_hex "0x1d", [DWA_reference]) ; + ("DW_AT_default_value" , sym_natural_of_hex "0x1e", [DWA_reference]) ; + ("DW_AT_inline" , sym_natural_of_hex "0x20", [DWA_constant]) ; + ("DW_AT_is_optional" , sym_natural_of_hex "0x21", [DWA_flag]) ; + ("DW_AT_lower_bound" , sym_natural_of_hex "0x22", [DWA_constant; DWA_exprloc; DWA_reference]) ; + ("DW_AT_producer" , sym_natural_of_hex "0x25", [DWA_string]) ; + ("DW_AT_prototyped" , sym_natural_of_hex "0x27", [DWA_flag]) ; + ("DW_AT_return_addr" , sym_natural_of_hex "0x2a", [DWA_exprloc; DWA_loclistptr]) ; + ("DW_AT_start_scope" , sym_natural_of_hex "0x2c", [DWA_constant; DWA_rangelistptr]) ; + ("DW_AT_bit_stride" , sym_natural_of_hex "0x2e", [DWA_constant; DWA_exprloc; DWA_reference]) ; + ("DW_AT_upper_bound" , sym_natural_of_hex "0x2f", [DWA_constant; DWA_exprloc; DWA_reference]) ; + ("DW_AT_abstract_origin" , sym_natural_of_hex "0x31", [DWA_reference]) ; + ("DW_AT_accessibility" , sym_natural_of_hex "0x32", [DWA_constant]) ; + ("DW_AT_address_class" , sym_natural_of_hex "0x33", [DWA_constant]) ; + ("DW_AT_artificial" , sym_natural_of_hex "0x34", [DWA_flag]) ; + ("DW_AT_base_types" , sym_natural_of_hex "0x35", [DWA_reference]) ; + ("DW_AT_calling_convention" , sym_natural_of_hex "0x36", [DWA_constant]) ; + ("DW_AT_count" , sym_natural_of_hex "0x37", [DWA_constant; DWA_exprloc; DWA_reference]) ; + ("DW_AT_data_member_location" , sym_natural_of_hex "0x38", [DWA_constant; DWA_exprloc; DWA_loclistptr]) ; + ("DW_AT_decl_column" , sym_natural_of_hex "0x39", [DWA_constant]) ; + ("DW_AT_decl_file" , sym_natural_of_hex "0x3a", [DWA_constant]) ; + ("DW_AT_decl_line" , sym_natural_of_hex "0x3b", [DWA_constant]) ; + ("DW_AT_declaration" , sym_natural_of_hex "0x3c", [DWA_flag]) ; + ("DW_AT_discr_list" , sym_natural_of_hex "0x3d", [DWA_block]) ; + ("DW_AT_encoding" , sym_natural_of_hex "0x3e", [DWA_constant]) ; + ("DW_AT_external" , sym_natural_of_hex "0x3f", [DWA_flag]) ; + ("DW_AT_frame_base" , sym_natural_of_hex "0x40", [DWA_exprloc; DWA_loclistptr]) ; + ("DW_AT_friend" , sym_natural_of_hex "0x41", [DWA_reference]) ; + ("DW_AT_identifier_case" , sym_natural_of_hex "0x42", [DWA_constant]) ; + ("DW_AT_macro_info" , sym_natural_of_hex "0x43", [DWA_macptr]) ; + ("DW_AT_namelist_item" , sym_natural_of_hex "0x44", [DWA_reference]) ; + ("DW_AT_priority" , sym_natural_of_hex "0x45", [DWA_reference]) ; + ("DW_AT_segment" , sym_natural_of_hex "0x46", [DWA_exprloc; DWA_loclistptr]) ; + ("DW_AT_specification" , sym_natural_of_hex "0x47", [DWA_reference]) ; + ("DW_AT_static_link" , sym_natural_of_hex "0x48", [DWA_exprloc; DWA_loclistptr]) ; + ("DW_AT_type" , sym_natural_of_hex "0x49", [DWA_reference]) ; + ("DW_AT_use_location" , sym_natural_of_hex "0x4a", [DWA_exprloc; DWA_loclistptr]) ; + ("DW_AT_variable_parameter" , sym_natural_of_hex "0x4b", [DWA_flag]) ; + ("DW_AT_virtuality" , sym_natural_of_hex "0x4c", [DWA_constant]) ; + ("DW_AT_vtable_elem_location" , sym_natural_of_hex "0x4d", [DWA_exprloc; DWA_loclistptr]) ; + ("DW_AT_allocated" , sym_natural_of_hex "0x4e", [DWA_constant; DWA_exprloc; DWA_reference]) ; + ("DW_AT_associated" , sym_natural_of_hex "0x4f", [DWA_constant; DWA_exprloc; DWA_reference]) ; + ("DW_AT_data_location" , sym_natural_of_hex "0x50", [DWA_exprloc]) ; + ("DW_AT_byte_stride" , sym_natural_of_hex "0x51", [DWA_constant; DWA_exprloc; DWA_reference]) ; + ("DW_AT_entry_pc" , sym_natural_of_hex "0x52", [DWA_address]) ; + ("DW_AT_use_UTF8" , sym_natural_of_hex "0x53", [DWA_flag]) ; + ("DW_AT_extension" , sym_natural_of_hex "0x54", [DWA_reference]) ; + ("DW_AT_ranges" , sym_natural_of_hex "0x55", [DWA_rangelistptr]) ; + ("DW_AT_trampoline" , sym_natural_of_hex "0x56", [DWA_address; DWA_flag; DWA_reference; DWA_string]); + ("DW_AT_call_column" , sym_natural_of_hex "0x57", [DWA_constant]) ; + ("DW_AT_call_file" , sym_natural_of_hex "0x58", [DWA_constant]) ; + ("DW_AT_call_line" , sym_natural_of_hex "0x59", [DWA_constant]) ; + ("DW_AT_description" , sym_natural_of_hex "0x5a", [DWA_string]) ; + ("DW_AT_binary_scale" , sym_natural_of_hex "0x5b", [DWA_constant]) ; + ("DW_AT_decimal_scale" , sym_natural_of_hex "0x5c", [DWA_constant]) ; + ("DW_AT_small" , sym_natural_of_hex "0x5d", [DWA_reference]) ; + ("DW_AT_decimal_sign" , sym_natural_of_hex "0x5e", [DWA_constant]) ; + ("DW_AT_digit_count" , sym_natural_of_hex "0x5f", [DWA_constant]) ; + ("DW_AT_picture_string" , sym_natural_of_hex "0x60", [DWA_string]) ; + ("DW_AT_mutable" , sym_natural_of_hex "0x61", [DWA_flag]) ; + ("DW_AT_threads_scaled" , sym_natural_of_hex "0x62", [DWA_flag]) ; + ("DW_AT_explicit" , sym_natural_of_hex "0x63", [DWA_flag]) ; + ("DW_AT_object_pointer" , sym_natural_of_hex "0x64", [DWA_reference]) ; + ("DW_AT_endianity" , sym_natural_of_hex "0x65", [DWA_constant]) ; + ("DW_AT_elemental" , sym_natural_of_hex "0x66", [DWA_flag]) ; + ("DW_AT_pure" , sym_natural_of_hex "0x67", [DWA_flag]) ; + ("DW_AT_recursive" , sym_natural_of_hex "0x68", [DWA_flag]) ; + ("DW_AT_signature" , sym_natural_of_hex "0x69", [DWA_reference]) ; + ("DW_AT_main_subprogram" , sym_natural_of_hex "0x6a", [DWA_flag]) ; + ("DW_AT_data_bit_offset" , sym_natural_of_hex "0x6b", [DWA_constant]) ; + ("DW_AT_const_expr" , sym_natural_of_hex "0x6c", [DWA_flag]) ; + ("DW_AT_enum_class" , sym_natural_of_hex "0x6d", [DWA_flag]) ; + ("DW_AT_linkage_name" , sym_natural_of_hex "0x6e", [DWA_string]) ; (* DW_AT_noreturn is a gcc extension to support the C11 _Noreturn keyword*) - ("DW_AT_noreturn" , natural_of_hex "0x87", [DWA_flag]) ; - ("DW_AT_alignment" , natural_of_hex "0x88", [DWA_constant]) ; - ("DW_AT_lo_user" , natural_of_hex "0x2000", [DWA_dash]) ; - ("DW_AT_hi_user" , natural_of_hex "0x3fff", [DWA_dash]) + ("DW_AT_noreturn" , sym_natural_of_hex "0x87", [DWA_flag]) ; + ("DW_AT_alignment" , sym_natural_of_hex "0x88", [DWA_constant]) ; + ("DW_AT_lo_user" , sym_natural_of_hex "0x2000", [DWA_dash]) ; + ("DW_AT_hi_user" , sym_natural_of_hex "0x3fff", [DWA_dash]) ] (* attribute form encoding *) let attribute_form_encodings = [ - ("DW_FORM_addr" , natural_of_hex "0x01", [DWA_address]) ; - ("DW_FORM_block2" , natural_of_hex "0x03", [DWA_block]) ; - ("DW_FORM_block4" , natural_of_hex "0x04", [DWA_block]) ; - ("DW_FORM_data2" , natural_of_hex "0x05", [DWA_constant]) ; - ("DW_FORM_data4" , natural_of_hex "0x06", [DWA_constant]) ; - ("DW_FORM_data8" , natural_of_hex "0x07", [DWA_constant]) ; - ("DW_FORM_string" , natural_of_hex "0x08", [DWA_string]) ; - ("DW_FORM_block" , natural_of_hex "0x09", [DWA_block]) ; - ("DW_FORM_block1" , natural_of_hex "0x0a", [DWA_block]) ; - ("DW_FORM_data1" , natural_of_hex "0x0b", [DWA_constant]) ; - ("DW_FORM_flag" , natural_of_hex "0x0c", [DWA_flag]) ; - ("DW_FORM_sdata" , natural_of_hex "0x0d", [DWA_constant]) ; - ("DW_FORM_strp" , natural_of_hex "0x0e", [DWA_string]) ; - ("DW_FORM_udata" , natural_of_hex "0x0f", [DWA_constant]) ; - ("DW_FORM_ref_addr" , natural_of_hex "0x10", [DWA_reference]); - ("DW_FORM_ref1" , natural_of_hex "0x11", [DWA_reference]); - ("DW_FORM_ref2" , natural_of_hex "0x12", [DWA_reference]); - ("DW_FORM_ref4" , natural_of_hex "0x13", [DWA_reference]); - ("DW_FORM_ref8" , natural_of_hex "0x14", [DWA_reference]); - ("DW_FORM_ref_udata" , natural_of_hex "0x15", [DWA_reference]); - ("DW_FORM_indirect" , natural_of_hex "0x16", [DWA_7_5_3]) ; - ("DW_FORM_sec_offset" , natural_of_hex "0x17", [DWA_lineptr; DWA_loclistptr; DWA_macptr; DWA_rangelistptr]) ; - ("DW_FORM_exprloc" , natural_of_hex "0x18", [DWA_exprloc]) ; - ("DW_FORM_flag_present", natural_of_hex "0x19", [DWA_flag]) ; - ("DW_FORM_ref_sig8" , natural_of_hex "0x20", [DWA_reference]) + ("DW_FORM_addr" , sym_natural_of_hex "0x01", [DWA_address]) ; + ("DW_FORM_block2" , sym_natural_of_hex "0x03", [DWA_block]) ; + ("DW_FORM_block4" , sym_natural_of_hex "0x04", [DWA_block]) ; + ("DW_FORM_data2" , sym_natural_of_hex "0x05", [DWA_constant]) ; + ("DW_FORM_data4" , sym_natural_of_hex "0x06", [DWA_constant]) ; + ("DW_FORM_data8" , sym_natural_of_hex "0x07", [DWA_constant]) ; + ("DW_FORM_string" , sym_natural_of_hex "0x08", [DWA_string]) ; + ("DW_FORM_block" , sym_natural_of_hex "0x09", [DWA_block]) ; + ("DW_FORM_block1" , sym_natural_of_hex "0x0a", [DWA_block]) ; + ("DW_FORM_data1" , sym_natural_of_hex "0x0b", [DWA_constant]) ; + ("DW_FORM_flag" , sym_natural_of_hex "0x0c", [DWA_flag]) ; + ("DW_FORM_sdata" , sym_natural_of_hex "0x0d", [DWA_constant]) ; + ("DW_FORM_strp" , sym_natural_of_hex "0x0e", [DWA_string]) ; + ("DW_FORM_udata" , sym_natural_of_hex "0x0f", [DWA_constant]) ; + ("DW_FORM_ref_addr" , sym_natural_of_hex "0x10", [DWA_reference]); + ("DW_FORM_ref1" , sym_natural_of_hex "0x11", [DWA_reference]); + ("DW_FORM_ref2" , sym_natural_of_hex "0x12", [DWA_reference]); + ("DW_FORM_ref4" , sym_natural_of_hex "0x13", [DWA_reference]); + ("DW_FORM_ref8" , sym_natural_of_hex "0x14", [DWA_reference]); + ("DW_FORM_ref_udata" , sym_natural_of_hex "0x15", [DWA_reference]); + ("DW_FORM_indirect" , sym_natural_of_hex "0x16", [DWA_7_5_3]) ; + ("DW_FORM_sec_offset" , sym_natural_of_hex "0x17", [DWA_lineptr; DWA_loclistptr; DWA_macptr; DWA_rangelistptr]) ; + ("DW_FORM_exprloc" , sym_natural_of_hex "0x18", [DWA_exprloc]) ; + ("DW_FORM_flag_present", sym_natural_of_hex "0x19", [DWA_flag]) ; + ("DW_FORM_ref_sig8" , sym_natural_of_hex "0x20", [DWA_reference]) ] (* operation encoding *) let operation_encodings = [ -("DW_OP_addr", natural_of_hex "0x03", [OAT_addr] , OpSem_lit); (*1*) (*constant address (size target specific)*) -("DW_OP_deref", natural_of_hex "0x06", [] , OpSem_deref); (*0*) -("DW_OP_const1u", natural_of_hex "0x08", [OAT_uint8] , OpSem_lit); (*1*) (* 1-byte constant *) -("DW_OP_const1s", natural_of_hex "0x09", [OAT_sint8] , OpSem_lit); (*1*) (* 1-byte constant *) -("DW_OP_const2u", natural_of_hex "0x0a", [OAT_uint16] , OpSem_lit); (*1*) (* 2-byte constant *) -("DW_OP_const2s", natural_of_hex "0x0b", [OAT_sint16] , OpSem_lit); (*1*) (* 2-byte constant *) -("DW_OP_const4u", natural_of_hex "0x0c", [OAT_uint32] , OpSem_lit); (*1*) (* 4-byte constant *) -("DW_OP_const4s", natural_of_hex "0x0d", [OAT_sint32] , OpSem_lit); (*1*) (* 4-byte constant *) -("DW_OP_const8u", natural_of_hex "0x0e", [OAT_uint64] , OpSem_lit); (*1*) (* 8-byte constant *) -("DW_OP_const8s", natural_of_hex "0x0f", [OAT_sint64] , OpSem_lit); (*1*) (* 8-byte constant *) -("DW_OP_constu", natural_of_hex "0x10", [OAT_ULEB128] , OpSem_lit); (*1*) (* ULEB128 constant *) -("DW_OP_consts", natural_of_hex "0x11", [OAT_SLEB128] , OpSem_lit); (*1*) (* SLEB128 constant *) -("DW_OP_dup", natural_of_hex "0x12", [] , OpSem_stack (fun ac vs args -> match vs with v::vs -> Just (v::v::vs) | _ -> Nothing end)); (*0*) -("DW_OP_drop", natural_of_hex "0x13", [] , OpSem_stack (fun ac vs args -> match vs with v::vs -> Just vs | _ -> Nothing end)); (*0*) -("DW_OP_over", natural_of_hex "0x14", [] , OpSem_stack (fun ac vs args -> match vs with v::v'::vs -> Just (v'::v::v'::vs) | _ -> Nothing end)); (*0*) -("DW_OP_pick", natural_of_hex "0x15", [OAT_uint8] , OpSem_stack (fun ac vs args -> match args with [OAV_natural n] -> match index_natural vs n with Just v -> Just (v::vs) | Nothing -> Nothing end | _ -> Nothing end)); (*1*) (* 1-byte stack index *) -("DW_OP_swap", natural_of_hex "0x16", [] , OpSem_stack (fun ac vs args -> match vs with v::v'::vs -> Just (v'::v::vs) | _ -> Nothing end)); (*0*) -("DW_OP_rot", natural_of_hex "0x17", [] , OpSem_stack (fun ac vs args -> match vs with v::v'::v''::vs -> Just (v'::v''::v::vs) | _ -> Nothing end)); (*0*) -("DW_OP_xderef", natural_of_hex "0x18", [] , OpSem_not_supported); (*0*) -("DW_OP_abs", natural_of_hex "0x19", [] , OpSem_unary (fun ac v -> if v < ac.ac_half then Just v else if v=ac.ac_max then Nothing else Just (ac.ac_all-v))); (*0*) -("DW_OP_and", natural_of_hex "0x1a", [] , OpSem_binary (fun ac v1 v2 -> Just (natural_land v1 v2))); (*0*) -("DW_OP_div", natural_of_hex "0x1b", [] , OpSem_not_supported) (*TODO*); (*0*) -("DW_OP_minus", natural_of_hex "0x1c", [] , OpSem_binary (fun ac v1 v2 -> Just (partialNaturalFromInteger ((integerFromNatural v1 - integerFromNatural v2) mod (integerFromNatural ac.ac_all))))); (*0*) -("DW_OP_mod", natural_of_hex "0x1d", [] , OpSem_binary (fun ac v1 v2 -> Just (v1 mod v2))); (*0*) -("DW_OP_mul", natural_of_hex "0x1e", [] , OpSem_binary (fun ac v1 v2 -> Just (partialNaturalFromInteger ((integerFromNatural v1 * integerFromNatural v2) mod (integerFromNatural ac.ac_all))))); (*0*) -("DW_OP_neg", natural_of_hex "0x1f", [] , OpSem_unary (fun ac v -> if v < ac.ac_half then Just (ac.ac_max - v) else if v=ac.ac_half then Nothing else Just (ac.ac_all - v))); (*0*) -("DW_OP_not", natural_of_hex "0x20", [] , OpSem_unary (fun ac v -> Just (natural_lxor v ac.ac_max))); (*0*) -("DW_OP_or", natural_of_hex "0x21", [] , OpSem_binary (fun ac v1 v2 -> Just (natural_lor v1 v2))); (*0*) -("DW_OP_plus", natural_of_hex "0x22", [] , OpSem_binary (fun ac v1 v2 -> Just ((v1 + v2) mod ac.ac_all))); (*0*) -("DW_OP_plus_uconst", natural_of_hex "0x23", [OAT_ULEB128] , OpSem_stack (fun ac vs args -> match args with [OAV_natural n] -> match vs with v::vs' -> let v' = (v+n) mod ac.ac_all in Just (v'::vs) | [] -> Nothing end | _ -> Nothing end)); (*1*) (* ULEB128 addend *) -("DW_OP_shl", natural_of_hex "0x24", [] , OpSem_binary (fun ac v1 v2 -> if v2 >= ac.ac_bitwidth then Just 0 else Just (natural_nat_shift_left v1 (natFromNatural v2)))); (*0*) -("DW_OP_shr", natural_of_hex "0x25", [] , OpSem_binary (fun ac v1 v2 -> if v2 >= ac.ac_bitwidth then Just 0 else Just (natural_nat_shift_right v1 (natFromNatural v2)))); (*0*) -("DW_OP_shra", natural_of_hex "0x26", [] , OpSem_binary (fun ac v1 v2 -> if v1 < ac.ac_half then (if v2 >= ac.ac_bitwidth then Just 0 else Just (natural_nat_shift_right v1 (natFromNatural v2))) else (if v2 >= ac.ac_bitwidth then Just ac.ac_max else Just (ac.ac_max - (natural_nat_shift_right (ac.ac_max - v1) (natFromNatural v2)))))); (*0*) -("DW_OP_xor", natural_of_hex "0x27", [] , OpSem_binary (fun ac v1 v2 -> Just (natural_lxor v1 v2))); (*0*) -("DW_OP_skip", natural_of_hex "0x2f", [OAT_sint16] , OpSem_not_supported); (*1*) (* signed 2-byte constant *) -("DW_OP_bra", natural_of_hex "0x28", [OAT_sint16] , OpSem_not_supported); (*1*) (* signed 2-byte constant *) -("DW_OP_eq", natural_of_hex "0x29", [] , OpSem_not_supported); (*0*) -("DW_OP_ge", natural_of_hex "0x2a", [] , OpSem_not_supported); (*0*) -("DW_OP_gt", natural_of_hex "0x2b", [] , OpSem_not_supported); (*0*) -("DW_OP_le", natural_of_hex "0x2c", [] , OpSem_not_supported); (*0*) -("DW_OP_lt", natural_of_hex "0x2d", [] , OpSem_not_supported); (*0*) -("DW_OP_ne", natural_of_hex "0x2e", [] , OpSem_not_supported); (*0*) -("DW_OP_lit0", natural_of_hex "0x30", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) (* literals 0..31 =(DW_OP_lit0 + literal) *) -("DW_OP_lit1", natural_of_hex "0x31", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit2", natural_of_hex "0x32", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit3", natural_of_hex "0x33", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit4", natural_of_hex "0x34", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit5", natural_of_hex "0x35", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit6", natural_of_hex "0x36", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit7", natural_of_hex "0x37", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit8", natural_of_hex "0x38", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit9", natural_of_hex "0x39", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit10", natural_of_hex "0x3a", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit11", natural_of_hex "0x3b", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit12", natural_of_hex "0x3c", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit13", natural_of_hex "0x3d", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit14", natural_of_hex "0x3e", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit15", natural_of_hex "0x3f", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit16", natural_of_hex "0x40", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit17", natural_of_hex "0x41", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit18", natural_of_hex "0x42", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit19", natural_of_hex "0x43", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit20", natural_of_hex "0x44", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit21", natural_of_hex "0x45", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit22", natural_of_hex "0x46", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit23", natural_of_hex "0x47", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit24", natural_of_hex "0x48", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit25", natural_of_hex "0x49", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit26", natural_of_hex "0x4a", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit27", natural_of_hex "0x4b", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit28", natural_of_hex "0x4c", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit29", natural_of_hex "0x4d", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit30", natural_of_hex "0x4e", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit31", natural_of_hex "0x4f", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_reg0", natural_of_hex "0x50", [] , OpSem_reg); (*1*) (* reg 0..31 = (DW_OP_reg0 + regnum) *) -("DW_OP_reg1", natural_of_hex "0x51", [] , OpSem_reg); (*1*) -("DW_OP_reg2", natural_of_hex "0x52", [] , OpSem_reg); (*1*) -("DW_OP_reg3", natural_of_hex "0x53", [] , OpSem_reg); (*1*) -("DW_OP_reg4", natural_of_hex "0x54", [] , OpSem_reg); (*1*) -("DW_OP_reg5", natural_of_hex "0x55", [] , OpSem_reg); (*1*) -("DW_OP_reg6", natural_of_hex "0x56", [] , OpSem_reg); (*1*) -("DW_OP_reg7", natural_of_hex "0x57", [] , OpSem_reg); (*1*) -("DW_OP_reg8", natural_of_hex "0x58", [] , OpSem_reg); (*1*) -("DW_OP_reg9", natural_of_hex "0x59", [] , OpSem_reg); (*1*) -("DW_OP_reg10", natural_of_hex "0x5a", [] , OpSem_reg); (*1*) -("DW_OP_reg11", natural_of_hex "0x5b", [] , OpSem_reg); (*1*) -("DW_OP_reg12", natural_of_hex "0x5c", [] , OpSem_reg); (*1*) -("DW_OP_reg13", natural_of_hex "0x5d", [] , OpSem_reg); (*1*) -("DW_OP_reg14", natural_of_hex "0x5e", [] , OpSem_reg); (*1*) -("DW_OP_reg15", natural_of_hex "0x5f", [] , OpSem_reg); (*1*) -("DW_OP_reg16", natural_of_hex "0x60", [] , OpSem_reg); (*1*) -("DW_OP_reg17", natural_of_hex "0x61", [] , OpSem_reg); (*1*) -("DW_OP_reg18", natural_of_hex "0x62", [] , OpSem_reg); (*1*) -("DW_OP_reg19", natural_of_hex "0x63", [] , OpSem_reg); (*1*) -("DW_OP_reg20", natural_of_hex "0x64", [] , OpSem_reg); (*1*) -("DW_OP_reg21", natural_of_hex "0x65", [] , OpSem_reg); (*1*) -("DW_OP_reg22", natural_of_hex "0x66", [] , OpSem_reg); (*1*) -("DW_OP_reg23", natural_of_hex "0x67", [] , OpSem_reg); (*1*) -("DW_OP_reg24", natural_of_hex "0x68", [] , OpSem_reg); (*1*) -("DW_OP_reg25", natural_of_hex "0x69", [] , OpSem_reg); (*1*) -("DW_OP_reg26", natural_of_hex "0x6a", [] , OpSem_reg); (*1*) -("DW_OP_reg27", natural_of_hex "0x6b", [] , OpSem_reg); (*1*) -("DW_OP_reg28", natural_of_hex "0x6c", [] , OpSem_reg); (*1*) -("DW_OP_reg29", natural_of_hex "0x6d", [] , OpSem_reg); (*1*) -("DW_OP_reg30", natural_of_hex "0x6e", [] , OpSem_reg); (*1*) -("DW_OP_reg31", natural_of_hex "0x6f", [] , OpSem_reg); (*1*) -("DW_OP_breg0", natural_of_hex "0x70", [OAT_SLEB128] , OpSem_breg); (*1*) (* base register 0..31 = (DW_OP_breg0 + regnum) *) -("DW_OP_breg1", natural_of_hex "0x71", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg2", natural_of_hex "0x72", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg3", natural_of_hex "0x73", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg4", natural_of_hex "0x74", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg5", natural_of_hex "0x75", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg6", natural_of_hex "0x76", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg7", natural_of_hex "0x77", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg8", natural_of_hex "0x78", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg9", natural_of_hex "0x79", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg10", natural_of_hex "0x7a", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg11", natural_of_hex "0x7b", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg12", natural_of_hex "0x7c", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg13", natural_of_hex "0x7d", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg14", natural_of_hex "0x7e", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg15", natural_of_hex "0x7f", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg16", natural_of_hex "0x80", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg17", natural_of_hex "0x81", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg18", natural_of_hex "0x82", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg19", natural_of_hex "0x83", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg20", natural_of_hex "0x84", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg21", natural_of_hex "0x85", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg22", natural_of_hex "0x86", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg23", natural_of_hex "0x87", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg24", natural_of_hex "0x88", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg25", natural_of_hex "0x89", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg26", natural_of_hex "0x8a", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg27", natural_of_hex "0x8b", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg28", natural_of_hex "0x8c", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg29", natural_of_hex "0x8d", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg30", natural_of_hex "0x8e", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg31", natural_of_hex "0x8f", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_regx", natural_of_hex "0x90", [OAT_ULEB128] , OpSem_lit); (*1*) (* ULEB128 register *) -("DW_OP_fbreg", natural_of_hex "0x91", [OAT_SLEB128] , OpSem_fbreg); (*1*) (* SLEB128 offset *) -("DW_OP_bregx", natural_of_hex "0x92", [OAT_ULEB128; OAT_SLEB128] , OpSem_bregx); (*2*) (* ULEB128 register followed by SLEB128 offset *) -("DW_OP_piece", natural_of_hex "0x93", [OAT_ULEB128] , OpSem_piece); (*1*) (* ULEB128 size of piece addressed *) -("DW_OP_deref_size", natural_of_hex "0x94", [OAT_uint8] , OpSem_deref_size); (*1*) (* 1-byte size of data retrieved *) -("DW_OP_xderef_size", natural_of_hex "0x95", [OAT_uint8] , OpSem_not_supported); (*1*) (* 1-byte size of data retrieved *) -("DW_OP_nop", natural_of_hex "0x96", [] , OpSem_nop); (*0*) -("DW_OP_push_object_address", natural_of_hex "0x97", [] , OpSem_not_supported); (*0*) -("DW_OP_call2", natural_of_hex "0x98", [OAT_uint16] , OpSem_not_supported); (*1*) (* 2-byte offset of DIE *) -("DW_OP_call4", natural_of_hex "0x99", [OAT_uint32] , OpSem_not_supported); (*1*) (* 4-byte offset of DIE *) -("DW_OP_call_ref", natural_of_hex "0x9a", [OAT_dwarf_format_t] , OpSem_not_supported); (*1*) (* 4- or 8-byte offset of DIE *) -("DW_OP_form_tls_address", natural_of_hex "0x9b", [] , OpSem_not_supported); (*0*) -("DW_OP_call_frame_cfa", natural_of_hex "0x9c", [] , OpSem_call_frame_cfa); (*0*) -("DW_OP_bit_piece", natural_of_hex "0x9d", [OAT_ULEB128; OAT_ULEB128] , OpSem_bit_piece); (*2*) (* ULEB128 size followed by ULEB128 offset *) -("DW_OP_implicit_value", natural_of_hex "0x9e", [OAT_block] , OpSem_implicit_value); (*2*) (* ULEB128 size followed by block of that size *) -("DW_OP_stack_value", natural_of_hex "0x9f", [] , OpSem_stack_value); (*0*) +("DW_OP_addr", sym_natural_of_hex "0x03", [OAT_addr] , OpSem_lit); (*1*) (*constant address (size target specific)*) +("DW_OP_deref", sym_natural_of_hex "0x06", [] , OpSem_deref); (*0*) +("DW_OP_const1u", sym_natural_of_hex "0x08", [OAT_uint8] , OpSem_lit); (*1*) (* 1-byte constant *) +("DW_OP_const1s", sym_natural_of_hex "0x09", [OAT_sint8] , OpSem_lit); (*1*) (* 1-byte constant *) +("DW_OP_const2u", sym_natural_of_hex "0x0a", [OAT_uint16] , OpSem_lit); (*1*) (* 2-byte constant *) +("DW_OP_const2s", sym_natural_of_hex "0x0b", [OAT_sint16] , OpSem_lit); (*1*) (* 2-byte constant *) +("DW_OP_const4u", sym_natural_of_hex "0x0c", [OAT_uint32] , OpSem_lit); (*1*) (* 4-byte constant *) +("DW_OP_const4s", sym_natural_of_hex "0x0d", [OAT_sint32] , OpSem_lit); (*1*) (* 4-byte constant *) +("DW_OP_const8u", sym_natural_of_hex "0x0e", [OAT_uint64] , OpSem_lit); (*1*) (* 8-byte constant *) +("DW_OP_const8s", sym_natural_of_hex "0x0f", [OAT_sint64] , OpSem_lit); (*1*) (* 8-byte constant *) +("DW_OP_constu", sym_natural_of_hex "0x10", [OAT_ULEB128] , OpSem_lit); (*1*) (* ULEB128 constant *) +("DW_OP_consts", sym_natural_of_hex "0x11", [OAT_SLEB128] , OpSem_lit); (*1*) (* SLEB128 constant *) +("DW_OP_dup", sym_natural_of_hex "0x12", [] , OpSem_stack (fun ac vs args -> match vs with v::vs -> Just (v::v::vs) | _ -> Nothing end)); (*0*) +("DW_OP_drop", sym_natural_of_hex "0x13", [] , OpSem_stack (fun ac vs args -> match vs with v::vs -> Just vs | _ -> Nothing end)); (*0*) +("DW_OP_over", sym_natural_of_hex "0x14", [] , OpSem_stack (fun ac vs args -> match vs with v::v'::vs -> Just (v'::v::v'::vs) | _ -> Nothing end)); (*0*) +("DW_OP_pick", sym_natural_of_hex "0x15", [OAT_uint8] , OpSem_stack (fun ac vs args -> match args with [OAV_natural n] -> match index_sym_natural vs n with Just v -> Just (v::vs) | Nothing -> Nothing end | _ -> Nothing end)); (*1*) (* 1-byte stack index *) +("DW_OP_swap", sym_natural_of_hex "0x16", [] , OpSem_stack (fun ac vs args -> match vs with v::v'::vs -> Just (v'::v::vs) | _ -> Nothing end)); (*0*) +("DW_OP_rot", sym_natural_of_hex "0x17", [] , OpSem_stack (fun ac vs args -> match vs with v::v'::v''::vs -> Just (v'::v''::v::vs) | _ -> Nothing end)); (*0*) +("DW_OP_xderef", sym_natural_of_hex "0x18", [] , OpSem_not_supported); (*0*) +("DW_OP_abs", sym_natural_of_hex "0x19", [] , OpSem_unary (fun ac v -> if v < ac.ac_half then Just v else if v=ac.ac_max then Nothing else Just (ac.ac_all-v))); (*0*) +("DW_OP_and", sym_natural_of_hex "0x1a", [] , OpSem_binary (fun ac v1 v2 -> Just (sym_natural_land v1 v2))); (*0*) +("DW_OP_div", sym_natural_of_hex "0x1b", [] , OpSem_not_supported) (*TODO*); (*0*) +("DW_OP_minus", sym_natural_of_hex "0x1c", [] , OpSem_binary (fun ac v1 v2 -> Just (partialSymNaturalFromInteger ((integerFromSymNatural v1 - integerFromSymNatural v2) mod (integerFromSymNatural ac.ac_all))))); (*0*) +("DW_OP_mod", sym_natural_of_hex "0x1d", [] , OpSem_binary (fun ac v1 v2 -> Just (v1 mod v2))); (*0*) +("DW_OP_mul", sym_natural_of_hex "0x1e", [] , OpSem_binary (fun ac v1 v2 -> Just (partialSymNaturalFromInteger ((integerFromSymNatural v1 * integerFromSymNatural v2) mod (integerFromSymNatural ac.ac_all))))); (*0*) +("DW_OP_neg", sym_natural_of_hex "0x1f", [] , OpSem_unary (fun ac v -> if v < ac.ac_half then Just (ac.ac_max - v) else if v=ac.ac_half then Nothing else Just (ac.ac_all - v))); (*0*) +("DW_OP_not", sym_natural_of_hex "0x20", [] , OpSem_unary (fun ac v -> Just (sym_natural_lxor v ac.ac_max))); (*0*) +("DW_OP_or", sym_natural_of_hex "0x21", [] , OpSem_binary (fun ac v1 v2 -> Just (sym_natural_lor v1 v2))); (*0*) +("DW_OP_plus", sym_natural_of_hex "0x22", [] , OpSem_binary (fun ac v1 v2 -> Just ((v1 + v2) mod ac.ac_all))); (*0*) +("DW_OP_plus_uconst", sym_natural_of_hex "0x23", [OAT_ULEB128] , OpSem_stack (fun ac vs args -> match args with [OAV_natural n] -> match vs with v::vs' -> let v' = (v+n) mod ac.ac_all in Just (v'::vs) | [] -> Nothing end | _ -> Nothing end)); (*1*) (* ULEB128 addend *) +("DW_OP_shl", sym_natural_of_hex "0x24", [] , OpSem_binary (fun ac v1 v2 -> if v2 >= ac.ac_bitwidth then Just 0 else Just (sym_natural_nat_shift_left v1 (natFromSymNatural v2)))); (*0*) +("DW_OP_shr", sym_natural_of_hex "0x25", [] , OpSem_binary (fun ac v1 v2 -> if v2 >= ac.ac_bitwidth then Just 0 else Just (sym_natural_nat_shift_right v1 (natFromSymNatural v2)))); (*0*) +("DW_OP_shra", sym_natural_of_hex "0x26", [] , OpSem_binary (fun ac v1 v2 -> if v1 < ac.ac_half then (if v2 >= ac.ac_bitwidth then Just 0 else Just (sym_natural_nat_shift_right v1 (natFromSymNatural v2))) else (if v2 >= ac.ac_bitwidth then Just ac.ac_max else Just (ac.ac_max - (sym_natural_nat_shift_right (ac.ac_max - v1) (natFromSymNatural v2)))))); (*0*) +("DW_OP_xor", sym_natural_of_hex "0x27", [] , OpSem_binary (fun ac v1 v2 -> Just (sym_natural_lxor v1 v2))); (*0*) +("DW_OP_skip", sym_natural_of_hex "0x2f", [OAT_sint16] , OpSem_not_supported); (*1*) (* signed 2-byte constant *) +("DW_OP_bra", sym_natural_of_hex "0x28", [OAT_sint16] , OpSem_not_supported); (*1*) (* signed 2-byte constant *) +("DW_OP_eq", sym_natural_of_hex "0x29", [] , OpSem_not_supported); (*0*) +("DW_OP_ge", sym_natural_of_hex "0x2a", [] , OpSem_not_supported); (*0*) +("DW_OP_gt", sym_natural_of_hex "0x2b", [] , OpSem_not_supported); (*0*) +("DW_OP_le", sym_natural_of_hex "0x2c", [] , OpSem_not_supported); (*0*) +("DW_OP_lt", sym_natural_of_hex "0x2d", [] , OpSem_not_supported); (*0*) +("DW_OP_ne", sym_natural_of_hex "0x2e", [] , OpSem_not_supported); (*0*) +("DW_OP_lit0", sym_natural_of_hex "0x30", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) (* literals 0..31 =(DW_OP_lit0 + literal) *) +("DW_OP_lit1", sym_natural_of_hex "0x31", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit2", sym_natural_of_hex "0x32", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit3", sym_natural_of_hex "0x33", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit4", sym_natural_of_hex "0x34", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit5", sym_natural_of_hex "0x35", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit6", sym_natural_of_hex "0x36", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit7", sym_natural_of_hex "0x37", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit8", sym_natural_of_hex "0x38", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit9", sym_natural_of_hex "0x39", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit10", sym_natural_of_hex "0x3a", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit11", sym_natural_of_hex "0x3b", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit12", sym_natural_of_hex "0x3c", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit13", sym_natural_of_hex "0x3d", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit14", sym_natural_of_hex "0x3e", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit15", sym_natural_of_hex "0x3f", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit16", sym_natural_of_hex "0x40", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit17", sym_natural_of_hex "0x41", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit18", sym_natural_of_hex "0x42", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit19", sym_natural_of_hex "0x43", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit20", sym_natural_of_hex "0x44", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit21", sym_natural_of_hex "0x45", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit22", sym_natural_of_hex "0x46", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit23", sym_natural_of_hex "0x47", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit24", sym_natural_of_hex "0x48", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit25", sym_natural_of_hex "0x49", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit26", sym_natural_of_hex "0x4a", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit27", sym_natural_of_hex "0x4b", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit28", sym_natural_of_hex "0x4c", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit29", sym_natural_of_hex "0x4d", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit30", sym_natural_of_hex "0x4e", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit31", sym_natural_of_hex "0x4f", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_reg0", sym_natural_of_hex "0x50", [] , OpSem_reg); (*1*) (* reg 0..31 = (DW_OP_reg0 + regnum) *) +("DW_OP_reg1", sym_natural_of_hex "0x51", [] , OpSem_reg); (*1*) +("DW_OP_reg2", sym_natural_of_hex "0x52", [] , OpSem_reg); (*1*) +("DW_OP_reg3", sym_natural_of_hex "0x53", [] , OpSem_reg); (*1*) +("DW_OP_reg4", sym_natural_of_hex "0x54", [] , OpSem_reg); (*1*) +("DW_OP_reg5", sym_natural_of_hex "0x55", [] , OpSem_reg); (*1*) +("DW_OP_reg6", sym_natural_of_hex "0x56", [] , OpSem_reg); (*1*) +("DW_OP_reg7", sym_natural_of_hex "0x57", [] , OpSem_reg); (*1*) +("DW_OP_reg8", sym_natural_of_hex "0x58", [] , OpSem_reg); (*1*) +("DW_OP_reg9", sym_natural_of_hex "0x59", [] , OpSem_reg); (*1*) +("DW_OP_reg10", sym_natural_of_hex "0x5a", [] , OpSem_reg); (*1*) +("DW_OP_reg11", sym_natural_of_hex "0x5b", [] , OpSem_reg); (*1*) +("DW_OP_reg12", sym_natural_of_hex "0x5c", [] , OpSem_reg); (*1*) +("DW_OP_reg13", sym_natural_of_hex "0x5d", [] , OpSem_reg); (*1*) +("DW_OP_reg14", sym_natural_of_hex "0x5e", [] , OpSem_reg); (*1*) +("DW_OP_reg15", sym_natural_of_hex "0x5f", [] , OpSem_reg); (*1*) +("DW_OP_reg16", sym_natural_of_hex "0x60", [] , OpSem_reg); (*1*) +("DW_OP_reg17", sym_natural_of_hex "0x61", [] , OpSem_reg); (*1*) +("DW_OP_reg18", sym_natural_of_hex "0x62", [] , OpSem_reg); (*1*) +("DW_OP_reg19", sym_natural_of_hex "0x63", [] , OpSem_reg); (*1*) +("DW_OP_reg20", sym_natural_of_hex "0x64", [] , OpSem_reg); (*1*) +("DW_OP_reg21", sym_natural_of_hex "0x65", [] , OpSem_reg); (*1*) +("DW_OP_reg22", sym_natural_of_hex "0x66", [] , OpSem_reg); (*1*) +("DW_OP_reg23", sym_natural_of_hex "0x67", [] , OpSem_reg); (*1*) +("DW_OP_reg24", sym_natural_of_hex "0x68", [] , OpSem_reg); (*1*) +("DW_OP_reg25", sym_natural_of_hex "0x69", [] , OpSem_reg); (*1*) +("DW_OP_reg26", sym_natural_of_hex "0x6a", [] , OpSem_reg); (*1*) +("DW_OP_reg27", sym_natural_of_hex "0x6b", [] , OpSem_reg); (*1*) +("DW_OP_reg28", sym_natural_of_hex "0x6c", [] , OpSem_reg); (*1*) +("DW_OP_reg29", sym_natural_of_hex "0x6d", [] , OpSem_reg); (*1*) +("DW_OP_reg30", sym_natural_of_hex "0x6e", [] , OpSem_reg); (*1*) +("DW_OP_reg31", sym_natural_of_hex "0x6f", [] , OpSem_reg); (*1*) +("DW_OP_breg0", sym_natural_of_hex "0x70", [OAT_SLEB128] , OpSem_breg); (*1*) (* base register 0..31 = (DW_OP_breg0 + regnum) *) +("DW_OP_breg1", sym_natural_of_hex "0x71", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg2", sym_natural_of_hex "0x72", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg3", sym_natural_of_hex "0x73", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg4", sym_natural_of_hex "0x74", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg5", sym_natural_of_hex "0x75", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg6", sym_natural_of_hex "0x76", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg7", sym_natural_of_hex "0x77", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg8", sym_natural_of_hex "0x78", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg9", sym_natural_of_hex "0x79", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg10", sym_natural_of_hex "0x7a", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg11", sym_natural_of_hex "0x7b", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg12", sym_natural_of_hex "0x7c", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg13", sym_natural_of_hex "0x7d", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg14", sym_natural_of_hex "0x7e", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg15", sym_natural_of_hex "0x7f", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg16", sym_natural_of_hex "0x80", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg17", sym_natural_of_hex "0x81", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg18", sym_natural_of_hex "0x82", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg19", sym_natural_of_hex "0x83", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg20", sym_natural_of_hex "0x84", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg21", sym_natural_of_hex "0x85", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg22", sym_natural_of_hex "0x86", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg23", sym_natural_of_hex "0x87", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg24", sym_natural_of_hex "0x88", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg25", sym_natural_of_hex "0x89", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg26", sym_natural_of_hex "0x8a", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg27", sym_natural_of_hex "0x8b", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg28", sym_natural_of_hex "0x8c", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg29", sym_natural_of_hex "0x8d", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg30", sym_natural_of_hex "0x8e", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg31", sym_natural_of_hex "0x8f", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_regx", sym_natural_of_hex "0x90", [OAT_ULEB128] , OpSem_lit); (*1*) (* ULEB128 register *) +("DW_OP_fbreg", sym_natural_of_hex "0x91", [OAT_SLEB128] , OpSem_fbreg); (*1*) (* SLEB128 offset *) +("DW_OP_bregx", sym_natural_of_hex "0x92", [OAT_ULEB128; OAT_SLEB128] , OpSem_bregx); (*2*) (* ULEB128 register followed by SLEB128 offset *) +("DW_OP_piece", sym_natural_of_hex "0x93", [OAT_ULEB128] , OpSem_piece); (*1*) (* ULEB128 size of piece addressed *) +("DW_OP_deref_size", sym_natural_of_hex "0x94", [OAT_uint8] , OpSem_deref_size); (*1*) (* 1-byte size of data retrieved *) +("DW_OP_xderef_size", sym_natural_of_hex "0x95", [OAT_uint8] , OpSem_not_supported); (*1*) (* 1-byte size of data retrieved *) +("DW_OP_nop", sym_natural_of_hex "0x96", [] , OpSem_nop); (*0*) +("DW_OP_push_object_address", sym_natural_of_hex "0x97", [] , OpSem_not_supported); (*0*) +("DW_OP_call2", sym_natural_of_hex "0x98", [OAT_uint16] , OpSem_not_supported); (*1*) (* 2-byte offset of DIE *) +("DW_OP_call4", sym_natural_of_hex "0x99", [OAT_uint32] , OpSem_not_supported); (*1*) (* 4-byte offset of DIE *) +("DW_OP_call_ref", sym_natural_of_hex "0x9a", [OAT_dwarf_format_t] , OpSem_not_supported); (*1*) (* 4- or 8-byte offset of DIE *) +("DW_OP_form_tls_address", sym_natural_of_hex "0x9b", [] , OpSem_not_supported); (*0*) +("DW_OP_call_frame_cfa", sym_natural_of_hex "0x9c", [] , OpSem_call_frame_cfa); (*0*) +("DW_OP_bit_piece", sym_natural_of_hex "0x9d", [OAT_ULEB128; OAT_ULEB128] , OpSem_bit_piece); (*2*) (* ULEB128 size followed by ULEB128 offset *) +("DW_OP_implicit_value", sym_natural_of_hex "0x9e", [OAT_block] , OpSem_implicit_value); (*2*) (* ULEB128 size followed by block of that size *) +("DW_OP_stack_value", sym_natural_of_hex "0x9f", [] , OpSem_stack_value); (*0*) (* these aren't real operations -("DW_OP_lo_user", natural_of_hex "0xe0", [] , ); -("DW_OP_hi_user", natural_of_hex "0xff", [] , ); +("DW_OP_lo_user", sym_natural_of_hex "0xe0", [] , ); +("DW_OP_hi_user", sym_natural_of_hex "0xff", [] , ); *) (* GCC also produces these for our example: https://fedorahosted.org/elfutils/wiki/DwarfExtensions http://dwarfstd.org/ShowIssue.php?issue=100909.1 *) -("DW_GNU_OP_entry_value", natural_of_hex "0xf3", [OAT_block], OpSem_not_supported); (*2*) (* ULEB128 size followed by DWARF expression block of that size*) -("DW_OP_GNU_implicit_pointer", natural_of_hex "0xf2", [OAT_dwarf_format_t;OAT_SLEB128], OpSem_not_supported) +("DW_GNU_OP_entry_value", sym_natural_of_hex "0xf3", [OAT_block], OpSem_not_supported); (*2*) (* ULEB128 size followed by DWARF expression block of that size*) +("DW_OP_GNU_implicit_pointer", sym_natural_of_hex "0xf2", [OAT_dwarf_format_t;OAT_SLEB128], OpSem_not_supported) ] -let vDW_OP_reg0 = natural_of_hex "0x50" -let vDW_OP_breg0 = natural_of_hex "0x70" +let vDW_OP_reg0 = sym_natural_of_hex "0x50" +let vDW_OP_breg0 = sym_natural_of_hex "0x70" (* call frame instruction encoding *) -let call_frame_instruction_encoding : list (string * natural * natural * list call_frame_argument_type * ((list call_frame_argument_value) -> maybe call_frame_instruction)) = [ +let call_frame_instruction_encoding : list (string * sym_natural * sym_natural * list call_frame_argument_type * ((list call_frame_argument_value) -> maybe call_frame_instruction)) = [ (* high-order 2 bits low-order 6 bits uniformly parsed arguments *) (* instructions using low-order 6 bits for first argument *) @@ -1247,53 +1348,53 @@ let call_frame_instruction_encoding : list (string * natural * natural * list ca ("DW_CFA_restore", 3, 0,(*register*) []); *) (* instructions using low-order 6 bits as part of opcode *) -("DW_CFA_nop", 0, natural_of_hex "0x00", [], (* *) +("DW_CFA_nop", 0, sym_natural_of_hex "0x00", [], (* *) fun avs -> match avs with [] -> Just (DW_CFA_nop) | _ -> Nothing end); -("DW_CFA_set_loc", 0, natural_of_hex "0x01", [CFAT_address], (* address *) +("DW_CFA_set_loc", 0, sym_natural_of_hex "0x01", [CFAT_address], (* address *) fun avs -> match avs with [CFAV_address a] -> Just (DW_CFA_set_loc a) | _ -> Nothing end); -("DW_CFA_advance_loc1", 0, natural_of_hex "0x02", [CFAT_delta1], (* 1-byte delta *) +("DW_CFA_advance_loc1", 0, sym_natural_of_hex "0x02", [CFAT_delta1], (* 1-byte delta *) fun avs -> match avs with [CFAV_delta d] -> Just (DW_CFA_advance_loc1 d) | _ -> Nothing end); -("DW_CFA_advance_loc2", 0, natural_of_hex "0x03", [CFAT_delta2], (* 2-byte delta *) +("DW_CFA_advance_loc2", 0, sym_natural_of_hex "0x03", [CFAT_delta2], (* 2-byte delta *) fun avs -> match avs with [CFAV_delta d] -> Just (DW_CFA_advance_loc2 d) | _ -> Nothing end); -("DW_CFA_advance_loc4", 0, natural_of_hex "0x04", [CFAT_delta4], (* 4-byte delta *) +("DW_CFA_advance_loc4", 0, sym_natural_of_hex "0x04", [CFAT_delta4], (* 4-byte delta *) fun avs -> match avs with [CFAV_delta d] -> Just (DW_CFA_advance_loc4 d) | _ -> Nothing end); -("DW_CFA_offset_extended", 0, natural_of_hex "0x05", [CFAT_register; CFAT_offset], (* ULEB128 register ULEB128 offset *) +("DW_CFA_offset_extended", 0, sym_natural_of_hex "0x05", [CFAT_register; CFAT_offset], (* ULEB128 register ULEB128 offset *) fun avs -> match avs with [CFAV_register r; CFAV_offset n] -> Just (DW_CFA_offset_extended r n) | _ -> Nothing end); -("DW_CFA_restore_extended", 0, natural_of_hex "0x06", [CFAT_register], (* ULEB128 register *) +("DW_CFA_restore_extended", 0, sym_natural_of_hex "0x06", [CFAT_register], (* ULEB128 register *) fun avs -> match avs with [CFAV_register r] -> Just (DW_CFA_restore_extended r) | _ -> Nothing end); -("DW_CFA_undefined", 0, natural_of_hex "0x07", [CFAT_register], (* ULEB128 register *) +("DW_CFA_undefined", 0, sym_natural_of_hex "0x07", [CFAT_register], (* ULEB128 register *) fun avs -> match avs with [CFAV_register r] -> Just (DW_CFA_undefined r) | _ -> Nothing end); -("DW_CFA_same_value", 0, natural_of_hex "0x08", [CFAT_register], (* ULEB128 register *) +("DW_CFA_same_value", 0, sym_natural_of_hex "0x08", [CFAT_register], (* ULEB128 register *) fun avs -> match avs with [CFAV_register r] -> Just (DW_CFA_same_value r) | _ -> Nothing end); -("DW_CFA_register", 0, natural_of_hex "0x09", [CFAT_register; CFAT_register], (* ULEB128 register ULEB128 register *) +("DW_CFA_register", 0, sym_natural_of_hex "0x09", [CFAT_register; CFAT_register], (* ULEB128 register ULEB128 register *) fun avs -> match avs with [CFAV_register r1; CFAV_register r2] -> Just (DW_CFA_register r1 r2) | _ -> Nothing end); -("DW_CFA_remember_state", 0, natural_of_hex "0x0a", [], (* *) +("DW_CFA_remember_state", 0, sym_natural_of_hex "0x0a", [], (* *) fun avs -> match avs with [] -> Just (DW_CFA_remember_state) | _ -> Nothing end); -("DW_CFA_restore_state", 0, natural_of_hex "0x0b", [], (* *) +("DW_CFA_restore_state", 0, sym_natural_of_hex "0x0b", [], (* *) fun avs -> match avs with [] -> Just (DW_CFA_restore_state) | _ -> Nothing end); -("DW_CFA_def_cfa", 0, natural_of_hex "0x0c", [CFAT_register; CFAT_offset], (* ULEB128 register ULEB128 offset *) +("DW_CFA_def_cfa", 0, sym_natural_of_hex "0x0c", [CFAT_register; CFAT_offset], (* ULEB128 register ULEB128 offset *) fun avs -> match avs with [CFAV_register r; CFAV_offset n] -> Just (DW_CFA_def_cfa r n) | _ -> Nothing end); -("DW_CFA_def_cfa_register", 0, natural_of_hex "0x0d", [CFAT_register], (* ULEB128 register *) +("DW_CFA_def_cfa_register", 0, sym_natural_of_hex "0x0d", [CFAT_register], (* ULEB128 register *) fun avs -> match avs with [CFAV_register r] -> Just (DW_CFA_def_cfa_register r) | _ -> Nothing end); -("DW_CFA_def_cfa_offset", 0, natural_of_hex "0x0e", [CFAT_offset], (* ULEB128 offset *) +("DW_CFA_def_cfa_offset", 0, sym_natural_of_hex "0x0e", [CFAT_offset], (* ULEB128 offset *) fun avs -> match avs with [CFAV_offset n] -> Just (DW_CFA_def_cfa_offset n) | _ -> Nothing end); -("DW_CFA_def_cfa_expression", 0, natural_of_hex "0x0f", [CFAT_block], (* BLOCK *) +("DW_CFA_def_cfa_expression", 0, sym_natural_of_hex "0x0f", [CFAT_block], (* BLOCK *) fun avs -> match avs with [CFAV_block b] -> Just (DW_CFA_def_cfa_expression b) | _ -> Nothing end); -("DW_CFA_expression", 0, natural_of_hex "0x10", [CFAT_register; CFAT_block], (* ULEB128 register BLOCK *) +("DW_CFA_expression", 0, sym_natural_of_hex "0x10", [CFAT_register; CFAT_block], (* ULEB128 register BLOCK *) fun avs -> match avs with [CFAV_register r; CFAV_block b] -> Just (DW_CFA_expression r b) | _ -> Nothing end); -("DW_CFA_offset_extended_sf", 0, natural_of_hex "0x11", [CFAT_register; CFAT_sfoffset], (* ULEB128 register SLEB128 offset *) +("DW_CFA_offset_extended_sf", 0, sym_natural_of_hex "0x11", [CFAT_register; CFAT_sfoffset], (* ULEB128 register SLEB128 offset *) fun avs -> match avs with [CFAV_register r; CFAV_sfoffset i] -> Just (DW_CFA_offset_extended_sf r i) | _ -> Nothing end); -("DW_CFA_def_cfa_sf", 0, natural_of_hex "0x12", [CFAT_register; CFAT_sfoffset], (* ULEB128 register SLEB128 offset *) +("DW_CFA_def_cfa_sf", 0, sym_natural_of_hex "0x12", [CFAT_register; CFAT_sfoffset], (* ULEB128 register SLEB128 offset *) fun avs -> match avs with [CFAV_register r; CFAV_sfoffset i] -> Just (DW_CFA_def_cfa_sf r i) | _ -> Nothing end); -("DW_CFA_def_cfa_offset_sf", 0, natural_of_hex "0x13", [CFAT_sfoffset], (* SLEB128 offset *) +("DW_CFA_def_cfa_offset_sf", 0, sym_natural_of_hex "0x13", [CFAT_sfoffset], (* SLEB128 offset *) fun avs -> match avs with [CFAV_sfoffset i] -> Just (DW_CFA_def_cfa_offset_sf i) | _ -> Nothing end); -("DW_CFA_val_offset", 0, natural_of_hex "0x14", [CFAT_register; CFAT_offset], (* ULEB128 ULEB128 *) +("DW_CFA_val_offset", 0, sym_natural_of_hex "0x14", [CFAT_register; CFAT_offset], (* ULEB128 ULEB128 *) fun avs -> match avs with [CFAV_register r; CFAV_offset n] -> Just (DW_CFA_val_offset r n) | _ -> Nothing end); -("DW_CFA_val_offset_sf", 0, natural_of_hex "0x15", [CFAT_register; CFAT_sfoffset], (* ULEB128 SLEB128 *) +("DW_CFA_val_offset_sf", 0, sym_natural_of_hex "0x15", [CFAT_register; CFAT_sfoffset], (* ULEB128 SLEB128 *) fun avs -> match avs with [CFAV_register r; CFAV_sfoffset i] -> Just (DW_CFA_val_offset_sf r i) | _ -> Nothing end); -("DW_CFA_val_expression", 0, natural_of_hex "0x16", [CFAT_register; CFAT_block], (* ULEB128 BLOCK *) +("DW_CFA_val_expression", 0, sym_natural_of_hex "0x16", [CFAT_register; CFAT_block], (* ULEB128 BLOCK *) fun avs -> match avs with [CFAV_register r; CFAV_block b] -> Just (DW_CFA_val_expression r b) | _ -> Nothing end); -("DW_CFA_AARCH64_negate_ra_state", 0, natural_of_hex "0x2d", [], (* *) +("DW_CFA_AARCH64_negate_ra_state", 0, sym_natural_of_hex "0x2d", [], (* *) fun avs -> match avs with [] -> Just (DW_CFA_AARCH64_negate_ra_state) | _ -> Nothing end); ] (* @@ -1310,55 +1411,55 @@ p10 says "The RA_SIGN_STATE pseudo-register records whether the return address h For our purposes it seems fine to nop-this. *) (* -("DW_CFA_lo_user", 0, natural_of_hex "0x1c", []); (* *) -("DW_CFA_hi_user", 0, natural_of_hex "0x3f", []); (* *) +("DW_CFA_lo_user", 0, sym_natural_of_hex "0x1c", []); (* *) +("DW_CFA_hi_user", 0, sym_natural_of_hex "0x3f", []); (* *) *) (* line number encodings *) let line_number_standard_encodings = [ - ("DW_LNS_copy" , natural_of_hex "0x01", [ ], + ("DW_LNS_copy" , sym_natural_of_hex "0x01", [ ], fun lnvs -> match lnvs with [] -> Just DW_LNS_copy | _ -> Nothing end); - ("DW_LNS_advance_pc" , natural_of_hex "0x02", [LNAT_ULEB128 ], + ("DW_LNS_advance_pc" , sym_natural_of_hex "0x02", [LNAT_ULEB128 ], fun lnvs -> match lnvs with [LNAV_ULEB128 n] -> Just (DW_LNS_advance_pc n) | _ -> Nothing end); - ("DW_LNS_advance_line" , natural_of_hex "0x03", [LNAT_SLEB128 ], + ("DW_LNS_advance_line" , sym_natural_of_hex "0x03", [LNAT_SLEB128 ], fun lnvs -> match lnvs with [LNAV_SLEB128 i] -> Just (DW_LNS_advance_line i) | _ -> Nothing end); - ("DW_LNS_set_file" , natural_of_hex "0x04", [LNAT_ULEB128 ], + ("DW_LNS_set_file" , sym_natural_of_hex "0x04", [LNAT_ULEB128 ], fun lnvs -> match lnvs with [LNAV_ULEB128 n] -> Just (DW_LNS_set_file n) | _ -> Nothing end); - ("DW_LNS_set_column" , natural_of_hex "0x05", [LNAT_ULEB128 ], + ("DW_LNS_set_column" , sym_natural_of_hex "0x05", [LNAT_ULEB128 ], fun lnvs -> match lnvs with [LNAV_ULEB128 n] -> Just (DW_LNS_set_column n) | _ -> Nothing end); - ("DW_LNS_negate_stmt" , natural_of_hex "0x06", [ ], + ("DW_LNS_negate_stmt" , sym_natural_of_hex "0x06", [ ], fun lnvs -> match lnvs with [] -> Just (DW_LNS_negate_stmt) | _ -> Nothing end); - ("DW_LNS_set_basic_block" , natural_of_hex "0x07", [ ], + ("DW_LNS_set_basic_block" , sym_natural_of_hex "0x07", [ ], fun lnvs -> match lnvs with [] -> Just (DW_LNS_set_basic_block) | _ -> Nothing end); - ("DW_LNS_const_add_pc" , natural_of_hex "0x08", [ ], + ("DW_LNS_const_add_pc" , sym_natural_of_hex "0x08", [ ], fun lnvs -> match lnvs with [] -> Just (DW_LNS_const_add_pc) | _ -> Nothing end); - ("DW_LNS_fixed_advance_pc" , natural_of_hex "0x09", [LNAT_uint16 ], + ("DW_LNS_fixed_advance_pc" , sym_natural_of_hex "0x09", [LNAT_uint16 ], fun lnvs -> match lnvs with [LNAV_uint16 n] -> Just (DW_LNS_fixed_advance_pc n) | _ -> Nothing end); - ("DW_LNS_set_prologue_end" , natural_of_hex "0x0a", [ ], + ("DW_LNS_set_prologue_end" , sym_natural_of_hex "0x0a", [ ], fun lnvs -> match lnvs with [] -> Just (DW_LNS_set_prologue_end) | _ -> Nothing end); - ("DW_LNS_set_epilogue_begin" , natural_of_hex "0x0b", [ ], + ("DW_LNS_set_epilogue_begin" , sym_natural_of_hex "0x0b", [ ], fun lnvs -> match lnvs with [] -> Just (DW_LNS_set_epilogue_begin) | _ -> Nothing end); - ("DW_LNS_set_isa" , natural_of_hex "0x0c", [LNAT_ULEB128 ], + ("DW_LNS_set_isa" , sym_natural_of_hex "0x0c", [LNAT_ULEB128 ], fun lnvs -> match lnvs with [LNAV_ULEB128 n] -> Just (DW_LNS_set_isa n) | _ -> Nothing end) ] let line_number_extended_encodings = [ - ("DW_LNE_end_sequence" , natural_of_hex "0x01", [], + ("DW_LNE_end_sequence" , sym_natural_of_hex "0x01", [], fun lnvs -> match lnvs with [] -> Just (DW_LNE_end_sequence) | _ -> Nothing end); - ("DW_LNE_set_address" , natural_of_hex "0x02", [LNAT_address], + ("DW_LNE_set_address" , sym_natural_of_hex "0x02", [LNAT_address], fun lnvs -> match lnvs with [LNAV_address n] -> Just (DW_LNE_set_address n) | _ -> Nothing end); - ("DW_LNE_define_file" , natural_of_hex "0x03", [LNAT_string; LNAT_ULEB128; LNAT_ULEB128; LNAT_ULEB128], + ("DW_LNE_define_file" , sym_natural_of_hex "0x03", [LNAT_string; LNAT_ULEB128; LNAT_ULEB128; LNAT_ULEB128], fun lnvs -> match lnvs with [LNAV_string s; LNAV_ULEB128 n1; LNAV_ULEB128 n2; LNAV_ULEB128 n3] -> Just (DW_LNE_define_file s n1 n2 n3) | _ -> Nothing end); - ("DW_LNE_set_discriminator" , natural_of_hex "0x04", [LNAT_ULEB128], + ("DW_LNE_set_discriminator" , sym_natural_of_hex "0x04", [LNAT_ULEB128], fun lnvs -> match lnvs with [LNAV_ULEB128 n] -> Just (DW_LNE_set_discriminator n) | _ -> Nothing end) (* new in Dwarf 4*) ] (* -(DW_LNE_lo_user , natural_of_hex "0x80", "DW_LNE_lo_user"); -(DW_LNE_hi_user , natural_of_hex "0xff", "DW_LNE_hi_user"); +(DW_LNE_lo_user , sym_natural_of_hex "0x80", "DW_LNE_lo_user"); +(DW_LNE_hi_user , sym_natural_of_hex "0xff", "DW_LNE_hi_user"); *) @@ -1367,26 +1468,26 @@ let line_number_extended_encodings = [ (* base type attribute encoding *) let base_type_attribute_encodings = [ - ("DW_ATE_address" , natural_of_hex "0x01"); - ("DW_ATE_boolean" , natural_of_hex "0x02"); - ("DW_ATE_complex_float" , natural_of_hex "0x03"); - ("DW_ATE_float" , natural_of_hex "0x04"); - ("DW_ATE_signed" , natural_of_hex "0x05"); - ("DW_ATE_signed_char" , natural_of_hex "0x06"); - ("DW_ATE_unsigned" , natural_of_hex "0x07"); - ("DW_ATE_unsigned_char" , natural_of_hex "0x08"); - ("DW_ATE_imaginary_float" , natural_of_hex "0x09"); - ("DW_ATE_packed_decimal" , natural_of_hex "0x0a"); - ("DW_ATE_numeric_string" , natural_of_hex "0x0b"); - ("DW_ATE_edited" , natural_of_hex "0x0c"); - ("DW_ATE_signed_fixed" , natural_of_hex "0x0d"); - ("DW_ATE_unsigned_fixed" , natural_of_hex "0x0e"); - ("DW_ATE_decimal_float" , natural_of_hex "0x0f"); - ("DW_ATE_UTF" , natural_of_hex "0x10"); - ("DW_ATE_lo_user" , natural_of_hex "0x80"); - ("DW_ATE_signed_capability_hack_a0" , natural_of_hex "0xa0"); - ("DW_ATE_unsigned_capability_hack_a1" , natural_of_hex "0xa1"); - ("DW_ATE_hi_user" , natural_of_hex "0xff") + ("DW_ATE_address" , sym_natural_of_hex "0x01"); + ("DW_ATE_boolean" , sym_natural_of_hex "0x02"); + ("DW_ATE_complex_float" , sym_natural_of_hex "0x03"); + ("DW_ATE_float" , sym_natural_of_hex "0x04"); + ("DW_ATE_signed" , sym_natural_of_hex "0x05"); + ("DW_ATE_signed_char" , sym_natural_of_hex "0x06"); + ("DW_ATE_unsigned" , sym_natural_of_hex "0x07"); + ("DW_ATE_unsigned_char" , sym_natural_of_hex "0x08"); + ("DW_ATE_imaginary_float" , sym_natural_of_hex "0x09"); + ("DW_ATE_packed_decimal" , sym_natural_of_hex "0x0a"); + ("DW_ATE_numeric_string" , sym_natural_of_hex "0x0b"); + ("DW_ATE_edited" , sym_natural_of_hex "0x0c"); + ("DW_ATE_signed_fixed" , sym_natural_of_hex "0x0d"); + ("DW_ATE_unsigned_fixed" , sym_natural_of_hex "0x0e"); + ("DW_ATE_decimal_float" , sym_natural_of_hex "0x0f"); + ("DW_ATE_UTF" , sym_natural_of_hex "0x10"); + ("DW_ATE_lo_user" , sym_natural_of_hex "0x80"); + ("DW_ATE_signed_capability_hack_a0" , sym_natural_of_hex "0xa0"); + ("DW_ATE_unsigned_capability_hack_a1" , sym_natural_of_hex "0xa1"); + ("DW_ATE_hi_user" , sym_natural_of_hex "0xff") ] (** ************************************************************ *) @@ -1449,6 +1550,8 @@ let bytes_of_natural en size n = else Assert_extra.failwith "bytes_of_natural given size that is not 4 or 8") +let bytes_of_sym_natural en size n = bytes_of_natural en (sym_unwrap size) (sym_unwrap n) + let rec natural_of_bytes_little bs : natural = match read_char bs with | Fail _ -> 0 @@ -1468,6 +1571,8 @@ let natural_of_bytes en bs = | Big -> natural_of_bytes_big 0 bs end +let sym_natural_of_bytes en bs = Absolute (natural_of_bytes en bs) + (* TODO: generalise *) (* @@ -1517,12 +1622,12 @@ let rec mytake' (n:natural) acc xs = | (_, x::xs') -> mytake' (n-1) (x::acc) xs' end -val mytake : forall 'a. natural -> (list 'a) -> maybe (list 'a * list 'a) -let mytake n xs = mytake' n [] xs +val mytake : forall 'a. sym_natural -> (list 'a) -> maybe (list 'a * list 'a) +let mytake n xs = mytake' (sym_unwrap n) [] xs -val mynth : forall 'a. natural -> (list 'a) -> maybe 'a -let rec mynth (n:natural) xs = - match (n,xs) with +val mynth : forall 'a. sym_natural -> (list 'a) -> maybe 'a +let rec mynth (n:sym_natural) xs = + match (sym_unwrap n,xs) with | (0, x::xs') -> Just x | (0, []) -> Nothing (*Assert_extra.failwith "mynth"*) | (_, x::xs') -> mynth (n-1) xs' @@ -1534,6 +1639,9 @@ let rec mynth (n:natural) xs = let pphexplain n = unsafe_hex_string_of_natural 0 n let pphex n = "0x" ^ pphexplain n +let pphexplain_sym = pp_sym pphexplain +let pphex_sym = pp_sym pphex + val abs : integer -> natural (*declare hol target_rep function abs = `int_of_num` *) declare ocaml target_rep function abs = `Nat_big_num.abs` @@ -1551,7 +1659,7 @@ let rec ppbytes2 n bs = | Success (x,xs') -> "<" ^ pphex n ^ "> " ^ show x ^ "\n" ^ ppbytes2 (n+1) xs' end -let rec ppbytesplain (c:p_context) (n:natural) bs = show (natural_of_bytes c.endianness bs) +let rec ppbytesplain (c:p_context) (n:sym_natural) bs = show (natural_of_bytes c.endianness bs) (* unsafe_hex_string_of_uc_list (List.map unsigned_char_of_byte xs) (*match xs with | [] -> "" | x::xs' -> pphexplain x ^ ppbytesplain (n+1) xs' end*) *) @@ -1573,17 +1681,17 @@ let just_one s xs = -let max_address (as': natural) : natural = - match as' with - | 4 -> natural_of_hex "0xffffffff" - | 8 -> natural_of_hex "0xffffffffffffffff" +let max_address (as': sym_natural) : sym_natural = + match sym_unwrap as' with + | 4 -> sym_natural_of_hex "0xffffffff" + | 8 -> sym_natural_of_hex "0xffffffffffffffff" | _ -> Assert_extra.failwith "max_address size not 4 or 8" end -let range_address (as': natural) : natural = - match as' with - | 4 -> natural_of_hex "0x100000000" - | 8 -> natural_of_hex "0x10000000000000000" +let range_address (as': sym_natural) : sym_natural = + match sym_unwrap as' with + | 4 -> sym_natural_of_hex "0x100000000" + | 8 -> sym_natural_of_hex "0x10000000000000000" | _ -> Assert_extra.failwith "range_address size not 4 or 8" end @@ -1651,32 +1759,32 @@ let rec lookup_abCde_de z0 xyzwus = end -let pp_maybe ppf n = match ppf n with Just s -> s | Nothing -> "Unknown AT value: " ^ pphexplain n (*encoding not found: "" ^ pphex n*) end +let pp_maybe ppf n = match ppf n with Just s -> s | Nothing -> "Unknown AT value: " ^ pphexplain_sym n (*encoding not found: "" ^ pphex n*) end let pp_tag_encoding n = pp_maybe (fun n -> lookup_aB_a n tag_encodings) n let pp_attribute_encoding n = pp_maybe (fun n -> lookup_aBc_a n attribute_encodings) n let pp_attribute_form_encoding n = pp_maybe (fun n -> lookup_aBc_a n attribute_form_encodings) n let pp_operation_encoding n = pp_maybe (fun n -> lookup_aBcd_a n operation_encodings) n -let tag_encode (s: string) : natural = +let tag_encode (s: string) : sym_natural = match lookup_Ab_b s tag_encodings with | Just n -> n | Nothing -> Assert_extra.failwith ("tag_encode: \""^s^"\"") end -let attribute_encode (s: string) : natural = +let attribute_encode (s: string) : sym_natural = match lookup_Abc_b s attribute_encodings with | Just n -> n | Nothing -> Assert_extra.failwith ("attribute_encode: \""^s^"\"") end -let attribute_form_encode (s: string) : natural = +let attribute_form_encode (s: string) : sym_natural = match lookup_Abc_b s attribute_form_encodings with | Just n -> n | Nothing -> Assert_extra.failwith "attribute_form_encode" end -let base_type_attribute_encode (s: string) : natural = +let base_type_attribute_encode (s: string) : sym_natural = match lookup_Ab_b s base_type_attribute_encodings with | Just n -> n | Nothing -> Assert_extra.failwith "base_type_attribute_encode" @@ -1743,8 +1851,8 @@ val pr_post_map : forall 'a 'b. (parser 'a) -> ('a -> 'b) -> (parser 'b) let pr_post_map p f = fun (pc: parse_context) -> pr_map f (p pc) -val pr_with_pos : forall 'a. (parser 'a) -> (parser (natural * 'a)) -let pr_with_pos p = fun pc -> pr_map (fun x -> (pc.pc_offset,x)) (p pc) +val pr_with_pos : forall 'a. (parser 'a) -> (parser (sym_natural * 'a)) +let pr_with_pos p = fun pc -> pr_map (fun x -> (Absolute pc.pc_offset,x)) (p pc) val parse_pair : forall 'a 'b. (parser 'a) -> (parser 'b) -> (parser ('a * 'b)) @@ -1836,10 +1944,10 @@ let parse_demaybe s p = end -val parse_restrict_length : forall 'a. natural -> parser 'a -> parser 'a +val parse_restrict_length : forall 'a. sym_natural -> parser 'a -> parser 'a let parse_restrict_length n p = fun pc -> - match partition n pc.pc_bytes with + match partition (sym_unwrap n) pc.pc_bytes with | Fail _ -> Assert_extra.failwith "parse_restrict_length not given enough bytes" | Success (xs,ys) -> let pc' = <| pc_bytes = xs; pc_offset = pc.pc_offset |> in @@ -1856,10 +1964,10 @@ let parse_byte : parser(byte) = | Success (b,bs) -> PR_success b (<|pc_bytes=bs; pc_offset= pc.pc_offset + 1 |> ) end -let parse_n_bytes (n:natural) : parser (byte_sequence) = +let parse_n_bytes (n:sym_natural) : parser (byte_sequence) = fun (pc:parse_context) -> - match partition n pc.pc_bytes with - | Fail _ -> PR_fail ("parse_n_bytes n=" ^ pphex n) pc + match partition (sym_unwrap n) pc.pc_bytes with + | Fail _ -> PR_fail ("parse_n_bytes n=" ^ pphex_sym n) pc | Success (xs,bs) -> PR_success xs (<|pc_bytes=bs; pc_offset= pc.pc_offset + (Byte_sequence.length xs) |> ) end @@ -1871,7 +1979,7 @@ let parse_string : parser (byte_sequence) = match find_byte pc.pc_bytes bzero with | Nothing -> PR_fail "parse_string" pc | Just n -> - pr_bind (parse_n_bytes n pc) (fun res pc -> + pr_bind (parse_n_bytes (Absolute n) pc) (fun res pc -> (*todo find byte should respect relocs*) pr_bind (parse_byte pc) (fun _ pc -> pr_return res pc)) end @@ -1886,23 +1994,25 @@ let parse_non_empty_string : parser (maybe byte_sequence) = pr_return (Just str) pc) -let parse_uint8 : parser natural = +(* TODO relocations *) +let parse_uint8 : parser sym_natural= fun (pc:parse_context) -> let _ = my_debug "uint8 " in match read_char pc.pc_bytes with | Success (b, bytes) -> let v = natural_of_byte b in - PR_success v (<| pc_bytes = bytes; pc_offset = pc.pc_offset + 1 |>) + PR_success (Absolute v) (<| pc_bytes = bytes; pc_offset = pc.pc_offset + 1 |>) | _ -> PR_fail "parse_uint32 not given enough bytes" pc end -let parse_uint8_constant (v:natural) : parser natural = +let parse_uint8_constant (v:sym_natural) : parser sym_natural= fun (pc:parse_context) -> let _ = my_debug "uint8_constant " in PR_success v pc - -let parse_uint16 c : parser natural = + +(* TODO relocations *) +let parse_uint16 c : parser sym_natural= fun (pc:parse_context) -> let _ = my_debug "uint16 " in match read_2_bytes_be pc.pc_bytes with @@ -1911,11 +2021,12 @@ let parse_uint16 c : parser natural = natural_of_byte b0 + 256*natural_of_byte b1 else natural_of_byte b1 + 256*natural_of_byte b0 in - PR_success v (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 2 |>) + PR_success (Absolute v) (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 2 |>) | _ -> PR_fail "parse_uint32 not given enough bytes" pc end -let parse_uint32 c : parser natural = +(* TODO relocations *) +let parse_uint32 c : parser sym_natural= fun (pc:parse_context) -> let _ = my_debug "uint32 " in match read_4_bytes_be pc.pc_bytes with @@ -1924,11 +2035,12 @@ let parse_uint32 c : parser natural = natural_of_byte b0 + 256*natural_of_byte b1 + 256*256*natural_of_byte b2 + 256*256*256*natural_of_byte b3 else natural_of_byte b3 + 256*natural_of_byte b2 + 256*256*natural_of_byte b1 + 256*256*256*natural_of_byte b0 in - PR_success v (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 4 |>) + PR_success (Absolute v) (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 4 |>) | _ -> PR_fail "parse_uint32 not given enough bytes" pc end -let parse_uint64 c : parser natural = +(* TODO relocations *) +let parse_uint64 c : parser sym_natural= fun (pc:parse_context) -> let _ = my_debug "uint64 " in match read_8_bytes_be pc.pc_bytes with @@ -1940,10 +2052,11 @@ let parse_uint64 c : parser natural = natural_of_byte b7 + 256*natural_of_byte b6 + 256*256*natural_of_byte b5 + 256*256*256*natural_of_byte b4 + (256*256*256*256*(natural_of_byte b3 + 256*natural_of_byte b2 + 256*256*natural_of_byte b1 + 256*256*256*natural_of_byte b0)) in - PR_success v (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 8 |>) + PR_success (Absolute v) (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 8 |>) | _ -> PR_fail "parse_uint64 not given enough bytes" pc end + let integerFromTwosComplementNatural (n:natural) (half: natural) (all:integer) : integer = if n < half then integerFromNatural n else integerFromNatural n - all @@ -1952,18 +2065,19 @@ let partialTwosComplementNaturalFromInteger (i:integer) (half: natural) (all:int else if i >= (0-integerFromNatural half) && i < 0 then partialNaturalFromInteger (all + i) else Assert_extra.failwith "partialTwosComplementNaturalFromInteger" +let partialTwosComplementSymNaturalFromInteger i half all = sym_map (fun x -> partialTwosComplementNaturalFromInteger i x all) half let parse_sint8 : parser integer = - pr_post_map (parse_uint8) (fun n -> integerFromTwosComplementNatural n 128 256) + pr_post_map (parse_uint8) (fun n -> integerFromTwosComplementNatural (sym_unwrap n) 128 256) let parse_sint16 c : parser integer = - pr_post_map (parse_uint16 c) (fun n -> integerFromTwosComplementNatural n (128*256) (256*256)) + pr_post_map (parse_uint16 c) (fun n -> integerFromTwosComplementNatural (sym_unwrap n) (128*256) (256*256)) let parse_sint32 c : parser integer = - pr_post_map (parse_uint32 c) (fun n -> integerFromTwosComplementNatural n (128*256*256*256) (256*256*256*256)) + pr_post_map (parse_uint32 c) (fun n -> integerFromTwosComplementNatural (sym_unwrap n) (128*256*256*256) (256*256*256*256)) let parse_sint64 c : parser integer = - pr_post_map (parse_uint64 c) (fun n -> integerFromTwosComplementNatural n (128*256*256*256*256*256*256*256) (256*256*256*256*256*256*256*256)) + pr_post_map (parse_uint64 c) (fun n -> integerFromTwosComplementNatural (sym_unwrap n) (128*256*256*256*256*256*256*256) (256*256*256*256*256*256*256*256)) let rec parse_ULEB128' (acc: natural) (shift_factor: natural) : parser natural = fun (pc:parse_context) -> @@ -1982,9 +2096,9 @@ let rec parse_ULEB128' (acc: natural) (shift_factor: natural) : parser natural = PR_fail "parse_ULEB128' not given enough bytes" pc end -let parse_ULEB128 : parser natural = +let parse_ULEB128 : parser sym_natural = fun (pc:parse_context) -> - parse_ULEB128' 0 1 pc + pr_map (fun x -> Absolute x) (parse_ULEB128' 0 1 pc) let rec parse_SLEB128' (acc: natural) (shift_factor: natural) : parser (bool * natural * natural) = fun (pc:parse_context) -> @@ -2007,33 +2121,33 @@ let rec parse_SLEB128' (acc: natural) (shift_factor: natural) : parser (bool * n let parse_SLEB128 : parser integer = pr_post_map (parse_SLEB128' 0 1) (fun (positive, shift_factor, acc) -> - if positive then integerFromNatural acc else integerFromNatural acc - integerFromNatural shift_factor) + if positive then integerFromNatural acc else integerFromNatural acc - integerFromNatural shift_factor) -let parse_nonzero_ULEB128_pair : parser (maybe (natural*natural)) = +let parse_nonzero_ULEB128_pair : parser (maybe (sym_natural*sym_natural)) = let _ = my_debug "nonzero_ULEB128_pair " in pr_post_map (parse_pair parse_ULEB128 parse_ULEB128) (fun (n1,n2) -> if n1=0 && n2=0 then Nothing else Just (n1,n2)) -let parse_zero_terminated_ULEB128_pair_list : parser (list (natural*natural)) = +let parse_zero_terminated_ULEB128_pair_list : parser (list (sym_natural*sym_natural)) = let _ = my_debug "zero_terminated_ULEB128_pair_list " in parse_list parse_nonzero_ULEB128_pair -let parse_uintDwarfN c (df: dwarf_format) : parser natural = +let parse_uintDwarfN c (df: dwarf_format) : parser sym_natural = match df with - | Dwarf32 -> (parse_uint32 c) - | Dwarf64 -> (parse_uint64 c) - end + | Dwarf32 -> (parse_uint32 c) + | Dwarf64 -> (parse_uint64 c) + end -let parse_uint_address_size c (as': natural) : parser natural = - match as' with +let parse_uint_address_size c (as': sym_natural) : parser sym_natural = + match sym_unwrap as' with | 4 -> (parse_uint32 c) | 8 -> (parse_uint64 c) | _ -> Assert_extra.failwith ("cuh_address_size not 4 or 8: " ^ show as') end -let parse_uint_segment_selector_size c (ss: natural) : parser (maybe natural) = - match ss with +let parse_uint_segment_selector_size c (ss: sym_natural) : parser (maybe sym_natural) = + match sym_unwrap ss with | 0 -> pr_return Nothing | 1 -> pr_post_map (parse_uint8) (fun n -> Just n) | 2 -> pr_post_map (parse_uint16 c) (fun n -> Just n) @@ -2067,7 +2181,7 @@ let pp_abbreviation_declaration (x:abbreviation_declaration) = let pp_abbreviations_table (x:abbreviations_table) = - "offset: "^pphex x.at_offset^"\n" + "offset: "^pphex_sym x.at_offset^"\n" ^ String.concat "" (List.map (pp_abbreviation_declaration) x.at_table) (* print the distinct abbreviation tables used by all compilation units *) @@ -2082,7 +2196,7 @@ let rec remove_duplicates xys xys_acc = end let pp_abbreviations_tables (d:dwarf) = - let xs : list (natural * abbreviations_table) = + let xs : list (sym_natural * abbreviations_table) = List.map (fun cu -> (cu.cu_header.cuh_debug_abbrev_offset, cu.cu_abbreviations_table)) d.d_compilation_units in @@ -2128,8 +2242,8 @@ let rec null_terminated_bs (bs: byte_sequence) : byte_sequence = | Nothing -> bs end -let pp_debug_str_entry (str: byte_sequence) (n: natural) : string = - match dropbytes n str with +let pp_debug_str_entry (str: byte_sequence) (n: sym_natural) : string = + match dropbytes (sym_unwrap n) str with | Fail _ -> "strp beyond .debug_str extent" | Success bs -> string_of_byte_sequence (null_terminated_bs bs) end @@ -2138,9 +2252,9 @@ let pp_debug_str_entry (str: byte_sequence) (n: natural) : string = let pp_operation_argument_value (oav:operation_argument_value) : string = match oav with - | OAV_natural n -> pphex n + | OAV_natural n -> pphex_sym n | OAV_integer n -> pphex_integer n (* show n*) - | OAV_block n bs -> pphex n ^ " " ^ ppbytes bs + | OAV_block n bs -> pphex_sym n ^ " " ^ ppbytes bs end let pp_operation_semantics (os: operation_semantics) : string = @@ -2205,7 +2319,7 @@ let parse_operation c cuh pc = | PR_fail s pc' -> PR_success Nothing pc | PR_success code pc' -> match lookup_aBcd_acd code operation_encodings with - | Nothing -> PR_fail ("encoding not found: " ^ pphex code) pc + | Nothing -> PR_fail ("encoding not found: " ^ pphex_sym code) pc | Just (s,oats,opsem) -> let ps = List.map (parser_of_operation_argument_type c cuh) oats in (pr_post_map @@ -2247,7 +2361,7 @@ let parse_and_pp_operations c cuh bs = val pp_attribute_value_plain : attribute_value -> string let pp_attribute_value_plain av = match av with - | AV_addr x -> "AV_addr " ^ pphex x + | AV_addr x -> "AV_addr " ^ pphex_sym x | AV_block n bs -> "AV_block " ^ show n ^ " " ^ ppbytes bs | AV_constantN n bs -> "AV_constantN " ^ show n ^ " " ^ ppbytes bs | AV_constant_SLEB128 i -> "AV_constant_SLEB128 " ^ show i @@ -2255,19 +2369,19 @@ let pp_attribute_value_plain av = | AV_exprloc n bs -> String.concat " " ["AV_exprloc"; show n; ppbytes bs] | AV_flag b -> "AV_flag " ^ show b - | AV_ref n -> "AV_ref " ^ pphex n - | AV_ref_addr n -> "AV_ref_addr " ^ pphex n - | AV_ref_sig8 n -> "AV_ref_sig8 " ^ pphex n - | AV_sec_offset n -> "AV_sec_offset " ^ pphex n + | AV_ref n -> "AV_ref " ^ pphex_sym n + | AV_ref_addr n -> "AV_ref_addr " ^ pphex_sym n + | AV_ref_sig8 n -> "AV_ref_sig8 " ^ pphex_sym n + | AV_sec_offset n -> "AV_sec_offset " ^ pphex_sym n | AV_string bs -> string_of_byte_sequence bs - | AV_strp n -> "AV_sec_offset " ^ pphex n ^ " " + | AV_strp n -> "AV_sec_offset " ^ pphex_sym n ^ " " end -val pp_attribute_value : p_context -> compilation_unit_header -> byte_sequence -> natural (*attribute tag*) -> attribute_value -> string +val pp_attribute_value : p_context -> compilation_unit_header -> byte_sequence -> sym_natural (*attribute tag*) -> attribute_value -> string let pp_attribute_value c cuh str at av = match av with - | AV_addr x -> "AV_addr " ^ pphex x + | AV_addr x -> "AV_addr " ^ pphex_sym x | AV_block n bs -> "AV_block " ^ show n ^ " " ^ ppbytes bs ^ if at = attribute_encode "DW_AT_location" then " " ^ parse_and_pp_operations c cuh bs else "" | AV_constantN n bs -> "AV_constantN " ^ show n ^ " " ^ ppbytes bs @@ -2276,19 +2390,19 @@ let pp_attribute_value c cuh str at av = | AV_exprloc n bs -> String.concat " " ["AV_exprloc"; show n; ppbytes bs; parse_and_pp_operations c cuh bs] | AV_flag b -> "AV_flag " ^ show b - | AV_ref n -> "AV_ref " ^ pphex n - | AV_ref_addr n -> "AV_ref_addr " ^ pphex n - | AV_ref_sig8 n -> "AV_ref_sig8 " ^ pphex n - | AV_sec_offset n -> "AV_sec_offset " ^ pphex n + | AV_ref n -> "AV_ref " ^ pphex_sym n + | AV_ref_addr n -> "AV_ref_addr " ^ pphex_sym n + | AV_ref_sig8 n -> "AV_ref_sig8 " ^ pphex_sym n + | AV_sec_offset n -> "AV_sec_offset " ^ pphex_sym n | AV_string bs -> string_of_byte_sequence bs - | AV_strp n -> "AV_sec_offset " ^ pphex n ^ " " + | AV_strp n -> "AV_sec_offset " ^ pphex_sym n ^ " " ^ pp_debug_str_entry str n end -val pp_attribute_value_like_objdump : p_context -> compilation_unit_header -> byte_sequence -> natural (*attribute tag*) -> attribute_value -> string +val pp_attribute_value_like_objdump : p_context -> compilation_unit_header -> byte_sequence -> sym_natural (*attribute tag*) -> attribute_value -> string let pp_attribute_value_like_objdump c cuh str at av = match av with - | AV_addr x -> (*"AV_addr " ^*) pphex x + | AV_addr x -> (*"AV_addr " ^*) pphex_sym x | AV_block n bs -> (*"AV_block " ^ show n ^ " " ^ ppbytes bs ^ if at = attribute_encode "DW_AT_location" then " " ^ parse_and_pp_operations c cuh bs else ""*) (* show n ^ " byte block: " *) ppbytesplain c n bs @@ -2299,21 +2413,21 @@ let pp_attribute_value_like_objdump c cuh str at av = | AV_exprloc n bs -> (*"AV_exprloc " ^ show n ^ " " ^*) ppbytes bs ^ " " ^ parse_and_pp_operations c cuh bs | AV_flag b -> (*"AV_flag " ^*)if b then "1" else "0" - | AV_ref n -> (*"AV_ref " ^*) "<"^pphex (n + cuh.cuh_offset)^">" - | AV_ref_addr n -> (*"AV_ref_addr " ^*) "<"^pphex n^">" - | AV_ref_sig8 n -> "AV_ref_sig8 " ^ pphex n - | AV_sec_offset n -> (*"AV_sec_offset " ^*) pphex n + | AV_ref n -> (*"AV_ref " ^*) "<"^pphex_sym (n + cuh.cuh_offset)^">" + | AV_ref_addr n -> (*"AV_ref_addr " ^*) "<"^pphex_sym n^">" + | AV_ref_sig8 n -> "AV_ref_sig8 " ^ pphex_sym n + | AV_sec_offset n -> (*"AV_sec_offset " ^*) pphex_sym n ^ if at = attribute_encode "DW_AT_location" then " (location list)" else "" | AV_string bs -> string_of_byte_sequence bs - | AV_strp n -> (*"AV_sec_offset " ^ pphex n ^ " " + | AV_strp n -> (*"AV_sec_offset " ^ pphex_sym n ^ " " ^ pp_debug_str_entry str n*) - "(indirect string, offset: "^pphex n ^ "): " ^ pp_debug_str_entry str n + "(indirect string, offset: "^pphex_sym n ^ "): " ^ pp_debug_str_entry str n end -val parser_of_attribute_form_non_indirect : p_context -> compilation_unit_header -> natural -> parser attribute_value +val parser_of_attribute_form_non_indirect : p_context -> compilation_unit_header -> sym_natural -> parser attribute_value let parser_of_attribute_form_non_indirect c cuh n = (* address*) if n = attribute_form_encode "DW_FORM_addr" then @@ -2396,7 +2510,7 @@ let parser_of_attribute_form c cuh n = (* *** where to put this? *) -let pp_pos pos = "<" ^ pphexplain pos ^">" +let pp_pos pos = "<" ^ pp_sym pphexplain pos ^">" let pp_cupdie (cu,parents,die) = pp_pos cu.cu_header.cuh_offset ^ "/" ^ pp_pos die.die_offset @@ -2450,15 +2564,15 @@ let string_of_string_attribute_value str av : string = | _ -> "find_string_attribute_value_of_die AV not understood" end -let maybe_natural_of_constant_attribute_value die1 c av : maybe natural = +let maybe_natural_of_constant_attribute_value die1 c av : maybe sym_natural = match av with | AV_constantN n bs -> Just n | AV_constant_ULEB128 n -> Just n - | AV_block n bs -> Just (natural_of_bytes c.endianness bs) + | AV_block n bs -> Just (sym_natural_of_bytes c.endianness bs) | _ -> Nothing end -let natural_of_constant_attribute_value die1 c av : natural = +let natural_of_constant_attribute_value die1 c av : sym_natural = match maybe_natural_of_constant_attribute_value die1 c av with | Just n -> n | Nothing -> Assert_extra.failwith ("natural_of_constant_attribute_value fail at " ^ (pp_pos die1.die_offset ^ (" with av= " ^ pp_attribute_value_plain av))) @@ -2466,8 +2580,8 @@ let natural_of_constant_attribute_value die1 c av : natural = let integer_of_constant_attribute_value c av : integer = match av with - | AV_constantN n bs -> integerFromNatural n - | AV_constant_ULEB128 n -> integerFromNatural n + | AV_constantN n bs -> integerFromSymNatural n + | AV_constant_ULEB128 n -> integerFromSymNatural n | AV_constant_SLEB128 n -> n | AV_block n bs -> integerFromNatural (natural_of_bytes c.endianness bs) | _ -> Assert_extra.failwith ("integer_of_constant_attribute_value fail") @@ -2507,7 +2621,7 @@ let find_attribute_value (an: string) (die:die) : maybe attribute_value = die.die_abbreviation_declaration.ad_attribute_specifications die.die_attribute_values in myfindmaybe - (fun (((at': natural), (af: natural)), ((pos: natural),(av:attribute_value))) -> + (fun (((at': sym_natural), (af: sym_natural)), ((pos: sym_natural),(av:attribute_value))) -> if at' = at then Just av else Nothing) ats @@ -2521,7 +2635,7 @@ let find_string_attribute_value_of_die (an: string) str (die:die) : maybe string Nothing end -let find_natural_attribute_value_of_die c (an: string) (die:die) : maybe natural = +let find_natural_attribute_value_of_die c (an: string) (die:die) : maybe sym_natural = match find_attribute_value an die with | Just av -> let n = natural_of_constant_attribute_value die c av in @@ -2628,21 +2742,21 @@ let find_flag_attribute_value_of_die_using_abstract_origin d (an: string) ((cu,p let pp_dwarf_format df = match df with Dwarf32 -> "(32-bit)" | Dwarf64 -> "(64-bit)" end let pp_unit_header (s:string) (x:compilation_unit_header) : string = - "**" ^ s ^ " Unit @ offset " ^ pphex x.cuh_offset ^ "\n" - ^ " " ^ s ^ " Unit @ offset " ^ pphex x.cuh_offset ^ ":\n" - ^ " Length: " ^ pphex x.cuh_unit_length ^ " " ^ pp_dwarf_format x.cuh_dwarf_format ^ "\n" + "**" ^ s ^ " Unit @ offset " ^ pphex_sym x.cuh_offset ^ "\n" + ^ " " ^ s ^ " Unit @ offset " ^ pphex_sym x.cuh_offset ^ ":\n" + ^ " Length: " ^ pphex_sym x.cuh_unit_length ^ " " ^ pp_dwarf_format x.cuh_dwarf_format ^ "\n" ^ " Version: " ^ show x.cuh_version ^ "\n" - ^ " Abbrev Offset: " ^ pphex x.cuh_debug_abbrev_offset ^ "\n" + ^ " Abbrev Offset: " ^ pphex_sym x.cuh_debug_abbrev_offset ^ "\n" ^ " Pointer Size: " ^ show x.cuh_address_size ^ "\n" let pp_compilation_unit_header (x:compilation_unit_header) : string = pp_unit_header "Compilation" x -let parse_unit_length c : parser (dwarf_format * natural) = +let parse_unit_length c : parser (dwarf_format * sym_natural) = fun (pc: parse_context) -> pr_bind (parse_uint32 c pc) (fun x pc' -> - if x < natural_of_hex "0xfffffff0" then PR_success (Dwarf32,x) pc' - else if x <> natural_of_hex "0xffffffff" then PR_fail "bad unit_length" pc + if x < sym_natural_of_hex "0xfffffff0" then PR_success (Dwarf32,x) pc' + else if x <> sym_natural_of_hex "0xffffffff" then PR_fail "bad unit_length" pc else pr_bind (parse_uint64 c pc') (fun x' pc'' -> PR_success (Dwarf64, x') pc')) @@ -2676,8 +2790,8 @@ let parse_compilation_unit_header c : parser compilation_unit_header = let pp_type_unit_header (x:type_unit_header) : string = pp_unit_header "Type" x.tuh_cuh - ^ " Type Signature: " ^ pphex x.tuh_type_signature ^ "\n" - ^ " Type Offset: " ^ pphex x.tuh_type_offset ^ "\n" + ^ " Type Signature: " ^ pphex_sym x.tuh_type_signature ^ "\n" + ^ " Type Offset: " ^ pphex_sym x.tuh_type_offset ^ "\n" let parse_type_unit_header c : parser type_unit_header = @@ -2726,7 +2840,7 @@ let indent_level_plus_one indent level = else " "^" " -let pp_die_attribute c (cuh:compilation_unit_header) (str : byte_sequence) (indent:bool) (level: natural) (((at: natural), (af: natural)), ((pos: natural),(av:attribute_value))) : string = +let pp_die_attribute c (cuh:compilation_unit_header) (str : byte_sequence) (indent:bool) (level: natural) (((at: sym_natural), (af: sym_natural)), ((pos: sym_natural),(av:attribute_value))) : string = indent_level_plus_one indent level ^ pp_pos pos ^ " " ^ right_space_padded_to 18 (pp_attribute_encoding at) ^ ": " ^ @@ -2814,7 +2928,7 @@ let pp_die_abbrev_var_parents c d cu str parents = -val parse_die : p_context -> byte_sequence -> compilation_unit_header -> (natural->abbreviation_declaration) -> parser (maybe die) +val parse_die : p_context -> byte_sequence -> compilation_unit_header -> (sym_natural->abbreviation_declaration) -> parser (maybe die) let rec parse_die c str cuh find_abbreviation_declaration = fun (pc: parse_context) -> (* let _ = my_debug3 ("parse_die called at " ^ pp_parse_context pc ^ "\n") in *) @@ -2841,7 +2955,7 @@ let rec parse_die c str cuh find_abbreviation_declaration = (fun dies pc''' -> PR_success (Just ( let die = <| - die_offset = pc.pc_offset; + die_offset = Absolute pc.pc_offset; die_abbreviation_code = abbreviation_code; die_abbreviation_declaration = ad; die_attribute_values = avs; @@ -2902,18 +3016,18 @@ let _ = my_debug4 (pp_compilation_unit_header cuh) in if cuh.cuh_unit_length = 0 then PR_success Nothing pc' else - let pc_abbrev = <|pc_bytes = match dropbytes cuh.cuh_debug_abbrev_offset debug_abbrev_section_body with Success bs -> bs | Fail _ -> Assert_extra.failwith "mydrop of debug_abbrev" end; pc_offset = cuh.cuh_debug_abbrev_offset |> in + let pc_abbrev = <|pc_bytes = match dropbytes (sym_unwrap cuh.cuh_debug_abbrev_offset) debug_abbrev_section_body with Success bs -> bs | Fail _ -> Assert_extra.failwith "mydrop of debug_abbrev" end; pc_offset = sym_unwrap cuh.cuh_debug_abbrev_offset |> in (* todo: this is reparsing the abbreviations table for each cu *) let abbreviations_table = match parse_abbreviations_table c pc_abbrev with | PR_fail s pc_abbrev' -> Assert_extra.failwith ("parse_abbrevations_table fail: " ^ pp_parse_fail s pc_abbrev') - | PR_success at pc_abbrev' -> <| at_offset=pc_abbrev.pc_offset; at_table= at|> + | PR_success at pc_abbrev' -> <| at_offset=Absolute pc_abbrev.pc_offset; at_table= at|> end in (* let _ = my_debug4 (pp_abbreviations_table abbreviations_table) in *) - let find_abbreviation_declaration (ac:natural) : abbreviation_declaration = + let find_abbreviation_declaration (ac:sym_natural) : abbreviation_declaration = (* let _ = my_debug4 ("find_abbreviation_declaration "^pphex ac) in *) myfindNonPure (fun ad -> ad.ad_abbreviation_code = ac) abbreviations_table.at_table in @@ -2962,17 +3076,17 @@ let parse_type_unit c (debug_str_section_body: byte_sequence) (debug_abbrev_sect (* let _ = my_debug4 (pp_type_unit_header tuh) in *) - let pc_abbrev = let n = tuh.tuh_cuh.cuh_debug_abbrev_offset in <|pc_bytes = match dropbytes n debug_abbrev_section_body with Success bs -> bs | Fail _ -> Assert_extra.failwith "mydrop of debug_abbrev" end; pc_offset = n |> in + let pc_abbrev = let n = tuh.tuh_cuh.cuh_debug_abbrev_offset in <|pc_bytes = match dropbytes (sym_unwrap n) debug_abbrev_section_body with Success bs -> bs | Fail _ -> Assert_extra.failwith "mydrop of debug_abbrev" end; pc_offset = sym_unwrap n |> in let abbreviations_table = match parse_abbreviations_table c pc_abbrev with | PR_fail s pc_abbrev' -> Assert_extra.failwith ("parse_abbrevations_table fail: " ^ pp_parse_fail s pc_abbrev') - | PR_success at pc_abbrev' -> <| at_offset=pc_abbrev.pc_offset; at_table= at|> + | PR_success at pc_abbrev' -> <| at_offset=Absolute pc_abbrev.pc_offset; at_table= at|> end in (* let _ = my_debug4 (pp_abbreviations_table abbreviations_table) in *) - let find_abbreviation_declaration (ac:natural) : abbreviation_declaration = + let find_abbreviation_declaration (ac:sym_natural) : abbreviation_declaration = (* let _ = my_debug4 ("find_abbreviation_declaration "^pphex ac) in *) myfindNonPure (fun ad -> ad.ad_abbreviation_code = ac) abbreviations_table.at_table in @@ -3010,27 +3124,27 @@ Contents of the .debug_loc section: -let pp_location_list_entry c (cuh:compilation_unit_header) (offset:natural) (x:location_list_entry) : string = - " " ^ pphex offset - ^ " " ^ pphex x.lle_beginning_address_offset - ^ " " ^ pphex x.lle_ending_address_offset +let pp_location_list_entry c (cuh:compilation_unit_header) (offset:sym_natural) (x:location_list_entry) : string = + " " ^ pphex_sym offset + ^ " " ^ pphex_sym x.lle_beginning_address_offset + ^ " " ^ pphex_sym x.lle_ending_address_offset ^ " (" ^ parse_and_pp_operations c cuh x.lle_single_location_description ^")" ^ "\n" -let pp_base_address_selection_entry c (cuh:compilation_unit_header) (offset:natural) (x:base_address_selection_entry) : string = - " " ^ pphex offset - ^ " " ^ pphex x.base_address +let pp_base_address_selection_entry c (cuh:compilation_unit_header) (offset:sym_natural) (x:base_address_selection_entry) : string = + " " ^ pphex_sym offset + ^ " " ^ pphex_sym x.base_address ^ "\n" -let pp_location_list_item c (cuh: compilation_unit_header) (offset: natural) (x:location_list_item) = +let pp_location_list_item c (cuh: compilation_unit_header) (offset: sym_natural) (x:location_list_item) = match x with | LLI_lle lle -> pp_location_list_entry c cuh offset lle | LLI_base base -> pp_base_address_selection_entry c cuh offset base end -let pp_location_list c (cuh: compilation_unit_header) ((offset:natural), (llis: list location_list_item)) = +let pp_location_list c (cuh: compilation_unit_header) ((offset:sym_natural), (llis: list location_list_item)) = String.concat "" (List.map (pp_location_list_item c cuh offset) llis) -(* ^ " " ^ pphex offset ^ " \n"*) +(* ^ " " ^ pphex_sym offset ^ " \n"*) let pp_loc c (cuh: compilation_unit_header) (lls: list location_list) = " Offset Begin End Expression\n" @@ -3052,7 +3166,7 @@ let parse_location_list_item c (cuh: compilation_unit_header) : parser (maybe lo (parse_uint_address_size c cuh.cuh_address_size) (parse_uint_address_size c cuh.cuh_address_size) pc) - (fun ((a1: natural),(a2:natural)) pc' -> + (fun ((a1: sym_natural),(a2:sym_natural)) pc' -> (* let _ = my_debug4 ("offset="^pphex pc.pc_offset ^ " begin=" ^ pphex a1 ^ " end=" ^ pphex a2) in *) if a1=0 && a2=0 then PR_success Nothing pc' @@ -3082,7 +3196,7 @@ let parse_location_list c cuh : parser (maybe location_list) = else pr_post_map1 (parse_list (parse_location_list_item c cuh) pc) - (fun llis -> (Just (pc.pc_offset, llis))) + (fun llis -> (Just (Absolute pc.pc_offset, llis))) let parse_location_list_list c cuh : parser location_list_list = parse_list (parse_location_list c cuh) @@ -3093,7 +3207,7 @@ let find_location_list dloc n : location_list = (* interpretation of a location list applies the base_address and LLI_base offsets to give a list indexed by concrete address ranges *) -let rec interpret_location_list (base_address: natural) (llis: list location_list_item) : list (natural * natural * single_location_description) = +let rec interpret_location_list (base_address: sym_natural) (llis: list location_list_item) : list (sym_natural * sym_natural * single_location_description) = match llis with | [] -> [] | LLI_base base::llis' -> interpret_location_list base.base_address llis' @@ -3121,22 +3235,22 @@ Contents of the .debug_ranges section: *) -let pp_range_list_entry c (cuh:compilation_unit_header) (offset:natural) (x:range_list_entry) : string = - " " ^ pphex offset - ^ " " ^ pphex x.rle_beginning_address_offset - ^ " " ^ pphex x.rle_ending_address_offset +let pp_range_list_entry c (cuh:compilation_unit_header) (offset:sym_natural) (x:range_list_entry) : string = + " " ^ pphex_sym offset + ^ " " ^ pphex_sym x.rle_beginning_address_offset + ^ " " ^ pphex_sym x.rle_ending_address_offset ^ (if x.rle_beginning_address_offset = x.rle_ending_address_offset then " (start == end)" else "") ^ "\n" -let pp_range_list_item c (cuh: compilation_unit_header) (offset: natural) (x:range_list_item) = +let pp_range_list_item c (cuh: compilation_unit_header) (offset: sym_natural) (x:range_list_item) = match x with | RLI_rle rle -> pp_range_list_entry c cuh offset rle | RLI_base base -> pp_base_address_selection_entry c cuh offset base end -let pp_range_list c (cuh: compilation_unit_header) ((offset:natural), (rlis: list range_list_item)) = +let pp_range_list c (cuh: compilation_unit_header) ((offset:sym_natural), (rlis: list range_list_item)) = String.concat "" (List.map (pp_range_list_item c cuh offset) rlis) - ^ " " ^ pphex offset ^ " \n" + ^ " " ^ pphex_sym offset ^ " \n" let pp_ranges c (cuh: compilation_unit_header) (rls: list range_list) = " Offset Begin End\n" @@ -3153,7 +3267,7 @@ let parse_range_list_item c (cuh: compilation_unit_header) : parser (maybe range (parse_uint_address_size c cuh.cuh_address_size) (parse_uint_address_size c cuh.cuh_address_size) pc) - (fun ((a1: natural),(a2:natural)) pc' -> + (fun ((a1: sym_natural),(a2:sym_natural)) pc' -> (* let _ = my_debug4 ("offset="^pphex pc.pc_offset ^ " begin=" ^ pphex a1 ^ " end=" ^ pphex a2) in *) if a1=0 && a2=0 then PR_success Nothing pc' @@ -3185,7 +3299,7 @@ let parse_range_list c cuh : parser (maybe (list range_list)) = else pr_post_map1 (parse_list (parse_range_list_item c cuh) pc) - (fun rlis -> (Just (expand_range_list_suffixes cuh (pc.pc_offset, rlis)))) + (fun rlis -> (Just (expand_range_list_suffixes cuh (Absolute pc.pc_offset, rlis)))) let parse_range_list_list c cuh : parser range_list_list = pr_map2 List.concat (parse_list (parse_range_list c cuh)) @@ -3196,7 +3310,7 @@ let find_range_list dranges n : maybe range_list = (* interpretation of a range list applies the base_address and RLI_base offsets to give a list of concrete address ranges *) -let rec interpret_range_list (base_address: natural) (rlis: list range_list_item) : list (natural * natural) = +let rec interpret_range_list (base_address: sym_natural) (rlis: list range_list_item) : list (sym_natural * sym_natural) = match rlis with | [] -> [] | RLI_base base::rlis' -> interpret_range_list base.base_address rlis' @@ -3244,9 +3358,9 @@ Contents of the .debug_frame section: -let pp_cfa_address a = pphex a +let pp_cfa_address a = pphex_sym a let pp_cfa_block b = ppbytes b -let pp_cfa_delta d = pphex d +let pp_cfa_delta d = pphex_sym d (*let pp_cfa_offset n = pphex n let pp_cfa_register r = show r*) let pp_cfa_sfoffset i = show i @@ -3279,29 +3393,29 @@ let pp_register_rule (rr:register_rule) : string = (*TODO make this more readel let pp_call_frame_instruction i = match i with | DW_CFA_advance_loc d -> "DW_CFA_advance_loc" ^ " " ^ pp_cfa_delta d - | DW_CFA_offset r n -> "DW_CFA_offset" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_offset (integerFromNatural n) + | DW_CFA_offset r n -> "DW_CFA_offset" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_offset (integerFromSymNatural n) | DW_CFA_restore r -> "DW_CFA_restore" ^ " " ^ pp_cfa_register r | DW_CFA_nop -> "DW_CFA_nop" | DW_CFA_set_loc a -> "DW_CFA_set_loc" ^ " " ^ pp_cfa_address a | DW_CFA_advance_loc1 d -> "DW_CFA_advance_loc1" ^ " " ^ pp_cfa_delta d | DW_CFA_advance_loc2 d -> "DW_CFA_advance_loc2" ^ " " ^ pp_cfa_delta d | DW_CFA_advance_loc4 d -> "DW_CFA_advance_loc4" ^ " " ^ pp_cfa_delta d - | DW_CFA_offset_extended r n -> "DW_CFA_offset_extended" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_offset (integerFromNatural n) + | DW_CFA_offset_extended r n -> "DW_CFA_offset_extended" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_offset (integerFromSymNatural n) | DW_CFA_restore_extended r -> "DW_CFA_restore_extended" ^ " " ^ pp_cfa_register r | DW_CFA_undefined r -> "DW_CFA_undefined" ^ " " ^ pp_cfa_register r | DW_CFA_same_value r -> "DW_CFA_same_value" ^ " " ^ pp_cfa_register r | DW_CFA_register r1 r2 -> "DW_CFA_register" ^ " " ^ pp_cfa_register r1 ^ " " ^ pp_cfa_register r2 | DW_CFA_remember_state -> "DW_CFA_remember_state" | DW_CFA_restore_state -> "DW_CFA_restore_state" - | DW_CFA_def_cfa r n -> "DW_CFA_def_cfa" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_offset (integerFromNatural n) + | DW_CFA_def_cfa r n -> "DW_CFA_def_cfa" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_offset (integerFromSymNatural n) | DW_CFA_def_cfa_register r -> "DW_CFA_def_cfa_register" ^ " " ^ pp_cfa_register r - | DW_CFA_def_cfa_offset n -> "DW_CFA_def_cfa_offset" ^ " " ^ pp_cfa_offset (integerFromNatural n) + | DW_CFA_def_cfa_offset n -> "DW_CFA_def_cfa_offset" ^ " " ^ pp_cfa_offset (integerFromSymNatural n) | DW_CFA_def_cfa_expression b -> "DW_CFA_def_cfa_expression" ^ " " ^ pp_cfa_block b | DW_CFA_expression r b -> "DW_CFA_expression" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_block b | DW_CFA_offset_extended_sf r i -> "DW_CFA_offset_extended_sf" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_sfoffset i | DW_CFA_def_cfa_sf r i -> "DW_CFA_def_cfa_sf" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_sfoffset i | DW_CFA_def_cfa_offset_sf i -> "DW_CFA_def_cfa_offset_sf" ^ " " ^ pp_cfa_sfoffset i - | DW_CFA_val_offset r n -> "DW_CFA_val_offset" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_offset (integerFromNatural n) + | DW_CFA_val_offset r n -> "DW_CFA_val_offset" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_offset (integerFromSymNatural n) | DW_CFA_val_offset_sf r i -> "DW_CFA_val_offset_sf" ^ pp_cfa_register r ^ " " ^ pp_cfa_sfoffset i | DW_CFA_val_expression r b -> "DW_CFA_val_expression" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_block b | DW_CFA_AARCH64_negate_ra_state -> "DW_CFA_AARCH64_negate_ra_state" @@ -3334,7 +3448,7 @@ let parse_call_frame_instruction c cuh : parser (maybe call_frame_instruction) = let pc' = <| pc_bytes = bs'; pc_offset = pc.pc_offset + 1 |> in let ch = unsigned_char_of_byte b in let high_bits = unsigned_char_land ch (unsigned_char_of_natural 192) in - let low_bits = natural_of_unsigned_char (unsigned_char_land ch (unsigned_char_of_natural 63)) in + let low_bits = Absolute (natural_of_unsigned_char (unsigned_char_land ch (unsigned_char_of_natural 63))) in if high_bits = unsigned_char_of_natural 0 then match lookup_abCde_de low_bits call_frame_instruction_encoding with | Just ((args: list call_frame_argument_type), result) -> @@ -3388,9 +3502,9 @@ let pp_call_frame_instructions' c cuh bs = let pp_cie c cuh cie = - pphex cie.cie_offset - ^ " " ^ pphex cie.cie_length - ^ " " ^ pphex cie.cie_id + pphex_sym cie.cie_offset + ^ " " ^ pphex_sym cie.cie_length + ^ " " ^ pphex_sym cie.cie_id ^ " CIE\n" ^ " Version: " ^ show cie.cie_version ^ "\n" ^ " Augmentation: \""^ show (string_of_byte_sequence cie.cie_augmentation) ^ "\"\n" @@ -3401,18 +3515,18 @@ let pp_cie c cuh cie = ^ ppbytes cie.cie_initial_instructions_bytes ^ "\n" ^ pp_call_frame_instructions cie.cie_initial_instructions -(* cie_address_size: natural; (* not shown by readelf - must match compilation unit *)*) -(* cie_segment_size: natural; (* not shown by readelf *)*) +(* cie_address_size: sym_natural; (* not shown by readelf - must match compilation unit *)*) +(* cie_segment_size: sym_natural; (* not shown by readelf *)*) (* readelf says "Return address column", but the DWARF spec says "Return address register" *) let pp_fde c cuh fde = - pphex fde.fde_offset - ^ " " ^ pphex fde.fde_length - ^ " " ^ pphex fde.fde_cie_pointer (* not what this field of readelf output is *) + pphex_sym fde.fde_offset + ^ " " ^ pphex_sym fde.fde_length + ^ " " ^ pphex_sym fde.fde_cie_pointer (* not what this field of readelf output is *) ^ " FDE" - ^ " cie=" ^ pphex fde.fde_cie_pointer (* duplicated?? *) - ^ " pc=" ^ match fde.fde_initial_location_segment_selector with Nothing -> "" | Just segment_selector -> "("^pphex segment_selector^")" end ^ pphex fde.fde_initial_location_address ^ ".." ^ pphex (fde.fde_initial_location_address + fde.fde_address_range) ^ "\n" + ^ " cie=" ^ pphex_sym fde.fde_cie_pointer (* duplicated?? *) + ^ " pc=" ^ match fde.fde_initial_location_segment_selector with Nothing -> "" | Just segment_selector -> "("^pphex_sym segment_selector^")" end ^ pphex_sym fde.fde_initial_location_address ^ ".." ^ pphex_sym (fde.fde_initial_location_address + fde.fde_address_range) ^ "\n" ^ ppbytes fde.fde_instructions_bytes ^ "\n" ^ pp_call_frame_instructions fde.fde_instructions @@ -3436,7 +3550,7 @@ let rec find_cie fi cie_id = | FIE_cie cie :: fi' -> if cie_id = cie.cie_offset then cie else find_cie fi' cie_id end -let parse_initial_location c cuh mss mas' : parser ((maybe natural) * natural) = (*(segment selector and target address)*) +let parse_initial_location c cuh mss mas' : parser ((maybe sym_natural) * sym_natural) = (*(segment selector and target address)*) (* assume segment selector size is zero unless given explicitly. Probably we need to do something architecture-specific for earlier dwarf versions?*) parse_pair (parse_uint_segment_selector_size c (match mss with Just n -> n | Nothing -> 0 end)) @@ -3445,7 +3559,7 @@ let parse_initial_location c cuh mss mas' : parser ((maybe natural) * natural) = let parse_call_frame_instruction_bytes offset' ul = fun (pc: parse_context) -> - parse_n_bytes (ul - (pc.pc_offset - offset')) pc + parse_n_bytes (ul - (Absolute pc.pc_offset - offset')) pc let parse_frame_info_element c cuh (fi: list frame_info_element) : parser frame_info_element = parse_dependent @@ -3459,8 +3573,8 @@ let parse_frame_info_element c cuh (fi: list frame_info_element) : parser frame_ (fun (offset,((df,ul),(offset',cie_id))) -> if (cie_id = match df with - | Dwarf32 -> natural_of_hex "0xffffffff" - | Dwarf64 -> natural_of_hex "0xffffffffffffffff" + | Dwarf32 -> sym_natural_of_hex "0xffffffff" + | Dwarf64 -> sym_natural_of_hex "0xffffffffffffffff" end) then (* parse cie *) @@ -3567,7 +3681,7 @@ let pp_line_number_file_entry lnfe = let pp_line_number_header lnh = - "offset = " ^ pphex lnh.lnh_offset ^ "\n" + "offset = " ^ pphex_sym lnh.lnh_offset ^ "\n" ^ "dwarf_format = " ^ pp_dwarf_format lnh.lnh_dwarf_format ^ "\n" ^ "unit_length = " ^ show lnh.lnh_unit_length ^ "\n" ^ "version = " ^ show lnh.lnh_version ^ "\n" @@ -3599,7 +3713,7 @@ let pp_line_number_operation lno = | DW_LNS_set_epilogue_begin -> "DW_LNS_set_epilogue_begin" | DW_LNS_set_isa n -> "DW_LNS_set_isa" ^ " " ^ show n | DW_LNE_end_sequence -> "DW_LNE_end_sequence" - | DW_LNE_set_address n -> "DW_LNE_set_address" ^ " " ^ pphex n + | DW_LNE_set_address n -> "DW_LNE_set_address" ^ " " ^ pphex_sym n | DW_LNE_define_file s n1 n2 n3 -> "DW_LNE_define_file" ^ " " ^ show s ^ " " ^ show n1 ^ " " ^ show n2 ^ " " ^ show n3 | DW_LNE_set_discriminator n -> "DW_LNE_set_discriminator" ^ " " ^ show n | DW_LN_special n -> "DW_LN_special" ^ " " ^ show n @@ -3669,8 +3783,8 @@ let parse_line_number_header c (comp_dir:maybe string) : parser line_number_head (parse_triple (parse_uintDwarfN c df) (* header_length *) (parse_uint8) (* minimum_instruction_length *) - (if v<4 then (* maximum_operations_per_instruction*)(* NOT IN DWARF 2 or 3; in DWARF 4*) - (parse_uint8_constant 1) + (if v pr_post_map (parse_triple - (pr_post_map (parse_n_bytes (ob-1)) (fun bs -> List.map natural_of_byte (byte_list_of_byte_sequence bs))) (* standard_opcode_lengths *) + (pr_post_map (parse_n_bytes (ob-Absolute 1)) (fun bs -> List.map sym_natural_of_byte (byte_list_of_byte_sequence bs))) (* standard_opcode_lengths *) ((*pr_return [[]]*) parse_list parse_non_empty_string) (* include_directories *) (parse_list parse_line_number_file_entry) (* file names *) ) @@ -3789,7 +3903,7 @@ let parse_line_number_program c (cuh:compilation_unit_header) (comp_dir:maybe st let line_number_offset_of_compilation_unit c cu = match find_attribute_value "DW_AT_stmt_list" cu.cu_die with | Just (AV_sec_offset n) -> n - | Just (AV_block n bs) -> natural_of_bytes c.endianness bs + | Just (AV_block n bs) -> sym_natural_of_bytes c.endianness bs (* a 32-bit MIPS example used a 4-byte AV_block not AV_sec_offset *) | Just _ -> (Assert_extra.failwith ("compilation unit DW_AT_stmt_list attribute was not an AV_sec_offset" ^ pp_compilation_unit_header cu.cu_header)) | _ -> Assert_extra.failwith ("compilation unit did not have a DW_AT_stmt_list attribute\n" ^ pp_compilation_unit_header cu.cu_header ^ "\n") @@ -3862,7 +3976,7 @@ let parse_line_number_info c str (d_line: byte_sequence) (cu: compilation_unit) lnp | PR_fail s pc' -> Assert_extra.failwith ("parse_line_number_header failed: " ^ s) end in - f (line_number_offset_of_compilation_unit c cu) + f (sym_unwrap (line_number_offset_of_compilation_unit c cu)) let parse_line_number_infos c str debug_line_section_body compilation_units = @@ -3977,7 +4091,7 @@ let parse_dwarf c d_line_info = li; |> -val extract_section_body : elf_file -> string -> bool -> p_context * natural * byte_sequence +val extract_section_body : elf_file -> string -> bool -> p_context * sym_natural * byte_sequence let extract_section_body (f:elf_file) (section_name:string) (strict: bool) = let (en: Endianness.endianness) = match f with @@ -3994,7 +4108,7 @@ let extract_section_body (f:elf_file) (section_name:string) (strict: bool) = ) f32.elf32_file_interpreted_sections in match sections with | [section] -> - let section_addr = section.Elf_interpreted_section.elf32_section_addr in + let section_addr = Absolute section.Elf_interpreted_section.elf32_section_addr in (*TODO symbolic*) let section_body = section.Elf_interpreted_section.elf32_section_body in (* let _ = my_debug4 (section_name ^ (": \n" ^ (Elf_interpreted_section.string_of_elf32_interpreted_section section ^ "\n" * ^ " body = " ^ ppbytes2 0 section_body ^ "\n"))) in *) @@ -4016,7 +4130,7 @@ let extract_section_body (f:elf_file) (section_name:string) (strict: bool) = ) f64.elf64_file_interpreted_sections in match sections with | [section] -> - let section_addr = section.Elf_interpreted_section.elf64_section_addr in + let section_addr = Absolute section.Elf_interpreted_section.elf64_section_addr in (*TODO symbolic*) let section_body = section.Elf_interpreted_section.elf64_section_body in (c,section_addr,section_body) | [] -> @@ -4042,7 +4156,7 @@ let extract_dwarf f = Just d -val extract_text : elf_file -> p_context * natural * byte_sequence (* (p_context, elf32/64_section_addr, elf32/64_section_body) *) +val extract_text : elf_file -> p_context * sym_natural * byte_sequence (* (p_context, elf32/64_section_addr, elf32/64_section_body) *) let extract_text f = extract_section_body f ".text" true @@ -4056,7 +4170,7 @@ let extract_text f = extract_section_body f ".text" true val pp_simple_location : simple_location -> string let pp_simple_location sl = match sl with - | SL_memory_address n -> pphex n + | SL_memory_address n -> pphex_sym n | SL_register n -> "reg" ^ show n | SL_implicit bs -> "value: " ^ ppbytes bs | SL_empty -> "" @@ -4162,25 +4276,25 @@ accumulated so far *) let arithmetic_context_of_cuh cuh = - match cuh.cuh_address_size with + match sym_unwrap cuh.cuh_address_size with | 8 -> <| ac_bitwidth = 64; - ac_half = naturalPow 2 32; - ac_all = naturalPow 2 64; - ac_max = (naturalPow 2 64) - 1; + ac_half = symNaturalPow 2 32; + ac_all = symNaturalPow 2 64; + ac_max = (symNaturalPow 2 64) - 1; |> | 4 -> <| ac_bitwidth = 32; - ac_half = naturalPow 2 16; - ac_all = naturalPow 2 32; - ac_max = (naturalPow 2 32) - 1; + ac_half = symNaturalPow 2 16; + ac_all = symNaturalPow 2 32; + ac_max = (symNaturalPow 2 32) - 1; |> | _ -> Assert_extra.failwith "arithmetic_context_of_cuh given non-4/8 size" end -let find_cfa_table_row_for_pc (evaluated_frame_info: evaluated_frame_info) (pc: natural) : cfa_table_row = +let find_cfa_table_row_for_pc (evaluated_frame_info: evaluated_frame_info) (pc: sym_natural) : cfa_table_row = match myfind (fun (fde,rows) -> pc >= fde.fde_initial_location_address && pc < fde.fde_initial_location_address + fde.fde_address_range) @@ -4195,11 +4309,11 @@ let find_cfa_table_row_for_pc (evaluated_frame_info: evaluated_frame_info) (pc: end -let rec evaluate_operation_list (c:p_context) (dloc: location_list_list) (evaluated_frame_info: evaluated_frame_info) (cuh: compilation_unit_header) (ac: arithmetic_context) (ev: evaluation_context) (mfbloc: maybe attribute_value) (pc: natural) (s: state) (ops: list operation) : error single_location = +let rec evaluate_operation_list (c:p_context) (dloc: location_list_list) (evaluated_frame_info: evaluated_frame_info) (cuh: compilation_unit_header) (ac: arithmetic_context) (ev: evaluation_context) (mfbloc: maybe attribute_value) (pc: sym_natural) (s: state) (ops: list operation) : error single_location = let push_memory_address v vs' = Success <| s with s_stack = v :: vs'; s_value = SL_memory_address v |> in - let push_memory_address_maybe (mv: maybe natural) vs' (err:string) op = + let push_memory_address_maybe (mv: maybe sym_natural) vs' (err:string) op = match mv with | Just v -> push_memory_address v vs' | Nothing -> Fail (err ^ pp_operation op) @@ -4207,7 +4321,7 @@ let rec evaluate_operation_list (c:p_context) (dloc: location_list_list) (evalua let bregxi r i = match ev.read_register r with - | RRR_result v -> push_memory_address (partialNaturalFromInteger ((integerFromNatural v+i) mod (integerFromNatural ac.ac_all))) s.s_stack + | RRR_result v -> push_memory_address (partialSymNaturalFromInteger ((integerFromSymNatural v+i) mod (integerFromSymNatural ac.ac_all))) s.s_stack | RRR_not_currently_available -> Fail "RRR_not_currently_available" | RRR_bad_register_number -> Fail ("RRR_bad_register_number " ^ show r) end in @@ -4241,7 +4355,7 @@ let rec evaluate_operation_list (c:p_context) (dloc: location_list_list) (evalua | (OpSem_lit, [OAV_natural n]) -> push_memory_address n s.s_stack | (OpSem_lit, [OAV_integer i]) -> - push_memory_address (partialTwosComplementNaturalFromInteger i ac.ac_half (integerFromNatural ac.ac_all)) s.s_stack + push_memory_address (partialTwosComplementSymNaturalFromInteger i ac.ac_half (integerFromSymNatural ac.ac_all)) s.s_stack | (OpSem_stack f, []) -> match f ac s.s_stack op.op_argument_values with | Just stack' -> @@ -4289,9 +4403,9 @@ let rec evaluate_operation_list (c:p_context) (dloc: location_list_list) (evalua match l with | SL_simple (SL_memory_address a) -> (*let _ = my_debug5 ("OpSem_fbreg: a = "^ pphex a ^ "\n") in*) - let vi = ((integerFromNatural a) + i) mod (integerFromNatural ac.ac_all) in + let vi = ((integerFromSymNatural a) + i) mod (integerFromSymNatural ac.ac_all) in (*let _ = my_debug5 ("OpSem_fbreg: v = "^ show vi ^ "\n") in*) - let v = partialNaturalFromInteger vi (*ac.ac_half (integerFromNatural ac.ac_all)*) in + let v = partialSymNaturalFromInteger vi (*ac.ac_half (integerFromSymNatural ac.ac_all)*) in push_memory_address v s.s_stack | _ -> Fail "OpSem_fbreg got a non-SL_simple (SL_memory_address _) result" @@ -4333,7 +4447,7 @@ let rec evaluate_operation_list (c:p_context) (dloc: location_list_list) (evalua match s.s_stack with | v::vs' -> let stack' = [] in - let value' = SL_implicit (bytes_of_natural c.endianness cuh.cuh_address_size v) in + let value' = SL_implicit (bytes_of_sym_natural c.endianness cuh.cuh_address_size v) in Success <| s with s_stack = stack'; s_value = value' |> | _ -> Fail "OpSem_stack_value not given an element on stack" @@ -4362,7 +4476,7 @@ let rec evaluate_operation_list (c:p_context) (dloc: location_list_list) (evalua end end -and evaluate_location_description_bytes (c:p_context) (dloc: location_list_list) (evaluated_frame_info: evaluated_frame_info) (cuh: compilation_unit_header) (ac: arithmetic_context) (ev: evaluation_context) (mfbloc: maybe attribute_value) (pc: natural) (bs: byte_sequence) : error single_location = +and evaluate_location_description_bytes (c:p_context) (dloc: location_list_list) (evaluated_frame_info: evaluated_frame_info) (cuh: compilation_unit_header) (ac: arithmetic_context) (ev: evaluation_context) (mfbloc: maybe attribute_value) (pc: sym_natural) (bs: byte_sequence) : error single_location = let parse_context = <|pc_bytes = bs; pc_offset = 0 |> in match parse_operations c cuh parse_context with | PR_fail s pc' -> Fail ("evaluate_location_description_bytes: parse_operations fail: " ^ pp_parse_fail s pc') @@ -4373,7 +4487,7 @@ and evaluate_location_description_bytes (c:p_context) (dloc: location_list_list) evaluate_operation_list c dloc evaluated_frame_info cuh ac ev mfbloc pc initial_state ops end -and evaluate_location_description (c:p_context) (dloc: location_list_list) (evaluated_frame_info: evaluated_frame_info) (cuh: compilation_unit_header) (ac: arithmetic_context) (ev: evaluation_context) (mfbloc: maybe attribute_value) (pc: natural) (loc:attribute_value) : error single_location = +and evaluate_location_description (c:p_context) (dloc: location_list_list) (evaluated_frame_info: evaluated_frame_info) (cuh: compilation_unit_header) (ac: arithmetic_context) (ev: evaluation_context) (mfbloc: maybe attribute_value) (pc: sym_natural) (loc:attribute_value) : error single_location = match loc with | AV_exprloc n bs -> evaluate_location_description_bytes c dloc evaluated_frame_info cuh ac ev mfbloc pc bs @@ -4504,10 +4618,10 @@ let pp_evaluated_fde (fde, (rows: list cfa_table_row)) : string = let regs = register_footprint rows in let header : list string = "LOC" :: "CFA" :: List.map pp_cfa_register regs in let ppd_rows : list (list string) = - List.map (fun row -> pphex row.ctr_loc :: pp_cfa_rule row.ctr_cfa :: List.map (fun r -> pp_register_rule (rrp_lookup r row.ctr_regs)) regs) rows in + List.map (fun row -> pphex_sym row.ctr_loc :: pp_cfa_rule row.ctr_cfa :: List.map (fun r -> pp_register_rule (rrp_lookup r row.ctr_regs)) regs) rows in pad_rows (header :: ppd_rows) -let semi_pp_evaluated_fde (fde, (rows: list cfa_table_row)) : list (natural (*address*) * string (*cfa*) * list (string*string) (*register rules*) ) = +let semi_pp_evaluated_fde (fde, (rows: list cfa_table_row)) : list (sym_natural (*address*) * string (*cfa*) * list (string*string) (*register rules*) ) = let regs = register_footprint rows in let ppd_rows = List.map @@ -4518,7 +4632,7 @@ let semi_pp_evaluated_fde (fde, (rows: list cfa_table_row)) : list (natural (*ad rows in ppd_rows -val semi_pp_evaluated_frame_info : evaluated_frame_info -> list (natural (*address*) * string (*cfa*) * list (string*string) (*register rules*) ) +val semi_pp_evaluated_frame_info : evaluated_frame_info -> list (sym_natural (*address*) * string (*cfa*) * list (string*string) (*register rules*) ) let semi_pp_evaluated_frame_info efi = List.concat (List.map semi_pp_evaluated_fde efi) @@ -4528,7 +4642,7 @@ let semi_pp_evaluated_frame_info efi = let evaluate_call_frame_instruction (fi: frame_info) (cie: cie) (state: cfa_state) (cfi: call_frame_instruction) : cfa_state = - let create_row (loc: natural) = + let create_row (loc: sym_natural) = let row = <| state.cs_current_row with ctr_loc = loc |> in <| state with cs_current_row = row; cs_previous_rows = state.cs_current_row::state.cs_previous_rows |> in @@ -4555,7 +4669,7 @@ let evaluate_call_frame_instruction (fi: frame_info) (cie: cie) (state: cfa_stat (* CFA Definition Instructions *) | DW_CFA_def_cfa r n -> - update_cfa (CR_register r (integerFromNatural n)) + update_cfa (CR_register r (integerFromSymNatural n)) | DW_CFA_def_cfa_sf r i -> update_cfa (CR_register r (i * cie.cie_data_alignment_factor)) | DW_CFA_def_cfa_register r -> @@ -4574,7 +4688,7 @@ let evaluate_call_frame_instruction (fi: frame_info) (cie: cie) (state: cfa_stat | DW_CFA_def_cfa_offset n -> match state.cs_current_row.ctr_cfa with | CR_register r i -> - update_cfa (CR_register r (integerFromNatural n)) + update_cfa (CR_register r (integerFromSymNatural n)) | _ -> Assert_extra.failwith "DW_CFA_def_cfa_offset: current rule is not CR_register" end | DW_CFA_def_cfa_offset_sf i -> @@ -4592,13 +4706,13 @@ let evaluate_call_frame_instruction (fi: frame_info) (cie: cie) (state: cfa_stat | DW_CFA_same_value r -> update_reg r (RR_same_value) | DW_CFA_offset r n -> - update_reg r (RR_offset ((integerFromNatural n) * cie.cie_data_alignment_factor)) + update_reg r (RR_offset ((integerFromSymNatural n) * cie.cie_data_alignment_factor)) | DW_CFA_offset_extended r n -> - update_reg r (RR_offset ((integerFromNatural n) * cie.cie_data_alignment_factor)) + update_reg r (RR_offset ((integerFromSymNatural n) * cie.cie_data_alignment_factor)) | DW_CFA_offset_extended_sf r i -> update_reg r (RR_offset (i * cie.cie_data_alignment_factor)) | DW_CFA_val_offset r n -> - update_reg r (RR_val_offset ((integerFromNatural n) * cie.cie_data_alignment_factor)) + update_reg r (RR_val_offset ((integerFromSymNatural n) * cie.cie_data_alignment_factor)) | DW_CFA_val_offset_sf r i -> update_reg r (RR_val_offset (i * cie.cie_data_alignment_factor)) | DW_CFA_register r1 r2 -> @@ -4837,7 +4951,7 @@ let analyse_type_info_top c (d: dwarf) (r:bool(*recurse into members*)) (cupdie: else - Assert_extra.failwith ("analyse_type_info_top didn't recognise tag: " ^ pphex die.die_abbreviation_declaration.ad_tag ^ " for DIE " ^ pp_cupdie3 cupdie) + Assert_extra.failwith ("analyse_type_info_top didn't recognise tag: " ^ pphex_sym die.die_abbreviation_declaration.ad_tag ^ " for DIE " ^ pp_cupdie3 cupdie) let rec analyse_type_info_deep (d: dwarf) (r:bool(*recurse_into_members*)) cupdie : c_type = @@ -5054,7 +5168,7 @@ let analyse_locations_raw c (d: dwarf) = die.die_abbreviation_declaration.ad_attribute_specifications die.die_attribute_values in - let find_ats (s:string) = myfindNonPure (fun (((at: natural), (af: natural)), ((pos: natural),(av:attribute_value))) -> attribute_encode s = at) ats in + let find_ats (s:string) = myfindNonPure (fun (((at: sym_natural), (af: sym_natural)), ((pos: sym_natural),(av:attribute_value))) -> attribute_encode s = at) ats in let ((_,_),(_,av_name)) = find_ats "DW_AT_name" in @@ -5124,15 +5238,15 @@ let cu_base_address cu = -let range_of_die c cuh str (dranges: range_list_list) (cu_base_address: natural) (die: die) : maybe (list (natural * natural)) = +let range_of_die c cuh str (dranges: range_list_list) (cu_base_address: sym_natural) (die: die) : maybe (list (sym_natural * sym_natural)) = match (find_attribute_value "DW_AT_low_pc" die, find_attribute_value "DW_AT_high_pc" die, find_attribute_value "DW_AT_ranges" die) with | (Just (AV_addr n), Nothing, Nothing ) -> Just [(n,n+1)] (* unclear if this case is used? *) | (Just (AV_addr n1), Just (AV_addr n2), Nothing ) -> Just [(n1,n2)] | (Just (AV_addr n1), Just (AV_constant_ULEB128 n2), Nothing ) -> Just [(n1, n1+n2)] (* should be mod all? *) - | (Just (AV_addr n1), Just (AV_constant_SLEB128 i2), Nothing ) -> Just [(n1, naturalFromInteger (integerFromNatural n1 + i2))] (* should be mod all? *) + | (Just (AV_addr n1), Just (AV_constant_SLEB128 i2), Nothing ) -> Just [(n1, symNaturalFromInteger (integerFromSymNatural n1 + i2))] (* should be mod all? *) | (Just (AV_addr n1), Just (AV_constantN _ _), Nothing ) -> Assert_extra.failwith "AV_constantN in range_of_die" - | (Just (AV_addr n1), Just (AV_block n bs), Nothing ) -> let n2 = natural_of_bytes c.endianness bs in Just [(n1, n1+n2)] (* should be mod all? *) (* signed or unsigned interp? *) + | (Just (AV_addr n1), Just (AV_block n bs), Nothing ) -> let n2 = sym_natural_of_bytes c.endianness bs in Just [(n1, n1+n2)] (* should be mod all? *) (* signed or unsigned interp? *) | (_, Nothing, Just (AV_sec_offset n)) -> let rlis = Tuple.snd (match find_range_list dranges n with Just rlis->rlis | None -> Assert_extra.failwith ("find_range_list failed on AV_sec_offset n=" ^ show n ^ " for die\n" ^ pp_die c cuh str false 0 false die) end) in let nns = interpret_range_list cu_base_address rlis in @@ -5141,18 +5255,18 @@ let range_of_die c cuh str (dranges: range_list_list) (cu_base_address: natural) | (_, _, _ ) -> Just [] (*Assert_extra.failwith "unexpected attribute values in closest_enclosing_range"*) end -let range_of_die_d (d:dwarf) cu (die: die) : maybe (list (natural * natural)) = +let range_of_die_d (d:dwarf) cu (die: die) : maybe (list (sym_natural * sym_natural)) = let c = p_context_of_d d in range_of_die c cu.cu_header d.d_str d.d_ranges (cu_base_address cu) die -let entry_address (die:die) : maybe natural = +let entry_address (die:die) : maybe sym_natural = match (find_attribute_value "DW_AT_low_pc" die, find_attribute_value "DW_AT_entry_pc" die) with | (_, Just (AV_addr n)) -> Just n | (Just (AV_addr n), _) -> Just n | (Nothing,Nothing) -> Nothing end -let rec closest_enclosing_range c cuh str (dranges: range_list_list) (cu_base_address: natural) (parents: list die) : maybe (list (natural * natural)) = +let rec closest_enclosing_range c cuh str (dranges: range_list_list) (cu_base_address: sym_natural) (parents: list die) : maybe (list (sym_natural * sym_natural)) = match parents with | [] -> Nothing | die::parents' -> @@ -5172,7 +5286,7 @@ rather than DW_FORM_data. no kidding - if we get an AV_constantN for DW_AT_high_pc, should it be interpreted as signed or unsigned? *) -let rec closest_enclosing_frame_base dloc (base_address: natural) (parents: list die) : maybe attribute_value = +let rec closest_enclosing_frame_base dloc (base_address: sym_natural) (parents: list die) : maybe attribute_value = match parents with | [] -> Nothing | die::parents' -> @@ -5185,7 +5299,7 @@ let rec closest_enclosing_frame_base dloc (base_address: natural) (parents: list -let interpreted_location_of_die c cuh str (dloc: location_list_list) (dranges: range_list_list) (base_address: natural) (parents: list die) (die: die) : maybe (list (natural * natural * single_location_description)) = +let interpreted_location_of_die c cuh str (dloc: location_list_list) (dranges: range_list_list) (base_address: sym_natural) (parents: list die) (die: die) : maybe (list (sym_natural * sym_natural * single_location_description)) = (* for a simple location expression bs, we look in the enclosing die tree to find the associated pc range *) @@ -5232,7 +5346,7 @@ let analyse_locations (d: dwarf) : analysed_location_data = List.map (fun (((cu:compilation_unit), (parents: list die), (die: die)) as x) -> let base_address = cu_base_address cu in - let interpreted_locations : maybe (list (natural * natural * single_location_description)) = + let interpreted_locations : maybe (list (sym_natural * sym_natural * single_location_description)) = interpreted_location_of_die c cu.cu_header d.d_str d.d_loc d.d_ranges base_address parents die in (x,interpreted_locations) ) @@ -5240,10 +5354,10 @@ let analyse_locations (d: dwarf) : analysed_location_data = -let pp_analysed_locations1 c cuh (nnls: list (natural * natural * single_location_description)) : string = +let pp_analysed_locations1 c cuh (nnls: list (sym_natural * sym_natural * single_location_description)) : string = String.concat "" (List.map - (fun (n1,n2,bs) -> " " ^ pphex n1 ^ " " ^ pphex n2 ^ " " ^ parse_and_pp_operations c cuh bs) + (fun (n1,n2,bs) -> " " ^ pphex_sym n1 ^ " " ^ pphex_sym n2 ^ " " ^ parse_and_pp_operations c cuh bs) nnls) let pp_analysed_locations2 c cuh mnnls = @@ -5362,11 +5476,11 @@ let pp_analysed_location_data_at_pc (d: dwarf) (alspc: analysed_location_data_at -val analysed_locations_at_pc : evaluation_context -> dwarf_static -> natural -> analysed_location_data_at_pc +val analysed_locations_at_pc : evaluation_context -> dwarf_static -> sym_natural -> analysed_location_data_at_pc let analysed_locations_at_pc (ev) (ds: dwarf_static) - (pc: natural) + (pc: sym_natural) : analysed_location_data_at_pc = let c : p_context = (<| endianness = ds.ds_dwarf.d_endianness |>) in @@ -5403,11 +5517,11 @@ let analysed_locations_at_pc ) xs) -val names_of_address : dwarf -> analysed_location_data_at_pc -> natural -> list string +val names_of_address : dwarf -> analysed_location_data_at_pc -> sym_natural -> list string let names_of_address (d: dwarf) (alspc: analysed_location_data_at_pc) - (address: natural) + (address: sym_natural) : list string = List.mapMaybe @@ -5428,7 +5542,7 @@ let names_of_address alspc -val filtered_analysed_location_data : dwarf_static -> natural -> analysed_location_data +val filtered_analysed_location_data : dwarf_static -> sym_natural -> analysed_location_data let filtered_analysed_location_data ds pc = List.mapMaybe (fun (cupd,mnns) -> @@ -5480,7 +5594,7 @@ let filtered_analysed_location_data ds pc = -let subprogram_line_extents_compilation_unit d cu : list (string * unpacked_file_entry * natural) = +let subprogram_line_extents_compilation_unit d cu : list (string * unpacked_file_entry * sym_natural) = let c = p_context_of_d d in let subprogram_dies = List.filter (fun die' -> die'.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_subprogram") cu.cu_die.die_children in @@ -5530,8 +5644,8 @@ let rec partitionby f lt xs acc = partitionby f lt xs' acc'' end -let subprogram_line_extents d : list (unpacked_file_entry * list (string * unpacked_file_entry * natural) ) = - let subprograms : list (string * unpacked_file_entry * natural) = +let subprogram_line_extents d : list (unpacked_file_entry * list (string * unpacked_file_entry * sym_natural) ) = + let subprograms : list (string * unpacked_file_entry * sym_natural) = List.concatMap (subprogram_line_extents_compilation_unit d) d.d_compilation_units in partitionby (fun (name, ufe, line) -> ufe) (fun (name,ufe,line) -> fun (name',ufe',line') -> line < line') subprograms [] @@ -5550,7 +5664,7 @@ let rec find_by_line line sles line_last name_last = if line >= line_last && line < line' then name_last else find_by_line line sles' line' name' end -let subprogram_at_line subprogram_line_extents (ufe:unpacked_file_entry) (line:natural) : string = +let subprogram_at_line subprogram_line_extents (ufe:unpacked_file_entry) (line:sym_natural) : string = match List.lookup ufe subprogram_line_extents with | Nothing -> "no matching unpacked_file_entry" | Just sles -> find_by_line line sles 0 "file preamble" @@ -5596,7 +5710,7 @@ let analyse_subprograms (d: dwarf) : analysed_location_data = | let base_address = cu_base_address cu in - let interpreted_locations : maybe (list (natural * natural * single_location_description)) = + let interpreted_locations : maybe (list (sym_natural * sym_natural * single_location_description)) = interpreted_location_of_die c cuh_default d.d_loc d.d_ranges base_address parents die in (x,interpreted_locations) ) @@ -5639,10 +5753,10 @@ let evaluate_line_number_operation match lno with | DW_LN_special adjusted_opcode -> let operation_advance = adjusted_opcode / lnh.lnh_line_range in - let line_increment = lnh.lnh_line_base + integerFromNatural (adjusted_opcode mod lnh.lnh_line_range) in + let line_increment = lnh.lnh_line_base + integerFromSymNatural (adjusted_opcode mod lnh.lnh_line_range) in let s' = <| s with - lnr_line = partialNaturalFromInteger ((integerFromNatural s.lnr_line) + line_increment); + lnr_line = partialSymNaturalFromInteger ((integerFromSymNatural s.lnr_line) + line_increment); lnr_address = new_address s operation_advance; lnr_op_index = new_op_index s operation_advance; |> in @@ -5673,7 +5787,7 @@ let evaluate_line_number_operation |> in (s', lnrs) | DW_LNS_advance_line line_increment -> - let s' = <| s with lnr_line = partialNaturalFromInteger ((integerFromNatural s.lnr_line) + line_increment) |> in (s', lnrs) + let s' = <| s with lnr_line = partialSymNaturalFromInteger ((integerFromSymNatural s.lnr_line) + line_increment) |> in (s', lnrs) | DW_LNS_set_file n -> let s' = <| s with lnr_file = n |> in (s', lnrs) | DW_LNS_set_column n -> @@ -5753,7 +5867,7 @@ let evaluated_line_info_of_compilation_unit d cu evaluated_line_info = let pp_line_number_registers lnr = "" - ^ "address = " ^ pphex lnr.lnr_address ^ "\n" + ^ "address = " ^ pphex_sym lnr.lnr_address ^ "\n" ^ "op_index = " ^ show lnr.lnr_op_index ^ "\n" ^ "file = " ^ show lnr.lnr_file ^ "\n" ^ "line = " ^ show lnr.lnr_line ^ "\n" @@ -5764,11 +5878,11 @@ let pp_line_number_registers lnr = ^ "prologue_end = " ^ show lnr.lnr_prologue_end ^ "\n" ^ "epilogue_begin = " ^ show lnr.lnr_epilogue_begin ^ "\n" ^ "isa = " ^ show lnr.lnr_isa ^ "\n" - ^ "discriminator = " ^ pphex lnr.lnr_discriminator ^ "\n" + ^ "discriminator = " ^ pphex_sym lnr.lnr_discriminator ^ "\n" let pp_line_number_registers_tight lnr : list string = [ - pphex lnr.lnr_address ; + pphex_sym lnr.lnr_address ; show lnr.lnr_op_index ; show lnr.lnr_file ; show lnr.lnr_line ; @@ -5779,7 +5893,7 @@ let pp_line_number_registers_tight lnr : list string = show lnr.lnr_prologue_end ; show lnr.lnr_epilogue_begin ; show lnr.lnr_isa ; - pphex lnr.lnr_discriminator + pphex_sym lnr.lnr_discriminator ] let pp_line_number_registerss lnrs = @@ -5821,7 +5935,7 @@ CU: /var/local/stephen/work/devel/rsem/ppcmem2/system/tests-adhoc/simple-malloc/ -let source_lines_of_address (ds:dwarf_static) (a: natural) : list ( unpacked_file_entry * natural * line_number_registers * string (*function*)) = +let source_lines_of_address (ds:dwarf_static) (a: sym_natural) : list ( unpacked_file_entry * sym_natural * line_number_registers * string (*function*)) = List.concat (List.map (fun (lnh, lnrs) -> @@ -5883,7 +5997,7 @@ let decl_of_die d subprogram_line_extents cu die : maybe (unpacked_file_entry * | (Just file, Just line) -> let ufe = unpack_file_entry lnh file in let subprogram_name = subprogram_at_line subprogram_line_extents ufe line in - Just (ufe, natFromNatural line, subprogram_name) + Just (ufe, natFromSymNatural line, subprogram_name) | (_,_) -> Nothing end @@ -5897,7 +6011,7 @@ let call_site_of_die d subprogram_line_extents cu die : maybe (unpacked_file_ent | (Just file, Just line) -> let ufe = unpack_file_entry lnh file in let subprogram_name = subprogram_at_line subprogram_line_extents ufe line in - Just (ufe, natFromNatural line, subprogram_name) + Just (ufe, natFromSymNatural line, subprogram_name) | (_,_) -> Nothing end @@ -5950,7 +6064,7 @@ let rec mk_sdt_variable_or_formal_parameter (d:dwarf) subprogram_line_extents cu svfp_declaration = match find_flag_attribute_value_of_die_using_abstract_origin d "DW_AT_declaration" cupdie with Just b -> b | Nothing -> false end; svfp_locations = let base_address = cu_base_address cu in - let interpreted_locations : maybe (list (natural * natural * single_location_description)) = + let interpreted_locations : maybe (list (sym_natural * sym_natural * single_location_description)) = interpreted_location_of_die c cu.cu_header d.d_str d.d_loc d.d_ranges base_address parents die in Maybe.map (fun nnbss -> List.map (fun (n1,n2,bs) -> (n1,n2,parse_operations_bs c cu.cu_header bs)) nnbss) interpreted_locations; svfp_decl = decl_of_die d subprogram_line_extents cu die; @@ -6048,20 +6162,20 @@ let mk_sdt_dwarf (d:dwarf) subprogram_line_extents : sdt_dwarf = let pp_sdt_unspecified_parameter (level:natural) (sup:sdt_unspecified_parameter) : string = indent_level true level ^ "unspecified parameters" ^ "\n" -let pp_parsed_single_location_description (level:natural) ((n1:natural), (n2:natural), (ops:list operation)) : string = +let pp_parsed_single_location_description (level:natural) ((n1:sym_natural), (n2:sym_natural), (ops:list operation)) : string = let indent = indent_level true level in indent - ^ pphex n1 - ^ " " ^ pphex n2 + ^ pphex_sym n1 + ^ " " ^ pphex_sym n2 ^ " (" ^ pp_operations ops ^")" ^"\n" -let pp_pc_ranges (level:natural) (rso:maybe (list (natural*natural))) = +let pp_pc_ranges (level:natural) (rso:maybe (list (sym_natural*sym_natural))) = match rso with | Nothing -> "none\n" | Just rs -> let indent = indent_level true level in - "\n" ^ String.concat "" (List.map (fun (n1,n2) -> indent ^ pphex n1 ^ " " ^ pphex n2 ^ "\n") rs) + "\n" ^ String.concat "" (List.map (fun (n1,n2) -> indent ^ pphex_sym n1 ^ " " ^ pphex_sym n2 ^ "\n") rs) end let pp_sdt_maybe x f = match x with Nothing -> "none\n" | Just y -> f y end @@ -6093,7 +6207,7 @@ let rec pp_sdt_subroutine (level:natural) (ss:sdt_subroutine) : string = ^ indent ^ "type:" ^ pp_sdt_maybe ss.ss_type (fun typ -> pp_type_info_deep typ ^"\n") ^ indent ^ "vars:" ^ pp_sdt_list ss.ss_vars (pp_sdt_variable_or_formal_parameter (level+1)) ^ indent ^ "unspecified_parameters:" ^ pp_sdt_list ss.ss_unspecified_parameters (pp_sdt_unspecified_parameter (level+1)) - ^ indent ^ "entry address: " ^ pp_sdt_maybe ss.ss_entry_address (fun n -> pphex n^"\n") + ^ indent ^ "entry address: " ^ pp_sdt_maybe ss.ss_entry_address (fun n -> pphex_sym n^"\n") ^ indent ^ "pc ranges:" ^ pp_pc_ranges (level+1) ss.ss_pc_ranges ^ indent ^ "subroutines:" ^ pp_sdt_list ss.ss_subroutines (pp_sdt_subroutine (level+1)) ^ indent ^ "lexical_blocks:" ^ pp_sdt_list ss.ss_lexical_blocks (pp_sdt_lexical_block (level+1)) @@ -6164,7 +6278,7 @@ let rec pp_sdt_locals_subroutine (level:natural) (ss:sdt_subroutine) : string = ^ indent (*^ "name:" ^*) ^ pp_sdt_maybe ss.ss_name (fun name -> name ^ "\n") (* ^ indent ^ "cupdie:" ^ pp_cupdie3 ss.ss_cupdie ^ "\n"*) ^ indent ^ "kind:" ^ (match ss.ss_kind with SSK_subprogram -> "subprogram" | SSK_inlined_subroutine -> "inlined subroutine" end) ^ "\n" - ^ indent ^ "entry address: " ^ pp_sdt_maybe ss.ss_entry_address (fun n -> pphex n^"\n") + ^ indent ^ "entry address: " ^ pp_sdt_maybe ss.ss_entry_address (fun n -> pphex_sym n^"\n") ^ indent ^ "call site:" ^ pp_sdt_maybe ss.ss_call_site (fun ud -> "\n" ^ indent_level true (level+1) ^ pp_ud ud ^ "\n") ^ indent ^ "abstract origin:" ^ pp_sdt_maybe ss.ss_abstract_origin (fun s -> "\n" ^ pp_sdt_locals_subroutine (level+1) s) (* ^ indent ^ "type:" ^ pp_sdt_maybe ss.ss_type (fun typ -> pp_type_info_deep typ ^"\n" end)*) @@ -6239,8 +6353,8 @@ let analyse_inlined_subroutines (d: dwarf) : inlined_subroutine_data = let file_index = strict_ais (find_natural_attribute_value_of_die c "DW_AT_call_file" die) "no DW_AT_call_file" s inlined_subroutine in unpack_file_entry (line_number_program_of_compilation_unit d cu).lnp_header file_index in (* match filename d cu file_index with | Just s -> s | Nothing -> "none" end in*) - let call_line : natural = strict_ais (find_natural_attribute_value_of_die c "DW_AT_call_line" die) "no DW_AT_call_line" s inlined_subroutine in - let pc_ranges : list (natural*natural) = + let call_line : sym_natural = strict_ais (find_natural_attribute_value_of_die c "DW_AT_call_line" die) "no DW_AT_call_line" s inlined_subroutine in + let pc_ranges : list (sym_natural*sym_natural) = strict_ais (closest_enclosing_range c d.d_ranges (cu_base_address cu) [die](*deliberately ignore parents*)) "no pc ranges" s inlined_subroutine in let const_params = @@ -6291,10 +6405,10 @@ let rec analyse_inlined_subroutines_sdt_subroutine (sdt_parents: list sdt_subrou let this : list inlined_subroutine = match (ss.ss_kind, ss.ss_abstract_origin) with | (SSK_inlined_subroutine, Just ss') -> - let ((call_file:unpacked_file_entry),(call_line:natural)) = + let ((call_file:unpacked_file_entry),(call_line:sym_natural)) = match ss.ss_call_site with | Just (((ufe,line,subprogram_name) as ud):unpacked_decl) -> - (ufe,naturalFromNat line) + (ufe,symNaturalFromNat line) | Nothing -> Assert_extra.failwith "analyse_inlined_subroutines_sdt_subroutine found no ss_call_site" end in @@ -6337,7 +6451,7 @@ let analyse_inlined_subroutines_sdt_dwarf (sd: sdt_dwarf) : list inlined_subrout let analyse_inlined_subroutine_by_range (is:inlined_subroutine) : inlined_subroutine_data_by_range = let n_ranges = List.length is.is_pc_ranges in - List.mapi (fun i -> fun (n1,n2) -> ((n1,n2),(naturalFromNat i, naturalFromNat n_ranges),is)) is.is_pc_ranges + List.mapi (fun i -> fun (n1,n2) -> ((n1,n2),(symNaturalFromNat i, symNaturalFromNat n_ranges),is)) is.is_pc_ranges let is_lt ((n1,n2),(m,n),is) ((n1',n2'),(m',n'),is') = n1 < n1' || (n1 = n1' && n2 > n2') @@ -6354,7 +6468,7 @@ let rec pp_inlined_subroutine_parents (ds:list die) : string = pp_pos die.die_offset ^ ":" ^ pp_inlined_subroutine_parents ds' else if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_lexical_block" then ":" ^ pp_inlined_subroutine_parents ds' else if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_subprogram" then "" - else "" + else "" end @@ -6387,16 +6501,16 @@ let pp_inlined_subroutine_const_params d is = let pp_inlined_subroutine ds is = pp_inlined_subroutine_header ds is ^ "\n" - ^ String.concat "" (List.map (fun (n1,n2) -> " " ^ pphex n1 ^ " " ^ pphex n2 ^ "\n") is.is_pc_ranges) + ^ String.concat "" (List.map (fun (n1,n2) -> " " ^ pphex_sym n1 ^ " " ^ pphex_sym n2 ^ "\n") is.is_pc_ranges) ^ pp_inlined_subroutine_const_params ds.ds_dwarf is let pp_inlined_subroutines ds iss = String.concat "" (List.map (pp_inlined_subroutine ds) iss) -let pp_inlined_subroutine_by_range ds ((n1,n2),((m:natural),(n:natural)),is) = - pphex n1 ^ " " ^ pphex n2 ^ " " - ^ (if n<>1 then "("^show m^" of "^show n^") " else "") +let pp_inlined_subroutine_by_range ds ((n1,n2),((m:sym_natural),(n:sym_natural)),is) = + pphex_sym n1 ^ " " ^ pphex_sym n2 ^ " " + ^ (if n<>(Absolute 1) then "("^show m^" of "^show n^") " else "") ^ pp_inlined_subroutine_header ds is ^"\n" ^ (if m=0 then pp_inlined_subroutine_const_params ds.ds_dwarf is else "") @@ -6411,21 +6525,21 @@ let pp_inlined_subroutines_by_range ds iss = (* assume 4-byte ARM instructions *) -let rec words_of_byte_sequence (addr:natural) (bs:byte_sequence) (acc:list (natural * natural)) : list (natural * natural) = +let rec words_of_byte_sequence (addr:sym_natural) (bs:byte_sequence) (acc:list (sym_natural * sym_natural)) : list (sym_natural * sym_natural) = match read_4_bytes_be bs with | Success ((b0,b1,b2,b3), bs') -> - let i : natural = natural_of_byte b0 + 256*natural_of_byte b1 + 65536*natural_of_byte b2 + 65536*256*natural_of_byte b3 in + let i : sym_natural = Absolute (natural_of_byte b0 + 256*natural_of_byte b1 + 65536*natural_of_byte b2 + 65536*256*natural_of_byte b3) in words_of_byte_sequence (addr+4) bs' ((addr,i)::acc) | Fail _ -> List.reverse acc end -let pp_instruction ((addr:natural),(i:natural)) = - hex_string_of_big_int_pad8 addr ^ " " ^ hex_string_of_big_int_pad8 i ^ "\n" +let pp_instruction ((addr:sym_natural),(i:sym_natural)) = + hex_string_of_big_int_pad8 (sym_unwrap addr) ^ " " ^ hex_string_of_big_int_pad8 (sym_unwrap i) ^ "\n" val pp_text_section : elf_file -> string let pp_text_section f = let (p_context, addr, bs) = extract_text f in - let instructions : list (natural * natural) = words_of_byte_sequence addr bs [] in + let instructions : list (sym_natural * sym_natural) = words_of_byte_sequence addr bs [] in String.concat "" (List.map pp_instruction instructions) (** ************************************************************ *) @@ -6481,21 +6595,21 @@ let mds = extract_dwarf_static f1 in end -val harness_string_of_elf64_debug_info_section : elf64_file -> byte_sequence -> (*(natural -> string) -> (natural -> string) -> (natural -> string) -> elf64_header -> elf64_section_header_table -> string_table -> *) string +val harness_string_of_elf64_debug_info_section : elf64_file -> byte_sequence -> (*(sym_natural -> string) -> (sym_natural -> string) -> (sym_natural -> string) -> elf64_header -> elf64_section_header_table -> string_table -> *) string let {ocaml} harness_string_of_elf64_debug_info_section f1 bs0 (*os proc usr hdr sht stbl*) = harness_string_of_elf (ELF_File_64 f1) bs0 -val harness_string_of_elf32_debug_info_section : elf32_file -> byte_sequence -> (* (natural -> string) -> (natural -> string) -> (natural -> string) -> elf32_header -> elf32_section_header_table -> string_table ->*) string +val harness_string_of_elf32_debug_info_section : elf32_file -> byte_sequence -> (* (sym_natural -> string) -> (sym_natural -> string) -> (sym_natural -> string) -> elf32_header -> elf32_section_header_table -> string_table ->*) string let {ocaml} harness_string_of_elf32_debug_info_section f1 bs0 (*os proc usr hdr sht stbl*) = harness_string_of_elf (ELF_File_32 f1) bs0 -val harness_string_of_elf64_like_objdump : elf64_file -> byte_sequence -> (*(natural -> string) -> (natural -> string) -> (natural -> string) -> elf64_header -> elf64_section_header_table -> string_table -> *) string +val harness_string_of_elf64_like_objdump : elf64_file -> byte_sequence -> (*(sym_natural -> string) -> (sym_natural -> string) -> (sym_natural -> string) -> elf64_header -> elf64_section_header_table -> string_table -> *) string let {ocaml} harness_string_of_elf64_like_objdump f1 bs0 (*os proc usr hdr sht stbl*) = harness_string_of_elf_like_objdump (ELF_File_64 f1) bs0 -val harness_string_of_elf32_like_objdump : elf32_file -> byte_sequence -> (* (natural -> string) -> (natural -> string) -> (natural -> string) -> elf32_header -> elf32_section_header_table -> string_table ->*) string +val harness_string_of_elf32_like_objdump : elf32_file -> byte_sequence -> (* (sym_natural -> string) -> (sym_natural -> string) -> (sym_natural -> string) -> elf32_header -> elf32_section_header_table -> string_table ->*) string let {ocaml} harness_string_of_elf32_like_objdump f1 bs0 (*os proc usr hdr sht stbl*) = harness_string_of_elf_like_objdump (ELF_File_32 f1) bs0 From 131b3a612b4d20668861a13914d1874de8a4b01e Mon Sep 17 00:00:00 2001 From: Matej Urban Date: Thu, 7 Nov 2024 17:11:40 +0000 Subject: [PATCH 03/44] remove dwarf copy --- src/dwarf copy.lem | 6599 -------------------------------------------- 1 file changed, 6599 deletions(-) delete mode 100644 src/dwarf copy.lem diff --git a/src/dwarf copy.lem b/src/dwarf copy.lem deleted file mode 100644 index ce9d432..0000000 --- a/src/dwarf copy.lem +++ /dev/null @@ -1,6599 +0,0 @@ -(* -*-tuareg-*- *) -open import Basic_classes -open import Bool -open import Function -open import Maybe -open import Num -open import String - -open import List (* TODO: check why this is not imported in ELF *) - -open import Byte_sequence -open import Error -open import Hex_printing -open import Missing_pervasives -open import Show - -open import Default_printing - -open import Endianness -open import String_table - -open import Elf_dynamic -open import Elf_file -open import Elf_header -open import Elf_program_header_table -open import Elf_relocation -open import Elf_section_header_table -open import Elf_symbol_table -open import Elf_types_native_uint - -(** ***************** experimental DWARF reading *********** *) - -(* - -This defines a representation of some of the DWARF debug information, -with parsing functions to extract it from the byte sequences of the -relevant ELF sections, and pretty-printing function to dump it in a -human-readable form, similar to that of readelf. The main functions -for this are: - - val extract_dwarf : elf64_file -> maybe dwarf - val pp_dwarf : dwarf -> string - -It also defines evaluation of DWARF expressions and analysis functions -to convert the variable location information to a form suitable for -looking up variable names from machine addresses that arise during -execution, including the call frame address calculation. The main -types and functions for this are: - - type analysed_location_data - val analyse_locations : dwarf -> analysed_location_data - - type evaluated_frame_info - val evaluate_frame_info : dwarf -> evaluated_frame_info - - type dwarf_static - val extract_dwarf_static : elf64_file -> maybe dwarf_static - -The last collects all the above - information that can be computed statically. - -Then to do lookup from addresses to source-code names, we have: - - type analysed_location_data_at_pc - val analysed_locations_at_pc : evaluation_context -> dwarf_static -> natural -> analysed_location_data_at_pc - val names_of_address : dwarf -> analysed_location_data_at_pc -> natural -> list string - -The definitions are deliberately simple-minded, to be quick to write, -easy to see the correspondence to the DWARF text specification, and -potentially support generation of theorem-prover definitions in -future. They are in a pure functional style, making the information -dependencies explicit. They are not written for performance, though -they may be efficient enough for small examples as-is. They are -written in Lem, and compiled from that to executable OCaml. - -The development follows the DWARF 4 pdf specification at http://www.dwarfstd.org/ -though tweaked in places where our examples use earlier versions. It doesn't -systematically cover all the DWARF versions. -It doesn't cover the GNU extensions -(at https://fedorahosted.org/elfutils/wiki/DwarfExtensions). -The representation, parsing, and pretty printing are mostly complete for the -data in these DWARF ELF sections: - -.debug_abbrev -.debug_info -.debug_types -.debug_loc -.debug_str -.debug_ranges -.debug_frame (without augmentations) -.debug_line - -The following DWARF ELF sections are not covered: - -.debug_aranges -.debug_macinfo -.debug_pubnames -.debug_pubtypes - -The evaluation of DWARF expressions covers only some of the operations -- probably enough for common cases. - -The analysis of DWARF location data should be enough to look up names -from the addresses of variables and formal parameters. It does not -currently handle the DWARF type data, so will not be useful for accesses -strictly within the extent of a variable or parameter. - -The 'dwarf' type gives a lightly parsed representation of some of the -dwarf information, with the byte sequences of the above .debug_* -sections parsed into a structured representation. That makes the list -and tree structures explicit, and converts the various numeric types -into just natural, integer, and byte sequences. The lem natural and -integer could be replaced by unsigned and signed 64-bit types; that'd -probably be better for execution but not for theorem-prover use. - -*) - -(* some spec ambiguities (more in comments in-line below): *) -(* can a location list be referenced from multiple compilation units, with different base addresses? *) - - -(** debug *) - -(* workaround debug.lem linking *) -val print_endline : string -> unit -declare ocaml target_rep function print_endline = `print_endline` - -let my_debug s= () (*print_endline s*) -let my_debug2 s= () (*print_endline s*) -let my_debug3 s= () (*print_endline s*) -let my_debug4 s= print_endline s -let my_debug5 s= print_endline s - - - -(* Symbolic types *) -type sym_natural = - | Offset of (string * natural) - | Absolute of natural - | Unknown - -let sym_add x y= - match (x, y) with - | (Absolute x, Absolute y) -> Absolute (x + y) - | (Offset (s, x), Absolute y) -> Offset (s, x + y) - | (Absolute x, Offset (s, y)) -> Offset (s, x + y) - | _ -> Unknown - end - -val sym_bind : sym_natural -> (natural -> sym_natural) -> sym_natural -let sym_bind x f = match x with - | Absolute x -> f x - | _ -> Unknown -end - -let sym_map f x = sym_bind x (fun x -> Absolute(f x)) - -let sym_map2 f x y = sym_bind x (fun x -> sym_map (f x) y) - -let sym_unwrap = function - | Absolute x -> x - | _ -> Assert_extra.failwith "sym_unwrap" -end - -instance (NumAdd sym_natural) - let (+) = sym_add -end - -instance (NumMinus sym_natural) - let (-) = sym_map2 (-) -end - -instance (NumRemainder sym_natural) - let (mod) = sym_map2 (mod) -end - -instance (Ord sym_natural) - let compare = (fun x -> fun y -> compare (sym_unwrap x) (sym_unwrap y)) - let (<) = (fun x -> fun y -> (sym_unwrap x) < (sym_unwrap y)) - let (<=) = (fun x -> fun y -> (sym_unwrap x) <= (sym_unwrap y)) - let (>) = (fun x -> fun y -> (sym_unwrap x) > (sym_unwrap y)) - let (>=) = (fun x -> fun y -> (sym_unwrap x) >= (sym_unwrap y)) -end - -instance (Numeral sym_natural) - let fromNumeral = fun x -> Absolute (fromNumeral x) -end - -let pp_sym ppf = function -| Absolute x -> ppf x -| Offset (s, x) -> s ^ "+" ^ ppf x -| Unknown -> "Unknown" -end - -instance (Show sym_natural) - let show = pp_sym show -end - -let sym_natural_land = sym_map2 natural_land -let sym_natural_lxor = sym_map2 natural_lxor -let sym_natural_lor = sym_map2 natural_lor - -let integerFromSymNatural = function - | Absolute x -> integerFromNatural x - | _ -> Assert_extra.failwith "integerFromSymNatural" -end - -let natFromSymNatural = function - | Absolute x -> natFromNatural x - | _ -> Assert_extra.failwith "integerFromSymNatural" -end - -let sym_natural_of_hex x = Absolute(natural_of_hex x) - -(** ************************************************************ *) -(** ** dwarf representation types **************************** *) -(** ************************************************************ *) - - -type dwarf_attribute_classes = - | DWA_7_5_3 - | DWA_address - | DWA_block - | DWA_constant - | DWA_dash - | DWA_exprloc - | DWA_flag - | DWA_lineptr - | DWA_loclistptr - | DWA_macptr - | DWA_rangelistptr - | DWA_reference - | DWA_string - -(* operations and expression evalution *) - -type operation_argument_type = - | OAT_addr - | OAT_dwarf_format_t - | OAT_uint8 - | OAT_uint16 - | OAT_uint32 - | OAT_uint64 - | OAT_sint8 - | OAT_sint16 - | OAT_sint32 - | OAT_sint64 - | OAT_ULEB128 - | OAT_SLEB128 - | OAT_block - -type operation_argument_value = - | OAV_natural of sym_natural - | OAV_integer of integer - | OAV_block of sym_natural * byte_sequence - -type operation_stack = list sym_natural - -type arithmetic_context = - <| - ac_bitwidth: sym_natural; - ac_half: sym_natural; (* 2 ^ (ac_bitwidth -1) *) - ac_all: sym_natural; (* 2 ^ ac_bitwidth *) - ac_max: sym_natural; (* (2 ^ ac_bitwidth) -1 *) (* also the representation of -1 *) -|> - -type operation_semantics = - | OpSem_lit - | OpSem_deref - | OpSem_stack of (arithmetic_context -> operation_stack -> list operation_argument_value -> maybe operation_stack) - | OpSem_not_supported - | OpSem_binary of (arithmetic_context -> sym_natural -> sym_natural -> maybe sym_natural) - | OpSem_unary of (arithmetic_context -> sym_natural -> maybe sym_natural) - | OpSem_opcode_lit of sym_natural - | OpSem_reg - | OpSem_breg - | OpSem_bregx - | OpSem_fbreg - | OpSem_deref_size - | OpSem_nop - | OpSem_piece - | OpSem_bit_piece - | OpSem_implicit_value - | OpSem_stack_value - | OpSem_call_frame_cfa - -type operation = - <| - op_code: sym_natural; - op_string: string; - op_argument_values: list operation_argument_value; - op_semantics: operation_semantics; - |> - - -(* the result of a location expression evaluation is a single_location (or failure) *) - -type simple_location = - | SL_memory_address of sym_natural - | SL_register of sym_natural - | SL_implicit of byte_sequence (* used for implicit and stack values *) - | SL_empty - -type composite_location_piece = - | CLP_piece of sym_natural * simple_location - | CLP_bit_piece of sym_natural * sym_natural * simple_location - -type single_location = - | SL_simple of simple_location - | SL_composite of list composite_location_piece - -(* location expression evaluation is a stack machine operating over the following state *) - -type state = - <| - s_stack: operation_stack; - s_value: simple_location; - s_location_pieces: list composite_location_piece; - |> - -(* location expression evaluation can involve register and memory reads, via the following interface *) - -type register_read_result 'a = - | RRR_result of sym_natural - | RRR_not_currently_available - | RRR_bad_register_number - -type memory_read_result 'a = - | MRR_result of sym_natural - | MRR_not_currently_available - | MRR_bad_address - -type evaluation_context = - <| - read_register: sym_natural -> register_read_result sym_natural; - read_memory: sym_natural -> sym_natural -> memory_read_result sym_natural; - |> - - -(* dwarf sections *) - -type dwarf_format = - | Dwarf32 - | Dwarf64 - -(* .debug_abbrev section *) - -type abbreviation_declaration = - <| - ad_abbreviation_code: natural; - ad_tag: natural; - ad_has_children: bool; - ad_attribute_specifications: list (natural * natural); - |> - -type abbreviations_table = - <| - at_offset: natural; - at_table: list abbreviation_declaration; -|> - -(* .debug_info section *) - -(* TODO byte sequences have relocations *) - -type attribute_value = (* following Figure 3 *) - | AV_addr of sym_natural - | AV_block of natural * byte_sequence - | AV_constantN of sym_natural * byte_sequence - | AV_constant_SLEB128 of integer - | AV_constant_ULEB128 of sym_natural - | AV_exprloc of natural * byte_sequence - | AV_flag of bool - | AV_ref of natural - | AV_ref_addr of natural (* dwarf_format dependent *) - | AV_ref_sig8 of natural - | AV_sec_offset of natural - | AV_string of byte_sequence (* not including terminating null *) - | AV_strp of natural (* dwarf_format dependent *) - - -type die = - <| - die_offset: natural; - die_abbreviation_code: natural; - die_abbreviation_declaration: abbreviation_declaration; - die_attribute_values: list (natural (*pos*) * attribute_value); - die_children: list die; - |> - -type die_index = Map.map natural (list die * die) - -type compilation_unit_header = - <| - cuh_offset: natural; - cuh_dwarf_format: dwarf_format; - cuh_unit_length: natural; - cuh_version: natural; - cuh_debug_abbrev_offset: natural; - cuh_address_size: natural; - |> - -type compilation_unit = - <| - cu_header: compilation_unit_header; - cu_abbreviations_table: abbreviations_table; - cu_die: die; - cu_index: die_index - |> - -type compilation_units = list compilation_unit - -(* .debug_type section *) - -type type_unit_header = - <| - tuh_cuh: compilation_unit_header; - tuh_type_signature: natural; - tuh_type_offset: natural; - |> - -type type_unit = - <| - tu_header: type_unit_header; - tu_abbreviations_table: abbreviations_table; - tu_die: die; - |> - -type type_units = list type_unit - -(* .debug_loc section *) - -type single_location_description = byte_sequence - -type location_list_entry = - <| - lle_beginning_address_offset: natural; - lle_ending_address_offset: natural; - lle_single_location_description: single_location_description; - |> - -type base_address_selection_entry = - <| - base_address: sym_natural; - |> - -type location_list_item = - | LLI_lle of location_list_entry - | LLI_base of base_address_selection_entry - -type location_list = natural (*offset*) * list location_list_item - -type location_list_list = list location_list - -(* .debug_ranges section *) - -type range_list_entry = - <| - rle_beginning_address_offset: natural; - rle_ending_address_offset: natural; - |> - -type range_list_item = - | RLI_rle of range_list_entry - | RLI_base of base_address_selection_entry - -type range_list = natural (*offset (of range_list from start of .debug_ranges section?) *) * list range_list_item - -type range_list_list = list range_list - -(* .debug_frame section: call frame instructions *) - -type cfa_address = sym_natural -type cfa_block = byte_sequence -type cfa_delta = sym_natural -type cfa_offset = sym_natural -type cfa_register = sym_natural -type cfa_sfoffset = integer - -type call_frame_argument_type = - | CFAT_address - | CFAT_delta1 - | CFAT_delta2 - | CFAT_delta4 - | CFAT_delta_ULEB128 - | CFAT_offset (*ULEB128*) - | CFAT_sfoffset (*SLEB128*) - | CFAT_register (*ULEB128*) - | CFAT_block - -type call_frame_argument_value = - | CFAV_address of cfa_address - | CFAV_block of cfa_block - | CFAV_delta of cfa_delta - | CFAV_offset of cfa_offset - | CFAV_register of cfa_register - | CFAV_sfoffset of cfa_sfoffset - -type call_frame_instruction = - | DW_CFA_advance_loc of cfa_delta - | DW_CFA_offset of cfa_register * cfa_offset - | DW_CFA_restore of cfa_register - | DW_CFA_nop - | DW_CFA_set_loc of cfa_address - | DW_CFA_advance_loc1 of cfa_delta - | DW_CFA_advance_loc2 of cfa_delta - | DW_CFA_advance_loc4 of cfa_delta - | DW_CFA_offset_extended of cfa_register * cfa_offset - | DW_CFA_restore_extended of cfa_register - | DW_CFA_undefined of cfa_register - | DW_CFA_same_value of cfa_register - | DW_CFA_register of cfa_register * cfa_register - | DW_CFA_remember_state - | DW_CFA_restore_state - | DW_CFA_def_cfa of cfa_register * cfa_offset - | DW_CFA_def_cfa_register of cfa_register - | DW_CFA_def_cfa_offset of cfa_offset - | DW_CFA_def_cfa_expression of cfa_block - | DW_CFA_expression of cfa_register * cfa_block - | DW_CFA_offset_extended_sf of cfa_register * cfa_sfoffset - | DW_CFA_def_cfa_sf of cfa_register * cfa_sfoffset - | DW_CFA_def_cfa_offset_sf of cfa_sfoffset - | DW_CFA_val_offset of cfa_register * cfa_offset - | DW_CFA_val_offset_sf of cfa_register * cfa_sfoffset - | DW_CFA_val_expression of cfa_register * cfa_block - | DW_CFA_AARCH64_negate_ra_state - | DW_CFA_unknown of byte - -(* .debug_frame section: top-level *) - -type cie = - <| - cie_offset: natural; - cie_length: natural; - cie_id: natural; - cie_version: natural; - cie_augmentation: byte_sequence; (* not including terminating null *) - cie_address_size: maybe natural; - cie_segment_size: maybe natural; - cie_code_alignment_factor: sym_natural; - cie_data_alignment_factor: integer; - cie_return_address_register: cfa_register; - cie_initial_instructions_bytes: byte_sequence; - cie_initial_instructions: list call_frame_instruction; - |> - -type fde = - <| - fde_offset: natural; - fde_length: natural; - fde_cie_pointer: natural; - fde_initial_location_segment_selector: maybe sym_natural; - fde_initial_location_address: sym_natural; - fde_address_range: sym_natural; - fde_instructions_bytes: byte_sequence; - fde_instructions: list call_frame_instruction; - |> - -type frame_info_element = - | FIE_cie of cie - | FIE_fde of fde - -type frame_info = list frame_info_element - - -(* evaluated cfa data *) - -type cfa_rule = - | CR_undefined - | CR_register of cfa_register * integer - | CR_expression of single_location_description - -type register_rule = - | RR_undefined (*A register that has this rule has no recoverable value in the previous frame. - (By convention, it is not preserved by a callee.)*) - | RR_same_value (*This register has not been modified from the previous frame. (By convention, - it is preserved by the callee, but the callee has not modified it.)*) - | RR_offset of integer (* The previous value of this register is saved at the address CFA+N where CFA - is the current CFA value and N is a signed offset.*) - | RR_val_offset of integer (* The previous value of this register is the value CFA+N where CFA is the - current CFA value and N is a signed offset.*) - | RR_register of sym_natural (* The previous value of this register is stored in another register numbered R.*) - | RR_expression of single_location_description (* The previous value of this register is located at the address produced by - executing the DWARF expression E.*) - | RR_val_expression of single_location_description (* The previous value of this register is the value produced by executing the -DWARF expression E.*) - | RR_architectural (*The rule is defined externally to this specification by the augmenter*) - -type register_rule_map = list (cfa_register * register_rule) - -type cfa_table_row = - <| - ctr_loc: sym_natural; - ctr_cfa: cfa_rule; - ctr_regs: register_rule_map; - |> - -type cfa_state = - <| - cs_current_row: cfa_table_row; - cs_previous_rows: list cfa_table_row; - cs_initial_instructions_row: cfa_table_row; - cs_row_stack: list cfa_table_row; - |> - - -type evaluated_frame_info = - list (fde * list cfa_table_row) - - -(* line number *) - -type line_number_argument_type = - | LNAT_address - | LNAT_ULEB128 - | LNAT_SLEB128 - | LNAT_uint16 - | LNAT_string - -type line_number_argument_value = - | LNAV_address of sym_natural - | LNAV_ULEB128 of sym_natural - | LNAV_SLEB128 of integer - | LNAV_uint16 of sym_natural - | LNAV_string of byte_sequence (* not including terminating null *) - -type line_number_operation = - (* standard *) - | DW_LNS_copy - | DW_LNS_advance_pc of sym_natural - | DW_LNS_advance_line of integer - | DW_LNS_set_file of sym_natural - | DW_LNS_set_column of sym_natural - | DW_LNS_negate_stmt - | DW_LNS_set_basic_block - | DW_LNS_const_add_pc - | DW_LNS_fixed_advance_pc of sym_natural - | DW_LNS_set_prologue_end - | DW_LNS_set_epilogue_begin - | DW_LNS_set_isa of sym_natural - (* extended *) - | DW_LNE_end_sequence - | DW_LNE_set_address of sym_natural - | DW_LNE_define_file of byte_sequence * sym_natural * sym_natural * sym_natural - | DW_LNE_set_discriminator of sym_natural - (* special *) - | DW_LN_special of sym_natural (* the adjusted opcode *) - -type line_number_file_entry = - <| - lnfe_path: byte_sequence; - lnfe_directory_index: sym_natural; - lnfe_last_modification: sym_natural; - lnfe_length: sym_natural; - |> - -type line_number_header = - <| - lnh_offset: natural; - lnh_dwarf_format: dwarf_format; - lnh_unit_length: natural; - lnh_version: natural; - lnh_header_length: natural; - lnh_minimum_instruction_length: sym_natural; - lnh_maximum_operations_per_instruction: sym_natural; - lnh_default_is_stmt: bool; - lnh_line_base: integer; - lnh_line_range: sym_natural; - lnh_opcode_base: natural; - lnh_standard_opcode_lengths: list natural; - lnh_include_directories: list (byte_sequence); - lnh_file_entries: list line_number_file_entry; - lnh_comp_dir: maybe string; (* passed down from cu DW_AT_comp_dir *) - |> - -type line_number_program = - <| - lnp_header: line_number_header; - lnp_operations: list line_number_operation; - |> - -(* line number evaluation *) - -type line_number_registers = - <| - lnr_address: sym_natural; - lnr_op_index: sym_natural; - lnr_file: sym_natural; - lnr_line: sym_natural; - lnr_column: sym_natural; - lnr_is_stmt: bool; - lnr_basic_block: bool; - lnr_end_sequence: bool; - lnr_prologue_end: bool; - lnr_epilogue_begin: bool; - lnr_isa: sym_natural; - lnr_discriminator: sym_natural; - |> - -type unpacked_file_entry = (maybe string (*comp_dir*)) * (maybe string (*dir*)) * string (*file*) - -type unpacked_decl = unpacked_file_entry * nat(*line*) * string(*subprogram name*) - - -(* top-level collection of dwarf data *) - -type dwarf = - <| - d_endianness: Endianness.endianness; (* from the ELF *) - d_str: byte_sequence; - d_compilation_units: compilation_units; - d_type_units: type_units; - d_loc: location_list_list; - d_ranges: range_list_list; - d_frame_info: frame_info; - d_line_info: list line_number_program; - |> - -(* analysed location data *) - -type analysed_location_data = list ((compilation_unit * (list die) * die) * maybe (list (sym_natural * sym_natural * single_location_description))) - -type analysed_location_data_at_pc = list ((compilation_unit * (list die) * die) * (sym_natural * sym_natural * single_location_description * error single_location)) - -(* evaluated line data *) - -type evaluated_line_info = list (line_number_header * list line_number_registers) - -(* all dwarf static data *) - -type dwarf_static = - <| - ds_dwarf: dwarf; - ds_analysed_location_data: analysed_location_data; - ds_evaluated_frame_info: evaluated_frame_info; - ds_evaluated_line_info: evaluated_line_info; - ds_subprogram_line_extents: list (unpacked_file_entry * list (string * unpacked_file_entry * sym_natural) ); - |> - -type dwarf_dynamic_at_pc = analysed_location_data_at_pc - -(** context for parsing and pp functions *) - -type p_context = - <| - endianness: Endianness.endianness; - |> - - - -(* type descriptions *) -(* NB these do not cover all the DWARF-expressible types; only some common C cases *) -(* ignore base type DW_endianity and DW_bitsize for now *) -type cupdie = compilation_unit * (list die) * die - -type decl = - <| - decl_file: maybe string; - decl_line: maybe sym_natural; - |> - -type array_dimension 't = maybe sym_natural(*count*) * maybe 't(*subrange type*) - -type struct_union_member 't = cupdie * (maybe string)(*mname*) * 't * maybe sym_natural(*data_member_location, non-Nothing for structs*) - -type struct_union_type_kind = - | Atk_structure - | Atk_union - -type enumeration_member = cupdie * (maybe string)(*mname*) * integer(*const_value*) - -type c_type_top 't = - | CT_missing of cupdie - | CT_base of cupdie * string(*name*) * sym_natural(*encoding*) * (maybe sym_natural)(*byte_size*) - | CT_pointer of cupdie * maybe 't - | CT_const of cupdie * maybe 't - | CT_volatile of cupdie * 't - | CT_restrict of cupdie * 't - | CT_typedef of cupdie * string(*name*) * 't * decl - | CT_array of cupdie * 't * list (array_dimension 't) - | CT_struct_union of cupdie * struct_union_type_kind * (maybe string)(*mname*) * (maybe sym_natural)(*byte_size*) * decl * maybe (list (struct_union_member 't)(*members*)) - | CT_enumeration of cupdie * (maybe string)(*mname*) * (maybe 't)(*mtyp*) * (maybe sym_natural)(*mbyte_size*) * decl * maybe (list (enumeration_member)(*members*)) - | CT_subroutine of cupdie * (bool)(*prototyped*) * (maybe 't)(*mresult_type*) * (list 't)(*parameter_types*) * (bool)(*variable_parameter_list*) - -(* In the CT_struct_union and C_enumeration cases, the final maybe(list(...member)) is Nothing if the analysis has not been recursed into the members, and Just ... if it has - which will typically be only one level deep *) - -type c_type = - | CT of (c_type_top c_type) - -(* simple die tree *) - -(* this unifies variables and formal parameters, and also subprograms - and inlined_subroutines (but not lexical_blocks). Debatable what's - best *) -(* not including DW_AT_low_pc/DW_AT_high_pc or DW_AT_ranges - might want that*) -(* also not including per-instruction line number info *) - -type variable_or_formal_parameter_kind = - | SVPK_var - | SVPK_param - -type sdt_unspecified_parameter = unit - - - -type sdt_variable_or_formal_parameter = - <| - svfp_cupdie : cupdie; - svfp_name : string; - svfp_kind : variable_or_formal_parameter_kind; - svfp_type : maybe c_type; - svfp_abstract_origin : maybe sdt_variable_or_formal_parameter; (* invariant: non-Nothing iff inlined *) - svfp_const_value : maybe integer; - svfp_external : bool; - svfp_declaration : bool; - svfp_locations : maybe (list (sym_natural * sym_natural * list operation (*the parsed single_location_description*))); - svfp_decl : maybe unpacked_decl; -|> - -type sdt_subroutine_kind = - | SSK_subprogram - | SSK_inlined_subroutine - -type sdt_subroutine = (* subprogram or inlined subroutine *) - <| - ss_cupdie : cupdie; - ss_name : maybe string; - ss_kind : sdt_subroutine_kind; - ss_call_site : maybe unpacked_decl; - ss_abstract_origin : maybe sdt_subroutine; (* invariant: non-Nothing iff inlined *) - ss_type : maybe c_type; - ss_vars : list sdt_variable_or_formal_parameter; - ss_pc_ranges : maybe (list (sym_natural*sym_natural)); - ss_entry_address : maybe sym_natural; - ss_unspecified_parameters : list sdt_unspecified_parameter; - ss_subroutines : list sdt_subroutine; (* invariant: all inlined*) - ss_lexical_blocks : list sdt_lexical_block; - ss_decl : maybe unpacked_decl; - ss_noreturn : bool; - ss_external : bool; - |> - -and sdt_lexical_block = - <| - slb_cupdie : cupdie; - slb_vars : list sdt_variable_or_formal_parameter; (* invariant: all variables *) - slb_pc_ranges : maybe (list (sym_natural*sym_natural)); - slb_subroutines : list sdt_subroutine; (* invariant: all inlined*) - slb_lexical_blocks : list sdt_lexical_block; - |> - -type sdt_compilation_unit = - <| - scu_cupdie : cupdie; - scu_name : string; - scu_subroutines : list sdt_subroutine; (* invariant: none inlined(?) *) - scu_vars : list sdt_variable_or_formal_parameter; - scu_pc_ranges : maybe (list (sym_natural*sym_natural)); - |> - -type sdt_dwarf = - <| sd_compilation_units : list sdt_compilation_unit; - |> - - -(* inlined subroutine data *) - -type inlined_subroutine_const_param = - <| - iscp_abstract_origin: compilation_unit * (list die) * die; - iscp_value: integer; - |> - -type inlined_subroutine = - <| - is_inlined_subroutine: compilation_unit * (list die) * die; - is_abstract_origin: compilation_unit * (list die) * die; - is_inlined_subroutine_sdt: sdt_subroutine; - is_inlined_subroutine_sdt_parents: list sdt_subroutine; - is_name : string; - is_call_file: unpacked_file_entry; - is_call_line: sym_natural; - is_pc_ranges: list (sym_natural * sym_natural); - is_const_params : list inlined_subroutine_const_param; - |> - (* ignoring the nesting structure of inlined subroutines for now *) - -type inlined_subroutine_data = list inlined_subroutine - -type inlined_subroutine_data_by_range_entry = (sym_natural*sym_natural)(*range*) * (sym_natural*sym_natural) (*range m-of-n*) * inlined_subroutine - -type inlined_subroutine_data_by_range = list inlined_subroutine_data_by_range_entry - -(*type inlined_subroutine_data_at_pc = list ((compilation_unit * (list die) * die) * (natural * natural * single_location_description * error single_location))*) - - - - - - -(** ************************************************************ *) -(** ** missing pervasives ************************************ *) -(** ************************************************************ *) - -(* natural version of List.index *) -val index_natural : forall 'a. list 'a -> sym_natural -> maybe 'a -let rec index_natural l n= match l with - | [] -> Nothing - | x :: xs -> if n = 0 then Just x else index_natural xs (n-1) -end - -let partialNaturalFromInteger (i:integer) : sym_natural= - if i<0 then Assert_extra.failwith "partialNaturalFromInteger" else Absolute(naturalFromInteger i) - -val natural_nat_shift_left : natural -> nat -> natural -declare ocaml target_rep function natural_nat_shift_left = `Nat_big_num.shift_left` - -let sym_natural_nat_shift_left x y = sym_map (fun x -> natural_nat_shift_left x y) x - -val natural_nat_shift_right : natural -> nat -> natural -declare ocaml target_rep function natural_nat_shift_right = `Nat_big_num.shift_right` - -let sym_natural_nat_shift_right x y = sym_map (fun x -> natural_nat_shift_right x y) x - -(** ************************************************************ *) -(** ** endianness *************************************** *) -(** ************************************************************ *) - -let p_context_of_d (d:dwarf) : p_context= <| endianness = d.d_endianness |> - - - -(** ************************************************************ *) -(** ** dwarf encodings *************************************** *) -(** ************************************************************ *) - -(* these encoding tables are pasted from the DWARF 4 specification *) - -(* tag encoding *) -let tag_encodings= [ - ("DW_TAG_array_type" , natural_of_hex "0x01" ); - ("DW_TAG_class_type" , natural_of_hex "0x02" ); - ("DW_TAG_entry_point" , natural_of_hex "0x03" ); - ("DW_TAG_enumeration_type" , natural_of_hex "0x04" ); - ("DW_TAG_formal_parameter" , natural_of_hex "0x05" ); - ("DW_TAG_imported_declaration" , natural_of_hex "0x08" ); - ("DW_TAG_label" , natural_of_hex "0x0a" ); - ("DW_TAG_lexical_block" , natural_of_hex "0x0b" ); - ("DW_TAG_member" , natural_of_hex "0x0d" ); - ("DW_TAG_pointer_type" , natural_of_hex "0x0f" ); - ("DW_TAG_reference_type" , natural_of_hex "0x10" ); - ("DW_TAG_compile_unit" , natural_of_hex "0x11" ); - ("DW_TAG_string_type" , natural_of_hex "0x12" ); - ("DW_TAG_structure_type" , natural_of_hex "0x13" ); - ("DW_TAG_subroutine_type" , natural_of_hex "0x15" ); - ("DW_TAG_typedef" , natural_of_hex "0x16" ); - ("DW_TAG_union_type" , natural_of_hex "0x17" ); - ("DW_TAG_unspecified_parameters" , natural_of_hex "0x18" ); - ("DW_TAG_variant" , natural_of_hex "0x19" ); - ("DW_TAG_common_block" , natural_of_hex "0x1a" ); - ("DW_TAG_common_inclusion" , natural_of_hex "0x1b" ); - ("DW_TAG_inheritance" , natural_of_hex "0x1c" ); - ("DW_TAG_inlined_subroutine" , natural_of_hex "0x1d" ); - ("DW_TAG_module" , natural_of_hex "0x1e" ); - ("DW_TAG_ptr_to_member_type" , natural_of_hex "0x1f" ); - ("DW_TAG_set_type" , natural_of_hex "0x20" ); - ("DW_TAG_subrange_type" , natural_of_hex "0x21" ); - ("DW_TAG_with_stmt" , natural_of_hex "0x22" ); - ("DW_TAG_access_declaration" , natural_of_hex "0x23" ); - ("DW_TAG_base_type" , natural_of_hex "0x24" ); - ("DW_TAG_catch_block" , natural_of_hex "0x25" ); - ("DW_TAG_const_type" , natural_of_hex "0x26" ); - ("DW_TAG_constant" , natural_of_hex "0x27" ); - ("DW_TAG_enumerator" , natural_of_hex "0x28" ); - ("DW_TAG_file_type" , natural_of_hex "0x29" ); - ("DW_TAG_friend" , natural_of_hex "0x2a" ); - ("DW_TAG_namelist" , natural_of_hex "0x2b" ); - ("DW_TAG_namelist_item" , natural_of_hex "0x2c" ); - ("DW_TAG_packed_type" , natural_of_hex "0x2d" ); - ("DW_TAG_subprogram" , natural_of_hex "0x2e" ); - ("DW_TAG_template_type_parameter" , natural_of_hex "0x2f" ); - ("DW_TAG_template_value_parameter" , natural_of_hex "0x30" ); - ("DW_TAG_thrown_type" , natural_of_hex "0x31" ); - ("DW_TAG_try_block" , natural_of_hex "0x32" ); - ("DW_TAG_variant_part" , natural_of_hex "0x33" ); - ("DW_TAG_variable" , natural_of_hex "0x34" ); - ("DW_TAG_volatile_type" , natural_of_hex "0x35" ); - ("DW_TAG_dwarf_procedure" , natural_of_hex "0x36" ); - ("DW_TAG_restrict_type" , natural_of_hex "0x37" ); - ("DW_TAG_interface_type" , natural_of_hex "0x38" ); - ("DW_TAG_namespace" , natural_of_hex "0x39" ); - ("DW_TAG_imported_module" , natural_of_hex "0x3a" ); - ("DW_TAG_unspecified_type" , natural_of_hex "0x3b" ); - ("DW_TAG_partial_unit" , natural_of_hex "0x3c" ); - ("DW_TAG_imported_unit" , natural_of_hex "0x3d" ); - ("DW_TAG_condition" , natural_of_hex "0x3f" ); - ("DW_TAG_shared_type" , natural_of_hex "0x40" ); - ("DW_TAG_type_unit" , natural_of_hex "0x41" ); - ("DW_TAG_rvalue_reference_type" , natural_of_hex "0x42" ); - ("DW_TAG_template_alias" , natural_of_hex "0x43" ); - ("DW_TAG_lo_user" , natural_of_hex "0x4080"); - ("DW_TAG_hi_user" , natural_of_hex "0xffff") -] - - -(* child determination encoding *) - -let vDW_CHILDREN_no= natural_of_hex "0x00" -let vDW_CHILDREN_yes= natural_of_hex "0x01" - - -(* attribute encoding *) - -let attribute_encodings= [ - ("DW_AT_sibling" , natural_of_hex "0x01", [DWA_reference]) ; - ("DW_AT_location" , natural_of_hex "0x02", [DWA_exprloc; DWA_loclistptr]) ; - ("DW_AT_name" , natural_of_hex "0x03", [DWA_string]) ; - ("DW_AT_ordering" , natural_of_hex "0x09", [DWA_constant]) ; - ("DW_AT_byte_size" , natural_of_hex "0x0b", [DWA_constant; DWA_exprloc; DWA_reference]) ; - ("DW_AT_bit_offset" , natural_of_hex "0x0c", [DWA_constant; DWA_exprloc; DWA_reference]) ; - ("DW_AT_bit_size" , natural_of_hex "0x0d", [DWA_constant; DWA_exprloc; DWA_reference]) ; - ("DW_AT_stmt_list" , natural_of_hex "0x10", [DWA_lineptr]) ; - ("DW_AT_low_pc" , natural_of_hex "0x11", [DWA_address]) ; - ("DW_AT_high_pc" , natural_of_hex "0x12", [DWA_address; DWA_constant]) ; - ("DW_AT_language" , natural_of_hex "0x13", [DWA_constant]) ; - ("DW_AT_discr" , natural_of_hex "0x15", [DWA_reference]) ; - ("DW_AT_discr_value" , natural_of_hex "0x16", [DWA_constant]) ; - ("DW_AT_visibility" , natural_of_hex "0x17", [DWA_constant]) ; - ("DW_AT_import" , natural_of_hex "0x18", [DWA_reference]) ; - ("DW_AT_string_length" , natural_of_hex "0x19", [DWA_exprloc; DWA_loclistptr]) ; - ("DW_AT_common_reference" , natural_of_hex "0x1a", [DWA_reference]) ; - ("DW_AT_comp_dir" , natural_of_hex "0x1b", [DWA_string]) ; - ("DW_AT_const_value" , natural_of_hex "0x1c", [DWA_block; DWA_constant; DWA_string]) ; - ("DW_AT_containing_type" , natural_of_hex "0x1d", [DWA_reference]) ; - ("DW_AT_default_value" , natural_of_hex "0x1e", [DWA_reference]) ; - ("DW_AT_inline" , natural_of_hex "0x20", [DWA_constant]) ; - ("DW_AT_is_optional" , natural_of_hex "0x21", [DWA_flag]) ; - ("DW_AT_lower_bound" , natural_of_hex "0x22", [DWA_constant; DWA_exprloc; DWA_reference]) ; - ("DW_AT_producer" , natural_of_hex "0x25", [DWA_string]) ; - ("DW_AT_prototyped" , natural_of_hex "0x27", [DWA_flag]) ; - ("DW_AT_return_addr" , natural_of_hex "0x2a", [DWA_exprloc; DWA_loclistptr]) ; - ("DW_AT_start_scope" , natural_of_hex "0x2c", [DWA_constant; DWA_rangelistptr]) ; - ("DW_AT_bit_stride" , natural_of_hex "0x2e", [DWA_constant; DWA_exprloc; DWA_reference]) ; - ("DW_AT_upper_bound" , natural_of_hex "0x2f", [DWA_constant; DWA_exprloc; DWA_reference]) ; - ("DW_AT_abstract_origin" , natural_of_hex "0x31", [DWA_reference]) ; - ("DW_AT_accessibility" , natural_of_hex "0x32", [DWA_constant]) ; - ("DW_AT_address_class" , natural_of_hex "0x33", [DWA_constant]) ; - ("DW_AT_artificial" , natural_of_hex "0x34", [DWA_flag]) ; - ("DW_AT_base_types" , natural_of_hex "0x35", [DWA_reference]) ; - ("DW_AT_calling_convention" , natural_of_hex "0x36", [DWA_constant]) ; - ("DW_AT_count" , natural_of_hex "0x37", [DWA_constant; DWA_exprloc; DWA_reference]) ; - ("DW_AT_data_member_location" , natural_of_hex "0x38", [DWA_constant; DWA_exprloc; DWA_loclistptr]) ; - ("DW_AT_decl_column" , natural_of_hex "0x39", [DWA_constant]) ; - ("DW_AT_decl_file" , natural_of_hex "0x3a", [DWA_constant]) ; - ("DW_AT_decl_line" , natural_of_hex "0x3b", [DWA_constant]) ; - ("DW_AT_declaration" , natural_of_hex "0x3c", [DWA_flag]) ; - ("DW_AT_discr_list" , natural_of_hex "0x3d", [DWA_block]) ; - ("DW_AT_encoding" , natural_of_hex "0x3e", [DWA_constant]) ; - ("DW_AT_external" , natural_of_hex "0x3f", [DWA_flag]) ; - ("DW_AT_frame_base" , natural_of_hex "0x40", [DWA_exprloc; DWA_loclistptr]) ; - ("DW_AT_friend" , natural_of_hex "0x41", [DWA_reference]) ; - ("DW_AT_identifier_case" , natural_of_hex "0x42", [DWA_constant]) ; - ("DW_AT_macro_info" , natural_of_hex "0x43", [DWA_macptr]) ; - ("DW_AT_namelist_item" , natural_of_hex "0x44", [DWA_reference]) ; - ("DW_AT_priority" , natural_of_hex "0x45", [DWA_reference]) ; - ("DW_AT_segment" , natural_of_hex "0x46", [DWA_exprloc; DWA_loclistptr]) ; - ("DW_AT_specification" , natural_of_hex "0x47", [DWA_reference]) ; - ("DW_AT_static_link" , natural_of_hex "0x48", [DWA_exprloc; DWA_loclistptr]) ; - ("DW_AT_type" , natural_of_hex "0x49", [DWA_reference]) ; - ("DW_AT_use_location" , natural_of_hex "0x4a", [DWA_exprloc; DWA_loclistptr]) ; - ("DW_AT_variable_parameter" , natural_of_hex "0x4b", [DWA_flag]) ; - ("DW_AT_virtuality" , natural_of_hex "0x4c", [DWA_constant]) ; - ("DW_AT_vtable_elem_location" , natural_of_hex "0x4d", [DWA_exprloc; DWA_loclistptr]) ; - ("DW_AT_allocated" , natural_of_hex "0x4e", [DWA_constant; DWA_exprloc; DWA_reference]) ; - ("DW_AT_associated" , natural_of_hex "0x4f", [DWA_constant; DWA_exprloc; DWA_reference]) ; - ("DW_AT_data_location" , natural_of_hex "0x50", [DWA_exprloc]) ; - ("DW_AT_byte_stride" , natural_of_hex "0x51", [DWA_constant; DWA_exprloc; DWA_reference]) ; - ("DW_AT_entry_pc" , natural_of_hex "0x52", [DWA_address]) ; - ("DW_AT_use_UTF8" , natural_of_hex "0x53", [DWA_flag]) ; - ("DW_AT_extension" , natural_of_hex "0x54", [DWA_reference]) ; - ("DW_AT_ranges" , natural_of_hex "0x55", [DWA_rangelistptr]) ; - ("DW_AT_trampoline" , natural_of_hex "0x56", [DWA_address; DWA_flag; DWA_reference; DWA_string]); - ("DW_AT_call_column" , natural_of_hex "0x57", [DWA_constant]) ; - ("DW_AT_call_file" , natural_of_hex "0x58", [DWA_constant]) ; - ("DW_AT_call_line" , natural_of_hex "0x59", [DWA_constant]) ; - ("DW_AT_description" , natural_of_hex "0x5a", [DWA_string]) ; - ("DW_AT_binary_scale" , natural_of_hex "0x5b", [DWA_constant]) ; - ("DW_AT_decimal_scale" , natural_of_hex "0x5c", [DWA_constant]) ; - ("DW_AT_small" , natural_of_hex "0x5d", [DWA_reference]) ; - ("DW_AT_decimal_sign" , natural_of_hex "0x5e", [DWA_constant]) ; - ("DW_AT_digit_count" , natural_of_hex "0x5f", [DWA_constant]) ; - ("DW_AT_picture_string" , natural_of_hex "0x60", [DWA_string]) ; - ("DW_AT_mutable" , natural_of_hex "0x61", [DWA_flag]) ; - ("DW_AT_threads_scaled" , natural_of_hex "0x62", [DWA_flag]) ; - ("DW_AT_explicit" , natural_of_hex "0x63", [DWA_flag]) ; - ("DW_AT_object_pointer" , natural_of_hex "0x64", [DWA_reference]) ; - ("DW_AT_endianity" , natural_of_hex "0x65", [DWA_constant]) ; - ("DW_AT_elemental" , natural_of_hex "0x66", [DWA_flag]) ; - ("DW_AT_pure" , natural_of_hex "0x67", [DWA_flag]) ; - ("DW_AT_recursive" , natural_of_hex "0x68", [DWA_flag]) ; - ("DW_AT_signature" , natural_of_hex "0x69", [DWA_reference]) ; - ("DW_AT_main_subprogram" , natural_of_hex "0x6a", [DWA_flag]) ; - ("DW_AT_data_bit_offset" , natural_of_hex "0x6b", [DWA_constant]) ; - ("DW_AT_const_expr" , natural_of_hex "0x6c", [DWA_flag]) ; - ("DW_AT_enum_class" , natural_of_hex "0x6d", [DWA_flag]) ; - ("DW_AT_linkage_name" , natural_of_hex "0x6e", [DWA_string]) ; -(* DW_AT_noreturn is a gcc extension to support the C11 _Noreturn keyword*) - ("DW_AT_noreturn" , natural_of_hex "0x87", [DWA_flag]) ; - ("DW_AT_alignment" , natural_of_hex "0x88", [DWA_constant]) ; - ("DW_AT_lo_user" , natural_of_hex "0x2000", [DWA_dash]) ; - ("DW_AT_hi_user" , natural_of_hex "0x3fff", [DWA_dash]) -] - - -(* attribute form encoding *) - -let attribute_form_encodings= [ - ("DW_FORM_addr" , natural_of_hex "0x01", [DWA_address]) ; - ("DW_FORM_block2" , natural_of_hex "0x03", [DWA_block]) ; - ("DW_FORM_block4" , natural_of_hex "0x04", [DWA_block]) ; - ("DW_FORM_data2" , natural_of_hex "0x05", [DWA_constant]) ; - ("DW_FORM_data4" , natural_of_hex "0x06", [DWA_constant]) ; - ("DW_FORM_data8" , natural_of_hex "0x07", [DWA_constant]) ; - ("DW_FORM_string" , natural_of_hex "0x08", [DWA_string]) ; - ("DW_FORM_block" , natural_of_hex "0x09", [DWA_block]) ; - ("DW_FORM_block1" , natural_of_hex "0x0a", [DWA_block]) ; - ("DW_FORM_data1" , natural_of_hex "0x0b", [DWA_constant]) ; - ("DW_FORM_flag" , natural_of_hex "0x0c", [DWA_flag]) ; - ("DW_FORM_sdata" , natural_of_hex "0x0d", [DWA_constant]) ; - ("DW_FORM_strp" , natural_of_hex "0x0e", [DWA_string]) ; - ("DW_FORM_udata" , natural_of_hex "0x0f", [DWA_constant]) ; - ("DW_FORM_ref_addr" , natural_of_hex "0x10", [DWA_reference]); - ("DW_FORM_ref1" , natural_of_hex "0x11", [DWA_reference]); - ("DW_FORM_ref2" , natural_of_hex "0x12", [DWA_reference]); - ("DW_FORM_ref4" , natural_of_hex "0x13", [DWA_reference]); - ("DW_FORM_ref8" , natural_of_hex "0x14", [DWA_reference]); - ("DW_FORM_ref_udata" , natural_of_hex "0x15", [DWA_reference]); - ("DW_FORM_indirect" , natural_of_hex "0x16", [DWA_7_5_3]) ; - ("DW_FORM_sec_offset" , natural_of_hex "0x17", [DWA_lineptr; DWA_loclistptr; DWA_macptr; DWA_rangelistptr]) ; - ("DW_FORM_exprloc" , natural_of_hex "0x18", [DWA_exprloc]) ; - ("DW_FORM_flag_present", natural_of_hex "0x19", [DWA_flag]) ; - ("DW_FORM_ref_sig8" , natural_of_hex "0x20", [DWA_reference]) -] - - -(* operation encoding *) - -let operation_encodings= [ -("DW_OP_addr", natural_of_hex "0x03", [OAT_addr] , OpSem_lit); (*1*) (*constant address (size target specific)*) -("DW_OP_deref", natural_of_hex "0x06", [] , OpSem_deref); (*0*) -("DW_OP_const1u", natural_of_hex "0x08", [OAT_uint8] , OpSem_lit); (*1*) (* 1-byte constant *) -("DW_OP_const1s", natural_of_hex "0x09", [OAT_sint8] , OpSem_lit); (*1*) (* 1-byte constant *) -("DW_OP_const2u", natural_of_hex "0x0a", [OAT_uint16] , OpSem_lit); (*1*) (* 2-byte constant *) -("DW_OP_const2s", natural_of_hex "0x0b", [OAT_sint16] , OpSem_lit); (*1*) (* 2-byte constant *) -("DW_OP_const4u", natural_of_hex "0x0c", [OAT_uint32] , OpSem_lit); (*1*) (* 4-byte constant *) -("DW_OP_const4s", natural_of_hex "0x0d", [OAT_sint32] , OpSem_lit); (*1*) (* 4-byte constant *) -("DW_OP_const8u", natural_of_hex "0x0e", [OAT_uint64] , OpSem_lit); (*1*) (* 8-byte constant *) -("DW_OP_const8s", natural_of_hex "0x0f", [OAT_sint64] , OpSem_lit); (*1*) (* 8-byte constant *) -("DW_OP_constu", natural_of_hex "0x10", [OAT_ULEB128] , OpSem_lit); (*1*) (* ULEB128 constant *) -("DW_OP_consts", natural_of_hex "0x11", [OAT_SLEB128] , OpSem_lit); (*1*) (* SLEB128 constant *) -("DW_OP_dup", natural_of_hex "0x12", [] , OpSem_stack (fun ac vs args -> match vs with v::vs -> Just (v::v::vs) | _ -> Nothing end)); (*0*) -("DW_OP_drop", natural_of_hex "0x13", [] , OpSem_stack (fun ac vs args -> match vs with v::vs -> Just vs | _ -> Nothing end)); (*0*) -("DW_OP_over", natural_of_hex "0x14", [] , OpSem_stack (fun ac vs args -> match vs with v::v'::vs -> Just (v'::v::v'::vs) | _ -> Nothing end)); (*0*) -("DW_OP_pick", natural_of_hex "0x15", [OAT_uint8] , OpSem_stack (fun ac vs args -> match args with [OAV_natural n] -> match index_natural vs n with Just v -> Just (v::vs) | Nothing -> Nothing end | _ -> Nothing end)); (*1*) (* 1-byte stack index *) -("DW_OP_swap", natural_of_hex "0x16", [] , OpSem_stack (fun ac vs args -> match vs with v::v'::vs -> Just (v'::v::vs) | _ -> Nothing end)); (*0*) -("DW_OP_rot", natural_of_hex "0x17", [] , OpSem_stack (fun ac vs args -> match vs with v::v'::v''::vs -> Just (v'::v''::v::vs) | _ -> Nothing end)); (*0*) -("DW_OP_xderef", natural_of_hex "0x18", [] , OpSem_not_supported); (*0*) -("DW_OP_abs", natural_of_hex "0x19", [] , OpSem_unary (fun ac v -> if v < ac.ac_half then Just v else if v=ac.ac_max then Nothing else Just (ac.ac_all-v))); (*0*) -("DW_OP_and", natural_of_hex "0x1a", [] , OpSem_binary (fun ac v1 v2 -> Just (sym_natural_land v1 v2))); (*0*) -("DW_OP_div", natural_of_hex "0x1b", [] , OpSem_not_supported) (*TODO*); (*0*) -("DW_OP_minus", natural_of_hex "0x1c", [] , OpSem_binary (fun ac v1 v2 -> Just (partialNaturalFromInteger ((integerFromSymNatural v1 - integerFromSymNatural v2) mod (integerFromSymNatural ac.ac_all))))); (*0*) -("DW_OP_mod", natural_of_hex "0x1d", [] , OpSem_binary (fun ac v1 v2 -> Just (v1 mod v2))); (*0*) -("DW_OP_mul", natural_of_hex "0x1e", [] , OpSem_binary (fun ac v1 v2 -> Just (partialNaturalFromInteger ((integerFromSymNatural v1 * integerFromSymNatural v2) mod (integerFromSymNatural ac.ac_all))))); (*0*) -("DW_OP_neg", natural_of_hex "0x1f", [] , OpSem_unary (fun ac v -> if v < ac.ac_half then Just (ac.ac_max - v) else if v=ac.ac_half then Nothing else Just (ac.ac_all - v))); (*0*) -("DW_OP_not", natural_of_hex "0x20", [] , OpSem_unary (fun ac v -> Just (sym_natural_lxor v ac.ac_max))); (*0*) -("DW_OP_or", natural_of_hex "0x21", [] , OpSem_binary (fun ac v1 v2 -> Just (sym_natural_lor v1 v2))); (*0*) -("DW_OP_plus", natural_of_hex "0x22", [] , OpSem_binary (fun ac v1 v2 -> Just ((v1 + v2) mod ac.ac_all))); (*0*) -("DW_OP_plus_uconst", natural_of_hex "0x23", [OAT_ULEB128] , OpSem_stack (fun ac vs args -> match args with [OAV_natural n] -> match vs with v::vs' -> let v' = (v+n) mod ac.ac_all in Just (v'::vs) | [] -> Nothing end | _ -> Nothing end)); (*1*) (* ULEB128 addend *) -("DW_OP_shl", natural_of_hex "0x24", [] , OpSem_binary (fun ac v1 v2 -> if v2 >= ac.ac_bitwidth then Just 0 else Just (sym_natural_nat_shift_left v1 (natFromSymNatural v2)))); (*0*) -("DW_OP_shr", natural_of_hex "0x25", [] , OpSem_binary (fun ac v1 v2 -> if v2 >= ac.ac_bitwidth then Just 0 else Just (sym_natural_nat_shift_right v1 (natFromSymNatural v2)))); (*0*) -("DW_OP_shra", natural_of_hex "0x26", [] , OpSem_binary (fun ac v1 v2 -> if v1 < ac.ac_half then (if v2 >= ac.ac_bitwidth then Just 0 else Just (sym_natural_nat_shift_right v1 (natFromSymNatural v2))) else (if v2 >= ac.ac_bitwidth then Just ac.ac_max else Just (ac.ac_max - (sym_natural_nat_shift_right (ac.ac_max - v1) (natFromSymNatural v2)))))); (*0*) -("DW_OP_xor", natural_of_hex "0x27", [] , OpSem_binary (fun ac v1 v2 -> Just (sym_natural_lxor v1 v2))); (*0*) -("DW_OP_skip", natural_of_hex "0x2f", [OAT_sint16] , OpSem_not_supported); (*1*) (* signed 2-byte constant *) -("DW_OP_bra", natural_of_hex "0x28", [OAT_sint16] , OpSem_not_supported); (*1*) (* signed 2-byte constant *) -("DW_OP_eq", natural_of_hex "0x29", [] , OpSem_not_supported); (*0*) -("DW_OP_ge", natural_of_hex "0x2a", [] , OpSem_not_supported); (*0*) -("DW_OP_gt", natural_of_hex "0x2b", [] , OpSem_not_supported); (*0*) -("DW_OP_le", natural_of_hex "0x2c", [] , OpSem_not_supported); (*0*) -("DW_OP_lt", natural_of_hex "0x2d", [] , OpSem_not_supported); (*0*) -("DW_OP_ne", natural_of_hex "0x2e", [] , OpSem_not_supported); (*0*) -("DW_OP_lit0", natural_of_hex "0x30", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) (* literals 0..31 =(DW_OP_lit0 + literal) *) -("DW_OP_lit1", natural_of_hex "0x31", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit2", natural_of_hex "0x32", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit3", natural_of_hex "0x33", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit4", natural_of_hex "0x34", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit5", natural_of_hex "0x35", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit6", natural_of_hex "0x36", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit7", natural_of_hex "0x37", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit8", natural_of_hex "0x38", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit9", natural_of_hex "0x39", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit10", natural_of_hex "0x3a", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit11", natural_of_hex "0x3b", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit12", natural_of_hex "0x3c", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit13", natural_of_hex "0x3d", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit14", natural_of_hex "0x3e", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit15", natural_of_hex "0x3f", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit16", natural_of_hex "0x40", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit17", natural_of_hex "0x41", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit18", natural_of_hex "0x42", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit19", natural_of_hex "0x43", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit20", natural_of_hex "0x44", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit21", natural_of_hex "0x45", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit22", natural_of_hex "0x46", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit23", natural_of_hex "0x47", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit24", natural_of_hex "0x48", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit25", natural_of_hex "0x49", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit26", natural_of_hex "0x4a", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit27", natural_of_hex "0x4b", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit28", natural_of_hex "0x4c", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit29", natural_of_hex "0x4d", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit30", natural_of_hex "0x4e", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit31", natural_of_hex "0x4f", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_reg0", natural_of_hex "0x50", [] , OpSem_reg); (*1*) (* reg 0..31 = (DW_OP_reg0 + regnum) *) -("DW_OP_reg1", natural_of_hex "0x51", [] , OpSem_reg); (*1*) -("DW_OP_reg2", natural_of_hex "0x52", [] , OpSem_reg); (*1*) -("DW_OP_reg3", natural_of_hex "0x53", [] , OpSem_reg); (*1*) -("DW_OP_reg4", natural_of_hex "0x54", [] , OpSem_reg); (*1*) -("DW_OP_reg5", natural_of_hex "0x55", [] , OpSem_reg); (*1*) -("DW_OP_reg6", natural_of_hex "0x56", [] , OpSem_reg); (*1*) -("DW_OP_reg7", natural_of_hex "0x57", [] , OpSem_reg); (*1*) -("DW_OP_reg8", natural_of_hex "0x58", [] , OpSem_reg); (*1*) -("DW_OP_reg9", natural_of_hex "0x59", [] , OpSem_reg); (*1*) -("DW_OP_reg10", natural_of_hex "0x5a", [] , OpSem_reg); (*1*) -("DW_OP_reg11", natural_of_hex "0x5b", [] , OpSem_reg); (*1*) -("DW_OP_reg12", natural_of_hex "0x5c", [] , OpSem_reg); (*1*) -("DW_OP_reg13", natural_of_hex "0x5d", [] , OpSem_reg); (*1*) -("DW_OP_reg14", natural_of_hex "0x5e", [] , OpSem_reg); (*1*) -("DW_OP_reg15", natural_of_hex "0x5f", [] , OpSem_reg); (*1*) -("DW_OP_reg16", natural_of_hex "0x60", [] , OpSem_reg); (*1*) -("DW_OP_reg17", natural_of_hex "0x61", [] , OpSem_reg); (*1*) -("DW_OP_reg18", natural_of_hex "0x62", [] , OpSem_reg); (*1*) -("DW_OP_reg19", natural_of_hex "0x63", [] , OpSem_reg); (*1*) -("DW_OP_reg20", natural_of_hex "0x64", [] , OpSem_reg); (*1*) -("DW_OP_reg21", natural_of_hex "0x65", [] , OpSem_reg); (*1*) -("DW_OP_reg22", natural_of_hex "0x66", [] , OpSem_reg); (*1*) -("DW_OP_reg23", natural_of_hex "0x67", [] , OpSem_reg); (*1*) -("DW_OP_reg24", natural_of_hex "0x68", [] , OpSem_reg); (*1*) -("DW_OP_reg25", natural_of_hex "0x69", [] , OpSem_reg); (*1*) -("DW_OP_reg26", natural_of_hex "0x6a", [] , OpSem_reg); (*1*) -("DW_OP_reg27", natural_of_hex "0x6b", [] , OpSem_reg); (*1*) -("DW_OP_reg28", natural_of_hex "0x6c", [] , OpSem_reg); (*1*) -("DW_OP_reg29", natural_of_hex "0x6d", [] , OpSem_reg); (*1*) -("DW_OP_reg30", natural_of_hex "0x6e", [] , OpSem_reg); (*1*) -("DW_OP_reg31", natural_of_hex "0x6f", [] , OpSem_reg); (*1*) -("DW_OP_breg0", natural_of_hex "0x70", [OAT_SLEB128] , OpSem_breg); (*1*) (* base register 0..31 = (DW_OP_breg0 + regnum) *) -("DW_OP_breg1", natural_of_hex "0x71", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg2", natural_of_hex "0x72", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg3", natural_of_hex "0x73", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg4", natural_of_hex "0x74", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg5", natural_of_hex "0x75", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg6", natural_of_hex "0x76", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg7", natural_of_hex "0x77", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg8", natural_of_hex "0x78", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg9", natural_of_hex "0x79", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg10", natural_of_hex "0x7a", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg11", natural_of_hex "0x7b", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg12", natural_of_hex "0x7c", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg13", natural_of_hex "0x7d", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg14", natural_of_hex "0x7e", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg15", natural_of_hex "0x7f", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg16", natural_of_hex "0x80", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg17", natural_of_hex "0x81", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg18", natural_of_hex "0x82", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg19", natural_of_hex "0x83", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg20", natural_of_hex "0x84", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg21", natural_of_hex "0x85", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg22", natural_of_hex "0x86", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg23", natural_of_hex "0x87", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg24", natural_of_hex "0x88", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg25", natural_of_hex "0x89", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg26", natural_of_hex "0x8a", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg27", natural_of_hex "0x8b", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg28", natural_of_hex "0x8c", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg29", natural_of_hex "0x8d", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg30", natural_of_hex "0x8e", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg31", natural_of_hex "0x8f", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_regx", natural_of_hex "0x90", [OAT_ULEB128] , OpSem_lit); (*1*) (* ULEB128 register *) -("DW_OP_fbreg", natural_of_hex "0x91", [OAT_SLEB128] , OpSem_fbreg); (*1*) (* SLEB128 offset *) -("DW_OP_bregx", natural_of_hex "0x92", [OAT_ULEB128; OAT_SLEB128] , OpSem_bregx); (*2*) (* ULEB128 register followed by SLEB128 offset *) -("DW_OP_piece", natural_of_hex "0x93", [OAT_ULEB128] , OpSem_piece); (*1*) (* ULEB128 size of piece addressed *) -("DW_OP_deref_size", natural_of_hex "0x94", [OAT_uint8] , OpSem_deref_size); (*1*) (* 1-byte size of data retrieved *) -("DW_OP_xderef_size", natural_of_hex "0x95", [OAT_uint8] , OpSem_not_supported); (*1*) (* 1-byte size of data retrieved *) -("DW_OP_nop", natural_of_hex "0x96", [] , OpSem_nop); (*0*) -("DW_OP_push_object_address", natural_of_hex "0x97", [] , OpSem_not_supported); (*0*) -("DW_OP_call2", natural_of_hex "0x98", [OAT_uint16] , OpSem_not_supported); (*1*) (* 2-byte offset of DIE *) -("DW_OP_call4", natural_of_hex "0x99", [OAT_uint32] , OpSem_not_supported); (*1*) (* 4-byte offset of DIE *) -("DW_OP_call_ref", natural_of_hex "0x9a", [OAT_dwarf_format_t] , OpSem_not_supported); (*1*) (* 4- or 8-byte offset of DIE *) -("DW_OP_form_tls_address", natural_of_hex "0x9b", [] , OpSem_not_supported); (*0*) -("DW_OP_call_frame_cfa", natural_of_hex "0x9c", [] , OpSem_call_frame_cfa); (*0*) -("DW_OP_bit_piece", natural_of_hex "0x9d", [OAT_ULEB128; OAT_ULEB128] , OpSem_bit_piece); (*2*) (* ULEB128 size followed by ULEB128 offset *) -("DW_OP_implicit_value", natural_of_hex "0x9e", [OAT_block] , OpSem_implicit_value); (*2*) (* ULEB128 size followed by block of that size *) -("DW_OP_stack_value", natural_of_hex "0x9f", [] , OpSem_stack_value); (*0*) -(* these aren't real operations -("DW_OP_lo_user", natural_of_hex "0xe0", [] , ); -("DW_OP_hi_user", natural_of_hex "0xff", [] , ); -*) - -(* GCC also produces these for our example: -https://fedorahosted.org/elfutils/wiki/DwarfExtensions -http://dwarfstd.org/ShowIssue.php?issue=100909.1 *) -("DW_GNU_OP_entry_value", natural_of_hex "0xf3", [OAT_block], OpSem_not_supported); (*2*) (* ULEB128 size followed by DWARF expression block of that size*) -("DW_OP_GNU_implicit_pointer", natural_of_hex "0xf2", [OAT_dwarf_format_t;OAT_SLEB128], OpSem_not_supported) - -] - - -let vDW_OP_reg0= natural_of_hex "0x50" -let vDW_OP_breg0= natural_of_hex "0x70" - - -(* call frame instruction encoding *) - -let call_frame_instruction_encoding : list (string * natural * natural * list call_frame_argument_type * ((list call_frame_argument_value) -> maybe call_frame_instruction))= [ -(* high-order 2 bits low-order 6 bits uniformly parsed arguments *) - -(* instructions using low-order 6 bits for first argument *) -(* -("DW_CFA_advance_loc", 1, 0,(*delta *) []); -("DW_CFA_offset", 2, 0,(*register*) [CFAT_offset]); -("DW_CFA_restore", 3, 0,(*register*) []); -*) -(* instructions using low-order 6 bits as part of opcode *) -("DW_CFA_nop", 0, natural_of_hex "0x00", [], (* *) - fun avs -> match avs with [] -> Just (DW_CFA_nop) | _ -> Nothing end); -("DW_CFA_set_loc", 0, natural_of_hex "0x01", [CFAT_address], (* address *) - fun avs -> match avs with [CFAV_address a] -> Just (DW_CFA_set_loc a) | _ -> Nothing end); -("DW_CFA_advance_loc1", 0, natural_of_hex "0x02", [CFAT_delta1], (* 1-byte delta *) - fun avs -> match avs with [CFAV_delta d] -> Just (DW_CFA_advance_loc1 d) | _ -> Nothing end); -("DW_CFA_advance_loc2", 0, natural_of_hex "0x03", [CFAT_delta2], (* 2-byte delta *) - fun avs -> match avs with [CFAV_delta d] -> Just (DW_CFA_advance_loc2 d) | _ -> Nothing end); -("DW_CFA_advance_loc4", 0, natural_of_hex "0x04", [CFAT_delta4], (* 4-byte delta *) - fun avs -> match avs with [CFAV_delta d] -> Just (DW_CFA_advance_loc4 d) | _ -> Nothing end); -("DW_CFA_offset_extended", 0, natural_of_hex "0x05", [CFAT_register; CFAT_offset], (* ULEB128 register ULEB128 offset *) - fun avs -> match avs with [CFAV_register r; CFAV_offset n] -> Just (DW_CFA_offset_extended r n) | _ -> Nothing end); -("DW_CFA_restore_extended", 0, natural_of_hex "0x06", [CFAT_register], (* ULEB128 register *) - fun avs -> match avs with [CFAV_register r] -> Just (DW_CFA_restore_extended r) | _ -> Nothing end); -("DW_CFA_undefined", 0, natural_of_hex "0x07", [CFAT_register], (* ULEB128 register *) - fun avs -> match avs with [CFAV_register r] -> Just (DW_CFA_undefined r) | _ -> Nothing end); -("DW_CFA_same_value", 0, natural_of_hex "0x08", [CFAT_register], (* ULEB128 register *) - fun avs -> match avs with [CFAV_register r] -> Just (DW_CFA_same_value r) | _ -> Nothing end); -("DW_CFA_register", 0, natural_of_hex "0x09", [CFAT_register; CFAT_register], (* ULEB128 register ULEB128 register *) - fun avs -> match avs with [CFAV_register r1; CFAV_register r2] -> Just (DW_CFA_register r1 r2) | _ -> Nothing end); -("DW_CFA_remember_state", 0, natural_of_hex "0x0a", [], (* *) - fun avs -> match avs with [] -> Just (DW_CFA_remember_state) | _ -> Nothing end); -("DW_CFA_restore_state", 0, natural_of_hex "0x0b", [], (* *) - fun avs -> match avs with [] -> Just (DW_CFA_restore_state) | _ -> Nothing end); -("DW_CFA_def_cfa", 0, natural_of_hex "0x0c", [CFAT_register; CFAT_offset], (* ULEB128 register ULEB128 offset *) - fun avs -> match avs with [CFAV_register r; CFAV_offset n] -> Just (DW_CFA_def_cfa r n) | _ -> Nothing end); -("DW_CFA_def_cfa_register", 0, natural_of_hex "0x0d", [CFAT_register], (* ULEB128 register *) - fun avs -> match avs with [CFAV_register r] -> Just (DW_CFA_def_cfa_register r) | _ -> Nothing end); -("DW_CFA_def_cfa_offset", 0, natural_of_hex "0x0e", [CFAT_offset], (* ULEB128 offset *) - fun avs -> match avs with [CFAV_offset n] -> Just (DW_CFA_def_cfa_offset n) | _ -> Nothing end); -("DW_CFA_def_cfa_expression", 0, natural_of_hex "0x0f", [CFAT_block], (* BLOCK *) - fun avs -> match avs with [CFAV_block b] -> Just (DW_CFA_def_cfa_expression b) | _ -> Nothing end); -("DW_CFA_expression", 0, natural_of_hex "0x10", [CFAT_register; CFAT_block], (* ULEB128 register BLOCK *) - fun avs -> match avs with [CFAV_register r; CFAV_block b] -> Just (DW_CFA_expression r b) | _ -> Nothing end); -("DW_CFA_offset_extended_sf", 0, natural_of_hex "0x11", [CFAT_register; CFAT_sfoffset], (* ULEB128 register SLEB128 offset *) - fun avs -> match avs with [CFAV_register r; CFAV_sfoffset i] -> Just (DW_CFA_offset_extended_sf r i) | _ -> Nothing end); -("DW_CFA_def_cfa_sf", 0, natural_of_hex "0x12", [CFAT_register; CFAT_sfoffset], (* ULEB128 register SLEB128 offset *) - fun avs -> match avs with [CFAV_register r; CFAV_sfoffset i] -> Just (DW_CFA_def_cfa_sf r i) | _ -> Nothing end); -("DW_CFA_def_cfa_offset_sf", 0, natural_of_hex "0x13", [CFAT_sfoffset], (* SLEB128 offset *) - fun avs -> match avs with [CFAV_sfoffset i] -> Just (DW_CFA_def_cfa_offset_sf i) | _ -> Nothing end); -("DW_CFA_val_offset", 0, natural_of_hex "0x14", [CFAT_register; CFAT_offset], (* ULEB128 ULEB128 *) - fun avs -> match avs with [CFAV_register r; CFAV_offset n] -> Just (DW_CFA_val_offset r n) | _ -> Nothing end); -("DW_CFA_val_offset_sf", 0, natural_of_hex "0x15", [CFAT_register; CFAT_sfoffset], (* ULEB128 SLEB128 *) - fun avs -> match avs with [CFAV_register r; CFAV_sfoffset i] -> Just (DW_CFA_val_offset_sf r i) | _ -> Nothing end); -("DW_CFA_val_expression", 0, natural_of_hex "0x16", [CFAT_register; CFAT_block], (* ULEB128 BLOCK *) - fun avs -> match avs with [CFAV_register r; CFAV_block b] -> Just (DW_CFA_val_expression r b) | _ -> Nothing end); -("DW_CFA_AARCH64_negate_ra_state", 0, natural_of_hex "0x2d", [], (* *) - fun avs -> match avs with [] -> Just (DW_CFA_AARCH64_negate_ra_state) | _ -> Nothing end); -] -(* -0x2d DW_CFA_GNU_window_save is listed in https://sourceware.org/elfutils/DwarfExtensions as "magic shorthand used only by SPARC" -https://elixir.bootlin.com/linux/v4.0/source/arch/arc/kernel/unwind.c#L842 no-ops it -https://refspecs.linuxbase.org/LSB_3.0.0/LSB-PDA/LSB-PDA/dwarfext.html doesn't mention it -https://github.com/gcc-mirror/gcc/blob/master/libgcc/unwind-dw2.c#L1189 says -"This CFA is multiplexed with Sparc. On AArch64 it's used to toggle return address signing status." -fs->regs.reg[DWARF_REGNUM_AARCH64_RA_STATE].loc.offset ^= 1; -https://developer.arm.com/docs/ihi0057/c/dwarf-for-the-arm-64-bit-architecture-aarch64-abi-2018q4 "DWARF for the Arm® 64-bit Architecture (AArch64) - ABI 2018Q4" -calls this "DW_CFA_AARCH64_negate_ra_state" -"The DW_CFA_AARCH64_negate_ra_state operation negates bit[0] of the RA_SIGN_STATE pseudo-register. It does not take any operands." -p10 says "The RA_SIGN_STATE pseudo-register records whether the return address has been signed with aPAC. This information can be used when unwinding. It is an unsigned integer with the same sizeas a general register. Only bit[0] is meaningful and is initialized to zero. A value of 0 indicates the return address has not been signed. A value of 1 indicates the return address has been signed" -For our purposes it seems fine to nop-this. - *) - (* -("DW_CFA_lo_user", 0, natural_of_hex "0x1c", []); (* *) -("DW_CFA_hi_user", 0, natural_of_hex "0x3f", []); (* *) -*) - - -(* line number encodings *) - -let line_number_standard_encodings= [ - ("DW_LNS_copy" , natural_of_hex "0x01", [ ], - fun lnvs -> match lnvs with [] -> Just DW_LNS_copy | _ -> Nothing end); - ("DW_LNS_advance_pc" , natural_of_hex "0x02", [LNAT_ULEB128 ], - fun lnvs -> match lnvs with [LNAV_ULEB128 n] -> Just (DW_LNS_advance_pc n) | _ -> Nothing end); - ("DW_LNS_advance_line" , natural_of_hex "0x03", [LNAT_SLEB128 ], - fun lnvs -> match lnvs with [LNAV_SLEB128 i] -> Just (DW_LNS_advance_line i) | _ -> Nothing end); - ("DW_LNS_set_file" , natural_of_hex "0x04", [LNAT_ULEB128 ], - fun lnvs -> match lnvs with [LNAV_ULEB128 n] -> Just (DW_LNS_set_file n) | _ -> Nothing end); - ("DW_LNS_set_column" , natural_of_hex "0x05", [LNAT_ULEB128 ], - fun lnvs -> match lnvs with [LNAV_ULEB128 n] -> Just (DW_LNS_set_column n) | _ -> Nothing end); - ("DW_LNS_negate_stmt" , natural_of_hex "0x06", [ ], - fun lnvs -> match lnvs with [] -> Just (DW_LNS_negate_stmt) | _ -> Nothing end); - ("DW_LNS_set_basic_block" , natural_of_hex "0x07", [ ], - fun lnvs -> match lnvs with [] -> Just (DW_LNS_set_basic_block) | _ -> Nothing end); - ("DW_LNS_const_add_pc" , natural_of_hex "0x08", [ ], - fun lnvs -> match lnvs with [] -> Just (DW_LNS_const_add_pc) | _ -> Nothing end); - ("DW_LNS_fixed_advance_pc" , natural_of_hex "0x09", [LNAT_uint16 ], - fun lnvs -> match lnvs with [LNAV_uint16 n] -> Just (DW_LNS_fixed_advance_pc n) | _ -> Nothing end); - ("DW_LNS_set_prologue_end" , natural_of_hex "0x0a", [ ], - fun lnvs -> match lnvs with [] -> Just (DW_LNS_set_prologue_end) | _ -> Nothing end); - ("DW_LNS_set_epilogue_begin" , natural_of_hex "0x0b", [ ], - fun lnvs -> match lnvs with [] -> Just (DW_LNS_set_epilogue_begin) | _ -> Nothing end); - ("DW_LNS_set_isa" , natural_of_hex "0x0c", [LNAT_ULEB128 ], - fun lnvs -> match lnvs with [LNAV_ULEB128 n] -> Just (DW_LNS_set_isa n) | _ -> Nothing end) -] - -let line_number_extended_encodings= [ - ("DW_LNE_end_sequence" , natural_of_hex "0x01", [], - fun lnvs -> match lnvs with [] -> Just (DW_LNE_end_sequence) | _ -> Nothing end); - ("DW_LNE_set_address" , natural_of_hex "0x02", [LNAT_address], - fun lnvs -> match lnvs with [LNAV_address n] -> Just (DW_LNE_set_address n) | _ -> Nothing end); - ("DW_LNE_define_file" , natural_of_hex "0x03", [LNAT_string; LNAT_ULEB128; LNAT_ULEB128; LNAT_ULEB128], - fun lnvs -> match lnvs with [LNAV_string s; LNAV_ULEB128 n1; LNAV_ULEB128 n2; LNAV_ULEB128 n3] -> Just (DW_LNE_define_file s n1 n2 n3) | _ -> Nothing end); - ("DW_LNE_set_discriminator" , natural_of_hex "0x04", [LNAT_ULEB128], - fun lnvs -> match lnvs with [LNAV_ULEB128 n] -> Just (DW_LNE_set_discriminator n) | _ -> Nothing end) (* new in Dwarf 4*) -] - - -(* -(DW_LNE_lo_user , natural_of_hex "0x80", "DW_LNE_lo_user"); -(DW_LNE_hi_user , natural_of_hex "0xff", "DW_LNE_hi_user"); -*) - - - -(* booleans encoded as a single byte containing the value 0 for “false,” and a non-zero value for “true.” *) - -(* base type attribute encoding *) -let base_type_attribute_encodings= [ - ("DW_ATE_address" , natural_of_hex "0x01"); - ("DW_ATE_boolean" , natural_of_hex "0x02"); - ("DW_ATE_complex_float" , natural_of_hex "0x03"); - ("DW_ATE_float" , natural_of_hex "0x04"); - ("DW_ATE_signed" , natural_of_hex "0x05"); - ("DW_ATE_signed_char" , natural_of_hex "0x06"); - ("DW_ATE_unsigned" , natural_of_hex "0x07"); - ("DW_ATE_unsigned_char" , natural_of_hex "0x08"); - ("DW_ATE_imaginary_float" , natural_of_hex "0x09"); - ("DW_ATE_packed_decimal" , natural_of_hex "0x0a"); - ("DW_ATE_numeric_string" , natural_of_hex "0x0b"); - ("DW_ATE_edited" , natural_of_hex "0x0c"); - ("DW_ATE_signed_fixed" , natural_of_hex "0x0d"); - ("DW_ATE_unsigned_fixed" , natural_of_hex "0x0e"); - ("DW_ATE_decimal_float" , natural_of_hex "0x0f"); - ("DW_ATE_UTF" , natural_of_hex "0x10"); - ("DW_ATE_lo_user" , natural_of_hex "0x80"); - ("DW_ATE_signed_capability_hack_a0" , natural_of_hex "0xa0"); - ("DW_ATE_unsigned_capability_hack_a1" , natural_of_hex "0xa1"); - ("DW_ATE_hi_user" , natural_of_hex "0xff") - ] - -(** ************************************************************ *) -(** ** more missing pervasives and bits *********************** *) -(** ************************************************************ *) - - -(* quick hacky workaround: this is in String.lem, in src_lem_library, but the linker doesn't find it *) -val myconcat : string -> list string -> string -let rec myconcat sep ss= - match ss with - | [] -> "" - | s :: ss' -> - match ss' with - | [] -> s - | _ -> s ^ sep ^ myconcat sep ss' - end - end - -val myhead : forall 'a. list 'a -> 'a -let myhead l= match l with | x::xs -> x | [] -> Assert_extra.failwith "myhead of empty list" end - - -val myfindNonPure : forall 'a. ('a -> bool) -> list 'a -> 'a -let myfindNonPure P l= match (List.find P l) with - | Just e -> e - | Nothing -> Assert_extra.failwith "myfindNonPure" -end - -val myfindmaybe : forall 'a 'b. ('a -> maybe 'b) -> list 'a -> maybe 'b -let rec myfindmaybe f xs= - match xs with - | [] -> Nothing - | x::xs' -> match f x with Just y -> Just y | Nothing -> myfindmaybe f xs' end - end - -val myfind : forall 'a. ('a -> bool) -> list 'a -> maybe 'a -let rec myfind f xs= - match xs with - | [] -> Nothing - | x::xs' -> match f x with true -> Just x | false -> myfind f xs' end - end - -val myfiltermaybe : forall 'a 'b. ('a -> maybe 'b) -> list 'a -> list 'b -let rec myfiltermaybe f xs= - match xs with - | [] -> [] - | x::xs' -> match f x with Just y -> y::myfiltermaybe f xs'| Nothing -> myfiltermaybe f xs' end - end - - - -val bytes_of_natural: endianness -> natural (*size*) -> natural (*value*) -> byte_sequence -let bytes_of_natural en size n= - byte_sequence_of_byte_list ( - if size = 8 then - bytes_of_elf64_xword en (elf64_xword_of_natural n) - else if size = 4 then - bytes_of_elf32_word en (elf32_word_of_natural n) - else - Assert_extra.failwith "bytes_of_natural given size that is not 4 or 8") - -let rec natural_of_bytes_little bs : natural= - match read_char bs with - | Fail _ -> 0 - | Success (b, bs') -> natural_of_byte b + 256 * natural_of_bytes_little bs' - end - -let rec natural_of_bytes_big acc bs= - match read_char bs with - | Fail _ -> acc - | Success (b, bs') -> natural_of_bytes_big (natural_of_byte b + 256 * acc) bs' -end - -val natural_of_bytes: endianness -> byte_sequence -> natural -let natural_of_bytes en bs= - match en with - | Little -> natural_of_bytes_little bs - | Big -> natural_of_bytes_big 0 bs - end - - -(* TODO: generalise *) -(* - match bs with - | b0::b1::b2::b3::b4::b5::b6::b7::[] -> - let v = if en=Little then - natural_of_byte b0 + 256*natural_of_byte b1 + 256*256*natural_of_byte b2 + 256*256*256*natural_of_byte b3 - + (256*256*256*256*(natural_of_byte b4 + 256*natural_of_byte b5 + 256*256*natural_of_byte b6 + 256*256*256*natural_of_byte b7)) - else - natural_of_byte b7 + 256*natural_of_byte b6 + 256*256*natural_of_byte b5 + 256*256*256*natural_of_byte b4 - + (256*256*256*256*(natural_of_byte b3 + 256*natural_of_byte b2 + 256*256*natural_of_byte b1 + 256*256*256*natural_of_byte b0)) - in - v - | b0::b1::b2::b3::[] -> - let v = if en=Little then - natural_of_byte b0 + 256*natural_of_byte b1 + 256*256*natural_of_byte b2 + 256*256*256*natural_of_byte b3 - else - natural_of_byte b3 + 256*natural_of_byte b2 + 256*256*natural_of_byte b1 + 256*256*256*natural_of_byte b0 - - in - v - | b0::b1::[] -> - let v = if en=Little then - natural_of_byte b0 + 256*natural_of_byte b1 - else - natural_of_byte b1 + 256*natural_of_byte b0 - - in - v - | b0::[] -> - natural_of_byte b0 - | _ -> Assert_extra.failwith "natural_of_bytes given not-8/4/2/1 bytes" - end -*) - -val bigunionListMap : forall 'a 'b. SetType 'b => ('a -> set 'b) -> list 'a -> set 'b -let rec bigunionListMap f xs= - match xs with - | [] -> {} - | x::xs' -> Set.(union) (f x) (bigunionListMap f xs') - end - -let rec mytake' (n:sym_natural) acc xs= - match (n,xs) with - | (0, _) -> Just (List.reverse acc, xs) - | (_, []) -> Nothing - | (_, x::xs') -> mytake' (n-1) (x::acc) xs' - end - -val mytake : forall 'a. sym_natural -> (list 'a) -> maybe (list 'a * list 'a) -let mytake n xs= mytake' n [] xs - -val mynth : forall 'a. sym_natural -> (list 'a) -> maybe 'a -let rec mynth (n:sym_natural) xs= - match (n,xs) with - | (0, x::xs') -> Just x - | (0, []) -> Nothing (*Assert_extra.failwith "mynth"*) - | (_, x::xs') -> mynth (n-1) xs' - end - - -(** basic pretty printing *) - -let pphexplain n= unsafe_hex_string_of_natural 0 n -let pphex n= "0x" ^ pphexplain n - -let pphex_sym = pp_sym pphex - -val abs : integer -> natural -(*declare hol target_rep function abs = `int_of_num` *) -declare ocaml target_rep function abs = `Nat_big_num.abs` -(*declare isabelle target_rep function abs = `int` -declare coq target_rep function abs n = (`Zpred` (`Zpos` (`P_of_succ_nat` n))) (* TODO: check*) -*) - -let pphex_integer n= if n<0 then "-" ^ pphex (abs n) else pphex (abs n) - -let ppbytes bs= show (List.map (fun x -> show x) (byte_list_of_byte_sequence bs)) - -let rec ppbytes2 n bs= - match read_char bs with - | Fail _ -> "" - | Success (x,xs') -> "<" ^ pphex n ^ "> " ^ show x ^ "\n" ^ ppbytes2 (n+1) xs' - end - -let rec ppbytesplain (c:p_context) (n:natural) bs= show (natural_of_bytes c.endianness bs) -(* - unsafe_hex_string_of_uc_list (List.map unsigned_char_of_byte xs) (*match xs with | [] -> "" | x::xs' -> pphexplain x ^ ppbytesplain (n+1) xs' end*) -*) - -(* workaround: from String *) -val mytoString : list char -> string -declare ocaml target_rep function mytoString = `Xstring.implode` - -let string_of_bytes bs= mytoString (List.map Missing_pervasives.char_of_byte bs) - - -let just_one s xs= - match xs with - | [] -> Assert_extra.failwith ("no " ^ s) - | x1::x2::_ -> Assert_extra.failwith ("more than one " ^ s) - | [x] -> x - end - - - - -let max_address (as': natural) : natural= - match as' with - | 4 -> natural_of_hex "0xffffffff" - | 8 -> natural_of_hex "0xffffffffffffffff" - | _ -> Assert_extra.failwith "max_address size not 4 or 8" - end - -let range_address (as': natural) : natural= - match as' with - | 4 -> natural_of_hex "0x100000000" - | 8 -> natural_of_hex "0x10000000000000000" - | _ -> Assert_extra.failwith "range_address size not 4 or 8" - end - - - -(** lookup of encodings *) - -val lookup_Ab_b : forall 'a 'b. Eq 'a => 'a -> list ('a * 'b) -> maybe 'b -let rec lookup_Ab_b x0 xys= - match xys with - | [] -> Nothing - | (x,y)::xys' -> if x=x0 then Just y else lookup_Ab_b x0 xys' - end - -val lookup_aB_a : forall 'a 'b. Eq 'b => 'b -> list ('a * 'b) -> maybe 'a -let rec lookup_aB_a y0 xys= - match xys with - | [] -> Nothing - | (x,y)::xys' -> if y=y0 then Just x else lookup_aB_a y0 xys' - end - - -val lookup_aBc_a : forall 'a 'b 'c. Eq 'b => 'b -> list ('a * 'b * 'c) -> maybe 'a -let rec lookup_aBc_a y0 xyzs= - match xyzs with - | [] -> Nothing - | (x,y,_)::xyzs' -> if y=y0 then Just x else lookup_aBc_a y0 xyzs' - end - -val lookup_aBc_ac : forall 'a 'b 'c. Eq 'b => 'b -> list ('a * 'b * 'c) -> maybe ('a*'c) -let rec lookup_aBc_ac y0 xyzs= - match xyzs with - | [] -> Nothing - | (x,y,z)::xyzs' -> if y=y0 then Just (x,z) else lookup_aBc_ac y0 xyzs' - end - -val lookup_Abc_b : forall 'a 'b 'c. Eq 'a => 'a -> list ('a * 'b * 'c) -> maybe 'b -let rec lookup_Abc_b x0 xyzs= - match xyzs with - | [] -> Nothing - | (x,y,_)::xyzs' -> if x=x0 then Just y else lookup_Abc_b x0 xyzs' - end - - - -val lookup_aBcd_a : forall 'a 'b 'c 'd. Eq 'b => 'b -> list ('a * 'b * 'c * 'd) -> maybe 'a -let rec lookup_aBcd_a y0 xyzws= - match xyzws with - | [] -> Nothing - | (x,y,_,_)::xyzws' -> if y=y0 then Just x else lookup_aBcd_a y0 xyzws' - end - -val lookup_aBcd_acd : forall 'a 'b 'c 'd. Eq 'b => 'b -> list ('a * 'b * 'c * 'd) -> maybe ('a * 'c * 'd) -let rec lookup_aBcd_acd y0 xyzws= - match xyzws with - | [] -> Nothing - | (x,y,z,w)::xyzws' -> if y=y0 then Just (x,z,w) else lookup_aBcd_acd y0 xyzws' - end - -val lookup_abCde_de : forall 'a 'b 'c 'd 'e. Eq 'c => 'c -> list ('a * 'b * 'c * 'd * 'e) -> maybe ('d * 'e) -let rec lookup_abCde_de z0 xyzwus= - match xyzwus with - | [] -> Nothing - | (x,y,z,w,u)::xyzwus' -> if z=z0 then Just (w,u) else lookup_abCde_de z0 xyzwus' - end - - -let pp_maybe ppf n= match ppf n with Just s -> s | Nothing -> "Unknown AT value: " ^ pphexplain n (*encoding not found: "" ^ pphex n*) end - -let pp_tag_encoding n= pp_maybe (fun n -> lookup_aB_a n tag_encodings) n -let pp_attribute_encoding n= pp_maybe (fun n -> lookup_aBc_a n attribute_encodings) n -let pp_attribute_form_encoding n= pp_maybe (fun n -> lookup_aBc_a n attribute_form_encodings) n -let pp_operation_encoding n= pp_maybe (fun n -> lookup_aBcd_a n operation_encodings) n - -let tag_encode (s: string) : natural= - match lookup_Ab_b s tag_encodings with - | Just n -> n - | Nothing -> Assert_extra.failwith ("tag_encode: \""^s^"\"") - end - -let attribute_encode (s: string) : natural= - match lookup_Abc_b s attribute_encodings with - | Just n -> n - | Nothing -> Assert_extra.failwith ("attribute_encode: \""^s^"\"") - end - -let attribute_form_encode (s: string) : natural= - match lookup_Abc_b s attribute_form_encodings with - | Just n -> n - | Nothing -> Assert_extra.failwith "attribute_form_encode" - end - -let base_type_attribute_encode (s: string) : natural= - match lookup_Ab_b s base_type_attribute_encodings with - | Just n -> n - | Nothing -> Assert_extra.failwith "base_type_attribute_encode" - end - - - -(** ************************************************************ *) -(** ** parser combinators and primitives ********************* *) -(** ************************************************************ *) - -(* parsing combinators *) - -type parse_context = <| pc_bytes: byte_sequence; pc_offset: natural |> - -type parse_result 'a = - | PR_success of 'a * parse_context - | PR_fail of string * parse_context - -type parser 'a = parse_context -> parse_result 'a - -let pp_parse_context pc= "pc_offset = " ^ pphex pc.pc_offset - -let pp_parse_fail s pc= - "Parse fail\n" ^ s ^ " at " ^ pp_parse_context pc ^ "\n" - -let pp_parse_result ppa pr= - match pr with - | PR_success x pc -> "Parse success\n" ^ ppa x ^ "\n" ^ pp_parse_context pc ^ "\n" - | PR_fail s pc -> pp_parse_fail s pc - end - -(* [(>>=)] should be the monadic binding function for [parse_result]. *) -(* but there's a type clash if we use >>=, and lem seems to output bad ocaml for >>>=. So we just use a non-infix version for now *) - -val pr_bind : forall 'a 'b. parse_result 'a -> ('a -> parser 'b) -> parse_result 'b -let pr_bind x f= - match x with - | PR_success v pc -> f v pc - | PR_fail err pc -> PR_fail err pc - end - -val pr_return : forall 'a. 'a -> (parser 'a) -let pr_return x pc= PR_success x pc - -val pr_map : forall 'a 'b. ('a -> 'b) -> parse_result 'a -> parse_result 'b -let pr_map f x= - match x with - | PR_success v pc -> PR_success (f v) pc - | PR_fail err pc -> PR_fail err pc - end - -val pr_map2 : forall 'a 'b. ('a -> 'b) -> (parser 'a) -> (parser 'b) -let pr_map2 f p= fun pc -> pr_map f (p pc) - -val pr_post_map1 : forall 'a 'b. (parse_result 'a) -> ('a -> 'b) -> (parse_result 'b) -let pr_post_map1 x f= pr_map f x - -(* -val pr_post_map : forall 'a 'b 'c. ('c -> parse_result 'a) -> ('a -> 'b) -> ('c -> parse_result 'b) -let pr_post_map g f = fun x -> pr_map f (g x) -*) -val pr_post_map : forall 'a 'b. (parser 'a) -> ('a -> 'b) -> (parser 'b) -let pr_post_map p f= fun (pc: parse_context) -> pr_map f (p pc) - - -val pr_with_pos : forall 'a. (parser 'a) -> (parser (natural * 'a)) -let pr_with_pos p= fun pc -> pr_map (fun x -> (pc.pc_offset,x)) (p pc) - - -val parse_pair : forall 'a 'b. (parser 'a) -> (parser 'b) -> (parser ('a * 'b)) -let parse_pair p1 p2= - fun pc -> - let _ = my_debug "pair " in - pr_bind (p1 pc) (fun x pc' -> match p2 pc' with - | PR_success y pc'' -> PR_success (x,y) pc'' - | PR_fail s pc'' -> PR_fail s pc'' - end) - -val parse_triple : forall 'a 'b 'c. (parser 'a) -> (parser 'b) -> (parser 'c) -> parser ('a * ('b * 'c)) -let parse_triple p1 p2 p3= - parse_pair p1 (parse_pair p2 p3) - -val parse_quadruple : forall 'a 'b 'c 'd. (parser 'a) -> (parser 'b) -> (parser 'c) -> (parser 'd) -> parser ('a * ('b * ('c * 'd))) -let parse_quadruple p1 p2 p3 p4= - parse_pair p1 (parse_pair p2 (parse_pair p3 p4)) - -val parse_pentuple : forall 'a 'b 'c 'd 'e. (parser 'a) -> (parser 'b) -> (parser 'c) -> (parser 'd) -> (parser 'e) -> parser ('a * ('b * ('c * ('d * 'e)))) -let parse_pentuple p1 p2 p3 p4 p5= - parse_pair p1 (parse_pair p2 (parse_pair p3 (parse_pair p4 p5))) - -val parse_sextuple : forall 'a 'b 'c 'd 'e 'f. (parser 'a) -> (parser 'b) -> (parser 'c) -> (parser 'd) -> (parser 'e) -> (parser 'f) -> parser ('a * ('b * ('c * ('d * ('e * 'f))))) -let parse_sextuple p1 p2 p3 p4 p5 p6= - parse_pair p1 (parse_pair p2 (parse_pair p3 (parse_pair p4 (parse_pair p5 p6)))) - -val parse_dependent_pair : forall 'a 'b. (parser 'a) -> ('a -> parser 'b) -> (parser ('a * 'b)) -let parse_dependent_pair p1 p2= - fun pc -> - pr_bind (p1 pc) (fun x pc' -> match p2 x pc' with - | PR_success y pc'' -> PR_success (x,y) pc'' - | PR_fail s pc'' -> PR_fail s pc'' - end) - -val parse_dependent : forall 'a 'b. (parser 'a) -> ('a -> parser 'b) -> (parser 'b) -let parse_dependent p1 p2= - fun pc -> - pr_bind (p1 pc) (fun x pc' -> p2 x pc') - - - -val parse_list' : forall 'a. (parser (maybe 'a)) -> (list 'a -> parser (list 'a)) -let rec parse_list' p1= - fun acc pc -> let _ = my_debug "list' " in pr_bind (p1 pc) (fun mx pc' -> - match mx with - | Nothing -> PR_success acc pc' - | Just x -> parse_list' p1 (x :: acc) pc' - end) - -val parse_list : forall 'a. (parser (maybe 'a)) -> (parser (list 'a)) -let parse_list p1= - pr_post_map - (parse_list' p1 []) - (List.reverse) - -val parse_parser_list : forall 'a. (list (parser 'a)) -> (parser (list 'a)) -let rec parse_parser_list ps= - match ps with - | [] -> pr_return [] - | p::ps' -> - (fun pc -> pr_bind (p pc) (fun x pc' -> - match parse_parser_list ps' pc' with - | PR_success xs pc'' -> PR_success (x::xs) pc'' - | PR_fail s pc'' -> PR_fail s pc'' - end)) - end - -val parse_maybe : forall 'a. parser 'a -> parser (maybe 'a) -let parse_maybe p= - fun pc -> - match Byte_sequence.length pc.pc_bytes with - | 0 -> pr_return Nothing pc - | _ -> - match p pc with - | PR_success v pc'' -> PR_success (Just v) pc'' - | PR_fail s pc'' -> PR_fail s pc'' - end - end - -val parse_demaybe : forall 'a. string ->parser (maybe 'a) -> parser 'a -let parse_demaybe s p= - fun pc -> - match p pc with - | PR_success (Just v) pc'' -> PR_success v pc'' - | PR_success (Nothing) pc'' -> PR_fail s pc'' - | PR_fail s pc'' -> PR_fail s pc'' - - end - - -val parse_restrict_length : forall 'a. natural -> parser 'a -> parser 'a -let parse_restrict_length n p= - fun pc -> - match partition n pc.pc_bytes with - | Fail _ -> Assert_extra.failwith "parse_restrict_length not given enough bytes" - | Success (xs,ys) -> - let pc' = <| pc_bytes = xs; pc_offset = pc.pc_offset |> in - p pc' - end - - -(* parsing of basic types *) - -let parse_byte : parser(byte)= - fun (pc:parse_context) -> - match read_char pc.pc_bytes with - | Fail _ -> PR_fail "parse_byte" pc - | Success (b,bs) -> PR_success b (<|pc_bytes=bs; pc_offset= pc.pc_offset + 1 |> ) - end - -let parse_n_bytes (n:natural) : parser (byte_sequence)= - fun (pc:parse_context) -> - match partition n pc.pc_bytes with - | Fail _ -> PR_fail ("parse_n_bytes n=" ^ pphex n) pc - | Success (xs,bs) -> - PR_success xs (<|pc_bytes=bs; pc_offset= pc.pc_offset + (Byte_sequence.length xs) |> ) - end - -let bzero= byte_of_natural 0 - -let parse_string : parser (byte_sequence)= - fun (pc:parse_context) -> - match find_byte pc.pc_bytes bzero with - | Nothing -> PR_fail "parse_string" pc - | Just n -> - pr_bind (parse_n_bytes n pc) (fun res pc -> - pr_bind (parse_byte pc) (fun _ pc -> - pr_return res pc)) - end - -(* parse a null-terminated string; return Nothing if it is empty, Just s otherwise *) -let parse_non_empty_string : parser (maybe byte_sequence)= - fun (pc:parse_context) -> - pr_bind (parse_string pc) (fun str pc -> - if Byte_sequence.length str = 0 then - pr_return Nothing pc - else - pr_return (Just str) pc) - -(* TODO relocations *) -let parse_uint8 : parser sym_natural= - fun (pc:parse_context) -> - let _ = my_debug "uint8 " in - match read_char pc.pc_bytes with - | Success (b, bytes) -> - let v = natural_of_byte b in - PR_success (Absolute v) (<| pc_bytes = bytes; pc_offset = pc.pc_offset + 1 |>) - | _ -> PR_fail "parse_uint32 not given enough bytes" pc - end - -let parse_uint8_constant (v:sym_natural) : parser sym_natural= - fun (pc:parse_context) -> - let _ = my_debug "uint8_constant " in - PR_success v pc - - -(* TODO relocations *) -let parse_uint16 c : parser sym_natural= - fun (pc:parse_context) -> - let _ = my_debug "uint16 " in - match read_2_bytes_be pc.pc_bytes with - | Success ((b0,b1),bytes') -> - let v = if c.endianness=Little then - natural_of_byte b0 + 256*natural_of_byte b1 - else - natural_of_byte b1 + 256*natural_of_byte b0 in - PR_success (Absolute v) (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 2 |>) - | _ -> PR_fail "parse_uint32 not given enough bytes" pc - end - -(* TODO relocations *) -let parse_uint32 c : parser sym_natural= - fun (pc:parse_context) -> - let _ = my_debug "uint32 " in - match read_4_bytes_be pc.pc_bytes with - | Success ((b0,b1,b2,b3),bytes') -> - let v = if c.endianness=Little then - natural_of_byte b0 + 256*natural_of_byte b1 + 256*256*natural_of_byte b2 + 256*256*256*natural_of_byte b3 - else - natural_of_byte b3 + 256*natural_of_byte b2 + 256*256*natural_of_byte b1 + 256*256*256*natural_of_byte b0 in - PR_success (Absolute v) (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 4 |>) - | _ -> PR_fail "parse_uint32 not given enough bytes" pc - end - -(* TODO relocations *) -let parse_uint64 c : parser sym_natural= - fun (pc:parse_context) -> - let _ = my_debug "uint64 " in - match read_8_bytes_be pc.pc_bytes with - | Success ((b0,b1,b2,b3,b4,b5,b6,b7),bytes') -> - let v = if c.endianness=Little then - natural_of_byte b0 + 256*natural_of_byte b1 + 256*256*natural_of_byte b2 + 256*256*256*natural_of_byte b3 - + (256*256*256*256*(natural_of_byte b4 + 256*natural_of_byte b5 + 256*256*natural_of_byte b6 + 256*256*256*natural_of_byte b7)) - else - natural_of_byte b7 + 256*natural_of_byte b6 + 256*256*natural_of_byte b5 + 256*256*256*natural_of_byte b4 - + (256*256*256*256*(natural_of_byte b3 + 256*natural_of_byte b2 + 256*256*natural_of_byte b1 + 256*256*256*natural_of_byte b0)) - in - PR_success (Absolute v) (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 8 |>) - | _ -> PR_fail "parse_uint64 not given enough bytes" pc - end - -let integerFromTwosComplementNatural (n:natural) (half: natural) (all:integer) : integer= - if n < half then integerFromNatural n else integerFromNatural n - all - -let partialTwosComplementNaturalFromInteger (i:integer) (half: sym_natural) (all:integer) : sym_natural= - if i >=0 && i < integerFromSymNatural half then partialNaturalFromInteger i - else if i >= (0-integerFromSymNatural half) && i < 0 then partialNaturalFromInteger (all + i) - else Assert_extra.failwith "partialTwosComplementNaturalFromInteger" - - -let parse_sint8 : parser integer= - pr_post_map (parse_uint8) (fun n -> integerFromTwosComplementNatural (sym_unwrap n) 128 256) - -let parse_sint16 c : parser integer= - pr_post_map (parse_uint16 c) (fun n -> integerFromTwosComplementNatural (sym_unwrap n) (128*256) (256*256)) - -let parse_sint32 c : parser integer= - pr_post_map (parse_uint32 c) (fun n -> integerFromTwosComplementNatural (sym_unwrap n) (128*256*256*256) (256*256*256*256)) - -let parse_sint64 c : parser integer= - pr_post_map (parse_uint64 c) (fun n -> integerFromTwosComplementNatural (sym_unwrap n) (128*256*256*256*256*256*256*256) (256*256*256*256*256*256*256*256)) - -let rec parse_ULEB128' (acc: natural) (shift_factor: natural) : parser natural= - fun (pc:parse_context) -> - let _ = my_debug "ULEB128' " in - match read_char pc.pc_bytes with - | Success (b,bytes') -> - let n = natural_of_byte b in - let acc' = (natural_land n 127) * shift_factor + acc in - let finished = ((natural_land n 128) = 0) in - let pc' = <| pc_bytes = bytes'; pc_offset = pc.pc_offset + 1 |> in - if finished then - PR_success acc' pc' - else - parse_ULEB128' acc' (shift_factor * 128) pc' - | _ -> - PR_fail "parse_ULEB128' not given enough bytes" pc - end - -let parse_ULEB128 : parser sym_natural= - fun (pc:parse_context) -> - pr_map (fun x -> Absolute x) (parse_ULEB128' 0 1 pc) - -let rec parse_SLEB128' (acc: natural) (shift_factor: natural) : parser (bool * natural * natural)= - fun (pc:parse_context) -> - let _ = my_debug "SLEB128' " in - match read_char pc.pc_bytes with - | Success (b,bytes') -> - let n = natural_of_byte b in - let acc' = acc + (natural_land n 127) * shift_factor in - let shift_factor' = shift_factor * 128 in - let finished = ((natural_land n 128) = 0) in - let positive = ((natural_land n 64) = 0) in - let pc' = <| pc_bytes = bytes'; pc_offset = pc.pc_offset + 1 |> in - if finished then - PR_success (positive, shift_factor', acc') pc' - else - parse_SLEB128' acc' shift_factor' pc' - | _ -> - PR_fail "parse_SLEB128' not given enough bytes" pc - end - -let parse_SLEB128 : parser integer= - pr_post_map (parse_SLEB128' 0 1) (fun (positive, shift_factor, acc) -> - if positive then integerFromNatural acc else integerFromNatural acc - integerFromNatural shift_factor) - -let parse_nonzero_ULEB128_pair : parser (maybe (sym_natural*sym_natural))= - let _ = my_debug "nonzero_ULEB128_pair " in - pr_post_map - (parse_pair parse_ULEB128 parse_ULEB128) - (fun (n1,n2) -> if n1=0 && n2=0 then Nothing else Just (n1,n2)) - -let parse_zero_terminated_ULEB128_pair_list : parser (list (sym_natural*sym_natural))= - let _ = my_debug "zero_terminated_ULEB128_pair_list " in - parse_list parse_nonzero_ULEB128_pair - -let parse_uintDwarfN c (df: dwarf_format) : parser sym_natural= - match df with - | Dwarf32 -> (parse_uint32 c) - | Dwarf64 -> (parse_uint64 c) - end - -let parse_uint_address_size c (as': natural) : parser sym_natural= - match as' with - | 4 -> (parse_uint32 c) - | 8 -> (parse_uint64 c) - | _ -> Assert_extra.failwith ("cuh_address_size not 4 or 8: " ^ show as') - end - -let parse_uint_segment_selector_size c (ss: natural) : parser (maybe sym_natural)= - match ss with - | 0 -> pr_return Nothing - | 1 -> pr_post_map (parse_uint8) (fun n -> Just n) - | 2 -> pr_post_map (parse_uint16 c) (fun n -> Just n) - | 4 -> pr_post_map (parse_uint32 c) (fun n -> Just n) - | 8 -> pr_post_map (parse_uint64 c) (fun n -> Just n) - | _ -> Assert_extra.failwith "cuh_address_size not 4 or 8" - end - - - -(** ************************************************************ *) -(** ** parsing and pretty printing of .debug_* sections ****** *) -(** ************************************************************ *) - - -(** abbreviations table: pp and parsing *) - -let pp_abbreviation_declaration (x:abbreviation_declaration)= - " " - ^ show x.ad_abbreviation_code ^ " " - ^ pp_tag_encoding x.ad_tag ^ " " - ^ (if x.ad_has_children then "[has children]" else "[no children]") - ^ "\n" -(* ^ " "^show (List.length x.ad_attribute_specifications) ^ " attributes\n"*) - ^ String.concat "" - (List.map - (fun (n1,n2) -> - " " ^ right_space_padded_to 18 (pp_attribute_encoding n1) ^ " " ^ pp_attribute_form_encoding n2 ^ "\n") - x.ad_attribute_specifications) - ^ " DW_AT value: 0 DW_FORM value: 0\n" - - -let pp_abbreviations_table (x:abbreviations_table)= - "offset: "^pphex x.at_offset^"\n" - ^ String.concat "" (List.map (pp_abbreviation_declaration) x.at_table) - -(* print the distinct abbreviation tables used by all compilation units *) -let rec remove_duplicates xys xys_acc= - match xys with - | [] -> List.reverse xys_acc - | (x,y)::xys' -> - if List.any (fun (x',y') -> x'=x) xys_acc then - remove_duplicates xys' xys_acc - else - remove_duplicates xys' ((x,y)::xys_acc) - end - -let pp_abbreviations_tables (d:dwarf)= - let xs : list (natural * abbreviations_table) = - List.map - (fun cu -> (cu.cu_header.cuh_debug_abbrev_offset, cu.cu_abbreviations_table)) - d.d_compilation_units in - let ys = remove_duplicates xs [] in - String.concat "*********************\n" (List.map (fun (x,y)->pp_abbreviations_table y) ys) - - - - -let parse_abbreviation_declaration c : parser (maybe abbreviation_declaration)= - fun (pc: parse_context) -> - pr_bind (parse_ULEB128 pc) (fun n1 pc' -> - if n1 = 0 then - PR_success Nothing pc' - else - pr_bind (parse_ULEB128 pc') (fun n2 pc'' -> - pr_bind (parse_uint8 pc'') (fun c pc''' -> - pr_post_map1 - (parse_zero_terminated_ULEB128_pair_list pc''') - (fun l -> - Just ( let ad = - <| - ad_abbreviation_code = (sym_unwrap n1); - ad_tag = (sym_unwrap n2); - ad_has_children = (c<>0); - ad_attribute_specifications = List.map (fun (x, y) -> (sym_unwrap x, sym_unwrap y)) l; - |> in (* let _ = my_debug2 (pp_abbreviation_declaration ad) in *) ad) - )))) - -let parse_abbreviations_table c= - parse_list (parse_abbreviation_declaration c) - - -(** debug_str entry *) - -let rec null_terminated_bs (bs: byte_sequence) : byte_sequence= - match find_byte bs bzero with - | Just i -> - match takebytes i bs with - | Success bs' -> bs' - | Fail _ -> Assert_extra.failwith "find_byte or take_byte is broken" - end - | Nothing -> bs - end - -let pp_debug_str_entry (str: byte_sequence) (n: natural) : string= - match dropbytes n str with - | Fail _ -> "strp beyond .debug_str extent" - | Success bs -> string_of_byte_sequence (null_terminated_bs bs) - end - -(** operations: pp and parsing *) - -let pp_operation_argument_value (oav:operation_argument_value) : string= - match oav with - | OAV_natural n -> pphex_sym n - | OAV_integer n -> pphex_integer n (* show n*) - | OAV_block n bs -> pphex_sym n ^ " " ^ ppbytes bs - end - -let pp_operation_semantics (os: operation_semantics) : string= - match os with - | OpSem_lit -> "OpSem_lit" - | OpSem_deref -> "OpSem_deref" - | OpSem_stack _ -> "OpSem_stack ..." - | OpSem_not_supported -> "OpSem_not_supported" - | OpSem_binary _ -> "OpSem_binary ..." - | OpSem_unary _ -> "OpSem_unary ..." - | OpSem_opcode_lit _ -> "OpSem_opcode_lit ..." - | OpSem_reg -> "OpSem_reg" - | OpSem_breg -> "OpSem_breg" - | OpSem_bregx -> "OpSem_bregx" - | OpSem_fbreg -> "OpSem_fbreg" - | OpSem_deref_size -> "OpSem_deref_size" - | OpSem_nop -> "OpSem_nop" - | OpSem_piece -> "OpSem_piece" - | OpSem_bit_piece -> "OpSem_bitpiece" - | OpSem_implicit_value -> "OpSem_implicit_value" - | OpSem_stack_value -> "OpSem_stack_value" - | OpSem_call_frame_cfa -> "OpSem_call_frame_cfa" - end - -let pp_operation_semantics_brief (os: operation_semantics) : string= - match os with - | OpSem_not_supported -> " (OpSem_not_supported)" - | _ -> "" - end - -let pp_operation (op: operation) : string= - op.op_string ^ (match op.op_argument_values with [] -> "" | _ -> " " ^ String.concat " " (List.map pp_operation_argument_value op.op_argument_values) end) ^ pp_operation_semantics_brief op.op_semantics - -let pp_operations (ops: list operation) : string= - String.concat "; " (List.map pp_operation ops) - -val parser_of_operation_argument_type : p_context -> compilation_unit_header -> operation_argument_type -> (parser operation_argument_value) -let parser_of_operation_argument_type c cuh oat= - match oat with - | OAT_addr -> - pr_map2 (fun n -> OAV_natural n) (parse_uint_address_size c cuh.cuh_address_size) - | OAT_dwarf_format_t -> - pr_map2 (fun n -> OAV_natural n) (parse_uintDwarfN c cuh.cuh_dwarf_format) - | OAT_uint8 -> pr_map2 (fun n -> OAV_natural n) (parse_uint8) - | OAT_uint16 -> pr_map2 (fun n -> OAV_natural n) (parse_uint16 c) - | OAT_uint32 -> pr_map2 (fun n -> OAV_natural n) (parse_uint32 c) - | OAT_uint64 -> pr_map2 (fun n -> OAV_natural n) (parse_uint64 c) - | OAT_sint8 -> pr_map2 (fun n -> OAV_integer n) (parse_sint8) - | OAT_sint16 -> pr_map2 (fun n -> OAV_integer n) (parse_sint16 c) - | OAT_sint32 -> pr_map2 (fun n -> OAV_integer n) (parse_sint32 c) - | OAT_sint64 -> pr_map2 (fun n -> OAV_integer n) (parse_sint64 c) - | OAT_ULEB128 -> pr_map2 (fun n -> OAV_natural n) parse_ULEB128 - | OAT_SLEB128 -> pr_map2 (fun n -> OAV_integer n) parse_SLEB128 - | OAT_block -> - (fun pc -> pr_bind (parse_ULEB128 pc) (fun n pc' -> - pr_map (fun bs -> OAV_block n bs) (parse_n_bytes (sym_unwrap n) pc'))) - end - -val parse_operation : p_context -> compilation_unit_header -> parser (maybe operation) -let parse_operation c cuh pc= - match parse_uint8 pc with - | PR_fail s pc' -> PR_success Nothing pc - | PR_success code pc' -> - match lookup_aBcd_acd (sym_unwrap code) operation_encodings with - | Nothing -> PR_fail ("encoding not found: " ^ pphex_sym code) pc - | Just (s,oats,opsem) -> - let ps = List.map (parser_of_operation_argument_type c cuh) oats in - (pr_post_map - (parse_parser_list ps) - (fun oavs -> Just <| op_code = code; op_string = s; op_argument_values = oavs; op_semantics = opsem |>) - ) - pc' - end - end - -val parse_operations : p_context -> compilation_unit_header -> parser (list operation) -let parse_operations c cuh= - parse_list (parse_operation c cuh) - -let parse_operations_bs c cuh bs : list operation= - let pc = <|pc_bytes = bs; pc_offset = 0 |> in - match parse_operations c cuh pc with - | PR_fail s pc' -> Assert_extra.failwith ("parse_operations_bs fail: " ^ pp_parse_fail s pc') - | PR_success ops pc' -> - let _ = if Byte_sequence.length pc'.pc_bytes <> 0 then Assert_extra.failwith ("parse_operations_bs extra non-parsed bytes") else () in - ops - end - - - -val parse_and_pp_operations : p_context -> compilation_unit_header -> byte_sequence -> string -let parse_and_pp_operations c cuh bs= - let pc = <|pc_bytes = bs; pc_offset = 0 |> in - match parse_operations c cuh pc with - | PR_fail s pc' -> "parse_operations fail: " ^ pp_parse_fail s pc' - | PR_success ops pc' -> - pp_operations ops - ^ if Byte_sequence.length pc'.pc_bytes <> 0 then " Warning: extra non-parsed bytes" else "" - end - - -(** attribute values: pp and parsing *) - -val pp_attribute_value_plain : attribute_value -> string -let pp_attribute_value_plain av= - match av with - | AV_addr x -> "AV_addr " ^ pphex_sym x - | AV_block n bs -> "AV_block " ^ show n ^ " " ^ ppbytes bs - | AV_constantN n bs -> "AV_constantN " ^ show n ^ " " ^ ppbytes bs - | AV_constant_SLEB128 i -> "AV_constant_SLEB128 " ^ show i - | AV_constant_ULEB128 n -> "AV_constant_ULEB128 " ^ show n - | AV_exprloc n bs -> - String.concat " " ["AV_exprloc"; show n; ppbytes bs] - | AV_flag b -> "AV_flag " ^ show b - | AV_ref n -> "AV_ref " ^ pphex n - | AV_ref_addr n -> "AV_ref_addr " ^ pphex n - | AV_ref_sig8 n -> "AV_ref_sig8 " ^ pphex n - | AV_sec_offset n -> "AV_sec_offset " ^ pphex n - | AV_string bs -> string_of_byte_sequence bs - | AV_strp n -> "AV_sec_offset " ^ pphex n ^ " " - end - - -val pp_attribute_value : p_context -> compilation_unit_header -> byte_sequence -> natural (*attribute tag*) -> attribute_value -> string -let pp_attribute_value c cuh str at av= - match av with - | AV_addr x -> "AV_addr " ^ pphex_sym x - | AV_block n bs -> "AV_block " ^ show n ^ " " ^ ppbytes bs - ^ if at = attribute_encode "DW_AT_location" then " " ^ parse_and_pp_operations c cuh bs else "" - | AV_constantN n bs -> "AV_constantN " ^ show n ^ " " ^ ppbytes bs - | AV_constant_SLEB128 i -> "AV_constant_SLEB128 " ^ show i - | AV_constant_ULEB128 n -> "AV_constant_ULEB128 " ^ show n - | AV_exprloc n bs -> - String.concat " " ["AV_exprloc"; show n; ppbytes bs; parse_and_pp_operations c cuh bs] - | AV_flag b -> "AV_flag " ^ show b - | AV_ref n -> "AV_ref " ^ pphex n - | AV_ref_addr n -> "AV_ref_addr " ^ pphex n - | AV_ref_sig8 n -> "AV_ref_sig8 " ^ pphex n - | AV_sec_offset n -> "AV_sec_offset " ^ pphex n - | AV_string bs -> string_of_byte_sequence bs - | AV_strp n -> "AV_sec_offset " ^ pphex n ^ " " - ^ pp_debug_str_entry str n - end - -val pp_attribute_value_like_objdump : p_context -> compilation_unit_header -> byte_sequence -> natural (*attribute tag*) -> attribute_value -> string -let pp_attribute_value_like_objdump c cuh str at av= - match av with - | AV_addr x -> (*"AV_addr " ^*) pphex_sym x - | AV_block n bs -> (*"AV_block " ^ show n ^ " " ^ ppbytes bs - ^ if at = attribute_encode "DW_AT_location" then " " ^ parse_and_pp_operations c cuh bs else ""*) - (* show n ^ " byte block: " *) ppbytesplain c n bs - ^ if at = attribute_encode "DW_AT_location" then " " ^ parse_and_pp_operations c cuh bs else "" - | AV_constantN n bs -> ppbytes bs (*"AV_constantN " ^ show n ^ " " ^ ppbytes bs*) - | AV_constant_SLEB128 i -> (*"AV_constant_SLEB128 " ^*) show i - | AV_constant_ULEB128 n -> (*"AV_constant_ULEB128 " ^*) show n - | AV_exprloc n bs -> (*"AV_exprloc " ^ show n ^ " " ^*) ppbytes bs - ^ " " ^ parse_and_pp_operations c cuh bs - | AV_flag b -> (*"AV_flag " ^*)if b then "1" else "0" - | AV_ref n -> (*"AV_ref " ^*) "<"^pphex (n + cuh.cuh_offset)^">" - | AV_ref_addr n -> (*"AV_ref_addr " ^*) "<"^pphex n^">" - | AV_ref_sig8 n -> "AV_ref_sig8 " ^ pphex n - | AV_sec_offset n -> (*"AV_sec_offset " ^*) pphex n - ^ if at = attribute_encode "DW_AT_location" then " (location list)" else "" - | AV_string bs -> string_of_byte_sequence bs - | AV_strp n -> (*"AV_sec_offset " ^ pphex n ^ " " - ^ pp_debug_str_entry str n*) - "(indirect string, offset: "^pphex n ^ "): " ^ pp_debug_str_entry str n - end - - - - -val parser_of_attribute_form_non_indirect : p_context -> compilation_unit_header -> natural -> parser attribute_value -let parser_of_attribute_form_non_indirect c cuh n= -(* address*) - if n = attribute_form_encode "DW_FORM_addr" then - pr_map2 (fun n -> AV_addr n) (parse_uint_address_size c cuh.cuh_address_size) -(* block *) - else if n = attribute_form_encode "DW_FORM_block1" then - (fun pc -> pr_bind (parse_uint8 pc) (fun n pc' -> - let n = sym_unwrap n in - pr_map (fun bs -> AV_block n bs) (parse_n_bytes n pc'))) - else if n = attribute_form_encode "DW_FORM_block2" then - (fun pc -> pr_bind (parse_uint16 c pc) (fun n pc' -> - let n = sym_unwrap n in - pr_map (fun bs -> AV_block n bs) (parse_n_bytes n pc'))) - else if n = attribute_form_encode "DW_FORM_block4" then - (fun pc -> pr_bind (parse_uint32 c pc) (fun n pc' -> - let n = sym_unwrap n in - pr_map (fun bs -> AV_block n bs) (parse_n_bytes n pc'))) - else if n = attribute_form_encode "DW_FORM_block" then - (fun pc -> pr_bind (parse_ULEB128 pc) (fun n pc' -> - let n = sym_unwrap n in - pr_map (fun bs -> AV_block n bs) (parse_n_bytes n pc'))) -(* constant *) - else if n = attribute_form_encode "DW_FORM_data1" then - pr_map2 (fun bs -> AV_block 1 bs) (parse_n_bytes 1) - else if n = attribute_form_encode "DW_FORM_data2" then - pr_map2 (fun bs -> AV_block 2 bs) (parse_n_bytes 2) - else if n = attribute_form_encode "DW_FORM_data4" then - pr_map2 (fun bs -> AV_block 4 bs) (parse_n_bytes 4) - else if n = attribute_form_encode "DW_FORM_data8" then - pr_map2 (fun bs -> AV_block 8 bs) (parse_n_bytes 8) - else if n = attribute_form_encode "DW_FORM_sdata" then - pr_map2 (fun i -> AV_constant_SLEB128 i) parse_SLEB128 - else if n = attribute_form_encode "DW_FORM_udata" then - pr_map2 (fun n -> AV_constant_ULEB128 n) parse_ULEB128 -(* exprloc *) - else if n = attribute_form_encode "DW_FORM_exprloc" then - (fun pc -> pr_bind (parse_ULEB128 pc) (fun n pc' -> - let n = sym_unwrap n in - pr_map (fun bs -> AV_exprloc n bs) (parse_n_bytes n pc'))) -(* flag *) - else if n = attribute_form_encode "DW_FORM_flag" then - pr_map2 (fun n -> AV_flag (n<>0)) (parse_uint8) - else if n = attribute_form_encode "DW_FORM_flag_present" then - pr_map2 (fun () -> AV_flag true) (pr_return ()) -(* lineptr, loclistptr, macptr, rangelistptr *) - else if n = attribute_form_encode "DW_FORM_sec_offset" then - pr_map2 (fun n -> AV_sec_offset (sym_unwrap n)) (parse_uintDwarfN c cuh.cuh_dwarf_format) -(* reference - first type *) - else if n = attribute_form_encode "DW_FORM_ref1" then - pr_map2 (fun n -> AV_ref (sym_unwrap n)) (parse_uint8) - else if n = attribute_form_encode "DW_FORM_ref2" then - pr_map2 (fun n -> AV_ref (sym_unwrap n)) (parse_uint16 c) - else if n = attribute_form_encode "DW_FORM_ref4" then - pr_map2 (fun n -> AV_ref (sym_unwrap n)) (parse_uint32 c) - else if n = attribute_form_encode "DW_FORM_ref8" then - pr_map2 (fun n -> AV_ref (sym_unwrap n)) (parse_uint64 c) - else if n = attribute_form_encode "DW_FORM_ref_udata" then - pr_map2 (fun n -> AV_ref (sym_unwrap n)) parse_ULEB128 -(* reference - second type *) - else if n = attribute_form_encode "DW_FORM_ref_addr" then - pr_map2 (fun n -> AV_ref_addr (sym_unwrap n)) (parse_uintDwarfN c cuh.cuh_dwarf_format) -(* reference - third type *) - else if n = attribute_form_encode "DW_FORM_ref_sig8" then - pr_map2 (fun n -> AV_ref_sig8 (sym_unwrap n)) (parse_uint64 c) -(* string *) - else if n = attribute_form_encode "DW_FORM_string" then - pr_map2 (fun bs -> AV_string bs) parse_string - else if n = attribute_form_encode "DW_FORM_strp" then - pr_map2 (fun n -> AV_strp (sym_unwrap n)) (parse_uintDwarfN c cuh.cuh_dwarf_format) -(* indirect (cycle detection) *) - else if n = attribute_form_encode "DW_FORM_indirect" then - Assert_extra.failwith "DW_FORM_INDIRECT cycle" -(* unknown *) - else - Assert_extra.failwith "parser_of_attribute_form_non_indirect: unknown attribute form" - - -let parser_of_attribute_form c cuh n= - if n = attribute_form_encode "DW_FORM_indirect" then - (fun pc -> pr_bind (parse_ULEB128 pc) (fun n -> - let n = sym_unwrap n in - parser_of_attribute_form_non_indirect c cuh n) ) - else - parser_of_attribute_form_non_indirect c cuh n - - -(* *** where to put this? *) - -let pp_pos pos= "<" ^ pphexplain pos ^">" - -let pp_cupdie (cu,parents,die)= pp_pos cu.cu_header.cuh_offset ^ "/" ^ pp_pos die.die_offset - -let pp_cupdie3 (cu,parents,die)= pp_pos die.die_offset ^ "/" ^ String.concat "/" (List.map (fun p -> pp_pos p.die_offset) parents) ^ "/" ^ pp_pos cu.cu_header.cuh_offset - - -(** ************************************************************ *) -(** ** finding things in the die tree *) -(** ************************************************************ *) - -val find_maybe : forall 'a 'b. ('a -> maybe 'b) -> list 'a -> maybe 'b -let rec find_maybe f l= - match l with - | [] -> Nothing - | x :: xs -> - match f x with - | Just y -> Just y - | Nothing -> find_maybe f xs - end - end - -let rec find_die_by_offset_in_cu offset cu : maybe cupdie= - match Map.lookup offset cu.cu_index with - | Just (parents,die) -> Just (cu, parents,die) - | Nothing -> Nothing - end - -let find_die_by_offset_in_all offset d : maybe cupdie= - find_maybe - (fun cu -> find_die_by_offset_in_cu offset cu) - d.d_compilation_units - -val find_dies_in_die : (die->bool) -> compilation_unit -> list die -> die -> list cupdie -let rec find_dies_in_die (p:die->bool) (cu:compilation_unit) (parents: list die) (d: die)= - let ds = List.concatMap (find_dies_in_die p cu (d::parents)) d.die_children in - if p d then (cu,parents,d)::ds else ds - -let find_dies (p:die->bool) (d: dwarf) : list cupdie= - List.concatMap - (fun cu -> find_dies_in_die p cu [] cu.cu_die) - d.d_compilation_units - - -(** convert attribute values to usable Lem types *) - - -let string_of_string_attribute_value str av : string= - match av with - | AV_string bs -> string_of_byte_sequence bs - | AV_strp n -> pp_debug_str_entry str n - | _ -> "find_string_attribute_value_of_die AV not understood" - end - -let maybe_natural_of_constant_attribute_value die1 c av : maybe sym_natural= - match av with - | AV_constantN n bs -> Just n - | AV_constant_ULEB128 n -> Just n - | AV_block n bs -> Just (Absolute (natural_of_bytes c.endianness bs)) - | _ -> Nothing - end - -let natural_of_constant_attribute_value die1 c av : sym_natural= - match maybe_natural_of_constant_attribute_value die1 c av with - | Just n -> n - | Nothing -> Assert_extra.failwith ("natural_of_constant_attribute_value fail at " ^ (pp_pos die1.die_offset ^ (" with av= " ^ pp_attribute_value_plain av))) - end - -let integer_of_constant_attribute_value c av : integer= - match av with - | AV_constantN n bs -> integerFromSymNatural n - | AV_constant_ULEB128 n -> integerFromSymNatural n - | AV_constant_SLEB128 n -> n - | AV_block n bs -> integerFromNatural (natural_of_bytes c.endianness bs) - | _ -> Assert_extra.failwith ("integer_of_constant_attribute_value fail") - end - -let bool_of_flag_attribute_value av : bool= - match av with - | AV_flag b -> b - | _ -> Assert_extra.failwith ("bool_of_maybe_flag_attribute_value fail") - end - -let reference_of_reference_attribute_value c d cu str av : maybe (compilation_unit * (list die) * die)= - match av with - (* "offset from the first byte of the compilation header for the compilation unit containing the reference" *) - | AV_ref n -> - let n' = n+cu.cu_header.cuh_offset in - match find_die_by_offset_in_all n' d (*cu.cu_die*) with - | Just (cu',parents',die') -> Just (cu',parents',die') - | Nothing -> Nothing (* Fail ("find_reference_attribute_of_die AV_ref failed (cuh="^pphex cu.cu_header.cuh_offset ^" n'="^pphex n'^")"^"\n"^ppd())*) - end - (* offset in .debug_info *) - | AV_ref_addr n -> - match find_die_by_offset_in_all n d with - | Just (cu',parents',die') -> Just (cu',parents',die') - | Nothing -> Nothing (*Fail ("find_reference_attribute_of_die AV_ref_addr failed\n"^ppd())*) - end - | _ -> - Nothing (*Fail ("reference_of_reference_attribute AV ("^pp_attribute_value c cu.cu_header str (attribute_encode an) av^") not supported\n"^ppd() )*) - (* TODO: handle the AV_ref_sig8 case for type signature references *) - end - -(** attribute find *) - -let find_attribute_value (an: string) (die:die) : maybe attribute_value= - let at = attribute_encode an in - let ats = List.zip - die.die_abbreviation_declaration.ad_attribute_specifications - die.die_attribute_values in - myfindmaybe - (fun (((at': natural), (af: natural)), ((pos: natural),(av:attribute_value))) -> - if at' = at then Just av else Nothing) - ats - - -let find_string_attribute_value_of_die (an: string) str (die:die) : maybe string= - match find_attribute_value an die with - | Just av -> - let s = string_of_string_attribute_value str av in - Just s - | Nothing -> - Nothing - end - -let find_natural_attribute_value_of_die c (an: string) (die:die) : maybe sym_natural= - match find_attribute_value an die with - | Just av -> - let n = natural_of_constant_attribute_value die c av in - Just n - | Nothing -> - Nothing - end - -let find_integer_attribute_value_of_die c (an: string) (die:die) : maybe integer= - match find_attribute_value an die with - | Just av -> - let n = integer_of_constant_attribute_value c av in - Just n - | Nothing -> - Nothing - end - -let find_flag_attribute_value_of_die (an: string) (die:die) : maybe bool= - Maybe.map bool_of_flag_attribute_value (find_attribute_value an die) - - -let find_flag_attribute_value_of_die_default_false (an: string) (die:die) : bool= - match find_flag_attribute_value_of_die an die with - | Just b -> b - | Nothing -> false - end - - - -let find_name_of_die str die : maybe string= - find_string_attribute_value_of_die "DW_AT_name" str die - - - - -let find_reference_attribute_of_die c d cu str an die : maybe (compilation_unit * (list die) * die)= - let ppd ()= pp_pos die.die_offset (*pp_die c cuh str true 0 false die ^ "\n"*) in - match find_attribute_value an die with - | Nothing -> - Nothing (*Fail ("find_reference_attribute_of_die found no " ^ an ^ "\n" ^ ppd())*) - | Just av -> - reference_of_reference_attribute_value c d cu str av - end - -let find_DW_AT_type_of_die c d cu str die : maybe (compilation_unit * (list die) * die)= - find_reference_attribute_of_die c d cu str "DW_AT_type" die - -(* look up "an" in die. If not found, see if die has an abstract origin, and if so, look up "an" in that. Return the relevant cu, too *) -let find_attribute_value_using_abstract_origin c d cu str an die : maybe (compilation_unit * attribute_value)= - match find_attribute_value an die with - | Just av -> Just (cu,av) - | Nothing -> - match find_reference_attribute_of_die c d cu str "DW_AT_abstract_origin" die with - | Nothing -> - Nothing (*s ^ " and no DW_AT_abstract_origin"*) - | Just (cu',parents',die') -> - match find_attribute_value an die' with - | Just av -> Just (cu',av) - | Nothing -> Nothing - end - end - end - -let find_name_of_die_using_abstract_origin c d cu str die : maybe string= - match find_attribute_value_using_abstract_origin c d cu str "DW_AT_name" die with - | Nothing -> Nothing - | Just (cu',av) -> Just (string_of_string_attribute_value str av) - end - -(* TODO: not sure how DW_AT_specification should interact with abstract origins *) -let find_name_of_die_using_abstract_origin_and_spec c d cu str die mcupdie_spec : maybe string= - match find_name_of_die_using_abstract_origin c d cu str die with - | Just name -> Just name - | Nothing -> - match mcupdie_spec with - | Just ((cu_spec,parents_spec,die_spec) as cupdie_spec) -> - find_name_of_die_using_abstract_origin c d cu_spec str die_spec - | Nothing -> - Nothing - end -end - -let find_reference_attribute_using_abstract_origin c d cu str an die : maybe (compilation_unit * (list die) * die)= - match find_attribute_value_using_abstract_origin c d cu str an die with - | Nothing -> Nothing - | Just (cu',av) -> - reference_of_reference_attribute_value c d cu' str av - end - -let find_DW_AT_type_of_die_using_abstract_origin c d cu str die : maybe (compilation_unit * (list die) * die)= - find_reference_attribute_using_abstract_origin c d cu str "DW_AT_type" die - -let find_flag_attribute_value_of_die_using_abstract_origin d (an: string) ((cu,parents,die):cupdie) : maybe bool= - let c = p_context_of_d d in - match find_attribute_value_using_abstract_origin c d cu d.d_str an die with - | Nothing -> Nothing - | Just (cu',av) -> - Just (bool_of_flag_attribute_value av) - end - - -(** compilation unit header: pp and parsing *) - -let pp_dwarf_format df= match df with Dwarf32 -> "(32-bit)" | Dwarf64 -> "(64-bit)" end - -let pp_unit_header (s:string) (x:compilation_unit_header) : string= - "**" ^ s ^ " Unit @ offset " ^ pphex x.cuh_offset ^ "\n" - ^ " " ^ s ^ " Unit @ offset " ^ pphex x.cuh_offset ^ ":\n" - ^ " Length: " ^ pphex x.cuh_unit_length ^ " " ^ pp_dwarf_format x.cuh_dwarf_format ^ "\n" - ^ " Version: " ^ show x.cuh_version ^ "\n" - ^ " Abbrev Offset: " ^ pphex x.cuh_debug_abbrev_offset ^ "\n" - ^ " Pointer Size: " ^ show x.cuh_address_size ^ "\n" - -let pp_compilation_unit_header (x:compilation_unit_header) : string= - pp_unit_header "Compilation" x - -let parse_unit_length c : parser (dwarf_format * natural)= - fun (pc: parse_context) -> - pr_bind (parse_uint32 c pc) (fun x pc' -> - let x = sym_unwrap x in - if x < natural_of_hex "0xfffffff0" then PR_success (Dwarf32,x) pc' - else if x <> natural_of_hex "0xffffffff" then PR_fail "bad unit_length" pc - else - pr_bind (parse_uint64 c pc') (fun x' pc'' -> - PR_success (Dwarf64, sym_unwrap x') pc')) - - -let parse_compilation_unit_header c : parser compilation_unit_header= - pr_post_map - (pr_with_pos - (parse_dependent_pair - (parse_unit_length c) - (fun (df,ul) -> - parse_triple - (parse_uint16 c) (* version *) - (parse_uintDwarfN c df) (* debug abbrev offset *) - (parse_uint8) (* address_size *)))) - (fun (offset,((df,ul), (v, (dao, as')))) -> - (*let _ = my_debug4 ("dao " ^ pphex dao) in *) - <| - cuh_offset = offset; - cuh_dwarf_format = df; - cuh_unit_length = ul; - cuh_version = (sym_unwrap v); - cuh_debug_abbrev_offset = (sym_unwrap dao); - cuh_address_size = (sym_unwrap as'); - |>) - - -(** type unit header: pp and parsing *) - -(* the test binaries don't have a .debug_types section, so this isn't tested *) - -let pp_type_unit_header (x:type_unit_header) : string= - pp_unit_header "Type" x.tuh_cuh - ^ " Type Signature: " ^ pphex x.tuh_type_signature ^ "\n" - ^ " Type Offset: " ^ pphex x.tuh_type_offset ^ "\n" - - -let parse_type_unit_header c : parser type_unit_header= - pr_post_map - (parse_dependent_pair - (parse_compilation_unit_header c) - (fun cuh -> - parse_pair - (parse_uint64 c) (* type signature *) - (parse_uintDwarfN c cuh.cuh_dwarf_format) (* type offset *) )) - (fun (cuh, (ts, to')) -> - <| - tuh_cuh = cuh; - tuh_type_signature = (sym_unwrap ts); - tuh_type_offset = (sym_unwrap to'); - |>) - - -(** debugging information entries: pp and parsing *) - -(* example pp from readelf - <2><51>: Abbrev Number: 3 (DW_TAG_variable) - <52> DW_AT_name : x - <54> DW_AT_decl_file : 1 - <55> DW_AT_decl_line : 2 - <56> DW_AT_type : <0x6a> - <5a> DW_AT_location : 2 byte block: 91 6c (DW_OP_fbreg: -20) -*) - - - - - - - -(** debugging information entries: pp and parsing *) - -let indent_level (indent: bool) (level: natural)= - if indent then - (toString (replicate (3 * level) #' ')) - else - " " -let indent_level_plus_one indent level= - if indent then - indent_level indent (level+1) - else - " "^" " - -let pp_die_attribute c (cuh:compilation_unit_header) (str : byte_sequence) (indent:bool) (level: natural) (((at: natural), (af: natural)), ((pos: natural),(av:attribute_value))) : string= - indent_level_plus_one indent level ^ pp_pos pos ^ " " - ^ right_space_padded_to 18 (pp_attribute_encoding at) ^ ": " - ^ - if indent then - "(" ^ pp_attribute_form_encoding af ^ ") " - ^ pp_attribute_value c cuh str at av - ^ "\n" - else - pp_attribute_value_like_objdump c cuh str at av - ^ "\n" - -val pp_die : p_context -> compilation_unit_header -> byte_sequence -> bool -> natural -> bool -> die -> string -let rec pp_die c cuh str indent level (pp_children:bool) die= - indent_level indent level ^ "<" ^ show level ^ ">" - ^ pp_pos die.die_offset - ^ ": Abbrev Number: " ^ show die.die_abbreviation_code - ^ " (" ^ pp_tag_encoding die.die_abbreviation_declaration.ad_tag ^")\n" - ^ - let ats = List.zip - die.die_abbreviation_declaration.ad_attribute_specifications - die.die_attribute_values in - (String.concat "" (List.map (pp_die_attribute c cuh str indent level) ats)) - ^ - if pp_children then String.concat "" (List.map (pp_die c cuh str indent (level +1) pp_children) die.die_children) else "" - -val pp_die_abbrev : p_context -> compilation_unit_header -> byte_sequence -> natural -> bool -> (list die) -> die -> string -let rec pp_die_abbrev c cuh str level (pp_children:bool) parents die= - indent_level true level - ^ pp_tag_encoding die.die_abbreviation_declaration.ad_tag - ^ " (" ^ pp_pos die.die_offset ^ ") " -(* ^ ": Abbrev Number: " ^ show die.die_abbreviation_code *) - ^ - (match find_name_of_die str die with Just s -> s | Nothing -> "-" end) - ^ " : " ^ String.concat " : " (List.map (fun die' -> pp_tag_encoding die'.die_abbreviation_declaration.ad_tag) parents) - ^ "\n" - ^ (*(String.concat "" (List.map (pp_die_abbrev_attribute c cuh str) ats))*) - - if pp_children then String.concat "" (List.map (pp_die_abbrev c cuh str (level +1) pp_children (die::parents)) die.die_children) else "" - - -(* condensed pp for variables *) -val pp_die_abbrev_var : p_context -> dwarf -> compilation_unit -> byte_sequence -> bool -> (list die) -> die -> (string (*name*) * string (*offset*) * string (*kind*)) -let rec pp_die_abbrev_var c d cu str (pp_children:bool) parents die= - (* (indent_level true level*) - (* ^ pp_tag_encoding die.die_abbreviation_declaration.ad_tag*) -(* ^ ": Abbrev Number: " ^ show die.die_abbreviation_code *) - ((match find_name_of_die_using_abstract_origin c d cu str die with - | Just s -> s - | Nothing -> "?" - end) - , - pp_pos die.die_offset, - (if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_variable" then "var" - else if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_formal_parameter" then "param" - else "other") - ) - -(* condensed pp for variable parents *) -val pp_die_abbrev_var_parent : p_context -> dwarf -> compilation_unit -> byte_sequence -> die -> string -let pp_die_abbrev_var_parent c d cu str die= - (* (indent_level true level*) - (* ^ pp_tag_encoding die.die_abbreviation_declaration.ad_tag*) -(* ^ ": Abbrev Number: " ^ show die.die_abbreviation_code *) - let name = (match find_name_of_die_using_abstract_origin c d cu str die with Just s -> s | Nothing -> "" end) in - let offset = pp_pos die.die_offset in - (if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_compile_unit" then name - else if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_subprogram" then name (*"subprogram"*) - else if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_inlined_subroutine" then name ^ "(inlined)" - else if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_lexical_block" then "block" - else name ^ "(" ^ pp_tag_encoding die.die_abbreviation_declaration.ad_tag ^ ")") - - - -val pp_die_abbrev_var_parents : p_context -> dwarf -> compilation_unit -> byte_sequence -> list die -> string -let pp_die_abbrev_var_parents c d cu str parents= - String.concat ":" (List.map (fun die -> pp_die_abbrev_var_parent c d cu str die) parents) - - - - (* ^ " : " ^ String.concat " : " (List.map (fun die' -> pp_tag_encoding die'.die_abbreviation_declaration.ad_tag) parents)*) - (* ^ "\n"*) -(* ^ (*(String.concat "" (List.map (pp_die_abbrev_attribute c cuh str) ats))*)*) - -(* if pp_children then String.concat "" (List.map (pp_die_abbrev c cuh str (level +1) pp_children (die::parents)) die.die_children) else ""*) - - - -val parse_die : p_context -> byte_sequence -> compilation_unit_header -> (natural->abbreviation_declaration) -> parser (maybe die) -let rec parse_die c str cuh find_abbreviation_declaration= - fun (pc: parse_context) -> - (* let _ = my_debug3 ("parse_die called at " ^ pp_parse_context pc ^ "\n") in *) - pr_bind (parse_ULEB128 pc) (fun abbreviation_code' pc' -> - let abbreviation_code = sym_unwrap abbreviation_code' in - if abbreviation_code = 0 then PR_success Nothing pc' - else - (* let _ = my_debug3 ("parse_die abbreviation code "^pphex abbreviation_code ^"\n") in *) - let ad = find_abbreviation_declaration abbreviation_code in - let attribute_value_parsers = List.map (fun (at,af) -> pr_with_pos (parser_of_attribute_form c cuh af)) ad.ad_attribute_specifications in - pr_bind (parse_parser_list attribute_value_parsers pc') (fun avs pc'' -> - -(* - let die_header = - <| - die_offset = pc.pc_offset; - die_abbreviation_code = abbreviation_code; - die_abbreviation_declaration = ad; - die_attribute_values = avs; - die_children = []; - |> in let _ = my_debug3 ("die_header " ^ pp_die cuh str true 999 die_header) in - *) - pr_bind - (if ad.ad_has_children then parse_list (parse_die c str cuh find_abbreviation_declaration) pc'' else pr_return [] pc'') - (fun dies pc''' -> - PR_success (Just ( let die = - <| - die_offset = pc.pc_offset; - die_abbreviation_code = abbreviation_code; - die_abbreviation_declaration = ad; - die_attribute_values = avs; - die_children = dies; - |> in - let _ = my_debug3 ("die entire " ^ pp_die c cuh str true 0 false die) in - die)) pc'''))) - -let has_attribute (an: string) (die: die) : bool= - List.elem - (attribute_encode an) - (List.map Tuple.fst die.die_abbreviation_declaration.ad_attribute_specifications) - - -(** compilation units: pp and parsing *) - -let pp_compilation_unit c (indent:bool) (debug_str_section_body: byte_sequence) cu= - "" -(* "*** compilation unit header ***\n"*) - ^ pp_compilation_unit_header cu.cu_header - ^ "\n*** compilation unit abbreviation table\n" - ^ pp_abbreviations_table cu.cu_abbreviations_table - ^ "\n" - ^ "*** compilation unit die tree\n" - ^ pp_die c cu.cu_header debug_str_section_body indent 0 true cu.cu_die - ^ "\n" - -let pp_compilation_units c (indent:bool) debug_string_section_body (compilation_units: list compilation_unit) : string= - String.concat "" (List.map (pp_compilation_unit c indent debug_string_section_body) compilation_units) - - -let pp_compilation_unit_abbrev c (debug_str_section_body: byte_sequence) cu= - pp_compilation_unit_header cu.cu_header -(* ^ pp_abbreviations_table cu.cu_abbreviations_table*) - ^ pp_die_abbrev c cu.cu_header debug_str_section_body 0 true [] cu.cu_die - -let pp_compilation_units_abbrev c debug_string_section_body (compilation_units: list compilation_unit) : string= - String.concat "" (List.map (pp_compilation_unit_abbrev c debug_string_section_body) compilation_units) - -val add_die_to_index : die_index -> list die -> die -> die_index -let rec add_die_to_index acc parents die= - let nacc : die_index = Map.insert die.die_offset (parents,die) acc in - List.foldl (fun acc ndie -> add_die_to_index acc (die::parents) ndie) nacc die.die_children - -let parse_compilation_unit c (debug_str_section_body: byte_sequence) (debug_abbrev_section_body: byte_sequence) : parser (maybe compilation_unit)= - fun (pc:parse_context) -> - - if Byte_sequence.length pc.pc_bytes = 0 then PR_success Nothing pc else - - let (cuh, pc') = - - match parse_compilation_unit_header c pc with - | PR_fail s pc' -> Assert_extra.failwith ("parse_cuh_header fail: " ^ pp_parse_fail s pc') - | PR_success cuh pc' -> (cuh,pc') - end in - -let _ = my_debug4 (pp_compilation_unit_header cuh) in - - if cuh.cuh_unit_length = 0 then PR_success Nothing pc' else - - let pc_abbrev = <|pc_bytes = match dropbytes cuh.cuh_debug_abbrev_offset debug_abbrev_section_body with Success bs -> bs | Fail _ -> Assert_extra.failwith "mydrop of debug_abbrev" end; pc_offset = cuh.cuh_debug_abbrev_offset |> in - - (* todo: this is reparsing the abbreviations table for each cu *) - let abbreviations_table = - match parse_abbreviations_table c pc_abbrev with - | PR_fail s pc_abbrev' -> Assert_extra.failwith ("parse_abbrevations_table fail: " ^ pp_parse_fail s pc_abbrev') - | PR_success at pc_abbrev' -> <| at_offset=pc_abbrev.pc_offset; at_table= at|> - end in - - (* let _ = my_debug4 (pp_abbreviations_table abbreviations_table) in *) - - let find_abbreviation_declaration (ac:natural) : abbreviation_declaration= - (* let _ = my_debug4 ("find_abbreviation_declaration "^pphex ac) in *) - myfindNonPure (fun ad -> ad.ad_abbreviation_code = ac) abbreviations_table.at_table in - - (* let _ = my_debug3 (pp_abbreviations_table abbreviations_table) in *) - - match parse_die c debug_str_section_body cuh find_abbreviation_declaration pc' with - | PR_fail s pc'' -> Assert_extra.failwith ("parse_die fail: " ^ pp_parse_fail s pc'') - | PR_success (Nothing) pc'' -> Assert_extra.failwith ("parse_die returned Nothing: " ^ pp_parse_context pc'') - | PR_success (Just die) pc'' -> - let cu = - <| - cu_header = cuh; - cu_abbreviations_table = abbreviations_table; - cu_die = die; - cu_index = add_die_to_index Map.empty [] die - |> in - PR_success (Just cu) pc'' - end - -let parse_compilation_units c (debug_str_section_body: byte_sequence) (debug_abbrev_section_body: byte_sequence): parser (list compilation_unit)= - - parse_list (parse_compilation_unit c debug_str_section_body debug_abbrev_section_body) - - -(** type units: pp and parsing *) - -let pp_type_unit c (debug_str_section_body: byte_sequence) tu= - pp_type_unit_header tu.tu_header - ^ pp_abbreviations_table tu.tu_abbreviations_table - ^ pp_die c tu.tu_header.tuh_cuh debug_str_section_body true 0 true tu.tu_die - -let pp_type_units c debug_string_section_body (type_units: list type_unit) : string= - String.concat "" (List.map (pp_type_unit c debug_string_section_body) type_units) - - -let parse_type_unit c (debug_str_section_body: byte_sequence) (debug_abbrev_section_body: byte_sequence) : parser (maybe type_unit)= - fun (pc:parse_context) -> - - if Byte_sequence.length pc.pc_bytes = 0 then PR_success Nothing pc else - - let (tuh, pc') = - match parse_type_unit_header c pc with - | PR_fail s pc' -> Assert_extra.failwith ("parse_tuh_header fail: " ^ pp_parse_fail s pc') - | PR_success tuh pc' -> (tuh,pc') - end in - - (* let _ = my_debug4 (pp_type_unit_header tuh) in *) - - let pc_abbrev = let n = tuh.tuh_cuh.cuh_debug_abbrev_offset in <|pc_bytes = match dropbytes n debug_abbrev_section_body with Success bs -> bs | Fail _ -> Assert_extra.failwith "mydrop of debug_abbrev" end; pc_offset = n |> in - - let abbreviations_table = - match parse_abbreviations_table c pc_abbrev with - | PR_fail s pc_abbrev' -> Assert_extra.failwith ("parse_abbrevations_table fail: " ^ pp_parse_fail s pc_abbrev') - | PR_success at pc_abbrev' -> <| at_offset=pc_abbrev.pc_offset; at_table= at|> - end in - - (* let _ = my_debug4 (pp_abbreviations_table abbreviations_table) in *) - - let find_abbreviation_declaration (ac:natural) : abbreviation_declaration= - (* let _ = my_debug4 ("find_abbreviation_declaration "^pphex ac) in *) - myfindNonPure (fun ad -> ad.ad_abbreviation_code = ac) abbreviations_table.at_table in - - (* let _ = my_debug3 (pp_abbreviations_table abbreviations_table) in *) - - match parse_die c debug_str_section_body tuh.tuh_cuh find_abbreviation_declaration pc' with - | PR_fail s pc'' -> Assert_extra.failwith ("parse_die fail: " ^ pp_parse_fail s pc'') - | PR_success (Nothing) pc'' -> Assert_extra.failwith ("parse_die returned Nothing: " ^ pp_parse_context pc'') - | PR_success (Just die) pc'' -> - let tu = - <| - tu_header = tuh; - tu_abbreviations_table = abbreviations_table; - tu_die = die; - |> in - PR_success (Just tu) pc'' - end - -let parse_type_units c (debug_str_section_body: byte_sequence) (debug_abbrev_section_body: byte_sequence): parser (list type_unit)= - - parse_list (parse_type_unit c debug_str_section_body debug_abbrev_section_body) - -(** location lists, pp and parsing *) - -(* readelf example -Contents of the .debug_loc section: - - Offset Begin End Expression - 00000000 0000000000400168 0000000000400174 (DW_OP_reg0 (r0)) - 00000000 0000000000400174 0000000000400184 (DW_OP_GNU_entry_value: (DW_OP_reg0 (r0)); DW_OP_stack_value) - 00000000 - 00000039 000000000040017c 0000000000400180 (DW_OP_lit1; DW_OP_stack_value) -*) - - - - -let pp_location_list_entry c (cuh:compilation_unit_header) (offset:natural) (x:location_list_entry) : string= - " " ^ pphex offset - ^ " " ^ pphex x.lle_beginning_address_offset - ^ " " ^ pphex x.lle_ending_address_offset - ^ " (" ^ parse_and_pp_operations c cuh x.lle_single_location_description ^")" - ^ "\n" - -let pp_base_address_selection_entry c (cuh:compilation_unit_header) (offset:natural) (x:base_address_selection_entry) : string= - " " ^ pphex offset - ^ " " ^ pphex_sym x.base_address - ^ "\n" - -let pp_location_list_item c (cuh: compilation_unit_header) (offset: natural) (x:location_list_item)= - match x with - | LLI_lle lle -> pp_location_list_entry c cuh offset lle - | LLI_base base -> pp_base_address_selection_entry c cuh offset base - end - -let pp_location_list c (cuh: compilation_unit_header) ((offset:natural), (llis: list location_list_item))= - String.concat "" (List.map (pp_location_list_item c cuh offset) llis) -(* ^ " " ^ pphex offset ^ " \n"*) - -let pp_loc c (cuh: compilation_unit_header) (lls: list location_list)= - " Offset Begin End Expression\n" - ^ String.concat "" (List.map (pp_location_list c cuh) lls) - -(* Note that this is just pp'ing the raw location list data - Section -3.1.1 says: The applicable base address of a location list entry is -determined by the closest preceding base address selection entry in -the same location list. If there is no such selection entry, then the -applicable base address defaults to the base address of the -compilation unit. That is handled by the interpret_location_list below *) - - - -let parse_location_list_item c (cuh: compilation_unit_header) : parser (maybe location_list_item)= - fun (pc:parse_context) -> - pr_bind - (parse_pair - (parse_uint_address_size c cuh.cuh_address_size) - (parse_uint_address_size c cuh.cuh_address_size) - pc) - (fun ((a1: sym_natural),(a2:sym_natural)) pc' -> - let a1 = sym_unwrap a1 in - (* let _ = my_debug4 ("offset="^pphex pc.pc_offset ^ " begin=" ^ pphex a1 ^ " end=" ^ pphex a2) in *) - if a1=0 && a2=Absolute 0 then - PR_success Nothing pc' - else if a1 = max_address cuh.cuh_address_size then - let x = LLI_base <| (*base_offset=pc.pc_offset;*) base_address=a2 |> in (* BUGFIX a1 -> a2 *) - PR_success (Just x (*(pc.pc_offset, x)*)) pc' - else - pr_bind (parse_uint16 c pc') (fun n pc'' -> - pr_post_map1 - (parse_n_bytes (sym_unwrap n) pc'') - (fun bs -> - let x = - LLI_lle <| - (*lle_offset = pc.pc_offset;*) - lle_beginning_address_offset = a1; - lle_ending_address_offset = (sym_unwrap a2); - lle_single_location_description = bs; - |> in - Just x (*(pc.pc_offset, x)*)) - ) - ) - -let parse_location_list c cuh : parser (maybe location_list)= - fun (pc: parse_context) -> - if Byte_sequence.length pc.pc_bytes = 0 then - PR_success Nothing pc - else - pr_post_map1 - (parse_list (parse_location_list_item c cuh) pc) - (fun llis -> (Just (pc.pc_offset, llis))) - -let parse_location_list_list c cuh : parser location_list_list= - parse_list (parse_location_list c cuh) - -let find_location_list dloc n : location_list= - myfindNonPure (fun (n',_)-> n'=n) dloc - (* fails if location list not found *) - -(* interpretation of a location list applies the base_address and LLI_base offsets to give a list indexed by concrete address ranges *) - -let rec interpret_location_list (base_address: sym_natural) (llis: list location_list_item) : list (sym_natural * sym_natural * single_location_description)= - match llis with - | [] -> [] - | LLI_base base::llis' -> interpret_location_list base.base_address llis' - | LLI_lle lle :: llis' -> (base_address+(Absolute lle.lle_beginning_address_offset), base_address+(Absolute lle.lle_ending_address_offset), lle.lle_single_location_description) :: interpret_location_list base_address llis' - end - - -(** range lists, pp and parsing *) - -(* example output from: aarch64-linux-gnu-objdump --dwarf=Ranges - -Contents of the .debug_ranges section: - - Offset Begin End - 00000000 00000000004000fc 0000000000400114 - 00000000 000000000040011c 0000000000400128 - 00000000 -... - 00000380 0000000000400598 000000000040059c - 00000380 00000000004005a0 00000000004005a4 - 00000380 00000000004005b4 00000000004005b8 - 00000380 00000000004005bc 00000000004005bc (start == end) - 00000380 00000000004005c0 00000000004005c4 - 00000380 - -*) - -let pp_range_list_entry c (cuh:compilation_unit_header) (offset:natural) (x:range_list_entry) : string= - " " ^ pphex offset - ^ " " ^ pphex x.rle_beginning_address_offset - ^ " " ^ pphex x.rle_ending_address_offset - ^ (if x.rle_beginning_address_offset = x.rle_ending_address_offset then " (start == end)" else "") - ^ "\n" - -let pp_range_list_item c (cuh: compilation_unit_header) (offset: natural) (x:range_list_item)= - match x with - | RLI_rle rle -> pp_range_list_entry c cuh offset rle - | RLI_base base -> pp_base_address_selection_entry c cuh offset base - end - -let pp_range_list c (cuh: compilation_unit_header) ((offset:natural), (rlis: list range_list_item))= - String.concat "" (List.map (pp_range_list_item c cuh offset) rlis) - ^ " " ^ pphex offset ^ " \n" - -let pp_ranges c (cuh: compilation_unit_header) (rls: list range_list)= - " Offset Begin End\n" - ^ String.concat "" (List.map (pp_range_list c cuh) rls) - -(* Note that this is just pp'ing the raw range list data - see also -the interpret_range_list below *) - - -let parse_range_list_item c (cuh: compilation_unit_header) : parser (maybe range_list_item)= - fun (pc:parse_context) -> - pr_bind - (parse_pair - (parse_uint_address_size c cuh.cuh_address_size) - (parse_uint_address_size c cuh.cuh_address_size) - pc) - (fun ((a1: sym_natural),(a2:sym_natural)) pc' -> - let a1 = sym_unwrap a1 in - (* let _ = my_debug4 ("offset="^pphex pc.pc_offset ^ " begin=" ^ pphex a1 ^ " end=" ^ pphex a2) in *) - if a1=0 && a2=(Absolute 0) then - PR_success Nothing pc' - else if a1 = max_address cuh.cuh_address_size then - let x = RLI_base <| base_address=a2 |> in - PR_success (Just x) pc' - else - let x = - RLI_rle <| - rle_beginning_address_offset = a1; - rle_ending_address_offset = (sym_unwrap a2); - |> in - PR_success (Just x (*(pc.pc_offset, x)*)) pc' - ) - -(* compiler output includes DW_AT_ranges attributes that point to proper suffixes of range lists. We support that by explicitly including each suffix - though one could be more efficient *) - -let rec expand_range_list_suffixes cuh (offset,(rlis: list range_list_item)) : list range_list= - match rlis with - | [] -> [] - | [rli] -> [(offset,rlis)] - | rli::rlis' -> (offset,rlis) :: expand_range_list_suffixes cuh ((offset + 2*cuh.cuh_address_size),rlis') - end - -let parse_range_list c cuh : parser (maybe (list range_list))= - fun (pc: parse_context) -> - if Byte_sequence.length pc.pc_bytes = 0 then - PR_success Nothing pc - else - pr_post_map1 - (parse_list (parse_range_list_item c cuh) pc) - (fun rlis -> (Just (expand_range_list_suffixes cuh (pc.pc_offset, rlis)))) - -let parse_range_list_list c cuh : parser range_list_list= - pr_map2 List.concat (parse_list (parse_range_list c cuh)) - -let find_range_list dranges n : maybe range_list= - List.find (fun (n',_)-> n'=n) dranges - (* fails if range list not found *) - -(* interpretation of a range list applies the base_address and RLI_base offsets to give a list of concrete address ranges *) - -let rec interpret_range_list (base_address: sym_natural) (rlis: list range_list_item) : list (sym_natural * sym_natural)= - match rlis with - | [] -> [] - | RLI_base base::rlis' -> interpret_range_list base.base_address rlis' - | RLI_rle rle :: rlis' -> (base_address+(Absolute rle.rle_beginning_address_offset), base_address+(Absolute rle.rle_ending_address_offset)) :: interpret_range_list base_address rlis' - end - -(** frame information, pp and parsing *) - -(* readelf example - -Contents of the .debug_frame section: - -00000000 0000000c ffffffff CIE - Version: 1 - Augmentation: "" - Code alignment factor: 4 - Data alignment factor: -8 - Return address column: 65 - - DW_CFA_def_cfa: r1 ofs 0 - -00000010 00000024 00000000 FDE cie=00000000 pc=100000b0..10000120 - DW_CFA_advance_loc: 8 to 100000b8 - DW_CFA_def_cfa_offset: 80 - DW_CFA_offset: r31 at cfa-8 - DW_CFA_advance_loc: 4 to 100000bc - DW_CFA_def_cfa_register: r31 - DW_CFA_advance_loc: 80 to 1000010c - DW_CFA_def_cfa: r1 ofs 0 - DW_CFA_nop - DW_CFA_nop - DW_CFA_nop - DW_CFA_nop - -00000038 00000024 00000000 FDE cie=00000000 pc=10000120..100001a4 - DW_CFA_advance_loc: 16 to 10000130 - DW_CFA_def_cfa_offset: 144 - DW_CFA_offset_extended_sf: r65 at cfa+16 - DW_CFA_offset: r31 at cfa-8 - DW_CFA_advance_loc: 4 to 10000134 - DW_CFA_def_cfa_register: r31 - DW_CFA_advance_loc: 84 to 10000188 - DW_CFA_def_cfa: r1 ofs 0 -*) - - - -let pp_cfa_address a= pphex_sym a -let pp_cfa_block b= ppbytes b -let pp_cfa_delta d= pphex_sym d -(*let pp_cfa_offset n = pphex n -let pp_cfa_register r = show r*) -let pp_cfa_sfoffset i= show i - -let pp_cfa_register r= "r"^show r (*TODO: arch-specific register names *) - -let pp_cfa_offset (i:integer)= if i=0 then "" else if i<0 then show i else "+" ^ show i - -let pp_cfa_rule (cr:cfa_rule) : string= - match cr with - | CR_undefined -> "u" - | CR_register r i -> pp_cfa_register r ^ pp_cfa_offset i - | CR_expression bs -> "exp" - end - -let pp_register_rule (rr:register_rule) : string= (*TODO make this more readelf-like *) - match rr with - | RR_undefined -> "u" - | RR_same_value -> "s" - | RR_offset i -> "c" ^ pp_cfa_offset i - | RR_val_offset i -> "val(c" ^ pp_cfa_offset i ^ ")" - | RR_register r -> pp_cfa_register r - | RR_expression bs -> "exp" - | RR_val_expression bs -> "val(exp)" - | RR_architectural -> "" - end - - - -let pp_call_frame_instruction i= - match i with - | DW_CFA_advance_loc d -> "DW_CFA_advance_loc" ^ " " ^ pp_cfa_delta d - | DW_CFA_offset r n -> "DW_CFA_offset" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_offset (integerFromSymNatural n) - | DW_CFA_restore r -> "DW_CFA_restore" ^ " " ^ pp_cfa_register r - | DW_CFA_nop -> "DW_CFA_nop" - | DW_CFA_set_loc a -> "DW_CFA_set_loc" ^ " " ^ pp_cfa_address a - | DW_CFA_advance_loc1 d -> "DW_CFA_advance_loc1" ^ " " ^ pp_cfa_delta d - | DW_CFA_advance_loc2 d -> "DW_CFA_advance_loc2" ^ " " ^ pp_cfa_delta d - | DW_CFA_advance_loc4 d -> "DW_CFA_advance_loc4" ^ " " ^ pp_cfa_delta d - | DW_CFA_offset_extended r n -> "DW_CFA_offset_extended" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_offset (integerFromSymNatural n) - | DW_CFA_restore_extended r -> "DW_CFA_restore_extended" ^ " " ^ pp_cfa_register r - | DW_CFA_undefined r -> "DW_CFA_undefined" ^ " " ^ pp_cfa_register r - | DW_CFA_same_value r -> "DW_CFA_same_value" ^ " " ^ pp_cfa_register r - | DW_CFA_register r1 r2 -> "DW_CFA_register" ^ " " ^ pp_cfa_register r1 ^ " " ^ pp_cfa_register r2 - | DW_CFA_remember_state -> "DW_CFA_remember_state" - | DW_CFA_restore_state -> "DW_CFA_restore_state" - | DW_CFA_def_cfa r n -> "DW_CFA_def_cfa" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_offset (integerFromSymNatural n) - | DW_CFA_def_cfa_register r -> "DW_CFA_def_cfa_register" ^ " " ^ pp_cfa_register r - | DW_CFA_def_cfa_offset n -> "DW_CFA_def_cfa_offset" ^ " " ^ pp_cfa_offset (integerFromSymNatural n) - | DW_CFA_def_cfa_expression b -> "DW_CFA_def_cfa_expression" ^ " " ^ pp_cfa_block b - | DW_CFA_expression r b -> "DW_CFA_expression" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_block b - | DW_CFA_offset_extended_sf r i -> "DW_CFA_offset_extended_sf" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_sfoffset i - | DW_CFA_def_cfa_sf r i -> "DW_CFA_def_cfa_sf" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_sfoffset i - | DW_CFA_def_cfa_offset_sf i -> "DW_CFA_def_cfa_offset_sf" ^ " " ^ pp_cfa_sfoffset i - | DW_CFA_val_offset r n -> "DW_CFA_val_offset" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_offset (integerFromSymNatural n) - | DW_CFA_val_offset_sf r i -> "DW_CFA_val_offset_sf" ^ pp_cfa_register r ^ " " ^ pp_cfa_sfoffset i - | DW_CFA_val_expression r b -> "DW_CFA_val_expression" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_block b - | DW_CFA_AARCH64_negate_ra_state -> "DW_CFA_AARCH64_negate_ra_state" - | DW_CFA_unknown bt -> "DW_CFA_unknown" ^ " " ^ show bt - end - -let pp_call_frame_instructions is= String.concat "" (List.map (fun i -> " " ^ pp_call_frame_instruction i ^ "\n") is) - - -let parser_of_call_frame_argument_type c cuh (cfat: call_frame_argument_type) : parser call_frame_argument_value= - match cfat with - | CFAT_address -> pr_map2 (fun n -> CFAV_address n) (parse_uint_address_size c cuh.cuh_address_size) - | CFAT_delta1 -> pr_map2 (fun n -> CFAV_delta n) (parse_uint8) - | CFAT_delta2 -> pr_map2 (fun n -> CFAV_delta n) (parse_uint16 c) - | CFAT_delta4 -> pr_map2 (fun n -> CFAV_delta n) (parse_uint32 c) - | CFAT_delta_ULEB128 -> pr_map2 (fun n -> CFAV_delta n) (parse_ULEB128) - | CFAT_offset -> pr_map2 (fun n -> CFAV_offset n) (parse_ULEB128) - | CFAT_sfoffset -> pr_map2 (fun n -> CFAV_sfoffset n) (parse_SLEB128) - | CFAT_register -> pr_map2 (fun n -> CFAV_register n) (parse_ULEB128) - | CFAT_block -> - (fun pc -> pr_bind (parse_ULEB128 pc) (fun n pc' -> - pr_map (fun bs -> CFAV_block bs) (parse_n_bytes (sym_unwrap n) pc'))) - end - -let parse_call_frame_instruction c cuh : parser (maybe call_frame_instruction)= - fun pc -> - match read_char pc.pc_bytes with - | Fail _ -> PR_success Nothing pc - | Success (b,bs') -> - let pc' = <| pc_bytes = bs'; pc_offset = pc.pc_offset + 1 |> in - let ch = unsigned_char_of_byte b in - let high_bits = unsigned_char_land ch (unsigned_char_of_natural 192) in - let low_bits = natural_of_unsigned_char (unsigned_char_land ch (unsigned_char_of_natural 63)) in - if high_bits = unsigned_char_of_natural 0 then - match lookup_abCde_de low_bits call_frame_instruction_encoding with - | Just ((args: list call_frame_argument_type), result) -> - let ps = List.map (parser_of_call_frame_argument_type c cuh) args in - let p = - pr_post_map - (parse_parser_list ps) - result in - match p pc' with - | PR_success (Just cfi) pc'' -> PR_success (Just cfi) pc'' - | PR_success (Nothing) pc'' -> Assert_extra.failwith "bad call frame instruction argument 1" - | PR_fail s pc'' -> Assert_extra.failwith "bad call frame instruction argument 2" - end - | Nothing -> - (*Assert_extra.failwith ("can't parse " ^ show b ^ " as call frame instruction")*) - PR_success (Just (DW_CFA_unknown b)) pc' - end - else - if high_bits = unsigned_char_of_natural 64 then - PR_success (Just (DW_CFA_advance_loc (Absolute low_bits))) pc' - else if high_bits = unsigned_char_of_natural 192 then - PR_success (Just (DW_CFA_restore (Absolute low_bits))) pc' - else - let p = parser_of_call_frame_argument_type c cuh CFAT_offset in - match p pc' with - | PR_success (CFAV_offset n) pc'' -> PR_success (Just (DW_CFA_offset (Absolute low_bits) n)) pc'' - | PR_success _ pc'' -> Assert_extra.failwith "bad call frame instruction argument 3" - | PR_fail s pc'' -> Assert_extra.failwith "bad call frame instruction argument 4" - end - end - -let parse_call_frame_instructions c cuh : parser (list call_frame_instruction)= - parse_list (parse_call_frame_instruction c cuh) - -val parse_and_pp_call_frame_instructions : p_context -> compilation_unit_header -> byte_sequence -> string -let parse_and_pp_call_frame_instructions c cuh bs= - let pc = <|pc_bytes = bs; pc_offset = 0 |> in - match parse_call_frame_instructions c cuh pc with - | PR_fail s pc' -> "parse_call_frame_instructions fail: " ^ pp_parse_fail s pc' - | PR_success is pc' -> - pp_call_frame_instructions is - ^ if Byte_sequence.length pc'.pc_bytes <> 0 then " Warning: extra non-parsed bytes" else "" - end - - - -let pp_call_frame_instructions' c cuh bs= - (* ppbytes bs ^ "\n" *) - parse_and_pp_call_frame_instructions c cuh bs - - - -let pp_cie c cuh cie= - pphex cie.cie_offset - ^ " " ^ pphex cie.cie_length - ^ " " ^ pphex cie.cie_id - ^ " CIE\n" - ^ " Version: " ^ show cie.cie_version ^ "\n" - ^ " Augmentation: \""^ show (string_of_byte_sequence cie.cie_augmentation) ^ "\"\n" - ^ " Code alignment factor: " ^ show cie.cie_code_alignment_factor ^ "\n" - ^ " Data alignment factor: " ^ show cie.cie_data_alignment_factor ^ "\n" - ^ " Return address column: " ^ show cie.cie_return_address_register ^ "\n" - ^ "\n" - ^ ppbytes cie.cie_initial_instructions_bytes ^ "\n" - ^ pp_call_frame_instructions cie.cie_initial_instructions - -(* cie_address_size: natural; (* not shown by readelf - must match compilation unit *)*) -(* cie_segment_size: natural; (* not shown by readelf *)*) -(* readelf says "Return address column", but the DWARF spec says "Return address register" *) - - -let pp_fde c cuh fde= - pphex fde.fde_offset - ^ " " ^ pphex fde.fde_length - ^ " " ^ pphex fde.fde_cie_pointer (* not what this field of readelf output is *) - ^ " FDE" - ^ " cie=" ^ pphex fde.fde_cie_pointer (* duplicated?? *) - ^ " pc=" ^ match fde.fde_initial_location_segment_selector with Nothing -> "" | Just segment_selector -> "("^pphex_sym segment_selector^")" end ^ pphex_sym fde.fde_initial_location_address ^ ".." ^ pphex_sym (fde.fde_initial_location_address + fde.fde_address_range) ^ "\n" - ^ ppbytes fde.fde_instructions_bytes ^ "\n" - ^ pp_call_frame_instructions fde.fde_instructions - -let pp_frame_info_element c cuh fie= - match fie with - | FIE_cie cie -> pp_cie c cuh cie - | FIE_fde fde -> pp_fde c cuh fde - end - -let pp_frame_info c cuh fi= - "Contents of the .debug_frame section:\n\n" - ^ String.concat "\n" (List.map (pp_frame_info_element c cuh) fi) - ^ "\n" - - - -let rec find_cie fi cie_id= - match fi with - | [] -> Assert_extra.failwith "find_cie: cie_id not found" - | FIE_fde _ :: fi' -> find_cie fi' cie_id - | FIE_cie cie :: fi' -> if cie_id = cie.cie_offset then cie else find_cie fi' cie_id - end - -let parse_initial_location c cuh mss mas' : parser ((maybe sym_natural) * sym_natural)= (*(segment selector and target address)*) - (* assume segment selector size is zero unless given explicitly. Probably we need to do something architecture-specific for earlier dwarf versions?*) - parse_pair - (parse_uint_segment_selector_size c (match mss with Just n -> n | Nothing -> 0 end)) - (parse_uint_address_size c (match mas' with Just n -> n | Nothing -> cuh.cuh_address_size end)) - - -let parse_call_frame_instruction_bytes offset' ul= - fun (pc: parse_context) -> - parse_n_bytes (ul - (pc.pc_offset - offset')) pc - -let parse_frame_info_element c cuh (fi: list frame_info_element) : parser frame_info_element= - parse_dependent - (pr_with_pos - (parse_dependent_pair - (parse_unit_length c) - (fun (df,ul) -> - pr_with_pos - (pr_post_map (parse_uintDwarfN c df) sym_unwrap) (* CIE_id (cie) or CIE_pointer (fde) *) - ))) - (fun (offset,((df,ul),(offset',cie_id))) -> - if (cie_id = - match df with - | Dwarf32 -> natural_of_hex "0xffffffff" - | Dwarf64 -> natural_of_hex "0xffffffffffffffff" - end) - then - (* parse cie *) - pr_post_map - (parse_pair - (parse_dependent_pair - (pr_post_map parse_uint8 sym_unwrap) (* version *) - (fun v -> - parse_triple - parse_string (* augmentation *) - (if v=4 || v=46 then pr_post_map parse_uint8 (fun i->Just (sym_unwrap i)) else pr_return Nothing) (* address_size *) - (if v=4 || v=46 then pr_post_map parse_uint8 (fun i->Just (sym_unwrap i)) else pr_return Nothing))) (* segment_size *) - (parse_quadruple - parse_ULEB128 (* code_alignment_factor *) - parse_SLEB128 (* data_alignment_factor *) - parse_ULEB128 (* return address register *) - (parse_call_frame_instruction_bytes offset' ul))) - (fun ( (v,(aug,(mas',mss))), (caf,(daf,(rar,bs))) ) -> - let pc = <|pc_bytes = bs; pc_offset = 0 |> in - match parse_call_frame_instructions c cuh pc with - | PR_success is _ -> - FIE_cie - ( - <| - cie_offset = offset; - cie_length = ul; - cie_id = cie_id; - cie_version = v; - cie_augmentation = aug; - cie_address_size = mas'; - cie_segment_size = mss; - cie_code_alignment_factor = caf; - cie_data_alignment_factor = daf; - cie_return_address_register = rar; - cie_initial_instructions_bytes = bs; - cie_initial_instructions = is; - |>) - | PR_fail s _ -> Assert_extra.failwith s - end - ) - - else - (* parse fde *) - let cie = find_cie fi cie_id in - (* let _ = my_debug4 (pp_cie c cuh cie) in *) - pr_post_map - (parse_triple - (parse_initial_location c cuh cie.cie_segment_size cie.cie_address_size) (*(segment selector and target address)*) - (parse_uint_address_size c (match cie.cie_address_size with Just n -> n | Nothing -> cuh.cuh_address_size end)) (* address_range (target address) *) - (parse_call_frame_instruction_bytes offset' ul) - ) - (fun ( (ss,adr), (ar, bs)) -> - let pc = <|pc_bytes = bs; pc_offset = 0 |> in - match parse_call_frame_instructions c cuh pc with - | PR_success is _ -> - FIE_fde - ( - <| - fde_offset = offset; - fde_length = ul; - fde_cie_pointer = cie_id; - fde_initial_location_segment_selector = ss; - fde_initial_location_address = adr; - fde_address_range = ar; - fde_instructions_bytes = bs; - fde_instructions = is; - |> ) - | PR_fail s _ -> Assert_extra.failwith s - end - ) - ) - -(* you can't even parse an fde without accessing the cie it refers to -(to determine the segment selector size). Gratuitous complexity or what? -Hence the following, which should be made more tail-recursive. *) - -val parse_dependent_list' : forall 'a. (list 'a -> parser 'a) -> list 'a -> parser (list 'a) -let rec parse_dependent_list' p1 acc= - fun pc -> - if Byte_sequence.length pc.pc_bytes = 0 then - PR_success (List.reverse acc) pc - else - pr_bind - (p1 acc pc) - (fun x pc' -> - parse_dependent_list' p1 (x::acc) pc') - -val parse_dependent_list : forall 'a. (list 'a -> parser 'a) -> parser (list 'a) -let parse_dependent_list p1= parse_dependent_list' p1 [] - - -let parse_frame_info c cuh : parser frame_info= - - parse_dependent_list (parse_frame_info_element c cuh) - - -(** line numbers .debug_line, pp and parsing *) - -let pp_line_number_file_entry lnfe= - "lnfe_path = " ^ string_of_byte_sequence lnfe.lnfe_path ^ "\n" -^ "lnfe_directory_index " ^ show lnfe.lnfe_directory_index ^ "\n" -^ "lnfe_last_modification = " ^ show lnfe.lnfe_last_modification ^ "\n" -^ "lnfe_length = " ^ show lnfe.lnfe_length ^ "\n" - - -let pp_line_number_header lnh= - "offset = " ^ pphex lnh.lnh_offset ^ "\n" -^ "dwarf_format = " ^ pp_dwarf_format lnh.lnh_dwarf_format ^ "\n" -^ "unit_length = " ^ show lnh.lnh_unit_length ^ "\n" -^ "version = " ^ show lnh.lnh_version ^ "\n" -^ "header_length = " ^ show lnh.lnh_header_length ^ "\n" -^ "minimum_instruction_length = " ^ show lnh.lnh_minimum_instruction_length ^ "\n" -^ "maximum_operations_per_instruction = " ^ show lnh.lnh_maximum_operations_per_instruction ^ "\n" -^ "default_is_stmt = " ^ show lnh.lnh_default_is_stmt ^ "\n" -^ "line_base = " ^ show lnh.lnh_line_base ^ "\n" -^ "line_range = " ^ show lnh.lnh_line_range ^ "\n" -^ "opcode_base = " ^ show lnh.lnh_opcode_base ^ "\n" -^ "standard_opcode_lengths = " ^ show lnh.lnh_standard_opcode_lengths ^ "\n" -^ "comp_dir = " ^ show lnh.lnh_comp_dir ^ "\n" -^ "include_directories = " ^ String.concat ", " (List.map string_of_byte_sequence lnh.lnh_include_directories) ^ "\n" -^ "file_entries = \n\n" ^ String.concat "\n" (List.map pp_line_number_file_entry lnh.lnh_file_entries) ^ "\n" - - -let pp_line_number_operation lno= - match lno with - | DW_LNS_copy -> "DW_LNS_copy" - | DW_LNS_advance_pc n -> "DW_LNS_advance_pc" ^ " " ^ show n - | DW_LNS_advance_line i -> "DW_LNS_advance_line" ^ " " ^ show i - | DW_LNS_set_file n -> "DW_LNS_set_file" ^ " " ^ show n - | DW_LNS_set_column n -> "DW_LNS_set_column" ^ " " ^ show n - | DW_LNS_negate_stmt -> "DW_LNS_negate_stmt" - | DW_LNS_set_basic_block -> "DW_LNS_set_basic_block" - | DW_LNS_const_add_pc -> "DW_LNS_const_add_pc" - | DW_LNS_fixed_advance_pc n -> "DW_LNS_fixed_advance_pc" ^ " " ^ show n - | DW_LNS_set_prologue_end -> "DW_LNS_set_prologue_end" - | DW_LNS_set_epilogue_begin -> "DW_LNS_set_epilogue_begin" - | DW_LNS_set_isa n -> "DW_LNS_set_isa" ^ " " ^ show n - | DW_LNE_end_sequence -> "DW_LNE_end_sequence" - | DW_LNE_set_address n -> "DW_LNE_set_address" ^ " " ^ pphex_sym n - | DW_LNE_define_file s n1 n2 n3 -> "DW_LNE_define_file" ^ " " ^ show s ^ " " ^ show n1 ^ " " ^ show n2 ^ " " ^ show n3 - | DW_LNE_set_discriminator n -> "DW_LNE_set_discriminator" ^ " " ^ show n - | DW_LN_special n -> "DW_LN_special" ^ " " ^ show n - end - -let pp_line_number_program lnp= - pp_line_number_header lnp.lnp_header - ^ "[" ^ String.concat ", " (List.map pp_line_number_operation lnp.lnp_operations) ^ "]\n" - - - -let parse_line_number_file_entry : parser (maybe line_number_file_entry)= - - parse_dependent - (parse_non_empty_string) - (fun ms -> - match ms with - | Nothing -> - pr_return Nothing - | Just s -> - pr_post_map - (parse_triple - parse_ULEB128 - parse_ULEB128 - parse_ULEB128 - ) - (fun (n1,(n2,n3)) -> - (Just - <| - lnfe_path = s; - lnfe_directory_index = n1; - lnfe_last_modification = n2; - lnfe_length = n3; - |> ) - ) - end - ) - -let parse_line_number_header c (comp_dir:maybe string) : parser line_number_header= - (parse_dependent - ((pr_with_pos - (parse_unit_length c) )) - (fun (pos,(df,ul)) -> - (* - parse_dependent_pair - (parse_pair - (parse_triple - (parse_uint16 c) (* version *) - (parse_uintDwarfN c df) (* header_length *) - (parse_uint8) (* minimum_instruction_length *) - (* (parse_uint8) (* maximum_operations_per_instruction NOT IN DWARF 2*)*) - ) - (parse_quadruple - (parse_uint8) (* default_is_stmt *) - (parse_sint8) (* line_base *) - (parse_uint8) (* line_range *) - (parse_uint8) (* opcode_base *) - )) - (fun ((v,(hl,(minil(*,maxopi*)))),(dis,(lb,(lr,ob)))) -> - - *) - (parse_dependent - (parse_dependent_pair - (pr_post_map (parse_uint16 c) sym_unwrap) (* version *) - (fun v -> - (parse_pair - (parse_triple - (pr_post_map (parse_uintDwarfN c df) sym_unwrap) (* header_length *) - (parse_uint8) (* minimum_instruction_length *) - (if v<4 then (* maximum_operations_per_instruction*)(* NOT IN DWARF 2 or 3; in DWARF 4*) - (parse_uint8_constant 1) - else - (parse_uint8) - )) - (parse_quadruple - (parse_uint8) (* default_is_stmt *) - (parse_sint8) (* line_base *) - (parse_uint8) (* line_range *) - (pr_post_map parse_uint8 sym_unwrap) (* opcode_base *) - )))) - (fun ((v,(((hl,(minil,maxopi))),(dis,(lb,(lr,ob)))))) -> - pr_post_map - (parse_triple - (pr_post_map (parse_n_bytes (ob-1)) (fun bs -> List.map natural_of_byte (byte_list_of_byte_sequence bs))) (* standard_opcode_lengths *) - ((*pr_return [[]]*) parse_list parse_non_empty_string) (* include_directories *) - (parse_list parse_line_number_file_entry) (* file names *) - ) - (fun (sols, (ids, fns)) -> - <| - lnh_offset = pos; - lnh_dwarf_format = df; - lnh_unit_length = ul; - lnh_version = v; - lnh_header_length = hl; - lnh_minimum_instruction_length = minil; - lnh_maximum_operations_per_instruction = maxopi; - lnh_default_is_stmt = (dis<>0); - lnh_line_base = lb; - lnh_line_range = lr; - lnh_opcode_base = ob; - lnh_standard_opcode_lengths = sols; - lnh_include_directories = ids; - lnh_file_entries = fns; - lnh_comp_dir = comp_dir; - |> - ) - ) - ) - ) - ) -let parser_of_line_number_argument_type c (cuh: compilation_unit_header) (lnat: line_number_argument_type) : parser line_number_argument_value= - match lnat with - | LNAT_address -> pr_map2 (fun n -> LNAV_address n) (parse_uint_address_size c cuh.cuh_address_size) - | LNAT_ULEB128 -> pr_map2 (fun n -> LNAV_ULEB128 n) (parse_ULEB128) - | LNAT_SLEB128 -> pr_map2 (fun i -> LNAV_SLEB128 i) (parse_SLEB128) - | LNAT_uint16 -> pr_map2 (fun n -> LNAV_uint16 n) (parse_uint16 c) - | LNAT_string -> pr_map2 (fun s -> LNAV_string s) (parse_string) - end - -let parse_line_number_operation c (cuh: compilation_unit_header) (lnh: line_number_header) : parser line_number_operation= - parse_dependent - (pr_post_map parse_uint8 sym_unwrap) - (fun opcode -> - if opcode=0 then - (* parse extended opcode *) - parse_dependent - (parse_pair - parse_ULEB128 - parse_uint8) - (fun (size,opcode') -> - match lookup_aBcd_acd opcode' line_number_extended_encodings with - | Just (_, arg_types, result) -> - let ps = List.map (parser_of_line_number_argument_type c cuh) arg_types in - parse_demaybe ("parse_line_number_operation fail") - (pr_post_map - (parse_parser_list ps) - result ) - | Nothing -> - Assert_extra.failwith ("parse_line_number_operation extended opcode not found: " ^ show opcode') - end) - (* it's not clear what the ULEB128 size field is for, as the extended opcides all seem to have well-defined sizes. perhaps there can be extra padding that needs to be absorbed? *) - else if opcode >= lnh.lnh_opcode_base then - (* parse special opcode *) - let adjusted_opcode = opcode - lnh.lnh_opcode_base in - pr_return (DW_LN_special adjusted_opcode) - else - (* parse standard opcode *) - match lookup_aBcd_acd opcode line_number_standard_encodings with - | Just (_, arg_types, result) -> - let ps = List.map (parser_of_line_number_argument_type c cuh) arg_types in - parse_demaybe ("parse_line_number_operation fail") - (pr_post_map - (parse_parser_list ps) - result) - | Nothing -> - Assert_extra.failwith ("parse_line_number_operation standard opcode not found: " ^ show opcode) - (* the standard_opcode_lengths machinery is intended to allow vendor specific extension instructions to be parsed and ignored, but here we couldn't usefully process such instructions in any case, so we just fail *) - end) - - -let parse_line_number_operations c (cuh:compilation_unit_header) (lnh:line_number_header) : parser (list line_number_operation)= - parse_list (parse_maybe (parse_line_number_operation c cuh lnh)) - - - (* assume operations start immediately after the header - not completely clear in DWARF whether the header_length is just an optimisation or whether it's intended to allow the operations to start later *) - (* line number operations have no no-op and no termination operation, so we have to cut down the available bytes to the right length *) - -let parse_line_number_program c (cuh:compilation_unit_header) (comp_dir:maybe string) : parser line_number_program= - parse_dependent - (parse_line_number_header c comp_dir) - (fun lnh -> - let byte_count_of_operations = - lnh.lnh_unit_length - (lnh.lnh_header_length + 2 + (match lnh.lnh_dwarf_format with Dwarf32 -> 4 | Dwarf64 -> 8 end)) in - pr_post_map - (parse_restrict_length - byte_count_of_operations - (parse_line_number_operations c cuh lnh) - ) - (fun ops -> - <| - lnp_header = lnh; - lnp_operations = ops; - |>) - ) - -(*TODO: this should use find_natural_attribute_value_of_die *) -let line_number_offset_of_compilation_unit c cu= - match find_attribute_value "DW_AT_stmt_list" cu.cu_die with - | Just (AV_sec_offset n) -> n - | Just (AV_block n bs) -> natural_of_bytes c.endianness bs - (* a 32-bit MIPS example used a 4-byte AV_block not AV_sec_offset *) - | Just _ -> (Assert_extra.failwith ("compilation unit DW_AT_stmt_list attribute was not an AV_sec_offset" ^ pp_compilation_unit_header cu.cu_header)) - | _ -> Assert_extra.failwith ("compilation unit did not have a DW_AT_stmt_list attribute\n" ^ pp_compilation_unit_header cu.cu_header ^ "\n") - end - -let line_number_program_of_compilation_unit d cu= - let c = p_context_of_d d in - let offset = line_number_offset_of_compilation_unit c cu in - match List.find (fun lnp -> lnp.lnp_header.lnh_offset = offset) d.d_line_info with - | Nothing -> Assert_extra.failwith "compilation unit line number offset not found" - | Just lnp ->lnp - end - -let filename d cu n= - let lnp = line_number_program_of_compilation_unit d cu in - if n=0 then Nothing else - match mynth (n - 1) lnp.lnp_header.lnh_file_entries with - | Just lnfe -> - Just (string_of_byte_sequence lnfe.lnfe_path) - | Nothing -> - Assert_extra.failwith ("line number file entry not found") - end - -let unpack_file_entry lnh file : unpacked_file_entry= - match mynth (file - 1) lnh.lnh_file_entries with - | Just lnfe -> - let directory = - if lnfe.lnfe_directory_index = 0 then - Nothing - else - match mynth (lnfe.lnfe_directory_index - 1) lnh.lnh_include_directories with - | Just d -> Just (string_of_byte_sequence d) - | Nothing -> Just "" - end - in - (lnh.lnh_comp_dir, directory, string_of_byte_sequence lnfe.lnfe_path) - | Nothing -> - (Nothing,Nothing,"") - end - - -let pp_ufe (((mcomp_dir,mdir,file) as ufe) : unpacked_file_entry) : string= - file - ^ " dir=" ^ match mdir with | Just s->s|Nothing->"" end - ^ " comp_dir=" ^ match mcomp_dir with | Just s->s|Nothing->"" end - -let pp_ud (((((mcomp_dir,mdir,file) as ufe) : unpacked_file_entry), (line:nat), (subprogram_name:string)) : unpacked_decl) : string= - file - ^ ":" ^ show line - ^ " " ^ subprogram_name - ^ " dir=" ^ match mdir with | Just s->s|Nothing->"" end - ^ " comp_dir=" ^ match mcomp_dir with | Just s->s|Nothing->"" end - - -let pp_ufe_brief (((mcomp_dir,mdir,file) as ufe) : unpacked_file_entry) : string= - file - (* - ^ " dir=" ^ match mdir with | Just s->s|Nothing->"" end - ^ " comp_dir=" ^ match mcomp_dir with | Just s->s|Nothing->"" end - *) - -let parse_line_number_info c str (d_line: byte_sequence) (cu: compilation_unit) : line_number_program= - let comp_dir = find_string_attribute_value_of_die "DW_AT_comp_dir" str cu.cu_die in - let f n= - let d_line' = match dropbytes n d_line with Success xs -> xs | Fail _ -> Assert_extra.failwith "parse_line_number_info drop" end in - let pc = <| pc_bytes = d_line'; pc_offset = n|> in - match parse_line_number_program c cu.cu_header comp_dir pc with - | PR_success lnp pc' -> - (*let _ = print_endline (pp_line_number_program lnp) in*) - lnp - | PR_fail s pc' -> Assert_extra.failwith ("parse_line_number_header failed: " ^ s) - end in - f (line_number_offset_of_compilation_unit c cu) - -let parse_line_number_infos c str debug_line_section_body compilation_units= - - List.map (parse_line_number_info c str debug_line_section_body) compilation_units - -let pp_line_info li= - - String.concat "\n" (List.map (pp_line_number_program) li) - - -(** all dwarf info: pp and parsing *) - -(* roughly matching objdump --dwarf=abbrev,info *) -let pp_dwarf_like_objdump d= - let c = p_context_of_d d in - "" - -(* ^ "\n*** compilation unit abbreviation table ***\n" *) - ^ "Contents of the .debug_abbrev section:\n\n" - ^ " Number TAG (0x0)\n" - ^ pp_abbreviations_tables d -(* ^ "\n*** compilation unit die tree ***\n"*) - -(* "\n************** .debug_info section - abbreviated *****************\n" - ^ pp_compilation_units_abbrev c d.d_str d.d_compilation_units - ^*) -(* ^"\n************** .debug_info section - full ************************\n"*) - ^ "\nContents of the .debug_info section:\n\n" - ^ pp_compilation_units c false (*false for no indent, like objdump; true for nice indent *) d.d_str d.d_compilation_units - - - -let pp_dwarf d= - let c = p_context_of_d d in - -(* "\n************** .debug_info section - abbreviated *****************\n" - ^ pp_compilation_units_abbrev c d.d_str d.d_compilation_units - ^*) "\n************** .debug_info section - full ************************\n" - ^ pp_compilation_units c true d.d_str d.d_compilation_units - ^ "\n************** .debug_loc section: location lists ****************\n" - ^ let (cuh_default : compilation_unit_header) = let cu = myhead d.d_compilation_units in cu.cu_header in - pp_loc c cuh_default d.d_loc - ^ "\n************** .debug_ranges section: range lists ****************\n" - ^ pp_ranges c cuh_default d.d_ranges - ^ "\n************** .debug_frame section: frame info ****************\n" - ^ pp_frame_info c cuh_default d.d_frame_info - ^ "\n************** .debug_line section: line number info ****************\n" - ^ pp_line_info d.d_line_info - - -(* TODO: don't use lists of bytes here! *) -let parse_dwarf c - (debug_info_section_body: byte_sequence) - (debug_abbrev_section_body: byte_sequence) - (debug_str_section_body: byte_sequence) - (debug_loc_section_body: byte_sequence) - (debug_ranges_section_body: byte_sequence) - (debug_frame_section_body: byte_sequence) - (debug_line_section_body: byte_sequence) - : dwarf= - - let pc_info = <|pc_bytes = debug_info_section_body; pc_offset = 0 |> in - - let compilation_units = - match parse_compilation_units c debug_str_section_body debug_abbrev_section_body pc_info with - | PR_fail s pc_info' -> Assert_extra.failwith ("parse_compilation_units: " ^ pp_parse_fail s pc_info') - | PR_success cus pc_info' -> cus - end in - - (*let _ = my_debug5 (pp_compilation_units c debug_str_section_body compilation_units) in*) - - -(* the DWARF4 spec doesn't seem to specify the address size used in the .debug_loc section, so we (hackishly) take it from the first compilation unit *) - let (cuh_default : compilation_unit_header) = let cu = myhead compilation_units in cu.cu_header in - - let pc_loc = <|pc_bytes = debug_loc_section_body; pc_offset = 0 |> in - - let loc = - match parse_location_list_list c cuh_default pc_loc with - | PR_fail s pc_info' -> Assert_extra.failwith ("parse_location_list: " ^ pp_parse_fail s pc_info') - | PR_success loc pc_loc' -> loc - end in - - let pc_ranges = <|pc_bytes = debug_ranges_section_body; pc_offset = 0 |> in - - let ranges = - match parse_range_list_list c cuh_default pc_ranges with - | PR_fail s pc_info' -> Assert_extra.failwith ("parse_range_list: " ^ pp_parse_fail s pc_info') - | PR_success r pc_loc' -> r - end in - - let pc_frame = <|pc_bytes = debug_frame_section_body; pc_offset = 0 |> in - - let fi = - (* let _ = my_debug5 ("debug_frame_section_body:\n" ^ ppbytes2 0 debug_frame_section_body) in *) - - match parse_frame_info c cuh_default pc_frame with - | PR_fail s pc_info' -> Assert_extra.failwith ("parse_frame_info: " ^ pp_parse_fail s pc_info') - | PR_success fi pc_loc' -> fi - end in - - let li = parse_line_number_infos c debug_str_section_body debug_line_section_body compilation_units in - - <| - d_endianness = c.endianness; - d_str = debug_str_section_body; - d_compilation_units = compilation_units; - d_type_units = []; - d_loc = loc; - d_ranges = ranges; - d_frame_info = fi; - d_line_info = li; - |> - -val extract_section_body : elf_file -> string -> bool -> p_context * sym_natural * byte_sequence -let extract_section_body (f:elf_file) (section_name:string) (strict: bool)= - let (en: Endianness.endianness) = - match f with - | ELF_File_32 f32 -> Elf_header.get_elf32_header_endianness f32.Elf_file.elf32_file_header - | ELF_File_64 f64 -> Elf_header.get_elf64_header_endianness f64.Elf_file.elf64_file_header - end in - let (c: p_context) = <| endianness = en |> in - match f with - | ELF_File_32 f32 -> - let sections = - List.filter - (fun x -> - x.Elf_interpreted_section.elf32_section_name_as_string = section_name - ) f32.elf32_file_interpreted_sections in - match sections with - | [section] -> - let section_addr = section.Elf_interpreted_section.elf32_section_addr in - let section_body = section.Elf_interpreted_section.elf32_section_body in - (* let _ = my_debug4 (section_name ^ (": \n" ^ (Elf_interpreted_section.string_of_elf32_interpreted_section section ^ "\n" - * ^ " body = " ^ ppbytes2 0 section_body ^ "\n"))) in *) - (c,section_addr,section_body) - | [] -> - if strict then - Assert_extra.failwith ("" ^ section_name ^ " section not present") - else - (c,0,Byte_sequence.empty) - | _ -> Assert_extra.failwith ("multiple " ^ section_name ^ " sections present") - end - - - | ELF_File_64 f64 -> - let sections = - List.filter - (fun x -> - x.Elf_interpreted_section.elf64_section_name_as_string = section_name - ) f64.elf64_file_interpreted_sections in - match sections with - | [section] -> - let section_addr = section.Elf_interpreted_section.elf64_section_addr in - let section_body = section.Elf_interpreted_section.elf64_section_body in - (c,section_addr,section_body) - | [] -> - if strict then - Assert_extra.failwith ("" ^ section_name ^ " section not present") - else - (c,0,Byte_sequence.empty) - | _ -> Assert_extra.failwith ("multiple " ^ section_name ^ " sections present") - end - end - -val extract_dwarf : elf_file -> maybe dwarf -let extract_dwarf f= - let (c, _, debug_info_section_body) = extract_section_body f ".debug_info" true in - let (c, _, debug_abbrev_section_body) = extract_section_body f ".debug_abbrev" false in - let (c, _, debug_str_section_body) = extract_section_body f ".debug_str" false in - let (c, _, debug_loc_section_body) = extract_section_body f ".debug_loc" false in - let (c, _, debug_ranges_section_body) = extract_section_body f ".debug_ranges" false in - let (c, _, debug_frame_section_body) = extract_section_body f ".debug_frame" false in - let (c, _, debug_line_section_body) = extract_section_body f ".debug_line" false in - - let d = parse_dwarf c debug_info_section_body debug_abbrev_section_body debug_str_section_body debug_loc_section_body debug_ranges_section_body debug_frame_section_body debug_line_section_body in - - Just d - -val extract_text : elf_file -> p_context * sym_natural * byte_sequence (* (p_context, elf32/64_section_addr, elf32/64_section_body) *) -let extract_text f= extract_section_body f ".text" true - - -(** ************************************************************ *) -(** ****** location evaluation ******************************** *) -(** ************************************************************ *) - - -(** pp of locations *) - -val pp_simple_location : simple_location -> string -let pp_simple_location sl= - match sl with - | SL_memory_address n -> pphex n - | SL_register n -> "reg" ^ show n - | SL_implicit bs -> "value: " ^ ppbytes bs - | SL_empty -> "" - end - -val pp_composite_location_piece : composite_location_piece -> string -let pp_composite_location_piece clp= - match clp with - | CLP_piece n sl -> "piece (" ^ show n ^ ") " ^ pp_simple_location sl - | CLP_bit_piece n1 n2 sl -> "bit_piece (" ^ show n1 ^ "," ^ show n2 ^ ") " ^ pp_simple_location sl - end - -val pp_single_location: single_location -> string -let pp_single_location sl= - match sl with - | SL_simple sl -> pp_simple_location sl - | SL_composite clps -> "composite: " ^ String.concat ", " (List.map pp_composite_location_piece clps) - end - - -(** evaluation of location expressions *) - -(* cf dwarflist, btw: https://fedorahosted.org/elfutils/wiki/DwarfLint?format=txt *) - -(* - -location description ::= -| single location description -| location list - -single location description ::= -| simple location description -| composite location description - -simple location description ::= -| memory location description : non-empty dwarf expr, value is address of all or part of object in memory -| register location description : single DW_OP_regN or DW_OP_regx, naming a register in which all the object is -| implicit location description : single DW_OP_implicit_value or a non-empty dwarf expr ending in DW_OP_stack_value, giving the value of all/part of object -| empty location description : an empty dwarf expr, indicating a part or all of an object that is not represented - -composite location description : a list of simple location descriptions, each followed by a DW_OP_piece or DW_OP_bitpiece - -(the simple location description can be a register location description: https://www.mail-archive.com/dwarf-discuss@lists.dwarfstd.org/msg00271.html) -(contradicting "A register location description must stand alone as the entire description of an object or a piece of an object.") - -location list entry : a list of address ranges (possibly overlapping), each with a single location description - -Dwarf expressions can include data-dependent control flow choices -(though we don't see that in the examples?), so we can't statically -determine which kind of single location description or simple location -description we have. We can distinguish: - -- empty -> simple.empty -- DW_OP_regN/DW_OP_regx -> simple.register -- DW_OP_implicit_value -> simple.implicit -- any of those followed by DW_OP_piece or DW_OP_bitpiece, perhaps followed by more composite parts -> composite part :: composite - -otherwise run to the end, or a DW_OP_stack_value at the end, or to -anything (except a DO_OP_regN/DW_OP_regx) followed by a -DW_OP_piece/DW_OP_bitpiece. Pfeh. - - -actually used in our examples (ignoring GNU extentions): - -DW_OP_addr literal -DW_OP_lit1 literal -DW_OP_const4u literal - -DW_OP_breg3 (r3) read register value and add offset - -DW_OP_and bitwise and -DW_OP_plus addition (mod whatever) - -DW_OP_deref_size -DW_OP_fbreg evaluate location description from DW_AT_frame_base attribute of the current function (which is DW_OP_call_frame_cfa in our examples) and add offset - -DW_OP_implicit_value the argument block is the actual value (not location) of the entity in question -DW_OP_stack_value use the value at top of stack as the actual value (not location) of the entity in question - -DW_OP_reg0 (r0)) read register value - -DW_OP_call_frame_cfa go off to 6.4 and pull info out of .debug_frame (possibly involving other location expressions) - -*) - - - -let initial_state= - <| - s_stack = []; - s_value = SL_empty; - s_location_pieces = []; -|> - -(* the main location expression evaluation function *) - -(* location expression evaluation is basically a recursive function -down a list of operations, maintaining an operation_stack (a list of -naturals representing machine-address-size words), the current -simple_location, and a list of any composite_location_piece's -accumulated so far *) - - - -let arithmetic_context_of_cuh cuh= - match cuh.cuh_address_size with - | 8 -> - <| - ac_bitwidth = 64; - ac_half = naturalPow 2 32; - ac_all = naturalPow 2 64; - ac_max = (naturalPow 2 64) - 1; - |> - | 4 -> - <| - ac_bitwidth = 32; - ac_half = naturalPow 2 16; - ac_all = naturalPow 2 32; - ac_max = (naturalPow 2 32) - 1; - |> - | _ -> Assert_extra.failwith "arithmetic_context_of_cuh given non-4/8 size" - end - -let find_cfa_table_row_for_pc (evaluated_frame_info: evaluated_frame_info) (pc: sym_natural) : cfa_table_row= - match - myfind - (fun (fde,rows) -> pc >= fde.fde_initial_location_address && pc < fde.fde_initial_location_address + fde.fde_address_range) - evaluated_frame_info - with - | Just (fde,rows) -> - match myfind (fun row -> pc >= row.ctr_loc) rows with - | Just row -> row - | Nothing -> Assert_extra.failwith "evaluate_cfa: no matchine row" - end - | Nothing -> Assert_extra.failwith "evaluate_cfa: no fde encloding pc" - end - - -let rec evaluate_operation_list (c:p_context) (dloc: location_list_list) (evaluated_frame_info: evaluated_frame_info) (cuh: compilation_unit_header) (ac: arithmetic_context) (ev: evaluation_context) (mfbloc: maybe attribute_value) (pc: sym_natural) (s: state) (ops: list operation) : error single_location= - - let push_memory_address v vs'= Success <| s with s_stack = v :: vs'; s_value = SL_memory_address v |> in - - let push_memory_address_maybe (mv: maybe sym_natural) vs' (err:string) op= - match mv with - | Just v -> push_memory_address v vs' - | Nothing -> Fail (err ^ pp_operation op) - end in - - let bregxi r i= - match ev.read_register r with - | RRR_result v -> push_memory_address (partialNaturalFromInteger ((integerFromSymNatural v+i) mod (integerFromSymNatural ac.ac_all))) s.s_stack - | RRR_not_currently_available -> Fail "RRR_not_currently_available" - | RRR_bad_register_number -> Fail ("RRR_bad_register_number " ^ show r) - end in - - let deref_size n= - match s.s_stack with - | v::vs' -> - match ev.read_memory v n with - | MRR_result v' -> push_memory_address v' vs' - | MRR_not_currently_available -> Fail "MRR_not_currently_available" - | MRR_bad_address -> Fail "MRR_bad_address" - end - | _ -> Fail "OpSem unary not given an element on stack" - end in - - match ops with - | [] -> - if s.s_location_pieces = [] then - Success (SL_simple s.s_value) - else if s.s_value = SL_empty then - Success (SL_composite s.s_location_pieces) - else - (* unclear what's supposed to happen in this case *) - Fail "unfinished part of composite expression" - - | op::ops' -> - let es' = - match (op.op_semantics, op.op_argument_values) with - | (OpSem_nop, []) -> - Success s - | (OpSem_lit, [OAV_natural n]) -> - push_memory_address n s.s_stack - | (OpSem_lit, [OAV_integer i]) -> - push_memory_address (partialTwosComplementNaturalFromInteger i ac.ac_half (integerFromSymNatural ac.ac_all)) s.s_stack - | (OpSem_stack f, []) -> - match f ac s.s_stack op.op_argument_values with - | Just stack' -> - let value' : simple_location = match stack' with [] -> SL_empty | v'::_ -> SL_memory_address v' end in - Success <| s with s_stack = stack'; s_value = value' |> - | Nothing -> Fail "OpSem_stack failed" - end - | (OpSem_not_supported, []) -> - Fail ("OpSem_not_supported: " ^ pp_operation op) - | (OpSem_binary f, []) -> - match s.s_stack with - | v1::v2::vs' -> push_memory_address_maybe (f ac v1 v2) vs' "OpSem_binary error: " op - | _ -> Fail "OpSem binary not given two elements on stack" - end - | (OpSem_unary f, []) -> - match s.s_stack with - | v1::vs' -> push_memory_address_maybe (f ac v1) vs' "OpSem_unary error: " op - | _ -> Fail "OpSem unary not given an element on stack" - end - | (OpSem_opcode_lit base, []) -> - if op.op_code >= base && op.op_code < base + 32 then - push_memory_address (op.op_code - base) s.s_stack - else - Fail "OpSem_opcode_lit opcode not within [base,base+32)" - | (OpSem_reg, []) -> - (* TODO: unclear whether this should push the register id or not *) - let r = op.op_code - vDW_OP_reg0 in - Success <| s with s_stack = r :: s.s_stack; s_value = SL_register r |> - | (OpSem_breg, [OAV_integer i]) -> - let r = op.op_code - vDW_OP_breg0 in - bregxi r i - | (OpSem_bregx, [OAV_natural r; OAV_integer i]) -> - bregxi r i - | (OpSem_deref, []) -> - deref_size cuh.cuh_address_size - | (OpSem_deref_size, [OAV_natural n]) -> - deref_size n - | (OpSem_fbreg, [OAV_integer i]) -> - match mfbloc with - | Just fbloc -> - (*let _ = my_debug5 ("OpSem_fbreg (" ^ show i ^ ")\n") in*) - match evaluate_location_description c dloc evaluated_frame_info cuh ac ev (*mfbloc*)Nothing pc fbloc with - (* what to do if the recursive call also uses fbreg? for now assume that's not allowed *) - | Success l -> - match l with - | SL_simple (SL_memory_address a) -> - (*let _ = my_debug5 ("OpSem_fbreg: a = "^ pphex a ^ "\n") in*) - let vi = ((integerFromSymNatural a) + i) mod (integerFromSymNatural ac.ac_all) in - (*let _ = my_debug5 ("OpSem_fbreg: v = "^ show vi ^ "\n") in*) - let v = partialNaturalFromInteger vi (*ac.ac_half (integerFromSymNatural ac.ac_all)*) in - push_memory_address v s.s_stack - | _ -> - Fail "OpSem_fbreg got a non-SL_simple (SL_memory_address _) result" - (* "The DW_OP_fbreg operation provides a signed LEB128 - offset from the address specified by the location - description in the DW_AT_frame_base attribute of the - current function. " - - so what to do if the location description returns a non-memory-address location? *) - end - | Fail e -> - Fail ("OpSem_fbreg failure: " ^ e) - end - | Nothing -> - Fail "OpSem_fbreg: no frame base location description given" - end - - | (OpSem_piece, [OAV_natural size_bytes]) -> - let piece = CLP_piece size_bytes s.s_value in - (* we allow a piece (or bit_piece) to be any simple_location, including implicit and stack values. Unclear if this is intended, esp. the latter *) - let stack' = [] in - let value' = SL_empty in - Success <| s_stack = stack'; s_value = value'; s_location_pieces = s.s_location_pieces ++ [piece] |> - | (OpSem_bit_piece, [OAV_natural size_bits; OAV_natural offset_bits]) -> - let piece = CLP_bit_piece size_bits offset_bits s.s_value in - let stack' = [] in - let value' = SL_empty in - Success <| s_stack = stack'; s_value = value'; s_location_pieces = s.s_location_pieces ++ [piece] |> - | (OpSem_implicit_value, [OAV_block size bs]) -> - let stack' = [] in - let value' = SL_implicit bs in - Success <| s with s_stack = stack'; s_value = value' |> - | (OpSem_stack_value, []) -> - (* "The DW_OP_stack_value operation terminates the expression." - does - this refer to just the subexpression, ie allowing a stack value to be - a piece of a composite location, or necessarily the whole expression? - Why does DW_OP_stack_value have this clause while DW_OP_implicit_value - does not? *) - (* why doesn't DW_OP_stack_value have a size argument? *) - match s.s_stack with - | v::vs' -> - let stack' = [] in - let value' = SL_implicit (bytes_of_natural c.endianness cuh.cuh_address_size v) in - Success <| s with s_stack = stack'; s_value = value' |> - - | _ -> Fail "OpSem_stack_value not given an element on stack" - end - | (OpSem_call_frame_cfa, []) -> - let row = find_cfa_table_row_for_pc evaluated_frame_info pc in - match row.ctr_cfa with - | CR_undefined -> - Assert_extra.failwith "evaluate_cfa of CR_undefined" - | CR_register r i -> - bregxi r i (* same behaviour as an OpSem_bregx *) - | CR_expression bs -> - Assert_extra.failwith "CR_expression" - (*TODO: fix result type - not this evaluate_location_description_bytes c dloc evaluated_frame_info cuh ac ev mfbloc pc bs*) - (* TODO: restrict allowed OpSem_* in that recursive call *) - end - | (_, _) -> - Fail ("bad OpSem invocation: op=" ^ pp_operation op ^ " arguments=" ^ String.concat "" (List.map pp_operation_argument_value op.op_argument_values)) - end - in - match es' with - | Success s' -> - evaluate_operation_list c dloc evaluated_frame_info cuh ac ev mfbloc pc s' ops' - | Fail e -> - Fail e - end - end - -and evaluate_location_description_bytes (c:p_context) (dloc: location_list_list) (evaluated_frame_info: evaluated_frame_info) (cuh: compilation_unit_header) (ac: arithmetic_context) (ev: evaluation_context) (mfbloc: maybe attribute_value) (pc: sym_natural) (bs: byte_sequence) : error single_location= - let parse_context = <|pc_bytes = bs; pc_offset = 0 |> in - match parse_operations c cuh parse_context with - | PR_fail s pc' -> Fail ("evaluate_location_description_bytes: parse_operations fail: " ^ pp_parse_fail s pc') - | PR_success ops pc' -> - if Byte_sequence.length pc'.pc_bytes <> 0 then - Fail "evaluate_location_description_bytes: extra non-parsed bytes" - else - evaluate_operation_list c dloc evaluated_frame_info cuh ac ev mfbloc pc initial_state ops - end - -and evaluate_location_description (c:p_context) (dloc: location_list_list) (evaluated_frame_info: evaluated_frame_info) (cuh: compilation_unit_header) (ac: arithmetic_context) (ev: evaluation_context) (mfbloc: maybe attribute_value) (pc: sym_natural) (loc:attribute_value) : error single_location= - match loc with - | AV_exprloc n bs -> - evaluate_location_description_bytes c dloc evaluated_frame_info cuh ac ev mfbloc pc bs - | AV_block n bs -> - evaluate_location_description_bytes c dloc evaluated_frame_info cuh ac ev mfbloc pc bs - | AV_sec_offset n -> - let location_list = find_location_list dloc n in - let (offset,(llis:list location_list_item)) = location_list in - let f (lli:location_list_item) : maybe single_location_description= - match lli with - | LLI_lle lle -> - if pc >= lle.lle_beginning_address_offset && pc < lle.lle_ending_address_offset then Just lle.lle_single_location_description else Nothing - | LLI_base _ -> - Nothing (* TODO: either refactor to do offset during parsing or update base offsets here. Should refactor to use "interpreted". *) - end in - match myfindmaybe f llis with - | Just bs -> - evaluate_location_description_bytes c dloc evaluated_frame_info cuh ac ev mfbloc pc bs - | Nothing -> - Fail "evaluate_location_description didn't find pc in location list ranges" - end - | _ -> Fail "evaluate_location_description av_location not understood" - end - - - - - -(** ************************************************************ *) -(** **** evaluation of frame information ********************** *) -(** ************************************************************ *) - -(** register maps *) - -val rrp_update : register_rule_map -> cfa_register -> register_rule -> register_rule_map -let rrp_update rrp r rr= (r,rr)::rrp - -val rrp_lookup : cfa_register -> register_rule_map -> register_rule -let rrp_lookup r rrp= - match List.lookup r rrp with - | Just rr -> rr - | Nothing -> RR_undefined - end - -val rrp_empty : register_rule_map -let rrp_empty= [] - - - -(** pp of evaluated cfa information from .debug_frame *) -(* readelf --debug-dump=frames-interp test/a.out - -Contents of the .eh_frame section: - -00000000 00000014 00000000 CIE "zR" cf=1 df=-8 ra=16 - LOC CFA ra -0000000000000000 rsp+8 c-8 - -00000018 00000024 0000001c FDE cie=00000000 pc=004003b0..004003d0 - LOC CFA ra -00000000004003b0 rsp+16 c-8 -00000000004003b6 rsp+24 c-8 -00000000004003c0 exp c-8 - -00000040 0000001c 00000044 FDE cie=00000000 pc=004004b4..004004ba - LOC CFA rbp ra -00000000004004b4 rsp+8 u c-8 -00000000004004b5 rsp+16 c-16 c-8 -00000000004004b8 rbp+16 c-16 c-8 -00000000004004b9 rsp+8 c-16 c-8 - -00000060 00000024 00000064 FDE cie=00000000 pc=004004c0..00400549 - LOC CFA rbx rbp r12 r13 r14 r15 ra -00000000004004c0 rsp+8 u u u u u u c-8 -00000000004004d1 rsp+8 u c-48 c-40 u u u c-8 -00000000004004f0 rsp+64 c-56 c-48 c-40 c-32 c-24 c-16 c-8 -0000000000400548 rsp+8 c-56 c-48 c-40 c-32 c-24 c-16 c-8 - -00000088 00000014 0000008c FDE cie=00000000 pc=00400550..00400552 - LOC CFA ra -0000000000400550 rsp+8 c-8 - -000000a0 ZERO terminator -*) - - - -val mytoList : forall 'a. SetType 'a => set 'a -> list 'a -declare ocaml target_rep function mytoList = `Pset.elements` - -let register_footprint_rrp (rrp: register_rule_map) : set cfa_register= - Set.fromList (List.map Tuple.fst rrp) - -let register_footprint (rows: list cfa_table_row) : list cfa_register= - mytoList (bigunionListMap (fun row -> register_footprint_rrp row.ctr_regs) rows) - - -val max_lengths : list (list string) -> list sym_natural -let rec max_lengths xss= - match xss with - | [] -> Assert_extra.failwith "max_lengths" - | xs::xss' -> - let lens = List.map (fun x -> naturalFromNat (String.stringLength x)) xs in - if xss' = [] then lens - else - let lens' = max_lengths xss' in - let z = List.zip lens lens' in - let lens'' = List.map (fun (l1,l2)-> max l1 l2) z in - lens'' - end - -let rec pad_row xs lens= - match (xs,lens) with - | ([],[]) -> [] - | ([x],[len]) -> [x] - | (x::((_::_) as xs'), len::((_::_) as lens')) -> right_space_padded_to len x :: pad_row xs' lens' - end - -let pad_rows (xss : list (list string)) : string= - match xss with - | [] -> "" - | _ -> - let lens = max_lengths xss in - String.concat "" (List.map (fun xs -> String.concat " " (pad_row xs lens) ^ "\n") xss) - end - -let pp_evaluated_fde (fde, (rows: list cfa_table_row)) : string= - let regs = register_footprint rows in - let header : list string = "LOC" :: "CFA" :: List.map pp_cfa_register regs in - let ppd_rows : list (list string) = - List.map (fun row -> pphex row.ctr_loc :: pp_cfa_rule row.ctr_cfa :: List.map (fun r -> pp_register_rule (rrp_lookup r row.ctr_regs)) regs) rows in - pad_rows (header :: ppd_rows) - -let semi_pp_evaluated_fde (fde, (rows: list cfa_table_row)) : list (sym_natural (*address*) * string (*cfa*) * list (string*string) (*register rules*) )= - let regs = register_footprint rows in - let ppd_rows = - List.map - (fun row -> - (row.ctr_loc, - pp_cfa_rule row.ctr_cfa, - List.map (fun r -> (pp_cfa_register r, pp_register_rule (rrp_lookup r row.ctr_regs))) regs)) - rows in - ppd_rows - -val semi_pp_evaluated_frame_info : evaluated_frame_info -> list (sym_natural (*address*) * string (*cfa*) * list (string*string) (*register rules*) ) -let semi_pp_evaluated_frame_info efi= - List.concat (List.map semi_pp_evaluated_fde efi) - - - -(** evaluation of cfa information from .debug_frame *) - -let evaluate_call_frame_instruction (fi: frame_info) (cie: cie) (state: cfa_state) (cfi: call_frame_instruction) : cfa_state= - - let create_row (loc: sym_natural)= - let row = <| state.cs_current_row with ctr_loc = loc |> in - <| state with cs_current_row = row; cs_previous_rows = state.cs_current_row::state.cs_previous_rows |> in - - let update_cfa (cr:cfa_rule)= - let row = <| state.cs_current_row with ctr_cfa = cr |> in - <| state with cs_current_row = row |> in - - let update_reg r rr= - let row = <| state.cs_current_row with ctr_regs = rrp_update state.cs_current_row.ctr_regs r rr |> in - <| state with cs_current_row = row |> in - - match cfi with - (* Row Creation Instructions *) - | DW_CFA_set_loc a -> - create_row a - | DW_CFA_advance_loc d -> - create_row (state.cs_current_row.ctr_loc + d * cie.cie_code_alignment_factor) - | DW_CFA_advance_loc1 d -> - create_row (state.cs_current_row.ctr_loc + d * cie.cie_code_alignment_factor) - | DW_CFA_advance_loc2 d -> - create_row (state.cs_current_row.ctr_loc + d * cie.cie_code_alignment_factor) - | DW_CFA_advance_loc4 d -> - create_row (state.cs_current_row.ctr_loc + d * cie.cie_code_alignment_factor) - - (* CFA Definition Instructions *) - | DW_CFA_def_cfa r n -> - update_cfa (CR_register r (integerFromSymNatural n)) - | DW_CFA_def_cfa_sf r i -> - update_cfa (CR_register r (i * cie.cie_data_alignment_factor)) - | DW_CFA_def_cfa_register r -> - match state.cs_current_row.ctr_cfa with - | CR_register r' i -> - update_cfa (CR_register r i) - | CR_undefined -> - (* FIXME: this is to handle a bug in riscv64-gcc. - gcc generates "DW_CFA_def_cfa_register: r2 (sp)" as the first instruction. - Dwarf5 documentation seems to suggest this is not valid. - We think what gcc meant to generate is "DW_CFA_def_cfa: r2 (sp) ofs 0" *) - update_cfa (CR_register r 0) - | CR_expression _ -> - Assert_extra.failwith "DW_CFA_def_cfa_register: current rule is CR_expression" - end - | DW_CFA_def_cfa_offset n -> - match state.cs_current_row.ctr_cfa with - | CR_register r i -> - update_cfa (CR_register r (integerFromSymNatural n)) - | _ -> Assert_extra.failwith "DW_CFA_def_cfa_offset: current rule is not CR_register" - end - | DW_CFA_def_cfa_offset_sf i -> - match state.cs_current_row.ctr_cfa with - | CR_register r i' -> - update_cfa (CR_register r (i' * cie.cie_data_alignment_factor)) - | _ -> Assert_extra.failwith "DW_CFA_def_cfa_offset_sf: current rule is not CR_register" - end - | DW_CFA_def_cfa_expression b -> - update_cfa (CR_expression b) - - (* Register Rule Instrutions *) - | DW_CFA_undefined r -> - update_reg r (RR_undefined) - | DW_CFA_same_value r -> - update_reg r (RR_same_value) - | DW_CFA_offset r n -> - update_reg r (RR_offset ((integerFromSymNatural n) * cie.cie_data_alignment_factor)) - | DW_CFA_offset_extended r n -> - update_reg r (RR_offset ((integerFromSymNatural n) * cie.cie_data_alignment_factor)) - | DW_CFA_offset_extended_sf r i -> - update_reg r (RR_offset (i * cie.cie_data_alignment_factor)) - | DW_CFA_val_offset r n -> - update_reg r (RR_val_offset ((integerFromSymNatural n) * cie.cie_data_alignment_factor)) - | DW_CFA_val_offset_sf r i -> - update_reg r (RR_val_offset (i * cie.cie_data_alignment_factor)) - | DW_CFA_register r1 r2 -> - update_reg r1 (RR_register r2) - | DW_CFA_expression r b -> - update_reg r (RR_expression b) - | DW_CFA_val_expression r b -> - update_reg r (RR_val_expression b) - | DW_CFA_restore r -> - update_reg r (rrp_lookup r state.cs_initial_instructions_row.ctr_regs) -(* RR_undefined if the lookup fails? *) - | DW_CFA_restore_extended r -> - update_reg r (rrp_lookup r state.cs_initial_instructions_row.ctr_regs) - -(* Row State Instructions *) -(* do these also push and restore the CFA rule? *) - | DW_CFA_remember_state -> - <| state with cs_row_stack = state.cs_current_row :: state.cs_row_stack |> - | DW_CFA_restore_state -> - match state.cs_row_stack with - | r::rs -> <| state with cs_current_row = r; cs_row_stack = rs |> - | [] -> Assert_extra.failwith "DW_CFA_restore_state: empty row stack" - end -(* Padding Instruction *) - | DW_CFA_nop -> - state - -(* DW_CFA_AARCH64_negate_ra_state Instruction *) - | DW_CFA_AARCH64_negate_ra_state -> - state - -(* Unknown *) - | DW_CFA_unknown b -> - Assert_extra.failwith ("evaluate_call_frame_instruction: DW_CFA_unknown " ^ show b) - - end - - - -let rec evaluate_call_frame_instructions (fi: frame_info) (cie: cie) (state: cfa_state) (cfis: list call_frame_instruction) : cfa_state= - match cfis with - | [] -> state - | cfi::cfis' -> - let state' = evaluate_call_frame_instruction fi cie state cfi in - evaluate_call_frame_instructions fi cie state' cfis' - end - - -let evaluate_fde (fi: frame_info) (fde:fde) : list cfa_table_row= - let cie = find_cie fi fde.fde_cie_pointer in - let final_location = fde.fde_initial_location_address + fde.fde_address_range in - let initial_cfa_state = - let initial_row = - <| - ctr_loc = fde.fde_initial_location_address; - ctr_cfa = CR_undefined; - ctr_regs = rrp_empty; - |> in - <| - cs_current_row = initial_row; - cs_previous_rows = []; - cs_initial_instructions_row = initial_row; - cs_row_stack = []; - |> - in - let state' = - evaluate_call_frame_instructions fi cie initial_cfa_state cie.cie_initial_instructions in - let initial_row' = state'.cs_current_row in - let state'' = <| initial_cfa_state with cs_current_row = initial_row'; cs_initial_instructions_row = initial_row' |> in - let state''' = - evaluate_call_frame_instructions fi cie (*final_location*) state'' fde.fde_instructions in - List.reverse (state'''.cs_current_row:: state'''.cs_previous_rows) - - - -val evaluate_frame_info : dwarf -> evaluated_frame_info -let evaluate_frame_info (d: dwarf) : evaluated_frame_info= - List.mapMaybe (fun fie -> match fie with FIE_fde fde -> Just (fde, (evaluate_fde d.d_frame_info fde)) | FIE_cie _ -> Nothing end) d.d_frame_info - -let pp_evaluated_frame_info (efi: evaluated_frame_info)= - String.concat "\n" (List.map pp_evaluated_fde efi) - - - - -(** ************************************************************ *) -(** ** pp of type info *) -(** ************************************************************ *) - -(* partial analysis and pp of type info - incomplete, but enough for some C code *) - -(* analyse top level of C type structure, without recursing into type subterms *) -let strict s x= - match x with - | Just y -> y - | Nothing -> - Assert_extra.failwith ("analyse_type_info_die strict failure on \n" ^ s () - ^ "\n") - end - - -let analyse_type_info_top c (d: dwarf) (r:bool(*recurse into members*)) (cupdie: cupdie) : c_type_top cupdie= - let (cu,parents,die) = cupdie in - let mname = find_name_of_die d.d_str die in - let mtyp = find_DW_AT_type_of_die c d cu d.d_str die in - let s ()= pp_die c cu.cu_header d.d_str true 0 false die in - - if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_base_type" then - let encoding = - let n = strict s (find_natural_attribute_value_of_die c "DW_AT_encoding" die) in - if not(List.any (fun (s,n')->n=n') base_type_attribute_encodings) then strict s Nothing else n in - (* TODO: handle user encodings correctly *) - let mbyte_size = find_natural_attribute_value_of_die c "DW_AT_byte_size" die in - CT_base cupdie (strict s mname) encoding mbyte_size - - else if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_pointer_type" then - CT_pointer cupdie mtyp - - else if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_const_type" then - CT_const cupdie mtyp - - else if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_volatile_type" then -(* CT_volatile cupdie (strict s mtyp')*) - (* TODO: this is a temporary hack, while we figure out what DW_TAG_volatile without a DW_AT_type is supposed to mean *) - match mtyp with - | Just typ -> CT_volatile cupdie typ - | Nothing -> CT_missing cupdie - end - - - else if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_restrict_type" then - CT_restrict cupdie (strict s mtyp) - - else if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_typedef" then - let decl = - <| - decl_file = Nothing; (* TODO *) - decl_line = Nothing; (* TODO *) - |> in - CT_typedef cupdie (strict s mname) (strict s mtyp) decl - - else if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_array_type" then - let dims = - let subranges = List.filter (fun die' -> die'.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_subrange_type") die.die_children in - List.map - (fun die' -> - (*WAS: let mcount = find_natural_attribute_value_of_die c "DW_AT_count" die' in*) - let mcount = - match find_attribute_value "DW_AT_count" die' with - | Nothing -> Nothing - | Just av -> - match maybe_natural_of_constant_attribute_value die' c av with - | Nothing -> Nothing - (* DWARF seems to sometimes use an AV_ref* attribute value for DW_AT_count, referring to a variable die, for a VLA length. In this case for the moment we will just forget the length information, which is what this clause does *) - | Just n -> Just n - end - end in - let msubrange_type = find_DW_AT_type_of_die c d cu d.d_str die' in - (mcount, msubrange_type)) - subranges in - CT_array cupdie (strict s mtyp) dims - - else if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_structure_type" || die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_union_type" then - let atk = if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_structure_type" then Atk_structure else Atk_union in - let mbyte_size = find_natural_attribute_value_of_die c "DW_AT_byte_size" die in - let decl = - (<| - decl_file = Nothing; (* TODO *) - decl_line = Nothing; (* TODO *) - |>) in - - let members = - if r then - let members_raw = List.filter (fun die' -> die'.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_member") die.die_children in - Just (List.map - (fun die' -> - let cupdie' = (cu,die::parents,die') in - let mname' = find_name_of_die d.d_str die' in - let typ' = strict s (find_DW_AT_type_of_die c d cu d.d_str die') in - let mdata_member_location' = - match atk with - | Atk_structure -> Just (strict s (find_natural_attribute_value_of_die c "DW_AT_data_member_location" die')) - | Atk_union -> (find_natural_attribute_value_of_die c "DW_AT_data_member_location" die') - end in - (cupdie',mname',typ',mdata_member_location')) - members_raw) - else - Nothing in - - CT_struct_union cupdie atk mname mbyte_size decl members - - else if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_enumeration_type" then - let mbyte_size = find_natural_attribute_value_of_die c "DW_AT_byte_size" die in - let decl = - <| - decl_file = Nothing; (* TODO *) - decl_line = Nothing; (* TODO *) - |> in - let members = - if r then - let members_raw = List.filter (fun die' -> die'.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_enumerator") die.die_children in - Just (List.map - (fun die' -> - let cupdie' = (cu,die::parents,die') in - let mname' = find_name_of_die d.d_str die' in - (*let _ = my_debug5 (s ()) in *) - let const_value = strict s (find_integer_attribute_value_of_die c "DW_AT_const_value" die') in (*let _ = my_debug5 "ok" in*) - (cupdie',mname',const_value)) - members_raw) - else - Nothing - in - - CT_enumeration cupdie mname mtyp mbyte_size decl members - - else if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_subroutine_type" then - - (* let prototyped = strict s (find_flag_attribute_value_of_die "DW_AT_prototyped" die) in*) - let prototyped = find_flag_attribute_value_of_die_default_false "DW_AT_prototyped" die in - - let mresult_type = mtyp in - - let parameter_types = - let parameter_types_raw = List.filter (fun die' -> die'.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_formal_parameter") die.die_children in - (List.map - (fun die' -> - let cupdie' = (cu,die::parents,die') in - let mname' = find_name_of_die d.d_str die' in - let typ' = strict s (find_DW_AT_type_of_die c d cu d.d_str die') in - typ') - parameter_types_raw) in - - let (variable_parameter_list: bool) = List.any (fun die' -> die'.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_unspecified_parameters") die.die_children in - - CT_subroutine cupdie prototyped mresult_type parameter_types variable_parameter_list - - else - - Assert_extra.failwith ("analyse_type_info_top didn't recognise tag: " ^ pphex die.die_abbreviation_declaration.ad_tag ^ " for DIE " ^ pp_cupdie3 cupdie) - - -let rec analyse_type_info_deep (d: dwarf) (r:bool(*recurse_into_members*)) cupdie : c_type= - let c = p_context_of_d d in - let (cu,parents,die) = cupdie in - let (typ:c_type_top cupdie) = analyse_type_info_top c (d: dwarf) r cupdie in - match typ with - | CT_missing cupdie -> CT (CT_missing cupdie) - | CT_base cupdie name encoding mbyte_size -> CT (CT_base cupdie name encoding mbyte_size) - | CT_pointer cupdie mtyp' -> CT (CT_pointer cupdie (Maybe.map (analyse_type_info_deep d r) mtyp')) - | CT_const cupdie mtyp' -> CT (CT_const cupdie (Maybe.map (analyse_type_info_deep d r) mtyp')) - | CT_volatile cupdie typ' -> CT (CT_volatile cupdie (analyse_type_info_deep d r typ')) - | CT_restrict cupdie typ' -> CT (CT_restrict cupdie (analyse_type_info_deep d r typ')) - | CT_typedef cupdie name typ' decl -> CT (CT_typedef cupdie name (analyse_type_info_deep d r typ') decl) - | CT_array cupdie typ' dims -> CT (CT_array cupdie (analyse_type_info_deep d r typ') - (List.map (fun (mcount,msubrange_typ) -> (mcount, (Maybe.map (analyse_type_info_deep d r) msubrange_typ))) dims)) - | CT_struct_union cupdie atk mname mbyte_size decl mmembers -> - CT (CT_struct_union cupdie atk mname mbyte_size decl (Maybe.map (fun members -> (List.map (fun ((cupdie,mname,typ,mdata_member_location) as am) -> (cupdie,mname,(analyse_type_info_deep d false typ),mdata_member_location))members)) mmembers)) - | CT_enumeration cupdie mname mtyp' mbyte_size decl mmembers -> - CT(CT_enumeration cupdie mname (Maybe.map (analyse_type_info_deep d r) mtyp') mbyte_size decl mmembers) - | CT_subroutine cupdie prototyped mresult_type parameter_types variable_parameter_list -> - CT (CT_subroutine cupdie prototyped (Maybe.map (analyse_type_info_deep d r) mresult_type) - (List.map (fun typ -> analyse_type_info_deep d r typ) parameter_types) variable_parameter_list) - end - -let find_DW_AT_type_of_die_deep d cupdie : maybe c_type= - let c = p_context_of_d d in - let (cu,parents,die) = cupdie in - match find_reference_attribute_of_die c d cu d.d_str "DW_AT_type" die with - | Nothing -> Nothing - | Just cupdie' -> - Just (analyse_type_info_deep d false cupdie') - end - -let find_DW_AT_type_of_die_deep_using_abstract_origin d cupdie : maybe c_type= - let c = p_context_of_d d in - let (cu,parents,die) = cupdie in - match find_reference_attribute_using_abstract_origin c d cu d.d_str "DW_AT_type" die with - | Nothing -> Nothing - | Just cupdie' -> - Just (analyse_type_info_deep d false cupdie') - end - - -(* analyse and pp C type structure, but without going into the definitions of struct_union or enumeration types *) -let pp_struct_union_type_kind atk= - match atk with - | Atk_structure -> "struct" - | Atk_union -> "union" - end - -let pp_mbyte_size mbyte_size= "size:" ^ match mbyte_size with | Just n -> show n | Nothing -> "?" end - -(* pp the top-level structure of a C type, omitting struct_union-type and enum member definitions*) -let pp_type_info_top (ppa:'a->string) (typ:c_type_top 'a) : string= - match typ with - | CT_missing cupdie -> "missing at " ^ pp_cupdie cupdie - | CT_base cupdie name encoding mbyte_size -> - name ^ " (base type, " ^ match lookup_aB_a encoding base_type_attribute_encodings with Just s -> s | Nothing -> show encoding end ^ " " ^ pp_mbyte_size mbyte_size ^ ")" - | CT_pointer cupdie mtyp' -> "pointer(" ^ match mtyp' with | Just typ' -> ppa typ' | Nothing -> "no type" end ^ ")" - | CT_const cupdie mtyp' -> "const(" ^ match mtyp' with Just typ'->ppa typ' | Nothing -> "no type" end ^ ")" - | CT_volatile cupdie typ' -> "volatile(" ^ ppa typ' ^ ")" - | CT_restrict cupdie typ' -> "restrict(" ^ ppa typ' ^ ")" - | CT_typedef cupdie name typ' decl -> "typedef("^name^"="^ppa typ' ^ ")" - | CT_array cupdie typ' dims -> - ppa typ' ^ String.concat "" (List.map (fun (mcount,msubrange_typ) -> "["^match mcount with | Just count -> show count | Nothing -> "no count" end ^"]") dims) - | CT_struct_union cupdie atk mname mbyte_size decl mmembers -> pp_struct_union_type_kind atk ^ " " ^ (match mname with | Just s -> s | Nothing -> "noname" end) ^ pp_cupdie cupdie - | CT_enumeration cupdie mname mtyp' mbyte_size decl mmembers -> "enum" ^ " " ^ (match mname with | Just s -> s | Nothing -> "noname" end) ^ pp_cupdie cupdie - | CT_subroutine cupdie prototyped mresult_type parameter_types variable_parameter_list -> - "subroutine(" ^ (if prototyped then "prototyped" else "not-prototyped") ^ " " ^ (match mresult_type with Nothing -> "no type" | Just result_type -> ppa result_type end) ^ "(" ^ String.concat "," ((List.map ppa parameter_types) ++ (if variable_parameter_list then ["..."] else [])) ^ ")" - end - - -let rec pp_type_info_deep (ctyp:c_type) : string= - let ppa = pp_type_info_deep in - match ctyp with - | CT typ -> - pp_type_info_top ppa typ - end - -let rec pp_type_info_die c (d: dwarf) cupdie : string= - let (typ:c_type_top cupdie) = analyse_type_info_top c (d: dwarf) false cupdie in - let ppa = pp_type_info_die c d in - pp_type_info_top ppa typ - - -let pp_struct_union_type_member c d (am:struct_union_member cupdie) : list string= - let (cupdie,mname,typ,mdata_member_location) = am in - [ " "; - (match mname with | Just s -> s | Nothing -> "noname" end); - " @ " ^ (match mdata_member_location with Nothing -> "nodatamemberlocation" | Just data_member_location -> show data_member_location end); - " : " ^ pp_type_info_die c d typ - ] - -let pp_struct_union_type_defn c d cupdie= - let (typ:c_type_top cupdie) = analyse_type_info_top c (d: dwarf) true cupdie in - match typ with - | CT_struct_union cupdie atk mname mbyte_size decl mmembers -> - (match mname with | Just s -> s | Nothing -> "noname" end) - ^ " " ^ pp_cupdie cupdie - ^ " " ^ pp_mbyte_size mbyte_size ^ "\n" - ^ pad_rows (match mmembers with Just members -> (List.map (pp_struct_union_type_member c d) members) | Nothing -> [] end) - | _ -> - Assert_extra.failwith "pp_struct_union_type_defn called on non-struct_union" - end - - -let pp_struct_union_type_member' (am:struct_union_member c_type) : list string= - let (cupdie,mname,ctyp,mdata_member_location) = am in - [ " "; - (match mname with | Just s -> s | Nothing -> "noname" end); - " @ " ^ (match mdata_member_location with Nothing -> "nodatamemberlocation" | Just data_member_location -> show data_member_location end); - " : " ^ pp_type_info_deep ctyp - ] - -let pp_enum_type_member' (em:enumeration_member) : list string= - let (cupdie,mname,const_value) = em in - [ " "; - (match mname with | Just s -> s | Nothing -> "noname" end); - " = " ^ show const_value - ] - -let pp_struct_union_type_defn' (ctyp: c_type) :string= - let preamble mname kind cupdie mbyte_size= - (match mname with | Just s -> s | Nothing -> "noname" end) - ^ " " ^ kind - ^ " " ^ pp_cupdie cupdie - ^ " " ^ pp_mbyte_size mbyte_size in - match ctyp with - | CT(CT_struct_union cupdie atk mname mbyte_size decl mmembers) -> - preamble mname (pp_struct_union_type_kind atk) cupdie mbyte_size ^ "\n" - ^ pad_rows (match mmembers with Just members -> (List.map (pp_struct_union_type_member') members) | Nothing -> [["warning: no members list"]] end) - | CT(CT_enumeration cupdie mname mtyp mbyte_size decl mmembers) -> - preamble mname "enum" cupdie mbyte_size - ^ " " ^ (match mtyp with Just typ -> pp_type_info_deep typ | Nothing -> "no representation type" end) - ^ "\n" - ^ pad_rows (match mmembers with Just members -> (List.map (pp_enum_type_member') members) | Nothing -> [["warning: no members list"]] end) - | _ -> - Assert_extra.failwith "pp_struct_union_type_defn called on non-struct_union" - end - - - -(* - match typ with - | CT_base cupdie name encoding mbyte_size -> - name ^ " (base type, " ^ match lookup_aB_a encoding base_type_attribute_encodings with Just s -> s | Nothing -> show encoding end ^ " " ^ pp_mbyte_size mbyte_size ^ ")" - | CT_pointer cupdie mtyp' -> "pointer(" ^ match mtyp' with | Just typ' -> pp_type_info_die c d typ' | Nothing -> "no type" end ^ ")" - | CT_const cupdie mtyp' -> "const(" ^ match mtyp' with Just typ'->pp_type_info_die c d typ' | Nothing -> "no type" end ^ ")" - | CT_volatile cupdie typ' -> "volatile(" ^ pp_type_info_die c d typ' ^ ")" - | CT_restrict cupdie typ' -> "restrict(" ^ pp_type_info_die c d typ' ^ ")" - | CT_typedef cupdie name typ' decl -> "typedef("^name^"="^pp_type_info_die c d typ' ^ ")" - | CT_array cupdie typ' dims -> - pp_type_info_die c d typ' ^ String.concat "" (List.map (fun (mcount,subrange_typ) -> "["^match mcount with | Just count -> show count | Nothing -> "no count" end ^"]") dims) - | CT_struct_union cupdie atk mname mbyte_size decl members -> pp_struct_union_type_kind atk ^ " " ^ (match mname with | Just s -> s | Nothing -> "noname" end) ^ pp_cupdie cupdie - | CT_enumeration cupdie mname mtyp' mbyte_size decl members -> "enum" ^ " " ^ (match mname with | Just s -> s | Nothing -> "noname" end) ^ pp_cupdie cupdie - end - *) - - -(* expect the die to have a DW_AT_type, and pp it *) - -let pp_type_info_die_DW_AT_type c (d: dwarf) cu str die= - match find_DW_AT_type_of_die_using_abstract_origin c d cu str die with - | Just (cu',parents',die') -> pp_type_info_die c (d: dwarf) (cu',parents',die') - | Nothing -> "DW_AT_abstract origin failed" - end - - - -let struct_union_enum_types (d:dwarf) : list c_type= - let cupdies = find_dies (fun die -> List.elem die.die_abbreviation_declaration.ad_tag [tag_encode "DW_TAG_structure_type"; tag_encode "DW_TAG_union_type"; tag_encode "DW_TAG_enumeration_type"]) d in - List.map (analyse_type_info_deep (d: dwarf) true) cupdies - - -(* -let pp_all_struct_union_enum_types c d : string = - String.concat "\n\n" (List.map ((fun (cu,parents,die) -> pp_struct_union_type_defn c d (cu,parents,die))) (struct_union_type_dies d)) - *) - -let pp_all_struct_union_enum_types' d : string= - let ctyps : list c_type = struct_union_enum_types d in - String.concat "" ((List.map pp_struct_union_type_defn') ctyps) - - - - -(** ************************************************************ *) -(** ** analysis of location and frame data for reverse mapping *) -(** ************************************************************ *) - -(** analysis *) - -(** simple-minded analysis of location *) - -let analyse_locations_raw c (d: dwarf)= - - let (cuh_default : compilation_unit_header) = let cu = myhead d.d_compilation_units in cu.cu_header in - - (* find all DW_TAG_variable and DW_TAG_formal_parameter dies with a DW_AT_name attribute *) - let tags = List.map tag_encode ["DW_TAG_variable"; "DW_TAG_formal_parameter"] in - let dies : list (compilation_unit * (list die) * die) = - find_dies - (fun die -> - List.elem die.die_abbreviation_declaration.ad_tag tags - && has_attribute "DW_AT_name" die) - d in - - String.concat "" - (List.map - (fun (cu,parents,die) -> - - let ats = List.zip - die.die_abbreviation_declaration.ad_attribute_specifications - die.die_attribute_values in - - let find_ats (s:string)= myfindNonPure (fun (((at: sym_natural), (af: sym_natural)), ((pos: sym_natural),(av:attribute_value))) -> attribute_encode s = at) ats in - - let ((_,_),(_,av_name)) = find_ats "DW_AT_name" in - - let name = - match av_name with - | AV_string bs -> string_of_byte_sequence bs - | AV_strp n -> pp_debug_str_entry d.d_str n - | _ -> "av_name AV not understood" - end in - - - let ((_,_),(_,av_location)) = find_ats "DW_AT_location" in - - let ppd_location = - match av_location with - | AV_exprloc n bs -> " "^parse_and_pp_operations c cuh_default bs^"\n" - | AV_block n bs -> " "^parse_and_pp_operations c cuh_default bs^"\n" - | AV_sec_offset n -> - let location_list = myfindNonPure (fun (n',_)-> n'=n) d.d_loc in - pp_location_list c cuh_default location_list - | _ -> "av_location AV not understood" - end in - - pp_tag_encoding die.die_abbreviation_declaration.ad_tag ^ " " ^ name ^ ":\n" ^ ppd_location ^ "\n" ) - - dies) - - -(** more proper analysis of locations *) - -(* TODO: handle this: -In a variable entry representing the definition of a variable (that is, with no -DW_AT_declaration attribute) if no location attribute is present, or if the location attribute is -present but has an empty location description (as described in Section 2.6), the variable is -assumed to exist in the source code but not in the executable program (but see number 10, -below). -In a variable entry representing a non-defining declaration of a variable, the location -specified modifies the location specified by the defining declaration and only applies for the -scope of the variable entry; if no location is specified, then the location specified in the -defining declaration applies. -The location of a variable may be further specified with a DW_AT_segment attribute, if -appropriate. -*) - - -(* -if there's a DW_AT_location that's a location list (DW_FORM_sec_offset/AV_sec_offset) : use that for both the range(s) and location; interpret the range(s) wrt the applicable base address of the compilation unit - -if there's a DW_AT_location that's a location expression (DW_FORM_exprloc/AV_exprloc or DW_block/AV_block), look for the closest enclosing range: - - DW_AT_low_pc (AV_addr) and no DW_AT_high_pc or DW_AT_ranges: just the singleton address - - DW_AT_low_pc (AV_addr) and DW_AT_high_pc (either an absolute AV_addr or an offset AV_constantN/AV_constant_SLEB128/AV_constantULEB128) : that range - - DW_AT_ranges (DW_FORM_sec_offset/AV_sec_offset) : get a range list from .debug_ranges; interpret wrt the applicable base address of the compilation unit - - for compilation units: a DW_AT_ranges together with a DW_AT_low_pc to specify the default base address to use in interpeting location and range lists - -DW_OP_fbreg in location expressions evaluate the DW_AT_frame_base of -the closest enclosing function - which is either a location expression -or a location list (what happens if the ranges of that location list -don't cover where we are?) - -For each variable and formal parameter that has a DW_AT_name, we'll calculate a list of pairs of a concrete (low,high) range and a location expression. -*) -let cu_base_address cu= - match find_attribute_value "DW_AT_low_pc" cu.cu_die with - | Just (AV_addr n) -> n - | _ -> 0 (*Nothing*) (*Assert_extra.failwith "no cu DW_AT_low_pc"*) - end - - - -let range_of_die c cuh str (dranges: range_list_list) (cu_base_address: sym_natural) (die: die) : maybe (list (sym_natural * sym_natural))= - match (find_attribute_value "DW_AT_low_pc" die, find_attribute_value "DW_AT_high_pc" die, find_attribute_value "DW_AT_ranges" die) with - | (Just (AV_addr n), Nothing, Nothing ) -> Just [(n,n+1)] (* unclear if this case is used? *) - | (Just (AV_addr n1), Just (AV_addr n2), Nothing ) -> Just [(n1,n2)] - | (Just (AV_addr n1), Just (AV_constant_ULEB128 n2), Nothing ) -> Just [(n1, n1+n2)] (* should be mod all? *) - | (Just (AV_addr n1), Just (AV_constant_SLEB128 i2), Nothing ) -> Just [(n1, naturalFromInteger (integerFromSymNatural n1 + i2))] (* should be mod all? *) - | (Just (AV_addr n1), Just (AV_constantN _ _), Nothing ) -> Assert_extra.failwith "AV_constantN in range_of_die" - - | (Just (AV_addr n1), Just (AV_block n bs), Nothing ) -> let n2 = natural_of_bytes c.endianness bs in Just [(n1, n1+n2)] (* should be mod all? *) (* signed or unsigned interp? *) - | (_, Nothing, Just (AV_sec_offset n)) -> - let rlis = Tuple.snd (match find_range_list dranges n with Just rlis->rlis | None -> Assert_extra.failwith ("find_range_list failed on AV_sec_offset n=" ^ show n ^ " for die\n" ^ pp_die c cuh str false 0 false die) end) in - let nns = interpret_range_list cu_base_address rlis in - Just nns - | (Nothing, Nothing, Nothing ) -> Nothing - | (_, _, _ ) -> Just [] (*Assert_extra.failwith "unexpected attribute values in closest_enclosing_range"*) -end - -let range_of_die_d (d:dwarf) cu (die: die) : maybe (list (sym_natural * sym_natural))= - let c = p_context_of_d d in - range_of_die c cu.cu_header d.d_str d.d_ranges (cu_base_address cu) die - -let entry_address (die:die) : maybe sym_natural= - match (find_attribute_value "DW_AT_low_pc" die, find_attribute_value "DW_AT_entry_pc" die) with - | (_, Just (AV_addr n)) -> Just n - | (Just (AV_addr n), _) -> Just n - | (Nothing,Nothing) -> Nothing - end - -let rec closest_enclosing_range c cuh str (dranges: range_list_list) (cu_base_address: sym_natural) (parents: list die) : maybe (list (sym_natural * sym_natural))= - match parents with - | [] -> Nothing - | die::parents' -> - match range_of_die c cuh str dranges cu_base_address die with - | ((Just x) as y) -> y - | Nothing -> - closest_enclosing_range c cuh str dranges cu_base_address parents' - end - end - -(* -If one of the DW_FORM_data forms is used to represent a signed or unsigned integer, it -can be hard for a consumer to discover the context necessary to determine which -interpretation is intended. Producers are therefore strongly encouraged to use -DW_FORM_sdata or DW_FORM_udata for signed and unsigned integers respectively, -rather than DW_FORM_data. -no kidding - if we get an AV_constantN for DW_AT_high_pc, should it be interpreted as signed or unsigned? *) - - -let rec closest_enclosing_frame_base dloc (base_address: sym_natural) (parents: list die) : maybe attribute_value= - match parents with - | [] -> Nothing - | die::parents' -> - match find_attribute_value "DW_AT_frame_base" die with - | Just av -> Just av - | Nothing -> closest_enclosing_frame_base dloc base_address parents' - end - end - - - - -let interpreted_location_of_die c cuh str (dloc: location_list_list) (dranges: range_list_list) (base_address: sym_natural) (parents: list die) (die: die) : maybe (list (sym_natural * sym_natural * single_location_description))= - - (* for a simple location expression bs, we look in the enclosing die - tree to find the associated pc range *) - let location bs= - match closest_enclosing_range c cuh str dranges base_address (die::parents) with - | Just nns -> - Just (List.map (fun (n1,n2) -> (n1,n2,bs)) nns) - | Nothing -> - (* if there is no such range, we take the full 0 - 0xfff.fff range*) - Just [(0,(arithmetic_context_of_cuh cuh).ac_max,bs)] - end in - - match find_attribute_value "DW_AT_location" die with - | Just (AV_exprloc n bs) -> location bs - | Just (AV_block n bs) -> location bs - (* while for a location list, we take the associated pc range from - each element of the list *) - | Just (AV_sec_offset n) -> - let (_,llis) = find_location_list dloc n in - Just (interpret_location_list base_address llis) - | Nothing -> Nothing - end - - - -val analyse_locations : dwarf -> analysed_location_data -let analyse_locations (d: dwarf) : analysed_location_data= - - let c = p_context_of_d d in - - (* let (cuh_default : compilation_unit_header) = let cu = myhead d.d_compilation_units in cu.cu_header in*) - - (* find all DW_TAG_variable and DW_TAG_formal_parameter dies with a DW_AT_location attribute and either a DW_AT_name or a DW_abstract_origin *) - (* (leaving formal parameters of inlined routines with a DW_AT_const_value to the future) *) - let tags = List.map tag_encode ["DW_TAG_variable"; "DW_TAG_formal_parameter"] in - let dies : list (compilation_unit * (list die) * die) = - find_dies - (fun die -> - List.elem die.die_abbreviation_declaration.ad_tag tags - && (has_attribute "DW_AT_name" die || has_attribute "DW_AT_abstract_origin" die) - && has_attribute "DW_AT_location" die) - d in - - List.map - (fun (((cu:compilation_unit), (parents: list die), (die: die)) as x) -> - let base_address = cu_base_address cu in - let interpreted_locations : maybe (list (sym_natural * sym_natural * single_location_description)) = - interpreted_location_of_die c cu.cu_header d.d_str d.d_loc d.d_ranges base_address parents die in - (x,interpreted_locations) - ) - dies - - - -let pp_analysed_locations1 c cuh (nnls: list (sym_natural * sym_natural * single_location_description)) : string= - String.concat "" - (List.map - (fun (n1,n2,bs) -> " " ^ pphex n1 ^ " " ^ pphex n2 ^ " " ^ parse_and_pp_operations c cuh bs) - nnls) - -let pp_analysed_locations2 c cuh mnnls= - match mnnls with - | Just nnls -> pp_analysed_locations1 c cuh nnls - | Nothing -> " " - end - - -(* -let pp_analysed_locations3 c d str (als: analysed_location_data) : string = - pad_rows - (List.map - (fun ((cu,parents,die),mnnls) -> - [" ";pp_die_abbrev_var c cu.cu_header str 0 false parents die - ^ pp_type_info_die_DW_AT_type c d cu cu.cu_header str die; - pp_analysed_locations2 c cu.cu_header mnnls] - ) - als - ) - -let pp_analysed_location_data (d: dwarf) (als: analysed_location_data) : string = - let c = p_context_of_d d in -(* let cu = myhead d.d_compilation_units in - let (cuh_default : compilation_unit_header) = cu.cu_header in - *) - pp_analysed_locations3 c (*HACK*) d d.d_str als - *) - - -let pp_analysed_locations3 c d str (removed:bool) (als: analysed_location_data) : list (bool(*removed?*) * (string(*name*) * string(*offset*) * string(*kind*)) * (unit->string)(*string*)(*type*) * string(*locations*) * (unit->string)(*parents*))= - List.map - (fun ((cu,parents,die1),mnnls) -> - (removed, - pp_die_abbrev_var c d cu str false parents die1, (*4.5s for only this*) - (fun () -> pp_type_info_die_DW_AT_type c d cu str die1), (*12.2s for this and above*) - pp_analysed_locations2 c cu.cu_header mnnls, (*12.4s for this and above*) - (fun () -> pp_die_abbrev_var_parents c d cu str parents)) (*14.4s for this and above*) - ) - als - -let pp_analysed_locations3_diff c d str (als_old: analysed_location_data) (als_new: analysed_location_data) : list (bool(*removed?*) * (string(*name*) * string(*offset*) * string(*kind*)) * (unit->string)(*type*) * string(*locations*) *(unit->string)(*parents*))= - (* maybe alpha sort these? *) - let ppd_old = pp_analysed_locations3 c d str true als_old in - let ppd_new = pp_analysed_locations3 c d str false als_new in - - (* the old entries that don't have a same-name new entry *) - let ppd_gone = List.filter (fun (removed,(name,offset,kind),typ,locs,parents) -> not (List.any (fun (removed',(name',offset',kind'),typ',locs',parents') -> name=name') ppd_new)) ppd_old in - - (* the new entries, each preceded by any same-name old entries (this will display strangely if there's any variable shadowing...) *) - let ppd_upd = - List.concat - (List.mapMaybe - (fun ((removed,((name,offset,kind) as y),typ,locs,parents) as x) -> - let same_name_old = (List.filter (fun (removed',(name',offset',kind'),typ',locs',parents') -> (name,offset)=(name',offset')) ppd_old) in - match same_name_old with - | [((removed',((name',offset',kind') as y'),typ',locs',parents') as x')] -> - if (y,(*typ,*)locs) = (y',(*typ',*)locs') then - Nothing - else - Just (same_name_old ++ [x]) - | _ -> - Just (same_name_old ++ [x]) - end) - ppd_new) in - - ppd_gone ++ ppd_upd - -let pp_analysed_location_format (xs : list (bool(*removed?*) * (string(*name*) * string(*offset*) * string(*kind*)) * (unit->string)(*string*)(*type*) * string(*locations*) * (unit->string)(*parents*)))= - pad_rows - (List.map - (fun ((removed,(name,offset,kind),typ,locs,parents) as x) -> - [ (if removed then "-" else " ") ^ name - ^ " (" ^ offset ^ "," ^ kind ^ ") " - ^ typ (); - locs; - parents ()] - ) - xs - ) - -let pp_analysed_location_data (d: dwarf) (als: analysed_location_data) : string= - let c = p_context_of_d d in -(* let cu = myhead d.d_compilation_units in - let (cuh_default : compilation_unit_header) = cu.cu_header in - *) - pp_analysed_location_format (pp_analysed_locations3 c (*HACK*) d d.d_str false als) - -let pp_analysed_location_data_diff (d: dwarf) (als_old: analysed_location_data) (als_new: analysed_location_data) : string= - let c = p_context_of_d d in -(* let cu = myhead d.d_compilation_units in - let (cuh_default : compilation_unit_header) = cu.cu_header in - *) - pp_analysed_location_format (pp_analysed_locations3_diff c (*HACK*) d d.d_str als_old als_new) - - - -let pp_analysed_location_data_at_pc (d: dwarf) (alspc: analysed_location_data_at_pc) : string= - String.concat "" (List.map - (fun ((cu,parents,die),(n1,n2,sld,esl)) -> - " " ^ - let name = - match find_name_of_die d.d_str die with - | Just s -> s - | Nothing -> "\n" - end in - match esl with - | Success sl -> - name ^ " @ " ^ pp_single_location sl ^"\n" - - | Fail e -> name ^ " @ " ^ "\n" - end - ) - alspc) - - - - -val analysed_locations_at_pc : evaluation_context -> dwarf_static -> sym_natural -> analysed_location_data_at_pc -let analysed_locations_at_pc - (ev) - (ds: dwarf_static) - (pc: sym_natural) - : analysed_location_data_at_pc= - - let c : p_context = (<| endianness = ds.ds_dwarf.d_endianness |>) in - - let xs = - List.mapMaybe - (fun (cupd,mnns) -> - match mnns with - | Nothing -> Nothing - | Just nns -> - let nns' = List.filter (fun (n1,n2,sld) -> pc >= n1 && pc < n2) nns in - match nns' with - | [] -> Nothing - | _ -> Just (cupd,nns') - end - end) - ds.ds_analysed_location_data - in - - List.concat - (List.map - (fun ((cu,parents,die),nns) -> - let ac = arithmetic_context_of_cuh cu.cu_header in - let base_address = cu_base_address cu in - let mfbloc : maybe attribute_value = - closest_enclosing_frame_base ds.ds_dwarf.d_loc base_address parents in - List.map - (fun (n1,n2,sld) -> - let el : error single_location = - evaluate_location_description_bytes c ds.ds_dwarf.d_loc ds.ds_evaluated_frame_info cu.cu_header ac ev mfbloc pc sld in - ((cu,parents,die),(n1,n2,sld,el)) - ) - nns - ) - xs) - -val names_of_address : dwarf -> analysed_location_data_at_pc -> sym_natural -> list string -let names_of_address - (d: dwarf) - (alspc: analysed_location_data_at_pc) - (address: sym_natural) - : list string= - - List.mapMaybe - (fun ((cu,parents,die),(n1,n2,sld,esl)) -> - match esl with - | Success (SL_simple (SL_memory_address a)) -> - if a=address then - match find_name_of_die d.d_str die with - | Just s -> Just s - | Nothing -> Nothing - end - else - Nothing - | Success _ -> Nothing (* just suppress? *) - | Fail e -> Nothing (* just suppress? *) - end - ) - alspc - - -val filtered_analysed_location_data : dwarf_static -> sym_natural -> analysed_location_data -let filtered_analysed_location_data ds pc= - List.mapMaybe - (fun (cupd,mnns) -> - match mnns with - | Nothing -> Nothing - | Just nns -> - let nns' = List.filter (fun (n1,n2,sld) -> pc >= n1 && pc < n2) nns in - match nns' with - | [] -> Nothing (*Just (cupd,Nothing)*) - | _::_ -> Just (cupd,Just nns') - end - end) - ds.ds_analysed_location_data - -(** ********************************************************************** *) -(** ** estimate source-file line extents of each (non-inlined) subprogram *) -(** ********************************************************************** *) - -(* The line number info associates source-file line numbers to - instruction addresses, but doesn't identify which subprogram those - line numbers come from. To recover that, we can use the - DW_TAG_subprogram die DW_AT_decl_file and DW_AT_decl_line info, - which gives the start of each subprogram. For C, function - definitions cannot be nested, so we can estimate their line-number - extents as from their start to the start of the next. Note that - this might be wrong if there are (eg) macro definitions between C - functions. Because of the lack of nesting, for C, just taking the - top-level DW_TAG_subprogram dies of each compilation unit should be - basically ok, and seems also to exclude inlined instances of - subprograms (which otherwise we could exclude by discarding any - with an abstract origin). However, those top-level subprograms are - not necessarily all from the "primary" file of the subprogram, and - conceivably some functions in the file might not be included in - that compilation unit but appear in another. We'll therefore take - all top-level subprograms from all compilation units, partition by - file (up to equality of (compilation directory, include directory, - and path)), and then sort. This assumes that the directory and - path strings from the line number info for different compilation - units are nicely comparable. - - We also have to identify the compilation unit referred to by a line - number file entry that's been reported from the line-number - info. The DW_TAG_compile_unit DW_AT_name appears to be the path - concatentation (inserting a "/", not just the string concatenation) - of the lnfe_directory_index's string and the lnfe_path of one the - lnfe's of the line number header pointed to by the compilation - unit's DW_AT_stmt_list, but not necessarily any particular such - lnfe.*) - - - -let subprogram_line_extents_compilation_unit d cu : list (string * unpacked_file_entry * sym_natural)= - let c = p_context_of_d d in - let subprogram_dies = List.filter (fun die' -> die'.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_subprogram") cu.cu_die.die_children in - - let lnp = line_number_program_of_compilation_unit d cu in - let lnh = lnp.lnp_header in - - List.mapMaybe - (fun die -> - match (find_name_of_die d.d_str die, - find_natural_attribute_value_of_die c "DW_AT_decl_file" die, - find_natural_attribute_value_of_die c "DW_AT_decl_line" die) with - | (Just name, Just file, Just line) -> - Just (name, unpack_file_entry lnh file, line) - | (_,_,_) -> - Nothing - end) - subprogram_dies - -(* lookup in an association list and also return the list with that entry (if any) removed *) -val extract : forall 'b 'c. Eq 'b => 'b -> list ('b * 'c) -> (maybe 'c) * list ('b * 'c) -let rec extract y yzs= - match yzs with - | [] -> (Nothing, []) - | (y',z')::yzs' -> - if y'=y then - (Just z', yzs') - else - let (result,yzs'') = extract y yzs' in - (result, (y',z')::yzs'') - end - -(* partition a list by the result of f, removing duplicates and sorting each partition by lt *) -val partitionby: forall 'a 'b. Eq 'a , Eq 'b => ('a -> 'b) -> ('a -> 'a -> bool) -> list 'a -> list ('b * list 'a) -> list ('b * list 'a) -let rec partitionby f lt xs acc= - match xs with - | [] -> acc - | x::xs' -> - let y = f x in - let (result, acc') = extract y acc in - let acc'' = - match result with - | Just xs'' -> - if List.elem x xs'' then acc else ((y, Sorting.insertBy lt x xs'')::acc') - | Nothing -> - (y,[x])::acc - end in - partitionby f lt xs' acc'' - end - -let subprogram_line_extents d : list (unpacked_file_entry * list (string * unpacked_file_entry * sym_natural) )= - let subprograms : list (string * unpacked_file_entry * sym_natural) = - List.concatMap (subprogram_line_extents_compilation_unit d) d.d_compilation_units in - partitionby (fun (name, ufe, line) -> ufe) (fun (name,ufe,line) -> fun (name',ufe',line') -> line < line') subprograms [] - -let pp_subprograms sles= - String.concat "\n" - (List.map - (fun (ufe,sles') -> - pp_ufe ufe ^ "\n" - ^ String.concat "" (List.map (fun (name, ufe, line) -> " " ^ show line ^ " " ^ name ^ "\n") sles')) - sles) - -let rec find_by_line line sles line_last name_last= - match sles with - | [] -> name_last - | (name',ufe',line') :: sles' -> - if line >= line_last && line < line' then name_last else find_by_line line sles' line' name' - end - -let subprogram_at_line subprogram_line_extents (ufe:unpacked_file_entry) (line:sym_natural) : string= - match List.lookup ufe subprogram_line_extents with - | Nothing -> "no matching unpacked_file_entry" - | Just sles -> find_by_line line sles 0 "file preamble" - end - - - - - -(** ************************************************************ *) -(** ** pull out subprograms *) -(** ************************************************************ *) -(* -val analyse_subprograms : dwarf -> analysed_location_data -let analyse_subprograms (d: dwarf) : analysed_location_data = - - let c = p_context_of_d d in - - let (cuh_default : compilation_unit_header) = let cu = myhead d.d_compilation_units in cu.cu_header in - - (* find all DW_TAG_subprogram dies *) - let tags = List.map tag_encode ["DW_TAG_subprogram"] in - let dies : list (compilation_unit * (list die) * die) = - find_dies - (fun die -> - List.elem die.die_abbreviation_declaration.ad_tag tags - && has_attribute "DW_AT_name" die - && has_attribute "DW_AT_location" die) - d in - - List.map - (fun (((cu:compilation_unit), (parents: list die), (die: die)) as x) -> - - let name = - match find_name_of_die d.d_str die with - | Just s -> s - | Nothing -> "\n" - end in - - let entry_point : maybe attribute_value = - match find_attribute_value "DW_AT_entry_pc" die with - | Nothing -> Nothing - | - - let base_address = cu_base_address cu in - let interpreted_locations : maybe (list (natural * natural * single_location_description)) = - interpreted_location_of_die c cuh_default d.d_loc d.d_ranges base_address parents die in - (x,interpreted_locations) - ) - dies - *) - - -(** ************************************************************ *) -(** ** evaluation of line-number info *) -(** ************************************************************ *) - -let initial_line_number_registers (lnh: line_number_header) : line_number_registers= - <| - lnr_address = 0; - lnr_op_index = 0; - lnr_file = 1; - lnr_line = 1; - lnr_column = 0; - lnr_is_stmt = lnh.lnh_default_is_stmt; - lnr_basic_block = false; - lnr_end_sequence = false; - lnr_prologue_end = false; - lnr_epilogue_begin = false; - lnr_isa = 0; - lnr_discriminator =0; - |> - -let evaluate_line_number_operation - (lnh: line_number_header) - ((s: line_number_registers), (lnrs: list line_number_registers)) - (lno: line_number_operation) - : line_number_registers * list line_number_registers= - - let new_address s operation_advance= (s.lnr_address + - lnh.lnh_minimum_instruction_length * - ((s.lnr_op_index + operation_advance)/lnh.lnh_maximum_operations_per_instruction)) mod (range_address 8) (* TODO: this should be taken from the compilation unit header address_size for DWARF<=4 or the line number header for DWARF5*) in - let new_op_index s operation_advance= - (s.lnr_op_index + operation_advance) mod lnh.lnh_maximum_operations_per_instruction in - - match lno with - | DW_LN_special adjusted_opcode -> - let operation_advance = adjusted_opcode / lnh.lnh_line_range in - let line_increment = lnh.lnh_line_base + integerFromSymNatural (adjusted_opcode mod lnh.lnh_line_range) in - let s' = - <| s with - lnr_line = partialNaturalFromInteger ((integerFromSymNatural s.lnr_line) + line_increment); - lnr_address = new_address s operation_advance; - lnr_op_index = new_op_index s operation_advance; - |> in - let lnrs' = s'::lnrs in - let s'' = - <| s' with - lnr_basic_block = false; - lnr_prologue_end = false; - lnr_epilogue_begin = false; - lnr_discriminator = 0; - |> in - (s'', lnrs') - | DW_LNS_copy -> - let lnrs' = s::lnrs in - let s' = - <| s with - lnr_basic_block = false; - lnr_prologue_end = false; - lnr_epilogue_begin = false; - lnr_discriminator = 0; - |> in - (s', lnrs') - | DW_LNS_advance_pc operation_advance -> - let s' = - <| s with - lnr_address = new_address s operation_advance; - lnr_op_index = new_op_index s operation_advance; - |> in - (s', lnrs) - | DW_LNS_advance_line line_increment -> - let s' = <| s with lnr_line = partialNaturalFromInteger ((integerFromSymNatural s.lnr_line) + line_increment) |> in (s', lnrs) - | DW_LNS_set_file n -> - let s' = <| s with lnr_file = n |> in (s', lnrs) - | DW_LNS_set_column n -> - let s' = <| s with lnr_column = n |> in (s', lnrs) - | DW_LNS_negate_stmt -> - let s' = <| s with lnr_is_stmt = not s.lnr_is_stmt |> in (s', lnrs) - | DW_LNS_set_basic_block -> - let s' = <| s with lnr_basic_block = true |> in (s', lnrs) - | DW_LNS_const_add_pc -> - let opcode = 255 in - let adjusted_opcode = opcode - lnh.lnh_opcode_base in - let operation_advance = adjusted_opcode / lnh.lnh_line_range in - let s' = - <| s with - lnr_address = new_address s operation_advance; - lnr_op_index = new_op_index s operation_advance; - |> in - (s', lnrs) - | DW_LNS_fixed_advance_pc n -> - let s' = - <| s with - lnr_address = s.lnr_address + n; - lnr_op_index = 0; - |> in - (s', lnrs) - | DW_LNS_set_prologue_end -> - let s' = <| s with lnr_prologue_end = true |> in (s', lnrs) - | DW_LNS_set_epilogue_begin -> - let s' = <| s with lnr_epilogue_begin = true |> in (s', lnrs) - | DW_LNS_set_isa n -> - let s' = <| s with lnr_isa = n |> in (s', lnrs) - | DW_LNE_end_sequence -> - let s' = <| s with lnr_end_sequence = true |> in - let lnrs' = s' :: lnrs in - let s'' = initial_line_number_registers lnh in - (s'', lnrs') - | DW_LNE_set_address n -> - let s' = - <| s with - lnr_address = n; - lnr_op_index = 0; - |> in - (s', lnrs) - | DW_LNE_define_file s n1 n2 n3 -> - Assert_extra.failwith "DW_LNE_define_file not implemented" (*TODO: add to file list in header - but why is this in the spec? *) - | DW_LNE_set_discriminator n -> - let s' = <| s with lnr_discriminator = n |> in (s', lnrs) - end - -let rec evaluate_line_number_operations - (lnh: line_number_header) - ((s: line_number_registers), (lnrs: list line_number_registers)) - (lnos: list line_number_operation) - : line_number_registers * list line_number_registers= - match lnos with - | [] -> (s,lnrs) - | lno :: lnos' -> - let (s',lnrs') = - evaluate_line_number_operation lnh (s,lnrs) lno in - evaluate_line_number_operations lnh (s',lnrs') lnos' - end - -let evaluate_line_number_program - (lnp:line_number_program) - : list line_number_registers= - List.reverse (Tuple.snd (evaluate_line_number_operations lnp.lnp_header ((initial_line_number_registers lnp.lnp_header),[]) lnp.lnp_operations)) - - -let evaluated_line_info_of_compilation_unit d cu evaluated_line_info= - let c = p_context_of_d d in - let offset = line_number_offset_of_compilation_unit c cu in - match List.find (fun (lnh,lnrs) -> lnh.lnh_offset = offset) evaluated_line_info with - | Nothing -> Assert_extra.failwith "compilation unit line number offset not found" - | Just (lnh,lnrs) ->lnrs - end - - -let pp_line_number_registers lnr= - "" - ^ "address = " ^ pphex lnr.lnr_address ^ "\n" - ^ "op_index = " ^ show lnr.lnr_op_index ^ "\n" - ^ "file = " ^ show lnr.lnr_file ^ "\n" - ^ "line = " ^ show lnr.lnr_line ^ "\n" - ^ "column = " ^ show lnr.lnr_column ^ "\n" - ^ "is_stmt = " ^ show lnr.lnr_is_stmt ^ "\n" - ^ "basic_block = " ^ show lnr.lnr_basic_block ^ "\n" - ^ "end_sequence = " ^ show lnr.lnr_end_sequence ^ "\n" - ^ "prologue_end = " ^ show lnr.lnr_prologue_end ^ "\n" - ^ "epilogue_begin = " ^ show lnr.lnr_epilogue_begin ^ "\n" - ^ "isa = " ^ show lnr.lnr_isa ^ "\n" - ^ "discriminator = " ^ pphex lnr.lnr_discriminator ^ "\n" - -let pp_line_number_registers_tight lnr : list string= - [ - pphex lnr.lnr_address ; - show lnr.lnr_op_index ; - show lnr.lnr_file ; - show lnr.lnr_line ; - show lnr.lnr_column ; - show lnr.lnr_is_stmt ; - show lnr.lnr_basic_block ; - show lnr.lnr_end_sequence ; - show lnr.lnr_prologue_end ; - show lnr.lnr_epilogue_begin ; - show lnr.lnr_isa ; - pphex lnr.lnr_discriminator - ] - -let pp_line_number_registerss lnrs= - pad_rows - ( - ["address"; "op_index"; "file"; "line"; "column"; "is_stmt"; "basic_block"; "end_sequence"; "prologue_end"; "epilogue_begin"; "isa"; "discriminator"] - :: - (List.map pp_line_number_registers_tight lnrs) - ) - -let pp_evaluated_line_info (eli: evaluated_line_info) : string= - String.concat "\n" (List.map (fun (lnh,lnrs) -> pp_line_number_header lnh ^ "\n" ^ pp_line_number_registerss lnrs) eli) - -(* readef example: -Decoded dump of debug contents of section .debug_line: - -CU: /var/local/stephen/work/devel/rsem/ppcmem2/system/tests-adhoc/simple-malloc/test-concurrent.c: -File name Line number Starting address -test-concurrent.c 11 0x400144 - -test-concurrent.c 12 0x40014c -test-concurrent.c 13 0x400154 -test-concurrent.c 14 0x400158 -test-concurrent.c 17 0x400160 - -/var/local/stephen/work/devel/rsem/ppcmem2/system/tests-adhoc/simple-malloc/../thread_start_aarch64.h: -thread_start_aarch64.h 34 0x400168 -thread_start_aarch64.h 36 0x400174 - -/var/local/stephen/work/devel/rsem/ppcmem2/system/tests-adhoc/simple-malloc/test-concurrent.c: -test-concurrent.c 19 0x400174 - -test-concurrent.c 20 0x40017c -test-concurrent.c 22 0x400180 - -CU: /var/local/stephen/work/devel/rsem/ppcmem2/system/tests-adhoc/simple-malloc/malloc.c: -... -*) - - - -let source_lines_of_address (ds:dwarf_static) (a: sym_natural) : list ( unpacked_file_entry * sym_natural * line_number_registers * string (*function*))= - List.concat - (List.map - (fun (lnh, lnrs) -> - myfiltermaybe - (fun lnr -> - if a = lnr.lnr_address && not lnr.lnr_end_sequence then - Just (unpack_file_entry lnh lnr.lnr_file, lnr.lnr_line, lnr, subprogram_at_line ds.ds_subprogram_line_extents (unpack_file_entry lnh lnr.lnr_file) lnr.lnr_line) - else - Nothing) - lnrs - ) - ds.ds_evaluated_line_info - ) - - - - -(** ************************************************************ *) -(** ** collecting all the statically calculated analysis info *) -(** ************************************************************ *) - -val extract_dwarf_static : elf_file -> maybe dwarf_static -let extract_dwarf_static f1= - match extract_dwarf f1 with - | Nothing -> Nothing - | Just dwarf -> - (*let _ = my_debug5 (pp_dwarf dwarf) in *) - - let ald : analysed_location_data = - analyse_locations dwarf in - let efi : evaluated_frame_info = - evaluate_frame_info dwarf in - let eli : evaluated_line_info = - List.map (fun lnp -> (lnp.lnp_header, evaluate_line_number_program lnp)) dwarf.d_line_info in - let sle = subprogram_line_extents dwarf in - let ds = - <| - ds_dwarf = dwarf; - ds_analysed_location_data = ald; - ds_evaluated_frame_info = efi; - ds_evaluated_line_info = eli; - ds_subprogram_line_extents = sle; - |> in - Just ds - end - - - -(** ************************************************************ *) -(** ** collect simple die tree view *) -(** ************************************************************ *) - -let decl_of_die d subprogram_line_extents cu die : maybe (unpacked_file_entry * nat (*line*) * string (*subprogram name*))= - let c = p_context_of_d d in - let lnp = line_number_program_of_compilation_unit d cu in - let lnh = lnp.lnp_header in - match (find_natural_attribute_value_of_die c "DW_AT_decl_file" die, - find_natural_attribute_value_of_die c "DW_AT_decl_line" die) with - | (Just file, Just line) -> - let ufe = unpack_file_entry lnh file in - let subprogram_name = subprogram_at_line subprogram_line_extents ufe line in - Just (ufe, natFromSymNatural line, subprogram_name) - | (_,_) -> - Nothing - end - -let call_site_of_die d subprogram_line_extents cu die : maybe (unpacked_file_entry * nat (*line*) * string (*subprogram name*))= - let c = p_context_of_d d in - let lnp = line_number_program_of_compilation_unit d cu in - let lnh = lnp.lnp_header in - match (find_natural_attribute_value_of_die c "DW_AT_call_file" die, - find_natural_attribute_value_of_die c "DW_AT_call_line" die) with - | (Just file, Just line) -> - let ufe = unpack_file_entry lnh file in - let subprogram_name = subprogram_at_line subprogram_line_extents ufe line in - Just (ufe, natFromSymNatural line, subprogram_name) - | (_,_) -> - Nothing - end - - -let mk_sdt_unspecified_parameter (d:dwarf) subprogram_line_extents cu parents die : maybe sdt_unspecified_parameter= - if not(List.elem die.die_abbreviation_declaration.ad_tag [tag_encode "DW_TAG_unspecified_parameters"]) - then Nothing - else Just () - - -(* -let strict_msvfp x e s z = - match x with - | Just y -> y - | Nothing -> - Assert_extra.failwith ("mk_sdt_variable_or_formal_parameter strict failure " ^ e ^ " on \n" ^ s z ^ "\n") - end - *) -let rec mk_sdt_variable_or_formal_parameter (d:dwarf) subprogram_line_extents cu parents die : maybe sdt_variable_or_formal_parameter= - if not(List.elem die.die_abbreviation_declaration.ad_tag [tag_encode "DW_TAG_variable"; tag_encode "DW_TAG_formal_parameter"]) - then Nothing - else - - let c = p_context_of_d d in - (* let s (cu,parents,die) = pp_die c cu.cu_header d.d_str true 0 false die in*) - - let cupdie = (cu,parents,die) in - let kind = if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_variable" then SVPK_var else if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_formal_parameter" then SVPK_param else Assert_extra.failwith ("unreachable bad kind") in - - (* find aDW_AT_specification die, if it exists. TODO: how should this interact with abstract origins? *) - let mcupdie_spec = find_reference_attribute_of_die c d cu d.d_str "DW_AT_specification" die in - - Just ( - <| - svfp_cupdie = cupdie; - svfp_kind = kind; - (* svfp_name = strict_msvfp (find_name_of_die_using_abstract_origin_and_spec c d cu d.d_str die mcupdie_spec) "no name" s cupdie;*) - svfp_name = match (find_name_of_die_using_abstract_origin_and_spec c d cu d.d_str die mcupdie_spec) with Just name -> name | Nothing -> "no name" end; - svfp_type = (*strict_msvfp*) (find_DW_AT_type_of_die_deep_using_abstract_origin d cupdie) (*"no type" s cupdie*); - svfp_abstract_origin = - match find_reference_attribute_of_die c d cu d.d_str "DW_AT_abstract_origin" die with - | Nothing -> - Nothing - | Just ((cu',parents',die') as cupdie') -> - mk_sdt_variable_or_formal_parameter d subprogram_line_extents cu' parents' die' - end; - svfp_const_value = find_integer_attribute_value_of_die c "DW_AT_const_value" die; - svfp_external = match find_flag_attribute_value_of_die_using_abstract_origin d "DW_AT_external" cupdie with Just b -> b | Nothing -> false end; - svfp_declaration = match find_flag_attribute_value_of_die_using_abstract_origin d "DW_AT_declaration" cupdie with Just b -> b | Nothing -> false end; - svfp_locations = - let base_address = cu_base_address cu in - let interpreted_locations : maybe (list (sym_natural * sym_natural * single_location_description)) = - interpreted_location_of_die c cu.cu_header d.d_str d.d_loc d.d_ranges base_address parents die in - Maybe.map (fun nnbss -> List.map (fun (n1,n2,bs) -> (n1,n2,parse_operations_bs c cu.cu_header bs)) nnbss) interpreted_locations; - svfp_decl = decl_of_die d subprogram_line_extents cu die; - |> ) - -let strict_mss x e s z= - match x with - | Just y -> y - | Nothing -> - Assert_extra.failwith ("mk_sdt_subroutine strict failure " ^ e ^ " on \n" ^ s z ^ "\n") - end - -let rec mk_sdt_subroutine (d:dwarf) subprogram_line_extents (cu:compilation_unit) parents (die:die) : maybe sdt_subroutine= - if not(List.elem die.die_abbreviation_declaration.ad_tag [tag_encode "DW_TAG_subprogram"; tag_encode "DW_TAG_inlined_subroutine"]) - then Nothing - else - let c = p_context_of_d d in - (* let s (cu,parents,die) : string = pp_die c cu.cu_header d.d_str true 0 false die in*) - - let cupdie = (cu, parents, die) in - let parents' = die::parents in - let kind = if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_subprogram" then SSK_subprogram else if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_inlined_subroutine" then SSK_inlined_subroutine else Assert_extra.failwith ("unreachable bad kind") in - Just ( - <| - ss_cupdie = cupdie; - ss_name = (*strict_mss ( *)find_name_of_die_using_abstract_origin c d cu d.d_str die(* ) "no name" s cupdie;*); - ss_kind = kind; - ss_call_site = call_site_of_die d subprogram_line_extents cu die; - ss_abstract_origin = - match find_reference_attribute_of_die c d cu d.d_str "DW_AT_abstract_origin" die with - | Nothing -> - Nothing - | Just ((cu',parents',die') as cupdie') -> - mk_sdt_subroutine d subprogram_line_extents cu' parents' die' - end; - ss_type = find_DW_AT_type_of_die_deep(*_using_abstract_origin*) d cupdie; - ss_vars = List.mapMaybe (mk_sdt_variable_or_formal_parameter d subprogram_line_extents cu parents') die.die_children; - ss_unspecified_parameters = List.mapMaybe (mk_sdt_unspecified_parameter d subprogram_line_extents cu parents') die.die_children; - ss_entry_address = entry_address die; - ss_pc_ranges = range_of_die_d d cu die; - ss_subroutines = List.mapMaybe (mk_sdt_subroutine d subprogram_line_extents cu parents') die.die_children; - ss_lexical_blocks = List.mapMaybe (mk_sdt_lexical_block d subprogram_line_extents cu parents') die.die_children; - ss_decl = decl_of_die d subprogram_line_extents cu die; - ss_noreturn = match find_flag_attribute_value_of_die_using_abstract_origin d "DW_AT_noreturn" cupdie with Just b -> b | Nothing -> false end; - ss_external = match find_flag_attribute_value_of_die_using_abstract_origin d "DW_AT_external" cupdie with Just b -> b | Nothing -> false end; - |> ) - - and mk_sdt_lexical_block (d:dwarf) subprogram_line_extents (cu:compilation_unit) parents (die:die) : maybe sdt_lexical_block= - if not (die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_lexical_block") - then Nothing - else - let c = p_context_of_d d in - (*let s (cu,parents,die) : string = pp_die c cu.cu_header d.d_str true 0 false die in*) - - let cupdie = (cu, parents, die) in - let parents' = die::parents in - Just ( - <| - slb_cupdie = cupdie; - slb_vars = List.mapMaybe (mk_sdt_variable_or_formal_parameter d subprogram_line_extents cu parents') die.die_children; - slb_pc_ranges = range_of_die_d d cu die; - slb_subroutines = List.mapMaybe (mk_sdt_subroutine d subprogram_line_extents cu parents') die.die_children; - slb_lexical_blocks = List.mapMaybe (mk_sdt_lexical_block d subprogram_line_extents cu parents') die.die_children; - |> ) - - -let strict_mscu x e s z= - match x with - | Just y -> y - | Nothing -> - Assert_extra.failwith ("mk_sdt_compilation_unit strict failure " ^ e ^ " on \n" ^ s z ^ "\n") - end - -let mk_sdt_compilation_unit (d:dwarf) subprogram_line_extents (cu:compilation_unit) : sdt_compilation_unit= - let c = p_context_of_d d in - let s (cu,(parents:list die),die) : string= pp_die c cu.cu_header d.d_str true 0 false die in - let cupdie = (cu, [], cu.cu_die) in - - let parents' = [cu.cu_die] in - <| - scu_cupdie = (cu, [], cu.cu_die); - scu_name = strict_mscu (find_name_of_die d.d_str cu.cu_die) "no name" s cupdie; - scu_subroutines = List.mapMaybe (mk_sdt_subroutine d subprogram_line_extents cu parents') cu.cu_die.die_children; - scu_vars = List.mapMaybe (mk_sdt_variable_or_formal_parameter d subprogram_line_extents cu parents') cu.cu_die.die_children; - scu_pc_ranges = range_of_die_d d cu cu.cu_die; - |> - - -let mk_sdt_dwarf (d:dwarf) subprogram_line_extents : sdt_dwarf= - <| sd_compilation_units = List.map (mk_sdt_compilation_unit d subprogram_line_extents) d.d_compilation_units; -|> - -(* **** verbose pp of simple die tree view *************** *) - -let pp_sdt_unspecified_parameter (level:sym_natural) (sup:sdt_unspecified_parameter) : string= - indent_level true level ^ "unspecified parameters" ^ "\n" - -let pp_parsed_single_location_description (level:sym_natural) ((n1:sym_natural), (n2:sym_natural), (ops:list operation)) : string= - let indent = indent_level true level in - indent - ^ pphex n1 - ^ " " ^ pphex n2 - ^ " (" ^ pp_operations ops ^")" - ^"\n" - -let pp_pc_ranges (level:sym_natural) (rso:maybe (list (sym_natural*sym_natural)))= - match rso with - | Nothing -> "none\n" - | Just rs -> - let indent = indent_level true level in - "\n" ^ String.concat "" (List.map (fun (n1,n2) -> indent ^ pphex n1 ^ " " ^ pphex n2 ^ "\n") rs) - end - -let pp_sdt_maybe x f= match x with Nothing -> "none\n" | Just y -> f y end -let pp_sdt_maybe' f x= pp_sdt_maybe x f -let pp_sdt_list xs f= match xs with [] -> "none\n" | _ -> "\n" ^ String.concat "" ((List.map f) xs) end - -let pp_sdt_variable_or_formal_parameter (level:sym_natural) (svfp: sdt_variable_or_formal_parameter) : string= - let indent = indent_level true level in - "" - ^ indent ^ "name:" ^ svfp.svfp_name ^ "\n" - ^ indent ^ "cupdie:" ^ pp_cupdie3 svfp.svfp_cupdie ^ "\n" - ^ indent ^ "kind:" ^ (match svfp.svfp_kind with SVPK_var -> "var" | SVPK_param -> "param" end) ^ "\n" - ^ indent ^ "type:" ^ pp_sdt_maybe' pp_type_info_deep svfp.svfp_type ^ "\n" - ^ indent ^ "const_value:" ^ show svfp.svfp_const_value ^ "\n" - ^ indent ^ "external:" ^ show svfp.svfp_external ^ "\n" - ^ indent ^ "declaration:" ^ show svfp.svfp_declaration ^ "\n" - ^ indent ^ "locations:" ^ pp_sdt_maybe svfp.svfp_locations (fun locs -> "\n" ^ String.concat "" (List.map (pp_parsed_single_location_description (level+1)) locs)) - ^ indent ^ "decl:" ^ pp_sdt_maybe svfp.svfp_decl (fun ud -> "\n" ^ indent_level true (level+1) ^ pp_ud ud ^ "\n") - ^ "\n" - -let rec pp_sdt_subroutine (level:sym_natural) (ss:sdt_subroutine) : string= - let indent = indent_level true level in - "" - ^ indent ^ "name:" ^ pp_sdt_maybe ss.ss_name (fun name -> name ^ "\n") - ^ indent ^ "cupdie:" ^ pp_cupdie3 ss.ss_cupdie ^ "\n" - ^ indent ^ "kind:" ^ (match ss.ss_kind with SSK_subprogram -> "subprogram" | SSK_inlined_subroutine -> "inlined subroutine" end) ^ "\n" - ^ indent ^ "call site:" ^ pp_sdt_maybe ss.ss_call_site (fun ud -> "\n" ^ indent_level true (level+1) ^ pp_ud ud ^ "\n") - ^ indent ^ "abstract origin:" ^ pp_sdt_maybe ss.ss_abstract_origin (pp_sdt_subroutine (level+1)) - ^ indent ^ "type:" ^ pp_sdt_maybe ss.ss_type (fun typ -> pp_type_info_deep typ ^"\n") - ^ indent ^ "vars:" ^ pp_sdt_list ss.ss_vars (pp_sdt_variable_or_formal_parameter (level+1)) - ^ indent ^ "unspecified_parameters:" ^ pp_sdt_list ss.ss_unspecified_parameters (pp_sdt_unspecified_parameter (level+1)) - ^ indent ^ "entry address: " ^ pp_sdt_maybe ss.ss_entry_address (fun n -> pphex n^"\n") - ^ indent ^ "pc ranges:" ^ pp_pc_ranges (level+1) ss.ss_pc_ranges - ^ indent ^ "subroutines:" ^ pp_sdt_list ss.ss_subroutines (pp_sdt_subroutine (level+1)) - ^ indent ^ "lexical_blocks:" ^ pp_sdt_list ss.ss_lexical_blocks (pp_sdt_lexical_block (level+1)) - ^ indent ^ "decl:" ^ pp_sdt_maybe ss.ss_decl (fun ud -> "\n" ^ indent_level true (level+1) ^ pp_ud ud ^ "\n") - ^ indent ^ "noreturn:" ^ show ss.ss_noreturn ^ "\n" - ^ indent ^ "external:" ^ show ss.ss_external ^"\n" - ^ "\n" - -and pp_sdt_lexical_block (level:sym_natural) (lb:sdt_lexical_block) : string= - let indent = indent_level true level in - "" - ^ indent ^ "cupdie:" ^ pp_cupdie3 lb.slb_cupdie ^ "\n" - ^ indent ^ "pc ranges:" ^ pp_pc_ranges (level+1) lb.slb_pc_ranges - ^ indent ^ "vars:" ^ pp_sdt_list lb.slb_vars (pp_sdt_variable_or_formal_parameter (level+1)) - ^ indent ^ "subroutines :" ^ pp_sdt_list lb.slb_subroutines (pp_sdt_subroutine (level+1)) - ^ indent ^ "lexical_blocks:" ^ pp_sdt_list lb.slb_lexical_blocks (pp_sdt_lexical_block (level+1)) - ^ "\n" - -let pp_sdt_compilation_unit (level:sym_natural) (cu:sdt_compilation_unit) : string= - let indent = indent_level true level in - "" - ^ indent ^ "name:" ^ cu.scu_name ^ "\n" - ^ indent ^ "cupdie:" ^ pp_cupdie3 cu.scu_cupdie ^ "\n" - ^ indent ^ "pc ranges:" ^ pp_pc_ranges (level+1) cu.scu_pc_ranges - ^ indent ^ "vars:" ^ pp_sdt_list cu.scu_vars (pp_sdt_variable_or_formal_parameter (level+1)) - ^ indent ^ "subroutines :" ^ pp_sdt_list cu.scu_subroutines (pp_sdt_subroutine (level+1)) - ^ "\n" - -let pp_sdt_dwarf (sdt_d:sdt_dwarf) : string= - let indent_level = 0 in - String.concat "" (List.map (pp_sdt_compilation_unit indent_level) sdt_d.sd_compilation_units) - -(* **** concise pp of simple die tree view *************** *) - -(* **************** global vars ************* *) - -let pp_sdt_concise_variable_or_formal_parameter (level:sym_natural) (svfp: sdt_variable_or_formal_parameter) : string= - let indent = indent_level true level in - "" - ^ indent - (* ^ indent ^ "cupdie:" ^ pp_cupdie3 svfp.svfp_cupdie ^ "\n"*) - (*^ indent ^ "name:" ^*) ^ svfp.svfp_name ^ " " - (*^ indent ^ "kind:" *) ^ (match svfp.svfp_kind with SVPK_var -> "var" | SVPK_param -> "param" end) ^ " " - (*^ indent ^ "type:" *) ^ pp_sdt_maybe' pp_type_info_deep svfp.svfp_type ^ " " - (*^ indent ^ "const_value:"*) ^ match svfp.svfp_const_value with | Nothing -> "" | Just v -> "const:"^show v ^ " " end - (*^ indent ^ "external:" ^ show svfp.svfp_external ^ "\n"*) - (*^ indent ^ "declaration:" ^ show svfp.svfp_declaration ^ "\n"*) -(*^ indent ^ "locations:" *) ^ (match svfp.svfp_locations with Nothing -> "no locations\n" | Just locs -> "\n" ^ String.concat "" (List.map (pp_parsed_single_location_description (level+1)) locs) end) -(* ^ indent ^ "decl:" ^ (match svfp.svfp_decl with Nothing -> "none\n" | Just ((ufe,line) as ud) -> "\n" ^ indent_level true (level+1) ^ pp_ufe ufe ^ " " ^ show line ^ "\n" end)*) - -let pp_sdt_globals_compilation_unit (level:sym_natural) (cu:sdt_compilation_unit) : string= - let indent = indent_level true level in - "" - (* ^ indent ^ "cupdie:" ^ pp_cupdie3 cu.scu_cupdie ^ "\n"*) - ^ indent ^ (*"name:" ^*) cu.scu_name ^ "\n" - (* ^ indent ^ "vars:" ^ "\n"*) ^ String.concat "" (List.map (pp_sdt_concise_variable_or_formal_parameter (level+1)) cu.scu_vars) -(* ^ indent ^ "subroutines :" ^ (match cu.scu_subroutines with | [] -> "none\n" | sus -> "\n" ^ String.concat "\n" (List.map (pp_sdt_subroutine (level+1)) sus) end) *) - -let pp_sdt_globals_dwarf (sdt_d:sdt_dwarf) : string= - let indent_level = 0 in - String.concat "" (List.map (pp_sdt_globals_compilation_unit indent_level) sdt_d.sd_compilation_units) - -(* ****************** local vars *************** *) - -let rec pp_sdt_locals_subroutine (level:sym_natural) (ss:sdt_subroutine) : string= - let indent = indent_level true level in - "" - ^ indent (*^ "name:" ^*) ^ pp_sdt_maybe ss.ss_name (fun name -> name ^ "\n") - (* ^ indent ^ "cupdie:" ^ pp_cupdie3 ss.ss_cupdie ^ "\n"*) - ^ indent ^ "kind:" ^ (match ss.ss_kind with SSK_subprogram -> "subprogram" | SSK_inlined_subroutine -> "inlined subroutine" end) ^ "\n" - ^ indent ^ "entry address: " ^ pp_sdt_maybe ss.ss_entry_address (fun n -> pphex n^"\n") - ^ indent ^ "call site:" ^ pp_sdt_maybe ss.ss_call_site (fun ud -> "\n" ^ indent_level true (level+1) ^ pp_ud ud ^ "\n") - ^ indent ^ "abstract origin:" ^ pp_sdt_maybe ss.ss_abstract_origin (fun s -> "\n" ^ pp_sdt_locals_subroutine (level+1) s) - (* ^ indent ^ "type:" ^ pp_sdt_maybe ss.ss_type (fun typ -> pp_type_info_deep typ ^"\n" end)*) - ^ indent ^ "vars:" ^ pp_sdt_list ss.ss_vars (pp_sdt_concise_variable_or_formal_parameter (level+1)) - ^ indent ^ "unspecified_parameters:" ^ pp_sdt_list ss.ss_unspecified_parameters (pp_sdt_unspecified_parameter (level+1)) - (* ^ indent ^ "pc ranges:" ^ pp_pc_ranges (level+1) ss.ss_pc_ranges*) - ^ indent ^ "subroutines:" ^ pp_sdt_list ss.ss_subroutines (pp_sdt_locals_subroutine (level+1)) - ^ indent ^ "lexical_blocks:" ^ pp_sdt_list ss.ss_lexical_blocks (pp_sdt_locals_lexical_block (level+1)) - (* ^ indent ^ "decl:" ^ pp_sdt_maybe ss.ss_decl (fun ((ufe,line) as ud) -> "\n" ^ indent_level true (level+1) ^ pp_ufe ufe ^ " " ^ show line ^ "\n" end)*) - (* ^ indent ^ "noreturn:" ^ show ss.ss_noreturn ^ "\n"*) - (* ^ indent ^ "external:" ^ show ss.ss_external ^"\n"*) - ^ "\n" - -and pp_sdt_locals_lexical_block (level:sym_natural) (lb:sdt_lexical_block) : string= - let indent = indent_level true level in - "" - (* ^ indent ^ "cupdie:" ^ pp_cupdie3 lb.slb_cupdie ^ "\n"*) - ^ indent ^ "vars:" ^ pp_sdt_list lb.slb_vars (pp_sdt_concise_variable_or_formal_parameter (level+1)) - (* ^ indent ^ "pc ranges:" ^ pp_pc_ranges (level+1) lb.slb_pc_ranges*) - ^ indent ^ "subroutines :" ^ pp_sdt_list lb.slb_subroutines (pp_sdt_locals_subroutine (level+1)) - ^ indent ^ "lexical_blocks:" ^ pp_sdt_list lb.slb_lexical_blocks (pp_sdt_locals_lexical_block (level+1)) - ^ "\n" - -let pp_sdt_locals_compilation_unit (level:sym_natural) (cu:sdt_compilation_unit) : string= - let indent = indent_level true level in - "" - ^ indent (*^ "name:" *) ^ cu.scu_name ^ "\n" - (* ^ indent ^ "cupdie:" ^ pp_cupdie3 cu.scu_cupdie ^ "\n"*) - ^ indent ^ "vars:" ^ pp_sdt_list cu.scu_vars (pp_sdt_concise_variable_or_formal_parameter (level+1)) - ^ indent ^ "subroutines :" ^ pp_sdt_list cu.scu_subroutines (pp_sdt_locals_subroutine (level+1)) - -let pp_sdt_locals_dwarf (sdt_d:sdt_dwarf) : string= - let indent_level = 0 in - String.concat "" (List.map (pp_sdt_locals_compilation_unit indent_level) sdt_d.sd_compilation_units) - -(** ************************************************************ *) -(** ** analysis of inlined_subroutine data *) -(** ************************************************************ *) - -(* old version, directly over die tree *) -(* -let strict_ais x e s z = - match x with - | Just y -> y - | Nothing -> - Assert_extra.failwith ("analyse_inlined_subroutine strict failure " ^ e ^ " on \n" ^ s z ^ "\n") - end - -val analyse_inlined_subroutines : dwarf -> inlined_subroutine_data -let analyse_inlined_subroutines (d: dwarf) : inlined_subroutine_data = - - let c = p_context_of_d d in - - let s (cu,parents,die) = pp_die c cu.cu_header d.d_str true 0 false die in - - let inlined_subroutines : list (compilation_unit * (list die) * die) = - find_dies - (fun die -> - die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_inlined_subroutine") - d in - - List.map - (fun (((cu:compilation_unit), (parents: list die), (die: die)) as inlined_subroutine) -> - - let ((cu',parents,die') as abstract_origin) : compilation_unit * (list die) * die = - strict_ais (find_reference_attribute_of_die c d cu d.d_str "DW_AT_abstract_origin" die) - "no abstract origin" s inlined_subroutine in - let name : string = - strict_ais (find_name_of_die d.d_str die') - "no abstract origin name" s abstract_origin in - let call_file : unpacked_file_entry = - let file_index = strict_ais (find_natural_attribute_value_of_die c "DW_AT_call_file" die) "no DW_AT_call_file" s inlined_subroutine in - unpack_file_entry (line_number_program_of_compilation_unit d cu).lnp_header file_index in - (* match filename d cu file_index with | Just s -> s | Nothing -> "none" end in*) - let call_line : natural = strict_ais (find_natural_attribute_value_of_die c "DW_AT_call_line" die) "no DW_AT_call_line" s inlined_subroutine in - let pc_ranges : list (natural*natural) = - strict_ais (closest_enclosing_range c d.d_ranges (cu_base_address cu) [die](*deliberately ignore parents*)) - "no pc ranges" s inlined_subroutine in - let const_params = - List.mapMaybe (fun die'' -> - if die''.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_formal_parameter" then - match find_reference_attribute_of_die c d cu d.d_str "DW_AT_abstract_origin" die'' with - | Nothing -> Nothing - | Just abstract_origin' -> - match find_integer_attribute_value_of_die c "DW_AT_const_value" die'' with - | Nothing -> Nothing - | Just n -> - Just (<| - iscp_abstract_origin = abstract_origin'; - iscp_value = n; - |>) - end - end - else - Nothing - ) die.die_children in - <| - is_inlined_subroutine = inlined_subroutine; - is_abstract_origin = abstract_origin; - is_name = name; - is_call_file = call_file; - is_call_line = call_line; - is_pc_ranges = pc_ranges; - is_const_params = const_params; - |> - ) - inlined_subroutines - *) - -(* new version, over simple-die-tree view, but still producing the previous old-style datastructure *) - -let analyse_inlined_subroutines_sdt_const_param (svfp:sdt_variable_or_formal_parameter) : maybe inlined_subroutine_const_param= - match (svfp.svfp_kind, svfp.svfp_abstract_origin, svfp.svfp_const_value) with - | (SVPK_param, Just svfp', Just n) -> - Just (<| - iscp_abstract_origin = svfp'.svfp_cupdie; - iscp_value = n; - |>) - | _ -> - Nothing - end - -let rec analyse_inlined_subroutines_sdt_subroutine (sdt_parents: list sdt_subroutine) (ss:sdt_subroutine) : list inlined_subroutine= - let this : list inlined_subroutine = - match (ss.ss_kind, ss.ss_abstract_origin) with - | (SSK_inlined_subroutine, Just ss') -> - let ((call_file:unpacked_file_entry),(call_line:sym_natural)) = - match ss.ss_call_site with - | Just (((ufe,line,subprogram_name) as ud):unpacked_decl) -> - (ufe,naturalFromNat line) - | Nothing -> - Assert_extra.failwith "analyse_inlined_subroutines_sdt_subroutine found no ss_call_site" - end in - let pc_ranges = match ss.ss_pc_ranges with | Just pc_ranges -> pc_ranges | Nothing -> Assert_extra.failwith "analyse_inlined_subroutines_sdt_subroutine found no ss_pc_ranges" end in - let const_params = List.mapMaybe analyse_inlined_subroutines_sdt_const_param ss.ss_vars in - [ (<| - is_inlined_subroutine = ss.ss_cupdie; - is_abstract_origin = ss'.ss_cupdie; - is_inlined_subroutine_sdt = ss; - is_inlined_subroutine_sdt_parents = sdt_parents; - is_name = match ss.ss_name with Just name->name | Nothing -> "no name" end; - is_call_file = call_file; - is_call_line = call_line; - is_pc_ranges = pc_ranges; - is_const_params = const_params; - |> - )] - | (SSK_inlined_subroutine, Nothing) -> - Assert_extra.failwith "analyse_inlined_subroutines_sdt_subroutine found SSK_inlined_subroutine without ss_abstract_origin" - | _ -> - [] - end in - let sdt_parents' = ss::sdt_parents in - - this - ++ List.concatMap (analyse_inlined_subroutines_sdt_subroutine sdt_parents') ss.ss_subroutines - ++ List.concatMap (analyse_inlined_subroutines_sdt_lexical_block sdt_parents') ss.ss_lexical_blocks - - -and analyse_inlined_subroutines_sdt_lexical_block sdt_parents (lb:sdt_lexical_block) : list inlined_subroutine= - List.concatMap (analyse_inlined_subroutines_sdt_subroutine sdt_parents) lb.slb_subroutines - ++ List.concatMap (analyse_inlined_subroutines_sdt_lexical_block sdt_parents) lb.slb_lexical_blocks - -let analyse_inlined_subroutines_sdt_compilation_unit (cu:sdt_compilation_unit) : list inlined_subroutine= - List.concatMap (analyse_inlined_subroutines_sdt_subroutine []) cu.scu_subroutines - -let analyse_inlined_subroutines_sdt_dwarf (sd: sdt_dwarf) : list inlined_subroutine= - List.concatMap analyse_inlined_subroutines_sdt_compilation_unit sd.sd_compilation_units - - -let analyse_inlined_subroutine_by_range (is:inlined_subroutine) : inlined_subroutine_data_by_range= - let n_ranges = List.length is.is_pc_ranges in - List.mapi (fun i -> fun (n1,n2) -> ((n1,n2),(naturalFromNat i, naturalFromNat n_ranges),is)) is.is_pc_ranges - - -let is_lt ((n1,n2),(m,n),is) ((n1',n2'),(m',n'),is')= n1 < n1' || (n1 = n1' && n2 > n2') - -let analyse_inlined_subroutines_by_range (iss:inlined_subroutine_data) : inlined_subroutine_data_by_range= - Sorting.sortBy is_lt (List.concat (List.map analyse_inlined_subroutine_by_range iss)) - -(* pp the inlined_subroutine tree structure. Technically these die offsets each also need the compilation-unit offset to be globally unique, but that's locally constant *) -let rec pp_inlined_subroutine_parents (ds:list die) : string= - match ds with - | [] -> "" - | die::ds' -> - if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_inlined_subroutine" then - pp_pos die.die_offset ^ ":" ^ pp_inlined_subroutine_parents ds' - else if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_lexical_block" then ":" ^ pp_inlined_subroutine_parents ds' - else if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_subprogram" then "" - else "" - end - - -let pp_inlined_subroutine_header ds is= - is.is_name - ^ " inlined from " ^ (subprogram_at_line ds.ds_subprogram_line_extents is.is_call_file is.is_call_line) ^ ":" ^ show is.is_call_line ^ " (" ^ (pp_ufe_brief is.is_call_file) ^ ")" - ^ " " - ^ let (cu,parents,die) = is.is_inlined_subroutine in - pp_inlined_subroutine_parents (die::parents) - -let pp_inlined_subroutine_const_params d is= - let c = p_context_of_d d in - match is.is_const_params with - | [] -> "" - | _ -> - String.concat "" - (List.map - (fun iscp -> - let fake_als : analysed_location_data = [(iscp.iscp_abstract_origin,Nothing)] in - let fake_diff = pp_analysed_locations3_diff c (*HACK*) d d.d_str [] fake_als in - let const_in_place_of_locs = - List.map - (fun (removed,(name,offset,kind),typ,locs,parents) -> - (removed,(name,offset,kind),typ,"const="^show iscp.iscp_value,parents)) - fake_diff in - pp_analysed_location_format const_in_place_of_locs - ) - is.is_const_params) - end - -let pp_inlined_subroutine ds is= - pp_inlined_subroutine_header ds is ^ "\n" - ^ String.concat "" (List.map (fun (n1,n2) -> " " ^ pphex n1 ^ " " ^ pphex n2 ^ "\n") is.is_pc_ranges) - ^ pp_inlined_subroutine_const_params ds.ds_dwarf is - -let pp_inlined_subroutines ds iss= - String.concat "" (List.map (pp_inlined_subroutine ds) iss) - - -let pp_inlined_subroutine_by_range ds ((n1,n2),((m:sym_natural),(n:sym_natural)),is)= - pphex n1 ^ " " ^ pphex n2 ^ " " - ^ (if n<>1 then "("^show m^" of "^show n^") " else "") - ^ pp_inlined_subroutine_header ds is - ^"\n" - ^ (if m=0 then pp_inlined_subroutine_const_params ds.ds_dwarf is else "") - -let pp_inlined_subroutines_by_range ds iss= - String.concat "" (List.map (pp_inlined_subroutine_by_range ds) iss) - -(** ************************************************************ *) -(** ** pp of text section *) -(** ************************************************************ *) - -(* assume 4-byte ARM instructions *) - - -let rec words_of_byte_sequence (addr:sym_natural) (bs:byte_sequence) (acc:list (sym_natural * sym_natural)) : list (sym_natural * sym_natural)= - match read_4_bytes_be bs with - | Success ((b0,b1,b2,b3), bs') -> - let i : sym_natural = natural_of_byte b0 + 256*natural_of_byte b1 + 65536*natural_of_byte b2 + 65536*256*natural_of_byte b3 in - words_of_byte_sequence (addr+4) bs' ((addr,i)::acc) - | Fail _ -> List.reverse acc - end - -let pp_instruction ((addr:sym_natural),(i:sym_natural))= - hex_string_of_big_int_pad8 addr ^ " " ^ hex_string_of_big_int_pad8 i ^ "\n" - -val pp_text_section : elf_file -> string -let pp_text_section f= - let (p_context, addr, bs) = extract_text f in - let instructions : list (sym_natural * sym_natural) = words_of_byte_sequence addr bs [] in - String.concat "" (List.map pp_instruction instructions) - -(** ************************************************************ *) -(** ** top level for main_elf ******************************** *) -(** ************************************************************ *) - -val harness_string_of_elf_like_objdump : elf_file -> byte_sequence -> string -let harness_string_of_elf_like_objdump f1 bs= - let mds = extract_dwarf_static f1 in - match mds with - | Nothing -> "" - | Just ds -> - "" (*pp_text_section f1*) - ^ pp_dwarf_like_objdump ds.ds_dwarf - end - - -val harness_string_of_elf : elf_file -> byte_sequence -> string -let harness_string_of_elf f1 bs= - let mds = extract_dwarf_static f1 in - match mds with - | Nothing -> "" - | Just ds -> - let sdt_d = mk_sdt_dwarf ds.ds_dwarf ds.ds_subprogram_line_extents in - - "* emacs outline-mode configuration -*-outline-*- C-c C-{t,a,d,e}" - ^ "" (*pp_text_section f1*) - ^ pp_dwarf ds.ds_dwarf - (* ^ analyse_locations_raw c d *) - - ^ "************** evaluation of frame data *************************\n" - ^ pp_evaluated_frame_info ds.ds_evaluated_frame_info - ^ "************** analysis of location data *************************\n" - ^ pp_analysed_location_data ds.ds_dwarf ds.ds_analysed_location_data - ^ "************** line info *************************\n" - ^ pp_evaluated_line_info ds.ds_evaluated_line_info - - ^ "************** inlined subroutine info *************************\n" - ^ let iss = analyse_inlined_subroutines_sdt_dwarf sdt_d in - pp_inlined_subroutines ds iss - ^ "************** inlined subroutine info by range *************************\n" - ^ pp_inlined_subroutines_by_range ds (analyse_inlined_subroutines_by_range iss) - ^ "************** subprogram line-number extent info *************************\n" - ^ pp_subprograms ds.ds_subprogram_line_extents - ^ "************** simple die tree *************************\n" - ^ pp_sdt_dwarf sdt_d - ^ "************** simple die tree globals *************************\n" - ^ pp_sdt_globals_dwarf sdt_d - ^ "************** simple die tree locals *************************\n" - ^ pp_sdt_locals_dwarf sdt_d - - -end - - -val harness_string_of_elf64_debug_info_section : elf64_file -> byte_sequence -> (*(natural -> string) -> (natural -> string) -> (natural -> string) -> elf64_header -> elf64_section_header_table -> string_table -> *) string -let {ocaml} harness_string_of_elf64_debug_info_section f1 bs0= - (*os proc usr hdr sht stbl*) harness_string_of_elf (ELF_File_64 f1) bs0 - -val harness_string_of_elf32_debug_info_section : elf32_file -> byte_sequence -> (* (natural -> string) -> (natural -> string) -> (natural -> string) -> elf32_header -> elf32_section_header_table -> string_table ->*) string -let {ocaml} harness_string_of_elf32_debug_info_section f1 bs0= - (*os proc usr hdr sht stbl*) harness_string_of_elf (ELF_File_32 f1) bs0 - - - -val harness_string_of_elf64_like_objdump : elf64_file -> byte_sequence -> (*(natural -> string) -> (natural -> string) -> (natural -> string) -> elf64_header -> elf64_section_header_table -> string_table -> *) string -let {ocaml} harness_string_of_elf64_like_objdump f1 bs0= - (*os proc usr hdr sht stbl*) harness_string_of_elf_like_objdump (ELF_File_64 f1) bs0 - -val harness_string_of_elf32_like_objdump : elf32_file -> byte_sequence -> (* (natural -> string) -> (natural -> string) -> (natural -> string) -> elf32_header -> elf32_section_header_table -> string_table ->*) string -let {ocaml} harness_string_of_elf32_like_objdump f1 bs0= - (*os proc usr hdr sht stbl*) harness_string_of_elf_like_objdump (ELF_File_32 f1) bs0 - - From 7a9c7781a08670fa2f684063705f881f7e619ce7 Mon Sep 17 00:00:00 2001 From: Matej Urban Date: Thu, 7 Nov 2024 19:01:34 +0000 Subject: [PATCH 04/44] refactor abstract relocations --- .../abi_aarch64_symbolic_relocation.lem | 1 + src/abis/abi_symbolic_relocation.lem | 19 +------------- src/dwarf.lem | 13 +++++++++- src/elf_symbolic.lem | 26 +++++++++++++++++++ src/lem.mk | 1 + 5 files changed, 41 insertions(+), 19 deletions(-) create mode 100644 src/elf_symbolic.lem diff --git a/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem b/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem index 62c7c06..69e29ee 100644 --- a/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem +++ b/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem @@ -9,6 +9,7 @@ open import Elf_types_native_uint open import Elf_file open import Elf_header open import Elf_relocation +open import Elf_symbolic open import Abi_aarch64_relocation open import Abi_utilities diff --git a/src/abis/abi_symbolic_relocation.lem b/src/abis/abi_symbolic_relocation.lem index ae98eac..ee376d4 100644 --- a/src/abis/abi_symbolic_relocation.lem +++ b/src/abis/abi_symbolic_relocation.lem @@ -6,21 +6,8 @@ open import Abi_utilities open import Elf_types_native_uint open import Elf_symbol_table +open import Elf_symbolic -(* TODO *) -type binary_operation - = Add - | Sub - -(* TODO *) -type symbolic_expression - = Section of elf64_half - | Const of integer - | BinOp of (symbolic_expression * binary_operation * symbolic_expression) - | AssertRange of (symbolic_expression * integer * integer) - | Mask of (symbolic_expression * natural * natural) - -let section_with_offset sidx offset = BinOp(Section sidx, Add, Const (integerFromNatural (natural_of_elf64_addr offset))) type relocation_description 'res 'tar = <| rel_desc_operation : (relocation_operator_expression 'res * integer_bit_width * can_fail 'res) @@ -28,10 +15,6 @@ type relocation_description 'res 'tar = ; rel_desc_target : 'tar |> -type abstract_relocation 'a = - <| arel_value : symbolic_expression - ; arel_target : 'a - |> let rec eval_op_exp op: error symbolic_expression = diff --git a/src/dwarf.lem b/src/dwarf.lem index 0611a28..e33032e 100644 --- a/src/dwarf.lem +++ b/src/dwarf.lem @@ -27,7 +27,7 @@ open import Elf_relocation open import Elf_section_header_table open import Elf_symbol_table open import Elf_types_native_uint - +open import Elf_symbolic (** ***************** experimental DWARF reading *********** *) @@ -227,6 +227,17 @@ let symNaturalPow x y = sym_map (fun x -> naturalPow x y) x let symNaturalFromInteger x = Absolute(naturalFromInteger x) +(* byte sequence *) + +type next_reloc = + | NoReloc of natural + | Reloc of abstract_relocation reloc_target_data + +type rel_byte_sequence = + <| rbs_bytes : byte_sequence + ; rbs_relocs : list next_reloc + |> + (** ************************************************************ *) (** ** dwarf representation types **************************** *) (** ************************************************************ *) diff --git a/src/elf_symbolic.lem b/src/elf_symbolic.lem new file mode 100644 index 0000000..726c386 --- /dev/null +++ b/src/elf_symbolic.lem @@ -0,0 +1,26 @@ +open import Num +open import Elf_types_native_uint + +(* TODO *) +type binary_operation + = Add + | Sub + +(* TODO *) +type symbolic_expression + = Section of elf64_half + | Const of integer + | BinOp of (symbolic_expression * binary_operation * symbolic_expression) + | AssertRange of (symbolic_expression * integer * integer) + | Mask of (symbolic_expression * natural * natural) + +let section_with_offset sidx offset = BinOp(Section sidx, Add, Const (integerFromNatural (natural_of_elf64_addr offset))) + +type abstract_relocation 'a = + <| arel_value : symbolic_expression + ; arel_target : 'a + |> + +type reloc_target_data = + | Data32 + | Data64 \ No newline at end of file diff --git a/src/lem.mk b/src/lem.mk index a271a46..91dfcd7 100644 --- a/src/lem.mk +++ b/src/lem.mk @@ -56,6 +56,7 @@ LEM_ELF_SRC := byte_sequence.lem byte_pattern.lem byte_pattern_extra.lem \ elf_relocation.lem \ elf_interpreted_segment.lem elf_interpreted_section.lem \ elf_note.lem elf_file.lem elf_dynamic.lem \ + elf_symbolic.lem \ dwarf_ctypes.lem dwarf.lem ldconfig.lem LEM_ABI_SRC := \ From 8430a5ee1a7c59be9143ea49f9e09a0f5ec4d1ae Mon Sep 17 00:00:00 2001 From: Matej Urban Date: Thu, 7 Nov 2024 19:56:54 +0000 Subject: [PATCH 05/44] wip --- src/dwarf.lem | 245 ++++++++++++++++++++++++++----------------- src/elf_symbolic.lem | 7 +- 2 files changed, 152 insertions(+), 100 deletions(-) diff --git a/src/dwarf.lem b/src/dwarf.lem index e33032e..2c526c8 100644 --- a/src/dwarf.lem +++ b/src/dwarf.lem @@ -238,6 +238,53 @@ type rel_byte_sequence = ; rbs_relocs : list next_reloc |> +let rbs_no_reloc (bs : byte_sequence) : rel_byte_sequence = + <| rbs_bytes = bs + ; rbs_relocs = [NoReloc (Byte_sequence.length bs)] |> + +let rbs_unwrap bs = + match bs.rbs_relocs with + | [NoReloc n] -> bs.rbs_bytes + | _ -> Assert_extra.failwith "rbs_unwrap: has relocations" +end + +let rel_byte_sequence_of_byte_list l = rbs_no_reloc (byte_sequence_of_byte_list l) + +let rel_read_char bs = + match bs.rbs_relocs with + | NoReloc n :: rels -> + read_char bs.rbs_bytes >>= fun (c,bs') -> + return (c, <| rbs_bytes = bs' ; rbs_relocs = if n = 1 then rels else NoReloc (n-1) :: rels |>) + | _ -> fail "rel_read_char: has reloaction" + end + +let rbs_length rbs = Byte_sequence.length rbs.rbs_bytes + +let rec reloc_list_partition n relocs = match (n, relocs) with + | (0, relocs) -> return ([], relocs) + | (n, NoReloc m :: relocs) -> if m > n then + return ([NoReloc n], NoReloc (m - n) :: relocs) + else + reloc_list_partition (n-m) relocs >>= fun (a, b) -> + return (NoReloc m :: a, b) + | (n, Reloc r :: relocs) -> + let m = reloc_width_bytes r.arel_target in + if m > n then + fail "reloc_list_partition: partition inside relocation" + else + reloc_list_partition (n-m) relocs >>= fun (a, b) -> + return (Reloc r :: a, b) + | (n, []) -> fail "reloc_list_partition: cannot take more bytes than are contained in sequence" +end + +let rbs_partition n rbs = + partition n rbs.rbs_bytes >>= fun (bs1, bs2) -> + reloc_list_partition n rbs.rbs_relocs >>= fun (r1, r2) -> + return (<| rbs_bytes = bs1 ; rbs_relocs = r1 |>, <| rbs_bytes = bs2 ; rbs_relocs = r2 |>) + +let byte_list_of_rel_byte_sequence bs = + byte_list_of_byte_sequence (rbs_unwrap bs) + (** ************************************************************ *) (** ** dwarf representation types **************************** *) (** ************************************************************ *) @@ -278,7 +325,7 @@ type operation_argument_type = type operation_argument_value = | OAV_natural of sym_natural | OAV_integer of integer - | OAV_block of sym_natural * byte_sequence + | OAV_block of sym_natural * rel_byte_sequence type operation_stack = list sym_natural @@ -324,7 +371,7 @@ type operation = type simple_location = | SL_memory_address of sym_natural | SL_register of sym_natural - | SL_implicit of byte_sequence (* used for implicit and stack values *) + | SL_implicit of rel_byte_sequence (* used for implicit and stack values *) | SL_empty type composite_location_piece = @@ -389,17 +436,17 @@ type abbreviations_table = type attribute_value = (* following Figure 3 *) | AV_addr of sym_natural - | AV_block of sym_natural * byte_sequence - | AV_constantN of sym_natural * byte_sequence + | AV_block of sym_natural * rel_byte_sequence + | AV_constantN of sym_natural * rel_byte_sequence | AV_constant_SLEB128 of integer | AV_constant_ULEB128 of sym_natural - | AV_exprloc of sym_natural * byte_sequence + | AV_exprloc of sym_natural * rel_byte_sequence | AV_flag of bool | AV_ref of sym_natural | AV_ref_addr of sym_natural (* dwarf_format dependent *) | AV_ref_sig8 of sym_natural | AV_sec_offset of sym_natural - | AV_string of byte_sequence (* not including terminating null *) + | AV_string of rel_byte_sequence (* not including terminating null *) | AV_strp of sym_natural (* dwarf_format dependent *) @@ -454,7 +501,7 @@ type type_units = list type_unit (* .debug_loc section *) -type single_location_description = byte_sequence +type single_location_description = rel_byte_sequence type location_list_entry = <| @@ -495,7 +542,7 @@ type range_list_list = list range_list (* .debug_frame section: call frame instructions *) type cfa_address = sym_natural -type cfa_block = byte_sequence +type cfa_block = rel_byte_sequence type cfa_delta = sym_natural type cfa_offset = sym_natural type cfa_register = sym_natural @@ -558,13 +605,13 @@ type cie = cie_length: sym_natural; cie_id: sym_natural; cie_version: sym_natural; - cie_augmentation: byte_sequence; (* not including terminating null *) + cie_augmentation: rel_byte_sequence; (* not including terminating null *) cie_address_size: maybe sym_natural; cie_segment_size: maybe sym_natural; cie_code_alignment_factor: sym_natural; cie_data_alignment_factor: integer; cie_return_address_register: cfa_register; - cie_initial_instructions_bytes: byte_sequence; + cie_initial_instructions_bytes: rel_byte_sequence; cie_initial_instructions: list call_frame_instruction; |> @@ -576,7 +623,7 @@ type fde = fde_initial_location_segment_selector: maybe sym_natural; fde_initial_location_address: sym_natural; fde_address_range: sym_natural; - fde_instructions_bytes: byte_sequence; + fde_instructions_bytes: rel_byte_sequence; fde_instructions: list call_frame_instruction; |> @@ -646,7 +693,7 @@ type line_number_argument_value = | LNAV_ULEB128 of sym_natural | LNAV_SLEB128 of integer | LNAV_uint16 of sym_natural - | LNAV_string of byte_sequence (* not including terminating null *) + | LNAV_string of rel_byte_sequence (* not including terminating null *) type line_number_operation = (* standard *) @@ -665,14 +712,14 @@ type line_number_operation = (* extended *) | DW_LNE_end_sequence | DW_LNE_set_address of sym_natural - | DW_LNE_define_file of byte_sequence * sym_natural * sym_natural * sym_natural + | DW_LNE_define_file of rel_byte_sequence * sym_natural * sym_natural * sym_natural | DW_LNE_set_discriminator of sym_natural (* special *) | DW_LN_special of sym_natural (* the adjusted opcode *) type line_number_file_entry = <| - lnfe_path: byte_sequence; + lnfe_path: rel_byte_sequence; lnfe_directory_index: sym_natural; lnfe_last_modification: sym_natural; lnfe_length: sym_natural; @@ -692,7 +739,7 @@ type line_number_header = lnh_line_range: sym_natural; lnh_opcode_base: sym_natural; lnh_standard_opcode_lengths: list sym_natural; - lnh_include_directories: list (byte_sequence); + lnh_include_directories: list (rel_byte_sequence); lnh_file_entries: list line_number_file_entry; lnh_comp_dir: maybe string; (* passed down from cu DW_AT_comp_dir *) |> @@ -731,7 +778,7 @@ type unpacked_decl = unpacked_file_entry * nat(*line*) * string(*subprogram name type dwarf = <| d_endianness: Endianness.endianness; (* from the ELF *) - d_str: byte_sequence; + d_str: rel_byte_sequence; d_compilation_units: compilation_units; d_type_units: type_units; d_loc: location_list_list; @@ -1551,9 +1598,9 @@ let rec myfiltermaybe f xs = -val bytes_of_natural: endianness -> natural (*size*) -> natural (*value*) -> byte_sequence +val bytes_of_natural: endianness -> natural (*size*) -> natural (*value*) -> rel_byte_sequence let bytes_of_natural en size n = - byte_sequence_of_byte_list ( + rel_byte_sequence_of_byte_list ( if size = 8 then bytes_of_elf64_xword en (elf64_xword_of_natural n) else if size = 4 then @@ -1564,18 +1611,18 @@ let bytes_of_natural en size n = let bytes_of_sym_natural en size n = bytes_of_natural en (sym_unwrap size) (sym_unwrap n) let rec natural_of_bytes_little bs : natural = - match read_char bs with + match rel_read_char bs with | Fail _ -> 0 | Success (b, bs') -> natural_of_byte b + 256 * natural_of_bytes_little bs' end let rec natural_of_bytes_big acc bs = - match read_char bs with + match rel_read_char bs with | Fail _ -> acc | Success (b, bs') -> natural_of_bytes_big (natural_of_byte b + 256 * acc) bs' end -val natural_of_bytes: endianness -> byte_sequence -> natural +val natural_of_bytes: endianness -> rel_byte_sequence -> natural let natural_of_bytes en bs = match en with | Little -> natural_of_bytes_little bs @@ -1662,10 +1709,10 @@ declare coq target_rep function abs n = (`Zpred` (`Zpos` (`P_of_succ_nat` n let pphex_integer n = if n<0 then "-" ^ pphex (abs n) else pphex (abs n) -let ppbytes bs = show (List.map (fun x -> show x) (byte_list_of_byte_sequence bs)) +let ppbytes bs = show (List.map (fun x -> show x) (byte_list_of_rel_byte_sequence bs)) let rec ppbytes2 n bs = - match read_char bs with + match rel_read_char bs with | Fail _ -> "" | Success (x,xs') -> "<" ^ pphex n ^ "> " ^ show x ^ "\n" ^ ppbytes2 (n+1) xs' end @@ -1809,7 +1856,7 @@ let base_type_attribute_encode (s: string) : sym_natural = (* parsing combinators *) -type parse_context = <| pc_bytes: byte_sequence; pc_offset: natural |> +type parse_context = <| pc_bytes: rel_byte_sequence; pc_offset: natural |> type parse_result 'a = | PR_success of 'a * parse_context @@ -1935,7 +1982,7 @@ let rec parse_parser_list ps = val parse_maybe : forall 'a. parser 'a -> parser (maybe 'a) let parse_maybe p = fun pc -> - match Byte_sequence.length pc.pc_bytes with + match rbs_length pc.pc_bytes with | 0 -> pr_return Nothing pc | _ -> match p pc with @@ -1958,7 +2005,7 @@ let parse_demaybe s p = val parse_restrict_length : forall 'a. sym_natural -> parser 'a -> parser 'a let parse_restrict_length n p = fun pc -> - match partition (sym_unwrap n) pc.pc_bytes with + match rbs_partition (sym_unwrap n) pc.pc_bytes with | Fail _ -> Assert_extra.failwith "parse_restrict_length not given enough bytes" | Success (xs,ys) -> let pc' = <| pc_bytes = xs; pc_offset = pc.pc_offset |> in @@ -1970,22 +2017,22 @@ let parse_restrict_length n p = let parse_byte : parser(byte) = fun (pc:parse_context) -> - match read_char pc.pc_bytes with + match rel_read_char pc.pc_bytes with | Fail _ -> PR_fail "parse_byte" pc | Success (b,bs) -> PR_success b (<|pc_bytes=bs; pc_offset= pc.pc_offset + 1 |> ) end -let parse_n_bytes (n:sym_natural) : parser (byte_sequence) = +let parse_n_bytes (n:sym_natural) : parser (rel_byte_sequence) = fun (pc:parse_context) -> - match partition (sym_unwrap n) pc.pc_bytes with + match rbs_partition (sym_unwrap n) pc.pc_bytes with | Fail _ -> PR_fail ("parse_n_bytes n=" ^ pphex_sym n) pc | Success (xs,bs) -> - PR_success xs (<|pc_bytes=bs; pc_offset= pc.pc_offset + (Byte_sequence.length xs) |> ) + PR_success xs (<|pc_bytes=bs; pc_offset= pc.pc_offset + (rbs_length xs) |> ) end let bzero = byte_of_natural 0 -let parse_string : parser (byte_sequence) = +let parse_string : parser (rel_byte_sequence) = fun (pc:parse_context) -> match find_byte pc.pc_bytes bzero with | Nothing -> PR_fail "parse_string" pc @@ -1996,10 +2043,10 @@ let parse_string : parser (byte_sequence) = end (* parse a null-terminated string; return Nothing if it is empty, Just s otherwise *) -let parse_non_empty_string : parser (maybe byte_sequence) = +let parse_non_empty_string : parser (maybe rel_byte_sequence) = fun (pc:parse_context) -> pr_bind (parse_string pc) (fun str pc -> - if Byte_sequence.length str = 0 then + if rbs_length str = 0 then pr_return Nothing pc else pr_return (Just str) pc) @@ -2009,7 +2056,7 @@ let parse_non_empty_string : parser (maybe byte_sequence) = let parse_uint8 : parser sym_natural= fun (pc:parse_context) -> let _ = my_debug "uint8 " in - match read_char pc.pc_bytes with + match rel_read_char pc.pc_bytes with | Success (b, bytes) -> let v = natural_of_byte b in PR_success (Absolute v) (<| pc_bytes = bytes; pc_offset = pc.pc_offset + 1 |>) @@ -2093,7 +2140,7 @@ let parse_sint64 c : parser integer = let rec parse_ULEB128' (acc: natural) (shift_factor: natural) : parser natural = fun (pc:parse_context) -> let _ = my_debug "ULEB128' " in - match read_char pc.pc_bytes with + match rel_read_char pc.pc_bytes with | Success (b,bytes') -> let n = natural_of_byte b in let acc' = (natural_land n 127) * shift_factor + acc in @@ -2114,7 +2161,7 @@ let parse_ULEB128 : parser sym_natural = let rec parse_SLEB128' (acc: natural) (shift_factor: natural) : parser (bool * natural * natural) = fun (pc:parse_context) -> let _ = my_debug "SLEB128' " in - match read_char pc.pc_bytes with + match rel_read_char pc.pc_bytes with | Success (b,bytes') -> let n = natural_of_byte b in let acc' = acc + (natural_land n 127) * shift_factor in @@ -2243,7 +2290,7 @@ let parse_abbreviations_table c = (** debug_str entry *) -let rec null_terminated_bs (bs: byte_sequence) : byte_sequence = +let rec null_terminated_bs (bs: rel_byte_sequence) : rel_byte_sequence = match find_byte bs bzero with | Just i -> match takebytes i bs with @@ -2253,10 +2300,10 @@ let rec null_terminated_bs (bs: byte_sequence) : byte_sequence = | Nothing -> bs end -let pp_debug_str_entry (str: byte_sequence) (n: sym_natural) : string = +let pp_debug_str_entry (str: rel_byte_sequence) (n: sym_natural) : string = match dropbytes (sym_unwrap n) str with | Fail _ -> "strp beyond .debug_str extent" - | Success bs -> string_of_byte_sequence (null_terminated_bs bs) + | Success bs -> string_of_rel_byte_sequence (null_terminated_bs bs) end (** operations: pp and parsing *) @@ -2350,20 +2397,20 @@ let parse_operations_bs c cuh bs : list operation = match parse_operations c cuh pc with | PR_fail s pc' -> Assert_extra.failwith ("parse_operations_bs fail: " ^ pp_parse_fail s pc') | PR_success ops pc' -> - let _ = if Byte_sequence.length pc'.pc_bytes <> 0 then Assert_extra.failwith ("parse_operations_bs extra non-parsed bytes") else () in + let _ = if rbs_length pc'.pc_bytes <> 0 then Assert_extra.failwith ("parse_operations_bs extra non-parsed bytes") else () in ops end -val parse_and_pp_operations : p_context -> compilation_unit_header -> byte_sequence -> string +val parse_and_pp_operations : p_context -> compilation_unit_header -> rel_byte_sequence -> string let parse_and_pp_operations c cuh bs = let pc = <|pc_bytes = bs; pc_offset = 0 |> in match parse_operations c cuh pc with | PR_fail s pc' -> "parse_operations fail: " ^ pp_parse_fail s pc' | PR_success ops pc' -> pp_operations ops - ^ if Byte_sequence.length pc'.pc_bytes <> 0 then " Warning: extra non-parsed bytes" else "" + ^ if rbs_length pc'.pc_bytes <> 0 then " Warning: extra non-parsed bytes" else "" end @@ -2384,12 +2431,12 @@ let pp_attribute_value_plain av = | AV_ref_addr n -> "AV_ref_addr " ^ pphex_sym n | AV_ref_sig8 n -> "AV_ref_sig8 " ^ pphex_sym n | AV_sec_offset n -> "AV_sec_offset " ^ pphex_sym n - | AV_string bs -> string_of_byte_sequence bs + | AV_string bs -> string_of_rel_byte_sequence bs | AV_strp n -> "AV_sec_offset " ^ pphex_sym n ^ " " end -val pp_attribute_value : p_context -> compilation_unit_header -> byte_sequence -> sym_natural (*attribute tag*) -> attribute_value -> string +val pp_attribute_value : p_context -> compilation_unit_header -> rel_byte_sequence -> sym_natural (*attribute tag*) -> attribute_value -> string let pp_attribute_value c cuh str at av = match av with | AV_addr x -> "AV_addr " ^ pphex_sym x @@ -2405,12 +2452,12 @@ let pp_attribute_value c cuh str at av = | AV_ref_addr n -> "AV_ref_addr " ^ pphex_sym n | AV_ref_sig8 n -> "AV_ref_sig8 " ^ pphex_sym n | AV_sec_offset n -> "AV_sec_offset " ^ pphex_sym n - | AV_string bs -> string_of_byte_sequence bs + | AV_string bs -> string_of_rel_byte_sequence bs | AV_strp n -> "AV_sec_offset " ^ pphex_sym n ^ " " ^ pp_debug_str_entry str n end -val pp_attribute_value_like_objdump : p_context -> compilation_unit_header -> byte_sequence -> sym_natural (*attribute tag*) -> attribute_value -> string +val pp_attribute_value_like_objdump : p_context -> compilation_unit_header -> rel_byte_sequence -> sym_natural (*attribute tag*) -> attribute_value -> string let pp_attribute_value_like_objdump c cuh str at av = match av with | AV_addr x -> (*"AV_addr " ^*) pphex_sym x @@ -2429,7 +2476,7 @@ let pp_attribute_value_like_objdump c cuh str at av = | AV_ref_sig8 n -> "AV_ref_sig8 " ^ pphex_sym n | AV_sec_offset n -> (*"AV_sec_offset " ^*) pphex_sym n ^ if at = attribute_encode "DW_AT_location" then " (location list)" else "" - | AV_string bs -> string_of_byte_sequence bs + | AV_string bs -> string_of_rel_byte_sequence bs | AV_strp n -> (*"AV_sec_offset " ^ pphex_sym n ^ " " ^ pp_debug_str_entry str n*) "(indirect string, offset: "^pphex_sym n ^ "): " ^ pp_debug_str_entry str n @@ -2570,7 +2617,7 @@ let find_dies (p:die->bool) (d: dwarf) : list cupdie = let string_of_string_attribute_value str av : string = match av with - | AV_string bs -> string_of_byte_sequence bs + | AV_string bs -> string_of_rel_byte_sequence bs | AV_strp n -> pp_debug_str_entry str n | _ -> "find_string_attribute_value_of_die AV not understood" end @@ -2851,7 +2898,7 @@ let indent_level_plus_one indent level = else " "^" " -let pp_die_attribute c (cuh:compilation_unit_header) (str : byte_sequence) (indent:bool) (level: natural) (((at: sym_natural), (af: sym_natural)), ((pos: sym_natural),(av:attribute_value))) : string = +let pp_die_attribute c (cuh:compilation_unit_header) (str : rel_byte_sequence) (indent:bool) (level: natural) (((at: sym_natural), (af: sym_natural)), ((pos: sym_natural),(av:attribute_value))) : string = indent_level_plus_one indent level ^ pp_pos pos ^ " " ^ right_space_padded_to 18 (pp_attribute_encoding at) ^ ": " ^ @@ -2863,7 +2910,7 @@ let pp_die_attribute c (cuh:compilation_unit_header) (str : byte_sequence) (inde pp_attribute_value_like_objdump c cuh str at av ^ "\n" -val pp_die : p_context -> compilation_unit_header -> byte_sequence -> bool -> natural -> bool -> die -> string +val pp_die : p_context -> compilation_unit_header -> rel_byte_sequence -> bool -> natural -> bool -> die -> string let rec pp_die c cuh str indent level (pp_children:bool) die = indent_level indent level ^ "<" ^ show level ^ ">" ^ pp_pos die.die_offset @@ -2877,7 +2924,7 @@ let rec pp_die c cuh str indent level (pp_children:bool) die = ^ if pp_children then String.concat "" (List.map (pp_die c cuh str indent (level +1) pp_children) die.die_children) else "" -val pp_die_abbrev : p_context -> compilation_unit_header -> byte_sequence -> natural -> bool -> (list die) -> die -> string +val pp_die_abbrev : p_context -> compilation_unit_header -> rel_byte_sequence -> natural -> bool -> (list die) -> die -> string let rec pp_die_abbrev c cuh str level (pp_children:bool) parents die = indent_level true level ^ pp_tag_encoding die.die_abbreviation_declaration.ad_tag @@ -2893,7 +2940,7 @@ let rec pp_die_abbrev c cuh str level (pp_children:bool) parents die = (* condensed pp for variables *) -val pp_die_abbrev_var : p_context -> dwarf -> compilation_unit -> byte_sequence -> bool -> (list die) -> die -> (string (*name*) * string (*offset*) * string (*kind*)) +val pp_die_abbrev_var : p_context -> dwarf -> compilation_unit -> rel_byte_sequence -> bool -> (list die) -> die -> (string (*name*) * string (*offset*) * string (*kind*)) let rec pp_die_abbrev_var c d cu str (pp_children:bool) parents die = (* (indent_level true level*) (* ^ pp_tag_encoding die.die_abbreviation_declaration.ad_tag*) @@ -2910,7 +2957,7 @@ let rec pp_die_abbrev_var c d cu str (pp_children:bool) parents die = ) (* condensed pp for variable parents *) -val pp_die_abbrev_var_parent : p_context -> dwarf -> compilation_unit -> byte_sequence -> die -> string +val pp_die_abbrev_var_parent : p_context -> dwarf -> compilation_unit -> rel_byte_sequence -> die -> string let pp_die_abbrev_var_parent c d cu str die = (* (indent_level true level*) (* ^ pp_tag_encoding die.die_abbreviation_declaration.ad_tag*) @@ -2925,7 +2972,7 @@ let pp_die_abbrev_var_parent c d cu str die = -val pp_die_abbrev_var_parents : p_context -> dwarf -> compilation_unit -> byte_sequence -> list die -> string +val pp_die_abbrev_var_parents : p_context -> dwarf -> compilation_unit -> rel_byte_sequence -> list die -> string let pp_die_abbrev_var_parents c d cu str parents = String.concat ":" (List.map (fun die -> pp_die_abbrev_var_parent c d cu str die) parents) @@ -2939,7 +2986,7 @@ let pp_die_abbrev_var_parents c d cu str parents = -val parse_die : p_context -> byte_sequence -> compilation_unit_header -> (sym_natural->abbreviation_declaration) -> parser (maybe die) +val parse_die : p_context -> rel_byte_sequence -> compilation_unit_header -> (sym_natural->abbreviation_declaration) -> parser (maybe die) let rec parse_die c str cuh find_abbreviation_declaration = fun (pc: parse_context) -> (* let _ = my_debug3 ("parse_die called at " ^ pp_parse_context pc ^ "\n") in *) @@ -2983,7 +3030,7 @@ let has_attribute (an: string) (die: die) : bool = (** compilation units: pp and parsing *) -let pp_compilation_unit c (indent:bool) (debug_str_section_body: byte_sequence) cu = +let pp_compilation_unit c (indent:bool) (debug_str_section_body: rel_byte_sequence) cu = "" (* "*** compilation unit header ***\n"*) ^ pp_compilation_unit_header cu.cu_header @@ -2998,7 +3045,7 @@ let pp_compilation_units c (indent:bool) debug_string_section_body (compilation_ String.concat "" (List.map (pp_compilation_unit c indent debug_string_section_body) compilation_units) -let pp_compilation_unit_abbrev c (debug_str_section_body: byte_sequence) cu = +let pp_compilation_unit_abbrev c (debug_str_section_body: rel_byte_sequence) cu = pp_compilation_unit_header cu.cu_header (* ^ pp_abbreviations_table cu.cu_abbreviations_table*) ^ pp_die_abbrev c cu.cu_header debug_str_section_body 0 true [] cu.cu_die @@ -3011,10 +3058,10 @@ let rec add_die_to_index acc parents die = let nacc : die_index = Map.insert die.die_offset (parents,die) acc in List.foldl (fun acc ndie -> add_die_to_index acc (die::parents) ndie) nacc die.die_children -let parse_compilation_unit c (debug_str_section_body: byte_sequence) (debug_abbrev_section_body: byte_sequence) : parser (maybe compilation_unit) = +let parse_compilation_unit c (debug_str_section_body: rel_byte_sequence) (debug_abbrev_section_body: rel_byte_sequence) : parser (maybe compilation_unit) = fun (pc:parse_context) -> - if Byte_sequence.length pc.pc_bytes = 0 then PR_success Nothing pc else + if rbs_length pc.pc_bytes = 0 then PR_success Nothing pc else let (cuh, pc') = @@ -3058,14 +3105,14 @@ let _ = my_debug4 (pp_compilation_unit_header cuh) in PR_success (Just cu) pc'' end -let parse_compilation_units c (debug_str_section_body: byte_sequence) (debug_abbrev_section_body: byte_sequence): parser (list compilation_unit) +let parse_compilation_units c (debug_str_section_body: rel_byte_sequence) (debug_abbrev_section_body: rel_byte_sequence): parser (list compilation_unit) = parse_list (parse_compilation_unit c debug_str_section_body debug_abbrev_section_body) (** type units: pp and parsing *) -let pp_type_unit c (debug_str_section_body: byte_sequence) tu = +let pp_type_unit c (debug_str_section_body: rel_byte_sequence) tu = pp_type_unit_header tu.tu_header ^ pp_abbreviations_table tu.tu_abbreviations_table ^ pp_die c tu.tu_header.tuh_cuh debug_str_section_body true 0 true tu.tu_die @@ -3074,10 +3121,10 @@ let pp_type_units c debug_string_section_body (type_units: list type_unit) : str String.concat "" (List.map (pp_type_unit c debug_string_section_body) type_units) -let parse_type_unit c (debug_str_section_body: byte_sequence) (debug_abbrev_section_body: byte_sequence) : parser (maybe type_unit) = +let parse_type_unit c (debug_str_section_body: rel_byte_sequence) (debug_abbrev_section_body: rel_byte_sequence) : parser (maybe type_unit) = fun (pc:parse_context) -> - if Byte_sequence.length pc.pc_bytes = 0 then PR_success Nothing pc else + if rbs_length pc.pc_bytes = 0 then PR_success Nothing pc else let (tuh, pc') = match parse_type_unit_header c pc with @@ -3116,7 +3163,7 @@ let parse_type_unit c (debug_str_section_body: byte_sequence) (debug_abbrev_sect PR_success (Just tu) pc'' end -let parse_type_units c (debug_str_section_body: byte_sequence) (debug_abbrev_section_body: byte_sequence): parser (list type_unit) +let parse_type_units c (debug_str_section_body: rel_byte_sequence) (debug_abbrev_section_body: rel_byte_sequence): parser (list type_unit) = parse_list (parse_type_unit c debug_str_section_body debug_abbrev_section_body) @@ -3202,7 +3249,7 @@ let parse_location_list_item c (cuh: compilation_unit_header) : parser (maybe lo let parse_location_list c cuh : parser (maybe location_list) = fun (pc: parse_context) -> - if Byte_sequence.length pc.pc_bytes = 0 then + if rbs_length pc.pc_bytes = 0 then PR_success Nothing pc else pr_post_map1 @@ -3305,7 +3352,7 @@ let rec expand_range_list_suffixes cuh (offset,(rlis: list range_list_item)) : l let parse_range_list c cuh : parser (maybe (list range_list)) = fun (pc: parse_context) -> - if Byte_sequence.length pc.pc_bytes = 0 then + if rbs_length pc.pc_bytes = 0 then PR_success Nothing pc else pr_post_map1 @@ -3453,7 +3500,7 @@ let parser_of_call_frame_argument_type c cuh (cfat: call_frame_argument_type) : let parse_call_frame_instruction c cuh : parser (maybe call_frame_instruction) = fun pc -> - match read_char pc.pc_bytes with + match rel_read_char pc.pc_bytes with | Fail _ -> PR_success Nothing pc | Success (b,bs') -> let pc' = <| pc_bytes = bs'; pc_offset = pc.pc_offset + 1 |> in @@ -3494,14 +3541,14 @@ let parse_call_frame_instruction c cuh : parser (maybe call_frame_instruction) = let parse_call_frame_instructions c cuh : parser (list call_frame_instruction) = parse_list (parse_call_frame_instruction c cuh) -val parse_and_pp_call_frame_instructions : p_context -> compilation_unit_header -> byte_sequence -> string +val parse_and_pp_call_frame_instructions : p_context -> compilation_unit_header -> rel_byte_sequence -> string let parse_and_pp_call_frame_instructions c cuh bs = let pc = <|pc_bytes = bs; pc_offset = 0 |> in match parse_call_frame_instructions c cuh pc with | PR_fail s pc' -> "parse_call_frame_instructions fail: " ^ pp_parse_fail s pc' | PR_success is pc' -> pp_call_frame_instructions is - ^ if Byte_sequence.length pc'.pc_bytes <> 0 then " Warning: extra non-parsed bytes" else "" + ^ if rbs_length pc'.pc_bytes <> 0 then " Warning: extra non-parsed bytes" else "" end @@ -3518,7 +3565,7 @@ let pp_cie c cuh cie = ^ " " ^ pphex_sym cie.cie_id ^ " CIE\n" ^ " Version: " ^ show cie.cie_version ^ "\n" - ^ " Augmentation: \""^ show (string_of_byte_sequence cie.cie_augmentation) ^ "\"\n" + ^ " Augmentation: \""^ show (string_of_rel_byte_sequence cie.cie_augmentation) ^ "\"\n" ^ " Code alignment factor: " ^ show cie.cie_code_alignment_factor ^ "\n" ^ " Data alignment factor: " ^ show cie.cie_data_alignment_factor ^ "\n" ^ " Return address column: " ^ show cie.cie_return_address_register ^ "\n" @@ -3665,7 +3712,7 @@ Hence the following, which should be made more tail-recursive. *) val parse_dependent_list' : forall 'a. (list 'a -> parser 'a) -> list 'a -> parser (list 'a) let rec parse_dependent_list' p1 acc = fun pc -> - if Byte_sequence.length pc.pc_bytes = 0 then + if rbs_length pc.pc_bytes = 0 then PR_success (List.reverse acc) pc else pr_bind @@ -3685,7 +3732,7 @@ let parse_frame_info c cuh : parser frame_info (** line numbers .debug_line, pp and parsing *) let pp_line_number_file_entry lnfe = - "lnfe_path = " ^ string_of_byte_sequence lnfe.lnfe_path ^ "\n" + "lnfe_path = " ^ string_of_rel_byte_sequence lnfe.lnfe_path ^ "\n" ^ "lnfe_directory_index " ^ show lnfe.lnfe_directory_index ^ "\n" ^ "lnfe_last_modification = " ^ show lnfe.lnfe_last_modification ^ "\n" ^ "lnfe_length = " ^ show lnfe.lnfe_length ^ "\n" @@ -3705,7 +3752,7 @@ let pp_line_number_header lnh = ^ "opcode_base = " ^ show lnh.lnh_opcode_base ^ "\n" ^ "standard_opcode_lengths = " ^ show lnh.lnh_standard_opcode_lengths ^ "\n" ^ "comp_dir = " ^ show lnh.lnh_comp_dir ^ "\n" -^ "include_directories = " ^ String.concat ", " (List.map string_of_byte_sequence lnh.lnh_include_directories) ^ "\n" +^ "include_directories = " ^ String.concat ", " (List.map string_of_rel_byte_sequence lnh.lnh_include_directories) ^ "\n" ^ "file_entries = \n\n" ^ String.concat "\n" (List.map pp_line_number_file_entry lnh.lnh_file_entries) ^ "\n" @@ -3808,7 +3855,7 @@ let parse_line_number_header c (comp_dir:maybe string) : parser line_number_head (fun ((v,(((hl,(minil,maxopi))),(dis,(lb,(lr,ob)))))) -> pr_post_map (parse_triple - (pr_post_map (parse_n_bytes (ob-Absolute 1)) (fun bs -> List.map sym_natural_of_byte (byte_list_of_byte_sequence bs))) (* standard_opcode_lengths *) + (pr_post_map (parse_n_bytes (ob-Absolute 1)) (fun bs -> List.map sym_natural_of_byte (byte_list_of_rel_byte_sequence bs))) (* standard_opcode_lengths *) ((*pr_return [[]]*) parse_list parse_non_empty_string) (* include_directories *) (parse_list parse_line_number_file_entry) (* file names *) ) @@ -3933,7 +3980,7 @@ let filename d cu n = if n=0 then Nothing else match mynth (n - 1) lnp.lnp_header.lnh_file_entries with | Just lnfe -> - Just (string_of_byte_sequence lnfe.lnfe_path) + Just (string_of_rel_byte_sequence lnfe.lnfe_path) | Nothing -> Assert_extra.failwith ("line number file entry not found") end @@ -3946,11 +3993,11 @@ let unpack_file_entry lnh file : unpacked_file_entry = Nothing else match mynth (lnfe.lnfe_directory_index - 1) lnh.lnh_include_directories with - | Just d -> Just (string_of_byte_sequence d) + | Just d -> Just (string_of_rel_byte_sequence d) | Nothing -> Just "" end in - (lnh.lnh_comp_dir, directory, string_of_byte_sequence lnfe.lnfe_path) + (lnh.lnh_comp_dir, directory, string_of_rel_byte_sequence lnfe.lnfe_path) | Nothing -> (Nothing,Nothing,"") end @@ -3976,7 +4023,7 @@ let pp_ufe_brief (((mcomp_dir,mdir,file) as ufe) : unpacked_file_entry) : string ^ " comp_dir=" ^ match mcomp_dir with | Just s->s|Nothing->"" end *) -let parse_line_number_info c str (d_line: byte_sequence) (cu: compilation_unit) : line_number_program = +let parse_line_number_info c str (d_line: rel_byte_sequence) (cu: compilation_unit) : line_number_program = let comp_dir = find_string_attribute_value_of_die "DW_AT_comp_dir" str cu.cu_die in let f n = let d_line' = match dropbytes n d_line with Success xs -> xs | Fail _ -> Assert_extra.failwith "parse_line_number_info drop" end in @@ -4040,13 +4087,13 @@ let pp_dwarf d = (* TODO: don't use lists of bytes here! *) let parse_dwarf c - (debug_info_section_body: byte_sequence) - (debug_abbrev_section_body: byte_sequence) - (debug_str_section_body: byte_sequence) - (debug_loc_section_body: byte_sequence) - (debug_ranges_section_body: byte_sequence) - (debug_frame_section_body: byte_sequence) - (debug_line_section_body: byte_sequence) + (debug_info_section_body: rel_byte_sequence) + (debug_abbrev_section_body: rel_byte_sequence) + (debug_str_section_body: rel_byte_sequence) + (debug_loc_section_body: rel_byte_sequence) + (debug_ranges_section_body: rel_byte_sequence) + (debug_frame_section_body: rel_byte_sequence) + (debug_line_section_body: rel_byte_sequence) : dwarf = let pc_info = <|pc_bytes = debug_info_section_body; pc_offset = 0 |> in @@ -4102,7 +4149,7 @@ let parse_dwarf c d_line_info = li; |> -val extract_section_body : elf_file -> string -> bool -> p_context * sym_natural * byte_sequence +val extract_section_body : elf_file -> string -> bool -> p_context * sym_natural * rel_byte_sequence let extract_section_body (f:elf_file) (section_name:string) (strict: bool) = let (en: Endianness.endianness) = match f with @@ -4167,7 +4214,7 @@ let extract_dwarf f = Just d -val extract_text : elf_file -> p_context * sym_natural * byte_sequence (* (p_context, elf32/64_section_addr, elf32/64_section_body) *) +val extract_text : elf_file -> p_context * sym_natural * rel_byte_sequence (* (p_context, elf32/64_section_addr, elf32/64_section_body) *) let extract_text f = extract_section_body f ".text" true @@ -4487,12 +4534,12 @@ let rec evaluate_operation_list (c:p_context) (dloc: location_list_list) (evalua end end -and evaluate_location_description_bytes (c:p_context) (dloc: location_list_list) (evaluated_frame_info: evaluated_frame_info) (cuh: compilation_unit_header) (ac: arithmetic_context) (ev: evaluation_context) (mfbloc: maybe attribute_value) (pc: sym_natural) (bs: byte_sequence) : error single_location = +and evaluate_location_description_bytes (c:p_context) (dloc: location_list_list) (evaluated_frame_info: evaluated_frame_info) (cuh: compilation_unit_header) (ac: arithmetic_context) (ev: evaluation_context) (mfbloc: maybe attribute_value) (pc: sym_natural) (bs: rel_byte_sequence) : error single_location = let parse_context = <|pc_bytes = bs; pc_offset = 0 |> in match parse_operations c cuh parse_context with | PR_fail s pc' -> Fail ("evaluate_location_description_bytes: parse_operations fail: " ^ pp_parse_fail s pc') | PR_success ops pc' -> - if Byte_sequence.length pc'.pc_bytes <> 0 then + if rbs_length pc'.pc_bytes <> 0 then Fail "evaluate_location_description_bytes: extra non-parsed bytes" else evaluate_operation_list c dloc evaluated_frame_info cuh ac ev mfbloc pc initial_state ops @@ -5185,7 +5232,7 @@ let analyse_locations_raw c (d: dwarf) = let name = match av_name with - | AV_string bs -> string_of_byte_sequence bs + | AV_string bs -> string_of_rel_byte_sequence bs | AV_strp n -> pp_debug_str_entry d.d_str n | _ -> "av_name AV not understood" end in @@ -6536,11 +6583,11 @@ let pp_inlined_subroutines_by_range ds iss = (* assume 4-byte ARM instructions *) -let rec words_of_byte_sequence (addr:sym_natural) (bs:byte_sequence) (acc:list (sym_natural * sym_natural)) : list (sym_natural * sym_natural) = +let rec words_of_rel_byte_sequence (addr:sym_natural) (bs:rel_byte_sequence) (acc:list (sym_natural * sym_natural)) : list (sym_natural * sym_natural) = match read_4_bytes_be bs with | Success ((b0,b1,b2,b3), bs') -> let i : sym_natural = Absolute (natural_of_byte b0 + 256*natural_of_byte b1 + 65536*natural_of_byte b2 + 65536*256*natural_of_byte b3) in - words_of_byte_sequence (addr+4) bs' ((addr,i)::acc) + words_of_rel_byte_sequence (addr+4) bs' ((addr,i)::acc) | Fail _ -> List.reverse acc end @@ -6550,14 +6597,14 @@ let pp_instruction ((addr:sym_natural),(i:sym_natural)) = val pp_text_section : elf_file -> string let pp_text_section f = let (p_context, addr, bs) = extract_text f in - let instructions : list (sym_natural * sym_natural) = words_of_byte_sequence addr bs [] in + let instructions : list (sym_natural * sym_natural) = words_of_rel_byte_sequence addr bs [] in String.concat "" (List.map pp_instruction instructions) (** ************************************************************ *) (** ** top level for main_elf ******************************** *) (** ************************************************************ *) -val harness_string_of_elf_like_objdump : elf_file -> byte_sequence -> string +val harness_string_of_elf_like_objdump : elf_file -> rel_byte_sequence -> string let harness_string_of_elf_like_objdump f1 bs = let mds = extract_dwarf_static f1 in match mds with @@ -6568,7 +6615,7 @@ let harness_string_of_elf_like_objdump f1 bs = end -val harness_string_of_elf : elf_file -> byte_sequence -> string +val harness_string_of_elf : elf_file -> rel_byte_sequence -> string let harness_string_of_elf f1 bs = let mds = extract_dwarf_static f1 in match mds with @@ -6606,21 +6653,21 @@ let mds = extract_dwarf_static f1 in end -val harness_string_of_elf64_debug_info_section : elf64_file -> byte_sequence -> (*(sym_natural -> string) -> (sym_natural -> string) -> (sym_natural -> string) -> elf64_header -> elf64_section_header_table -> string_table -> *) string +val harness_string_of_elf64_debug_info_section : elf64_file -> rel_byte_sequence -> (*(sym_natural -> string) -> (sym_natural -> string) -> (sym_natural -> string) -> elf64_header -> elf64_section_header_table -> string_table -> *) string let {ocaml} harness_string_of_elf64_debug_info_section f1 bs0 (*os proc usr hdr sht stbl*) = harness_string_of_elf (ELF_File_64 f1) bs0 -val harness_string_of_elf32_debug_info_section : elf32_file -> byte_sequence -> (* (sym_natural -> string) -> (sym_natural -> string) -> (sym_natural -> string) -> elf32_header -> elf32_section_header_table -> string_table ->*) string +val harness_string_of_elf32_debug_info_section : elf32_file -> rel_byte_sequence -> (* (sym_natural -> string) -> (sym_natural -> string) -> (sym_natural -> string) -> elf32_header -> elf32_section_header_table -> string_table ->*) string let {ocaml} harness_string_of_elf32_debug_info_section f1 bs0 (*os proc usr hdr sht stbl*) = harness_string_of_elf (ELF_File_32 f1) bs0 -val harness_string_of_elf64_like_objdump : elf64_file -> byte_sequence -> (*(sym_natural -> string) -> (sym_natural -> string) -> (sym_natural -> string) -> elf64_header -> elf64_section_header_table -> string_table -> *) string +val harness_string_of_elf64_like_objdump : elf64_file -> rel_byte_sequence -> (*(sym_natural -> string) -> (sym_natural -> string) -> (sym_natural -> string) -> elf64_header -> elf64_section_header_table -> string_table -> *) string let {ocaml} harness_string_of_elf64_like_objdump f1 bs0 (*os proc usr hdr sht stbl*) = harness_string_of_elf_like_objdump (ELF_File_64 f1) bs0 -val harness_string_of_elf32_like_objdump : elf32_file -> byte_sequence -> (* (sym_natural -> string) -> (sym_natural -> string) -> (sym_natural -> string) -> elf32_header -> elf32_section_header_table -> string_table ->*) string +val harness_string_of_elf32_like_objdump : elf32_file -> rel_byte_sequence -> (* (sym_natural -> string) -> (sym_natural -> string) -> (sym_natural -> string) -> elf32_header -> elf32_section_header_table -> string_table ->*) string let {ocaml} harness_string_of_elf32_like_objdump f1 bs0 (*os proc usr hdr sht stbl*) = harness_string_of_elf_like_objdump (ELF_File_32 f1) bs0 diff --git a/src/elf_symbolic.lem b/src/elf_symbolic.lem index 726c386..3af1ff4 100644 --- a/src/elf_symbolic.lem +++ b/src/elf_symbolic.lem @@ -23,4 +23,9 @@ type abstract_relocation 'a = type reloc_target_data = | Data32 - | Data64 \ No newline at end of file + | Data64 + +let reloc_width_bytes : reloc_target_data -> natural = function + | Data32 -> 4 + | Data64 -> 8 +end \ No newline at end of file From 71b657e2c6637e280aa70ab84e9e6df88fa7e87c Mon Sep 17 00:00:00 2001 From: Matej Urban Date: Fri, 15 Nov 2024 19:53:40 +0000 Subject: [PATCH 06/44] WIP pass relocations to dwarf --- .../abi_aarch64_symbolic_relocation.lem | 8 +- src/dwarf.lem | 150 ++++++++++++++---- src/elf_symbolic.lem | 39 +++++ src/main_elf.lem | 26 ++- 4 files changed, 186 insertions(+), 37 deletions(-) diff --git a/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem b/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem index 69e29ee..f92866e 100644 --- a/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem +++ b/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem @@ -127,7 +127,7 @@ let abi_aarch64_apply_relocation_symbolic rel s_val p_val ef = else fail "abi_aarch64_apply_relocation: not a relocatable file" -let abi_aarch64_relocation_to_abstract symtab sidx rel ef = +let abi_aarch64_relocation_to_abstract ef symtab sidx rel = let p_val = section_with_offset sidx rel.elf64_ra_offset in let (_, sym) = parse_elf64_relocation_info rel.elf64_ra_info in match List.index symtab (unsafe_nat_of_natural sym) with @@ -136,3 +136,9 @@ let abi_aarch64_relocation_to_abstract symtab sidx rel ef = end >>= fun s_val -> abi_aarch64_apply_relocation_symbolic rel s_val p_val ef >>= fun rel_desc_map -> map_mapM eval_relocation rel_desc_map + +let aarch64_relocation_target_to_data_target = function + | Data32 -> return Elf_symbolic.Data32 + | Data64 -> return Elf_symbolic.Data64 + | _ -> fail "Not a data relocation" +end \ No newline at end of file diff --git a/src/dwarf.lem b/src/dwarf.lem index 2c526c8..5efd017 100644 --- a/src/dwarf.lem +++ b/src/dwarf.lem @@ -237,6 +237,15 @@ type rel_byte_sequence = <| rbs_bytes : byte_sequence ; rbs_relocs : list next_reloc |> + +type read_result 'a = + | ReadValue of 'a + | ReadReloc of abstract_relocation reloc_target_data + +let read_result_unwrap = function + | ReadValue x -> x + | ReadReloc _ -> Assert_extra.failwith "read_result_unwrap" +end let rbs_no_reloc (bs : byte_sequence) : rel_byte_sequence = <| rbs_bytes = bs @@ -250,12 +259,65 @@ end let rel_byte_sequence_of_byte_list l = rbs_no_reloc (byte_sequence_of_byte_list l) -let rel_read_char bs = +let pad_no_reloc n rels = + if n = 0 then + rels + else match rels with + | NoReloc m :: rels -> NoReloc (n+m) :: rels + | _ -> NoReloc n :: rels +end + +let rbs_read_char bs = match bs.rbs_relocs with | NoReloc n :: rels -> read_char bs.rbs_bytes >>= fun (c,bs') -> - return (c, <| rbs_bytes = bs' ; rbs_relocs = if n = 1 then rels else NoReloc (n-1) :: rels |>) - | _ -> fail "rel_read_char: has reloaction" + return (c, <| rbs_bytes = bs' ; rbs_relocs = pad_no_reloc (n-1) rels |>) + | _ -> fail "rbs_read_char: has reloaction" + end + +let rbs_read_2_bytes_be bs = + match bs.rbs_relocs with + | NoReloc n :: rels -> + if n < 2 then + fail "rbs_read_2_bytes_be: has reloaction" + else + read_2_bytes_be bs.rbs_bytes >>= fun (b2,bs') -> + return (b2, <| rbs_bytes = bs' ; rbs_relocs = pad_no_reloc (n-2) rels |>) + | _ -> fail "rbs_read_2_bytes_be: has reloaction" + end + +let rbs_read_4_bytes_be bs = + match bs.rbs_relocs with + | NoReloc n :: rels -> + if n < 4 then + fail "rbs_read_4_bytes_be: has misaligned reloaction" + else + read_4_bytes_be bs.rbs_bytes >>= fun (b4,bs') -> + return (ReadValue b4, <| rbs_bytes = bs' ; rbs_relocs = pad_no_reloc (n-4) rels |>) + | Reloc rel :: rels -> + if reloc_width_bytes rel.arel_target <> 4 then + fail "rbs_read_4_bytes_be: has misaligned reloaction" + else + dropbytes 4 bs.rbs_bytes >>= fun bs' -> + return (ReadReloc rel, <| rbs_bytes = bs' ; rbs_relocs = rels |>) + | _ -> fail "rbs_read_4_bytes_be: has misaligned reloaction" + end + +let rbs_read_8_bytes_be bs = + match bs.rbs_relocs with + | NoReloc n :: rels -> + if n < 8 then + fail "rbs_read_8_bytes_be: has misaligned reloaction" + else + read_8_bytes_be bs.rbs_bytes >>= fun (b8,bs') -> + return (ReadValue b8, <| rbs_bytes = bs' ; rbs_relocs = pad_no_reloc (n-8) rels |>) + | Reloc rel :: rels -> + if reloc_width_bytes rel.arel_target <> 8 then + fail "rbs_read_8_bytes_be: has misaligned reloaction" + else + dropbytes 8 bs.rbs_bytes >>= fun bs' -> + return (ReadReloc rel, <| rbs_bytes = bs' ; rbs_relocs = rels |>) + | _ -> fail "rbs_read_8_bytes_be: has misaligned reloaction" end let rbs_length rbs = Byte_sequence.length rbs.rbs_bytes @@ -263,10 +325,10 @@ let rbs_length rbs = Byte_sequence.length rbs.rbs_bytes let rec reloc_list_partition n relocs = match (n, relocs) with | (0, relocs) -> return ([], relocs) | (n, NoReloc m :: relocs) -> if m > n then - return ([NoReloc n], NoReloc (m - n) :: relocs) + return ([NoReloc n], pad_no_reloc (m - n) relocs) else reloc_list_partition (n-m) relocs >>= fun (a, b) -> - return (NoReloc m :: a, b) + return (pad_no_reloc m a, b) | (n, Reloc r :: relocs) -> let m = reloc_width_bytes r.arel_target in if m > n then @@ -282,8 +344,29 @@ let rbs_partition n rbs = reloc_list_partition n rbs.rbs_relocs >>= fun (r1, r2) -> return (<| rbs_bytes = bs1 ; rbs_relocs = r1 |>, <| rbs_bytes = bs2 ; rbs_relocs = r2 |>) -let byte_list_of_rel_byte_sequence bs = - byte_list_of_byte_sequence (rbs_unwrap bs) +let rbs_takebytes n rbs = + rbs_partition n rbs >>= fun(x,_) -> return x + +let rbs_dropbytes n rbs = + rbs_partition n rbs >>= fun(_,x) -> return x + +let rbs_find_byte rbs b = + Maybe.bind (find_byte rbs.rbs_bytes b) (fun n -> + let errmsg = "rbs_find_byte: relocations before byte found" in + match rbs.rbs_relocs with + | NoReloc m :: _ -> if m >= n then Just n else Assert_extra.failwith errmsg + | _ -> Assert_extra.failwith errmsg + end) + +let byte_list_of_rel_byte_sequence rbs = + byte_list_of_byte_sequence (rbs_unwrap rbs) + +let string_of_rel_byte_sequence rbs = + string_of_byte_sequence (rbs_unwrap rbs) + +instance (Show rel_byte_sequence) + let show = string_of_rel_byte_sequence +end (** ************************************************************ *) (** ** dwarf representation types **************************** *) @@ -1611,13 +1694,13 @@ let bytes_of_natural en size n = let bytes_of_sym_natural en size n = bytes_of_natural en (sym_unwrap size) (sym_unwrap n) let rec natural_of_bytes_little bs : natural = - match rel_read_char bs with + match rbs_read_char bs with | Fail _ -> 0 | Success (b, bs') -> natural_of_byte b + 256 * natural_of_bytes_little bs' end let rec natural_of_bytes_big acc bs = - match rel_read_char bs with + match rbs_read_char bs with | Fail _ -> acc | Success (b, bs') -> natural_of_bytes_big (natural_of_byte b + 256 * acc) bs' end @@ -1712,7 +1795,7 @@ let pphex_integer n = if n<0 then "-" ^ pphex (abs n) else pphex (abs n) let ppbytes bs = show (List.map (fun x -> show x) (byte_list_of_rel_byte_sequence bs)) let rec ppbytes2 n bs = - match rel_read_char bs with + match rbs_read_char bs with | Fail _ -> "" | Success (x,xs') -> "<" ^ pphex n ^ "> " ^ show x ^ "\n" ^ ppbytes2 (n+1) xs' end @@ -2017,7 +2100,7 @@ let parse_restrict_length n p = let parse_byte : parser(byte) = fun (pc:parse_context) -> - match rel_read_char pc.pc_bytes with + match rbs_read_char pc.pc_bytes with | Fail _ -> PR_fail "parse_byte" pc | Success (b,bs) -> PR_success b (<|pc_bytes=bs; pc_offset= pc.pc_offset + 1 |> ) end @@ -2034,7 +2117,7 @@ let bzero = byte_of_natural 0 let parse_string : parser (rel_byte_sequence) = fun (pc:parse_context) -> - match find_byte pc.pc_bytes bzero with + match rbs_find_byte pc.pc_bytes bzero with | Nothing -> PR_fail "parse_string" pc | Just n -> pr_bind (parse_n_bytes (Absolute n) pc) (fun res pc -> (*todo find byte should respect relocs*) @@ -2056,7 +2139,7 @@ let parse_non_empty_string : parser (maybe rel_byte_sequence) = let parse_uint8 : parser sym_natural= fun (pc:parse_context) -> let _ = my_debug "uint8 " in - match rel_read_char pc.pc_bytes with + match rbs_read_char pc.pc_bytes with | Success (b, bytes) -> let v = natural_of_byte b in PR_success (Absolute v) (<| pc_bytes = bytes; pc_offset = pc.pc_offset + 1 |>) @@ -2073,7 +2156,7 @@ let parse_uint8_constant (v:sym_natural) : parser sym_natural= let parse_uint16 c : parser sym_natural= fun (pc:parse_context) -> let _ = my_debug "uint16 " in - match read_2_bytes_be pc.pc_bytes with + match rbs_read_2_bytes_be pc.pc_bytes with | Success ((b0,b1),bytes') -> let v = if c.endianness=Little then natural_of_byte b0 + 256*natural_of_byte b1 @@ -2087,8 +2170,8 @@ let parse_uint16 c : parser sym_natural= let parse_uint32 c : parser sym_natural= fun (pc:parse_context) -> let _ = my_debug "uint32 " in - match read_4_bytes_be pc.pc_bytes with - | Success ((b0,b1,b2,b3),bytes') -> + match rbs_read_4_bytes_be pc.pc_bytes with + | Success (ReadValue (b0,b1,b2,b3),bytes') -> (*TODO*) let v = if c.endianness=Little then natural_of_byte b0 + 256*natural_of_byte b1 + 256*256*natural_of_byte b2 + 256*256*256*natural_of_byte b3 else @@ -2101,8 +2184,8 @@ let parse_uint32 c : parser sym_natural= let parse_uint64 c : parser sym_natural= fun (pc:parse_context) -> let _ = my_debug "uint64 " in - match read_8_bytes_be pc.pc_bytes with - | Success ((b0,b1,b2,b3,b4,b5,b6,b7),bytes') -> + match rbs_read_8_bytes_be pc.pc_bytes with + | Success (ReadValue (b0,b1,b2,b3,b4,b5,b6,b7),bytes') -> (*TODO*) let v = if c.endianness=Little then natural_of_byte b0 + 256*natural_of_byte b1 + 256*256*natural_of_byte b2 + 256*256*256*natural_of_byte b3 + (256*256*256*256*(natural_of_byte b4 + 256*natural_of_byte b5 + 256*256*natural_of_byte b6 + 256*256*256*natural_of_byte b7)) @@ -2140,7 +2223,7 @@ let parse_sint64 c : parser integer = let rec parse_ULEB128' (acc: natural) (shift_factor: natural) : parser natural = fun (pc:parse_context) -> let _ = my_debug "ULEB128' " in - match rel_read_char pc.pc_bytes with + match rbs_read_char pc.pc_bytes with | Success (b,bytes') -> let n = natural_of_byte b in let acc' = (natural_land n 127) * shift_factor + acc in @@ -2161,7 +2244,7 @@ let parse_ULEB128 : parser sym_natural = let rec parse_SLEB128' (acc: natural) (shift_factor: natural) : parser (bool * natural * natural) = fun (pc:parse_context) -> let _ = my_debug "SLEB128' " in - match rel_read_char pc.pc_bytes with + match rbs_read_char pc.pc_bytes with | Success (b,bytes') -> let n = natural_of_byte b in let acc' = acc + (natural_land n 127) * shift_factor in @@ -2291,9 +2374,9 @@ let parse_abbreviations_table c = (** debug_str entry *) let rec null_terminated_bs (bs: rel_byte_sequence) : rel_byte_sequence = - match find_byte bs bzero with + match rbs_find_byte bs bzero with | Just i -> - match takebytes i bs with + match rbs_takebytes i bs with | Success bs' -> bs' | Fail _ -> Assert_extra.failwith "find_byte or take_byte is broken" end @@ -2301,7 +2384,7 @@ let rec null_terminated_bs (bs: rel_byte_sequence) : rel_byte_sequence = end let pp_debug_str_entry (str: rel_byte_sequence) (n: sym_natural) : string = - match dropbytes (sym_unwrap n) str with + match rbs_dropbytes (sym_unwrap n) str with | Fail _ -> "strp beyond .debug_str extent" | Success bs -> string_of_rel_byte_sequence (null_terminated_bs bs) end @@ -3074,7 +3157,7 @@ let _ = my_debug4 (pp_compilation_unit_header cuh) in if cuh.cuh_unit_length = 0 then PR_success Nothing pc' else - let pc_abbrev = <|pc_bytes = match dropbytes (sym_unwrap cuh.cuh_debug_abbrev_offset) debug_abbrev_section_body with Success bs -> bs | Fail _ -> Assert_extra.failwith "mydrop of debug_abbrev" end; pc_offset = sym_unwrap cuh.cuh_debug_abbrev_offset |> in + let pc_abbrev = <|pc_bytes = match rbs_dropbytes (sym_unwrap cuh.cuh_debug_abbrev_offset) debug_abbrev_section_body with Success bs -> bs | Fail _ -> Assert_extra.failwith "mydrop of debug_abbrev" end; pc_offset = sym_unwrap cuh.cuh_debug_abbrev_offset |> in (* todo: this is reparsing the abbreviations table for each cu *) let abbreviations_table = @@ -3134,7 +3217,7 @@ let parse_type_unit c (debug_str_section_body: rel_byte_sequence) (debug_abbrev_ (* let _ = my_debug4 (pp_type_unit_header tuh) in *) - let pc_abbrev = let n = tuh.tuh_cuh.cuh_debug_abbrev_offset in <|pc_bytes = match dropbytes (sym_unwrap n) debug_abbrev_section_body with Success bs -> bs | Fail _ -> Assert_extra.failwith "mydrop of debug_abbrev" end; pc_offset = sym_unwrap n |> in + let pc_abbrev = let n = tuh.tuh_cuh.cuh_debug_abbrev_offset in <|pc_bytes = match rbs_dropbytes (sym_unwrap n) debug_abbrev_section_body with Success bs -> bs | Fail _ -> Assert_extra.failwith "mydrop of debug_abbrev" end; pc_offset = sym_unwrap n |> in let abbreviations_table = match parse_abbreviations_table c pc_abbrev with @@ -3500,7 +3583,7 @@ let parser_of_call_frame_argument_type c cuh (cfat: call_frame_argument_type) : let parse_call_frame_instruction c cuh : parser (maybe call_frame_instruction) = fun pc -> - match rel_read_char pc.pc_bytes with + match rbs_read_char pc.pc_bytes with | Fail _ -> PR_success Nothing pc | Success (b,bs') -> let pc' = <| pc_bytes = bs'; pc_offset = pc.pc_offset + 1 |> in @@ -4026,7 +4109,7 @@ let pp_ufe_brief (((mcomp_dir,mdir,file) as ufe) : unpacked_file_entry) : string let parse_line_number_info c str (d_line: rel_byte_sequence) (cu: compilation_unit) : line_number_program = let comp_dir = find_string_attribute_value_of_die "DW_AT_comp_dir" str cu.cu_die in let f n = - let d_line' = match dropbytes n d_line with Success xs -> xs | Fail _ -> Assert_extra.failwith "parse_line_number_info drop" end in + let d_line' = match rbs_dropbytes n d_line with Success xs -> xs | Fail _ -> Assert_extra.failwith "parse_line_number_info drop" end in let pc = <| pc_bytes = d_line'; pc_offset = n|> in match parse_line_number_program c cu.cu_header comp_dir pc with | PR_success lnp pc' -> @@ -4149,8 +4232,9 @@ let parse_dwarf c d_line_info = li; |> -val extract_section_body : elf_file -> string -> bool -> p_context * sym_natural * rel_byte_sequence -let extract_section_body (f:elf_file) (section_name:string) (strict: bool) = +(* TODO *) +val extract_section_body' : elf_file -> string -> bool -> p_context * sym_natural * byte_sequence +let extract_section_body' (f:elf_file) (section_name:string) (strict: bool) = let (en: Endianness.endianness) = match f with | ELF_File_32 f32 -> Elf_header.get_elf32_header_endianness f32.Elf_file.elf32_file_header @@ -4200,6 +4284,10 @@ let extract_section_body (f:elf_file) (section_name:string) (strict: bool) = end end +val extract_section_body : elf_file -> string -> bool -> p_context * sym_natural * rel_byte_sequence +let extract_section_body (f:elf_file) (section_name:string) (strict: bool) = + let (c,n,bs) = extract_section_body' f section_name strict in (c,n,rbs_no_reloc bs) + val extract_dwarf : elf_file -> maybe dwarf let extract_dwarf f = let (c, _, debug_info_section_body) = extract_section_body f ".debug_info" true in @@ -6584,8 +6672,8 @@ let pp_inlined_subroutines_by_range ds iss = let rec words_of_rel_byte_sequence (addr:sym_natural) (bs:rel_byte_sequence) (acc:list (sym_natural * sym_natural)) : list (sym_natural * sym_natural) = - match read_4_bytes_be bs with - | Success ((b0,b1,b2,b3), bs') -> + match rbs_read_4_bytes_be bs with + | Success (ReadValue (b0,b1,b2,b3), bs') -> (*TODO*) let i : sym_natural = Absolute (natural_of_byte b0 + 256*natural_of_byte b1 + 65536*natural_of_byte b2 + 65536*256*natural_of_byte b3) in words_of_rel_byte_sequence (addr+4) bs' ((addr,i)::acc) | Fail _ -> List.reverse acc diff --git a/src/elf_symbolic.lem b/src/elf_symbolic.lem index 3af1ff4..07ad94a 100644 --- a/src/elf_symbolic.lem +++ b/src/elf_symbolic.lem @@ -1,5 +1,16 @@ +open import Basic_classes open import Num +open import Error +open import Byte_sequence +open import Bool + + open import Elf_types_native_uint +open import Elf_relocation +open import Elf_symbol_table +open import Elf_file +open import Elf_header +open import Elf_section_header_table (* TODO *) type binary_operation @@ -28,4 +39,32 @@ type reloc_target_data = let reloc_width_bytes : reloc_target_data -> natural = function | Data32 -> 4 | Data64 -> 8 +end + +type relocation_interpreter 'a = elf64_file -> elf64_symbol_table -> elf64_half -> elf64_relocation_a -> error (Map.map elf64_addr (abstract_relocation 'a)) + +val extract_elf64_relocations_for_section : forall 'a. elf64_file -> relocation_interpreter 'a -> elf64_half -> byte_sequence -> error (Map.map elf64_addr (abstract_relocation 'a)) +let extract_elf64_relocations_for_section f1 interp sidx bs0 = + let hdr = f1.elf64_file_header in + let sht = f1.elf64_file_section_header_table in + let endian = get_elf64_header_endianness hdr in + let cond x = + (x.elf64_sh_type = elf64_word_of_natural sht_rela) && (natural_of_elf64_word x.elf64_sh_info = natural_of_elf64_half sidx) + in + match List.filter cond sht with + | [] -> return Map.empty + | [rel_sec] -> + let off = natural_of_elf64_off rel_sec.elf64_sh_offset in + let siz = natural_of_elf64_xword rel_sec.elf64_sh_size in + let lnk = natural_of_elf64_word rel_sec.elf64_sh_link in + Byte_sequence.offset_and_cut off siz bs0 >>= fun rels -> + Elf_relocation.read_elf64_relocation_a_section' endian rels >>= fun rels -> + Elf_file.get_elf64_symbol_table_by_index f1 lnk >>= fun symtab -> + mapM (interp f1 symtab sidx) rels >>= fun rel_maps -> + let rel_map = Map.unions rel_maps in + if Map.size rel_map <> List.length rels then + fail "Multiple relocations at the same location" + else + return rel_map + | _ -> fail "Multiple relocation sections for this section" end \ No newline at end of file diff --git a/src/main_elf.lem b/src/main_elf.lem index e867dea..bc4eea3 100644 --- a/src/main_elf.lem +++ b/src/main_elf.lem @@ -32,11 +32,13 @@ open import Elf_file open import Elf_program_header_table open import Elf_section_header_table open import Elf_types_native_uint +open import Elf_symbolic open import Harness_interface open import Sail_interface open import Abi_aarch64_relocation +open import Abi_aarch64_symbolic_relocation open import Abi_amd64_elf_header open import Abi_amd64_relocation @@ -186,7 +188,21 @@ let obtain_abi_specific_string_of_reloc_type mach = string_of_mips64_relocation_type*) else const "Cannot deduce ABI" - + +val interpret_data_relocation : natural -> relocation_interpreter reloc_target_data +let interpret_data_relocation mach ef symtab sidx rel = + if mach = elf_ma_aarch64 then + abi_aarch64_relocation_to_abstract ef symtab sidx rel >>= fun arels -> + map_mapM (fun arel -> + aarch64_relocation_target_to_data_target arel.arel_target >>= fun target -> + return <| arel_value = arel.arel_value + ; arel_target = target + |> + ) arels + else + Error.fail "Unsupported machine" + + let _ = let res = let (flag, arg) = @@ -266,7 +282,7 @@ let _ = get_elf32_file_section_header_string_table f1 >>= fun stbl -> return (Dwarf.harness_string_of_elf32_debug_info_section f1 - bs0 + (Dwarf.rbs_no_reloc bs0) (*string_of_gnu_ext_section_type (fun x -> show x) (fun x -> show x) @@ -279,7 +295,7 @@ let _ = get_elf32_file_section_header_string_table f1 >>= fun stbl -> return (Dwarf.harness_string_of_elf32_like_objdump f1 - bs0 + (Dwarf.rbs_no_reloc bs0) (*string_of_gnu_ext_section_type (fun x -> show x) (fun x -> show x) @@ -358,7 +374,7 @@ let _ = get_elf64_file_section_header_string_table f1 >>= fun stbl -> return (Dwarf.harness_string_of_elf64_debug_info_section f1 - bs0 + (Dwarf.rbs_no_reloc bs0) (*string_of_gnu_ext_section_type (fun x -> show x) (fun x -> show x) @@ -371,7 +387,7 @@ let _ = get_elf64_file_section_header_string_table f1 >>= fun stbl -> return ("\n"^arg^": file format [...]" ^"\n\n"^ Dwarf.harness_string_of_elf64_like_objdump f1 - bs0 + (Dwarf.rbs_no_reloc bs0) (*string_of_gnu_ext_section_type (fun x -> show x) (fun x -> show x) From 14ec89649d1525fee5f5bd6878c251f162b0a994 Mon Sep 17 00:00:00 2001 From: Matej Urban Date: Wed, 4 Dec 2024 14:19:15 +0000 Subject: [PATCH 07/44] fixes --- .gitignore | 2 + .../abi_aarch64_symbolic_relocation.lem | 9 +- src/abis/abi_symbolic_relocation.lem | 2 - src/dwarf.lem | 396 +++++++++++------- src/elf_symbolic.lem | 75 +++- src/main_elf.lem | 34 +- 6 files changed, 328 insertions(+), 190 deletions(-) diff --git a/.gitignore b/.gitignore index 80f86a0..ba315b0 100644 --- a/.gitignore +++ b/.gitignore @@ -30,3 +30,5 @@ src/build_num src/build_zarith src/_build src/byte_sequence_impl.lem + +_opam diff --git a/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem b/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem index f92866e..5980ad9 100644 --- a/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem +++ b/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem @@ -127,11 +127,12 @@ let abi_aarch64_apply_relocation_symbolic rel s_val p_val ef = else fail "abi_aarch64_apply_relocation: not a relocatable file" -let abi_aarch64_relocation_to_abstract ef symtab sidx rel = - let p_val = section_with_offset sidx rel.elf64_ra_offset in +val abi_aarch64_relocation_to_abstract : relocation_interpreter aarch64_relocation_target +let abi_aarch64_relocation_to_abstract ef symtab_map sidx rel = + section_with_offset ef sidx rel.elf64_ra_offset >>= fun p_val -> let (_, sym) = parse_elf64_relocation_info rel.elf64_ra_info in - match List.index symtab (unsafe_nat_of_natural sym) with - | Just ste -> return (symbolic_address_from_elf64_symbol_table_entry ste) + match Map.lookup sym symtab_map with + | Just ste -> symbolic_address_from_elf64_symbol_table_entry ef ste | Nothing -> fail "Invalid symbol table index" end >>= fun s_val -> abi_aarch64_apply_relocation_symbolic rel s_val p_val ef >>= fun rel_desc_map -> diff --git a/src/abis/abi_symbolic_relocation.lem b/src/abis/abi_symbolic_relocation.lem index ee376d4..cc11c47 100644 --- a/src/abis/abi_symbolic_relocation.lem +++ b/src/abis/abi_symbolic_relocation.lem @@ -45,5 +45,3 @@ let eval_relocation desc = >>= fun value -> return <| arel_value = Mask(value, lo, hi) ; arel_target = desc.rel_desc_target |> -let symbolic_address_from_elf64_symbol_table_entry ste = - section_with_offset ste.elf64_st_shndx ste.elf64_st_value diff --git a/src/dwarf.lem b/src/dwarf.lem index 5efd017..0bc96e1 100644 --- a/src/dwarf.lem +++ b/src/dwarf.lem @@ -131,13 +131,36 @@ let my_debug3 s = () (*print_endline s*) let my_debug4 s = print_endline s let my_debug5 s = print_endline s +(** ************************************************************ *) +(** ** missing pervasives ************************************ *) +(** ************************************************************ *) + +(* sym_natural version of List.index *) +val index_natural : forall 'a. list 'a -> natural -> maybe 'a +let rec index_natural l n = match l with + | [] -> Nothing + | x :: xs -> if n = 0 then Just x else index_natural xs (n-1) +end + +let partialNaturalFromInteger (i:integer) : natural = + if i<0 then Assert_extra.failwith "partialNaturalFromInteger" else naturalFromInteger i + +val natural_nat_shift_left : natural -> nat -> natural +declare ocaml target_rep function natural_nat_shift_left = `Nat_big_num.shift_left` + +val natural_nat_shift_right : natural -> nat -> natural +declare ocaml target_rep function natural_nat_shift_right = `Nat_big_num.shift_right` (* Symbolic types *) -type sym_natural = - | Offset of (string * natural) - | Absolute of natural +type sym 'a = + | Offset of (string * 'a) + | Absolute of 'a | Unknown +type sym_natural = sym natural +type sym_integer = sym integer + +val sym_add : forall 'a. NumAdd 'a => (sym 'a -> sym 'a -> sym 'a) let sym_add x y= match (x, y) with | (Absolute x, Absolute y) -> Absolute (x + y) @@ -146,7 +169,7 @@ let sym_add x y= | _ -> Unknown end -val sym_bind : sym_natural -> (natural -> sym_natural) -> sym_natural +val sym_bind : forall 'a. sym 'a -> ('a -> sym 'a) -> sym 'a let sym_bind x f = match x with | Absolute x -> f x | _ -> Unknown @@ -156,51 +179,115 @@ let sym_map f x = sym_bind x (fun x -> Absolute(f x)) let sym_map2 f x y = sym_bind x (fun x -> sym_map (f x) y) -let sym_unwrap = function +(* TODO add everywhere or handle differently *) +let simplify = function + | Offset (s, x) -> match toCharList s with + | #'.'::#'d'::#'e'::#'b'::#'u'::#'g'::_ -> Absolute x (* HACK should be lookup in context *) + | _ -> Offset (s, x) + end + | x -> x +end + +let sym_unwrap sym_val ctx = match simplify sym_val with | Absolute x -> x - | _ -> Assert_extra.failwith "sym_unwrap" + | Offset (s, x) -> Assert_extra.failwith ("sym_unwrap (Offset from " ^ s ^ ") in " ^ ctx) + | Unknown -> Assert_extra.failwith ("sym_unwrap Unknown in " ^ ctx) end -instance (NumAdd sym_natural) +let pp_sym ppf = function +| Absolute x -> ppf x +| Offset (s, x) -> s ^ "+" ^ ppf x +| Unknown -> "Unknown" +end + +instance forall 'a. Show 'a => (Show (sym 'a)) + let show = pp_sym show +end + +instance forall 'a. NumAdd 'a => (NumAdd (sym 'a)) let (+) = sym_add end -instance (NumMinus sym_natural) +instance forall 'a. NumMinus 'a => (NumMinus (sym 'a)) let (-) = sym_map2 (-) end -instance (NumMult sym_natural) +instance forall 'a. NumMult 'a => (NumMult (sym 'a)) let ( * ) = sym_map2 ( * ) end -instance (NumDivision sym_natural) +instance forall 'a. NumDivision 'a => (NumDivision (sym 'a)) let (/) = sym_map2 (/) end -instance (NumRemainder sym_natural) +instance forall 'a. NumRemainder 'a => (NumRemainder (sym 'a)) let (mod) = sym_map2 (mod) end -instance (Ord sym_natural) - let compare = (fun x -> fun y -> compare (sym_unwrap x) (sym_unwrap y)) - let (<) = (fun x -> fun y -> (sym_unwrap x) < (sym_unwrap y)) - let (<=) = (fun x -> fun y -> (sym_unwrap x) <= (sym_unwrap y)) - let (>) = (fun x -> fun y -> (sym_unwrap x) > (sym_unwrap y)) - let (>=) = (fun x -> fun y -> (sym_unwrap x) >= (sym_unwrap y)) +let sym_comp f a b = match (simplify a, simplify b) with + | (Absolute a, Absolute b) -> f a b + | (Offset (s, a), Offset(t, b)) -> if s = t then + f a b + else + Assert_extra.failwith ("offsets of different sections " ^ s ^ " and " ^ t) + | _ -> Assert_extra.failwith "sym_comp" (* TODO should probably figure out better errors*) end -instance (Numeral sym_natural) - let fromNumeral = fun x -> Absolute (fromNumeral x) +instance forall 'a. Ord 'a => (Ord (sym 'a)) + let compare = sym_comp compare + let (<) = sym_comp (<) + let (<=) = sym_comp (<=) + let (>) = sym_comp (>) + let (>=) = sym_comp (>=) end -let pp_sym ppf = function -| Absolute x -> ppf x -| Offset (s, x) -> s ^ "+" ^ ppf x -| Unknown -> "Unknown" +(* instance forall 'a. Ord 'a, Show 'a => (Ord (sym 'a)) + let compare = (fun x -> fun y -> compare (sym_unwrap x ((show x) ^ "compare" ^ (show y))) (sym_unwrap y ((show x) ^ "compare" ^ (show y)))) + let (<) = (fun x -> fun y -> (sym_unwrap x ((show x) ^ "<" ^ (show y))) < (sym_unwrap y ((show x) ^ "<" ^ (show y)))) + let (<=) = (fun x -> fun y -> (sym_unwrap x ((show x) ^ "<=" ^ (show y))) <= (sym_unwrap y ((show x) ^ "<=" ^ (show y)))) + let (>) = (fun x -> fun y -> (sym_unwrap x ((show x) ^ ">" ^ (show y))) > (sym_unwrap y ((show x) ^ ">" ^ (show y)))) + let (>=) = (fun x -> fun y -> (sym_unwrap x ((show x) ^ ">=" ^ (show y))) >= (sym_unwrap y ((show x) ^ ">=" ^ (show y)))) +end *) + + +class ( NumeralSym 'a ) + val fromNumeralSym : numeral -> sym 'a end -instance (Show sym_natural) - let show = pp_sym show +instance (NumeralSym integer) + let fromNumeralSym = fun x -> Absolute (fromNumeral x) +end + +instance (NumeralSym natural) + let fromNumeralSym = fun x -> Absolute (fromNumeral x) +end + +instance forall 'a. NumeralSym 'a => (Numeral (sym 'a)) + let fromNumeral = fromNumeralSym +end + +val sym_eq : forall 'a. Eq 'a => sym 'a -> sym 'a -> bool +let sym_eq a b = match (simplify a, simplify b) with +| (Absolute x, Absolute y) -> x = y +| (Offset (s,x), Offset (t, y)) -> s=t && x=y +| _ -> Assert_extra.failwith "sym_eq" +end + + +let rec sym_integer_of_symbolic_expression x = match x with + | Section s -> Offset (s, 0) + | Const x -> Absolute x + | BinOp (x, Add, y) -> (sym_integer_of_symbolic_expression x) + (sym_integer_of_symbolic_expression y) + | BinOp (x, Sub, y) -> (sym_integer_of_symbolic_expression x) - (sym_integer_of_symbolic_expression y) + | AssertRange (x, _, _) -> sym_integer_of_symbolic_expression x (*TODO*) + | Mask (x, _, _) -> sym_integer_of_symbolic_expression x (*TODO*) +end + +let sym_natural_of_symbolic_expression x = + match sym_integer_of_symbolic_expression x with + | Offset (s, x) -> Offset (s, partialNaturalFromInteger x) + | Absolute x -> Absolute (partialNaturalFromInteger x) + | Unknown -> Unknown end let sym_natural_land = sym_map2 natural_land @@ -227,12 +314,30 @@ let symNaturalPow x y = sym_map (fun x -> naturalPow x y) x let symNaturalFromInteger x = Absolute(naturalFromInteger x) +let index_sym_natural l n = index_natural l (sym_unwrap n "index_sym_natural") + +let partialSymNaturalFromInteger i = Absolute (partialNaturalFromInteger i) + +let sym_natural_nat_shift_left x sh = sym_map (fun x -> natural_nat_shift_left x sh) x +let sym_natural_nat_shift_right x sh = sym_map (fun x -> natural_nat_shift_right x sh) x + (* byte sequence *) type next_reloc = | NoReloc of natural | Reloc of abstract_relocation reloc_target_data +let pp_relocs relocs = + let f = function + | NoReloc -> "NoReloc" + | Reloc x -> match x.arel_target with + | Data32 -> "Data32 " + | Data64 -> "Data64 " + end ^ pp_sym_expr x.arel_value + end in + "[" ^ String.concat "," (List.map f relocs) ^ "]" + + type rel_byte_sequence = <| rbs_bytes : byte_sequence ; rbs_relocs : list next_reloc @@ -247,6 +352,8 @@ let read_result_unwrap = function | ReadReloc _ -> Assert_extra.failwith "read_result_unwrap" end +let rbs_length rbs = Byte_sequence.length rbs.rbs_bytes + let rbs_no_reloc (bs : byte_sequence) : rel_byte_sequence = <| rbs_bytes = bs ; rbs_relocs = [NoReloc (Byte_sequence.length bs)] |> @@ -254,8 +361,11 @@ let rbs_no_reloc (bs : byte_sequence) : rel_byte_sequence = let rbs_unwrap bs = match bs.rbs_relocs with | [NoReloc n] -> bs.rbs_bytes - | _ -> Assert_extra.failwith "rbs_unwrap: has relocations" -end + | [] -> + let _ = my_debug ("Bytes should be empty:" ^ (show bs.rbs_bytes)) in + bs.rbs_bytes + | x -> Assert_extra.failwith ("rbs_unwrap: has relocations " ^ (pp_relocs x)) + end let rel_byte_sequence_of_byte_list l = rbs_no_reloc (byte_sequence_of_byte_list l) @@ -267,6 +377,23 @@ let pad_no_reloc n rels = | _ -> NoReloc n :: rels end +(* TODO strict mode? *) +val reloc_map_to_reloc_list' : Map.map elf64_addr (abstract_relocation reloc_target_data) -> natural -> natural -> list next_reloc +let rec reloc_map_to_reloc_list' rels i l = + if i = l then + [] + else + match Map.lookup (elf64_addr_of_natural i) rels with + | Nothing -> pad_no_reloc 1 (reloc_map_to_reloc_list' rels (i+1) l) + | Just x -> Reloc x :: reloc_map_to_reloc_list' rels (i + reloc_width_bytes x.arel_target) l + end + +let reloc_map_to_reloc_list rels l = + reloc_map_to_reloc_list' rels 0 l + +let construct_rel_byte_sequence bs rel = + <| rbs_bytes = bs ; rbs_relocs = reloc_map_to_reloc_list rel (Byte_sequence.length bs) |> + let rbs_read_char bs = match bs.rbs_relocs with | NoReloc n :: rels -> @@ -320,8 +447,6 @@ let rbs_read_8_bytes_be bs = | _ -> fail "rbs_read_8_bytes_be: has misaligned reloaction" end -let rbs_length rbs = Byte_sequence.length rbs.rbs_bytes - let rec reloc_list_partition n relocs = match (n, relocs) with | (0, relocs) -> return ([], relocs) | (n, NoReloc m :: relocs) -> if m > n then @@ -1050,37 +1175,6 @@ type inlined_subroutine_data_by_range = list inlined_subroutine_data_by_range_en - - - - -(** ************************************************************ *) -(** ** missing pervasives ************************************ *) -(** ************************************************************ *) - -(* sym_natural version of List.index *) -val index_natural : forall 'a. list 'a -> natural -> maybe 'a -let rec index_natural l n = match l with - | [] -> Nothing - | x :: xs -> if n = 0 then Just x else index_natural xs (n-1) -end - -let partialNaturalFromInteger (i:integer) : natural = - if i<0 then Assert_extra.failwith "partialNaturalFromInteger" else naturalFromInteger i - -val natural_nat_shift_left : natural -> nat -> natural -declare ocaml target_rep function natural_nat_shift_left = `Nat_big_num.shift_left` - -val natural_nat_shift_right : natural -> nat -> natural -declare ocaml target_rep function natural_nat_shift_right = `Nat_big_num.shift_right` - -let index_sym_natural l n = index_natural l (sym_unwrap n) - -let partialSymNaturalFromInteger i = Absolute (partialNaturalFromInteger i) - -let sym_natural_nat_shift_left x sh = sym_map (fun x -> natural_nat_shift_left x sh) x -let sym_natural_nat_shift_right x sh = sym_map (fun x -> natural_nat_shift_right x sh) x - (** ************************************************************ *) (** ** endianness *************************************** *) (** ************************************************************ *) @@ -1691,7 +1785,7 @@ let bytes_of_natural en size n = else Assert_extra.failwith "bytes_of_natural given size that is not 4 or 8") -let bytes_of_sym_natural en size n = bytes_of_natural en (sym_unwrap size) (sym_unwrap n) +let bytes_of_sym_natural en size n = bytes_of_natural en (sym_unwrap size "bytes_of_sym_natural size") (sym_unwrap n "bytes_of_sym_natural n") let rec natural_of_bytes_little bs : natural = match rbs_read_char bs with @@ -1764,11 +1858,11 @@ let rec mytake' (n:natural) acc xs = end val mytake : forall 'a. sym_natural -> (list 'a) -> maybe (list 'a * list 'a) -let mytake n xs = mytake' (sym_unwrap n) [] xs +let mytake n xs = mytake' (sym_unwrap n "mytake") [] xs val mynth : forall 'a. sym_natural -> (list 'a) -> maybe 'a let rec mynth (n:sym_natural) xs = - match (sym_unwrap n,xs) with + match (sym_unwrap n "mynth",xs) with | (0, x::xs') -> Just x | (0, []) -> Nothing (*Assert_extra.failwith "mynth"*) | (_, x::xs') -> mynth (n-1) xs' @@ -1792,7 +1886,8 @@ declare coq target_rep function abs n = (`Zpred` (`Zpos` (`P_of_succ_nat` n let pphex_integer n = if n<0 then "-" ^ pphex (abs n) else pphex (abs n) -let ppbytes bs = show (List.map (fun x -> show x) (byte_list_of_rel_byte_sequence bs)) +let ppbytes bs = show (List.map (fun x -> show x) (byte_list_of_byte_sequence bs.rbs_bytes)) +(* let ppbytes bs = show (List.map (fun x -> show x) (byte_list_of_rel_byte_sequence bs)) *) let rec ppbytes2 n bs = match rbs_read_char bs with @@ -1823,14 +1918,14 @@ let just_one s xs = let max_address (as': sym_natural) : sym_natural = - match sym_unwrap as' with + match sym_unwrap as' "max_addres" with | 4 -> sym_natural_of_hex "0xffffffff" | 8 -> sym_natural_of_hex "0xffffffffffffffff" | _ -> Assert_extra.failwith "max_address size not 4 or 8" end let range_address (as': sym_natural) : sym_natural = - match sym_unwrap as' with + match sym_unwrap as' "max_addres" with | 4 -> sym_natural_of_hex "0x100000000" | 8 -> sym_natural_of_hex "0x10000000000000000" | _ -> Assert_extra.failwith "range_address size not 4 or 8" @@ -2088,7 +2183,7 @@ let parse_demaybe s p = val parse_restrict_length : forall 'a. sym_natural -> parser 'a -> parser 'a let parse_restrict_length n p = fun pc -> - match rbs_partition (sym_unwrap n) pc.pc_bytes with + match rbs_partition (sym_unwrap n "parse_strict_length") pc.pc_bytes with | Fail _ -> Assert_extra.failwith "parse_restrict_length not given enough bytes" | Success (xs,ys) -> let pc' = <| pc_bytes = xs; pc_offset = pc.pc_offset |> in @@ -2107,7 +2202,7 @@ let parse_byte : parser(byte) = let parse_n_bytes (n:sym_natural) : parser (rel_byte_sequence) = fun (pc:parse_context) -> - match rbs_partition (sym_unwrap n) pc.pc_bytes with + match rbs_partition (sym_unwrap n "parse_n_bytes") pc.pc_bytes with | Fail _ -> PR_fail ("parse_n_bytes n=" ^ pphex_sym n) pc | Success (xs,bs) -> PR_success xs (<|pc_bytes=bs; pc_offset= pc.pc_offset + (rbs_length xs) |> ) @@ -2171,12 +2266,17 @@ let parse_uint32 c : parser sym_natural= fun (pc:parse_context) -> let _ = my_debug "uint32 " in match rbs_read_4_bytes_be pc.pc_bytes with - | Success (ReadValue (b0,b1,b2,b3),bytes') -> (*TODO*) + | Success (ReadValue (b0,b1,b2,b3),bytes') -> let v = if c.endianness=Little then natural_of_byte b0 + 256*natural_of_byte b1 + 256*256*natural_of_byte b2 + 256*256*256*natural_of_byte b3 else natural_of_byte b3 + 256*natural_of_byte b2 + 256*256*natural_of_byte b1 + 256*256*256*natural_of_byte b0 in PR_success (Absolute v) (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 4 |>) + | Success (ReadReloc r, bytes') -> + if r.arel_target = Data32 then + PR_success (sym_natural_of_symbolic_expression r.arel_value) (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 4 |>) + else + PR_fail "parse_uint32 wrong relocation type" pc | _ -> PR_fail "parse_uint32 not given enough bytes" pc end @@ -2194,6 +2294,11 @@ let parse_uint64 c : parser sym_natural= + (256*256*256*256*(natural_of_byte b3 + 256*natural_of_byte b2 + 256*256*natural_of_byte b1 + 256*256*256*natural_of_byte b0)) in PR_success (Absolute v) (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 8 |>) + | Success (ReadReloc r, bytes') -> + if r.arel_target = Data64 then + PR_success (sym_natural_of_symbolic_expression r.arel_value) (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 8 |>) + else + PR_fail "parse_uint64 wrong relocation type" pc | _ -> PR_fail "parse_uint64 not given enough bytes" pc end @@ -2209,16 +2314,16 @@ let partialTwosComplementNaturalFromInteger (i:integer) (half: natural) (all:int let partialTwosComplementSymNaturalFromInteger i half all = sym_map (fun x -> partialTwosComplementNaturalFromInteger i x all) half let parse_sint8 : parser integer = - pr_post_map (parse_uint8) (fun n -> integerFromTwosComplementNatural (sym_unwrap n) 128 256) + pr_post_map (parse_uint8) (fun n -> integerFromTwosComplementNatural (sym_unwrap n "parse_sint8") 128 256) let parse_sint16 c : parser integer = - pr_post_map (parse_uint16 c) (fun n -> integerFromTwosComplementNatural (sym_unwrap n) (128*256) (256*256)) + pr_post_map (parse_uint16 c) (fun n -> integerFromTwosComplementNatural (sym_unwrap n "parse_sint16") (128*256) (256*256)) let parse_sint32 c : parser integer = - pr_post_map (parse_uint32 c) (fun n -> integerFromTwosComplementNatural (sym_unwrap n) (128*256*256*256) (256*256*256*256)) + pr_post_map (parse_uint32 c) (fun n -> integerFromTwosComplementNatural (sym_unwrap n "parse_sint32") (128*256*256*256) (256*256*256*256)) let parse_sint64 c : parser integer = - pr_post_map (parse_uint64 c) (fun n -> integerFromTwosComplementNatural (sym_unwrap n) (128*256*256*256*256*256*256*256) (256*256*256*256*256*256*256*256)) + pr_post_map (parse_uint64 c) (fun n -> integerFromTwosComplementNatural (sym_unwrap n "parse_sint64") (128*256*256*256*256*256*256*256) (256*256*256*256*256*256*256*256)) let rec parse_ULEB128' (acc: natural) (shift_factor: natural) : parser natural = fun (pc:parse_context) -> @@ -2281,14 +2386,14 @@ let parse_uintDwarfN c (df: dwarf_format) : parser sym_natural = end let parse_uint_address_size c (as': sym_natural) : parser sym_natural = - match sym_unwrap as' with + match sym_unwrap as' "parse_uint_address_size" with | 4 -> (parse_uint32 c) | 8 -> (parse_uint64 c) | _ -> Assert_extra.failwith ("cuh_address_size not 4 or 8: " ^ show as') end let parse_uint_segment_selector_size c (ss: sym_natural) : parser (maybe sym_natural) = - match sym_unwrap ss with + match sym_unwrap ss "parse_uint_segment_selector_size_size" with | 0 -> pr_return Nothing | 1 -> pr_post_map (parse_uint8) (fun n -> Just n) | 2 -> pr_post_map (parse_uint16 c) (fun n -> Just n) @@ -2384,7 +2489,7 @@ let rec null_terminated_bs (bs: rel_byte_sequence) : rel_byte_sequence = end let pp_debug_str_entry (str: rel_byte_sequence) (n: sym_natural) : string = - match rbs_dropbytes (sym_unwrap n) str with + match rbs_dropbytes (sym_unwrap n "pp_debug_str_entry") str with | Fail _ -> "strp beyond .debug_str extent" | Success bs -> string_of_rel_byte_sequence (null_terminated_bs bs) end @@ -3072,11 +3177,11 @@ let pp_die_abbrev_var_parents c d cu str parents = val parse_die : p_context -> rel_byte_sequence -> compilation_unit_header -> (sym_natural->abbreviation_declaration) -> parser (maybe die) let rec parse_die c str cuh find_abbreviation_declaration = fun (pc: parse_context) -> - (* let _ = my_debug3 ("parse_die called at " ^ pp_parse_context pc ^ "\n") in *) + let _ = my_debug3 ("parse_die called at " ^ pp_parse_context pc ^ "\n") in pr_bind (parse_ULEB128 pc) (fun abbreviation_code pc' -> if abbreviation_code = 0 then PR_success Nothing pc' else - (* let _ = my_debug3 ("parse_die abbreviation code "^pphex abbreviation_code ^"\n") in *) + let _ = my_debug3 ("parse_die abbreviation code "^pphex_sym abbreviation_code ^"\n") in let ad = find_abbreviation_declaration abbreviation_code in let attribute_value_parsers = List.map (fun (at,af) -> pr_with_pos (parser_of_attribute_form c cuh af)) ad.ad_attribute_specifications in pr_bind (parse_parser_list attribute_value_parsers pc') (fun avs pc'' -> @@ -3157,7 +3262,7 @@ let _ = my_debug4 (pp_compilation_unit_header cuh) in if cuh.cuh_unit_length = 0 then PR_success Nothing pc' else - let pc_abbrev = <|pc_bytes = match rbs_dropbytes (sym_unwrap cuh.cuh_debug_abbrev_offset) debug_abbrev_section_body with Success bs -> bs | Fail _ -> Assert_extra.failwith "mydrop of debug_abbrev" end; pc_offset = sym_unwrap cuh.cuh_debug_abbrev_offset |> in + let pc_abbrev = <|pc_bytes = match rbs_dropbytes (sym_unwrap cuh.cuh_debug_abbrev_offset "mydrop of pc_abbrev") debug_abbrev_section_body with Success bs -> bs | Fail _ -> Assert_extra.failwith "mydrop of debug_abbrev" end; pc_offset = sym_unwrap cuh.cuh_debug_abbrev_offset "mydrop of pc_abbrev"|> in (* todo: this is reparsing the abbreviations table for each cu *) let abbreviations_table = @@ -3166,13 +3271,13 @@ let _ = my_debug4 (pp_compilation_unit_header cuh) in | PR_success at pc_abbrev' -> <| at_offset=Absolute pc_abbrev.pc_offset; at_table= at|> end in - (* let _ = my_debug4 (pp_abbreviations_table abbreviations_table) in *) + let _ = my_debug4 (pp_abbreviations_table abbreviations_table) in let find_abbreviation_declaration (ac:sym_natural) : abbreviation_declaration = (* let _ = my_debug4 ("find_abbreviation_declaration "^pphex ac) in *) - myfindNonPure (fun ad -> ad.ad_abbreviation_code = ac) abbreviations_table.at_table in + myfindNonPure (fun ad -> sym_eq ad.ad_abbreviation_code ac) abbreviations_table.at_table in - (* let _ = my_debug3 (pp_abbreviations_table abbreviations_table) in *) + let _ = my_debug3 (pp_abbreviations_table abbreviations_table) in match parse_die c debug_str_section_body cuh find_abbreviation_declaration pc' with | PR_fail s pc'' -> Assert_extra.failwith ("parse_die fail: " ^ pp_parse_fail s pc'') @@ -3217,7 +3322,7 @@ let parse_type_unit c (debug_str_section_body: rel_byte_sequence) (debug_abbrev_ (* let _ = my_debug4 (pp_type_unit_header tuh) in *) - let pc_abbrev = let n = tuh.tuh_cuh.cuh_debug_abbrev_offset in <|pc_bytes = match rbs_dropbytes (sym_unwrap n) debug_abbrev_section_body with Success bs -> bs | Fail _ -> Assert_extra.failwith "mydrop of debug_abbrev" end; pc_offset = sym_unwrap n |> in + let pc_abbrev = let n = tuh.tuh_cuh.cuh_debug_abbrev_offset in <|pc_bytes = match rbs_dropbytes (sym_unwrap n "mydrop of pc_abbrev") debug_abbrev_section_body with Success bs -> bs | Fail _ -> Assert_extra.failwith "mydrop of debug_abbrev" end; pc_offset = sym_unwrap n "mydrop of pc_abbrev" |> in let abbreviations_table = match parse_abbreviations_table c pc_abbrev with @@ -3229,7 +3334,7 @@ let parse_type_unit c (debug_str_section_body: rel_byte_sequence) (debug_abbrev_ let find_abbreviation_declaration (ac:sym_natural) : abbreviation_declaration = (* let _ = my_debug4 ("find_abbreviation_declaration "^pphex ac) in *) - myfindNonPure (fun ad -> ad.ad_abbreviation_code = ac) abbreviations_table.at_table in + myfindNonPure (fun ad -> sym_eq ad.ad_abbreviation_code ac) abbreviations_table.at_table in (* let _ = my_debug3 (pp_abbreviations_table abbreviations_table) in *) @@ -3343,7 +3448,7 @@ let parse_location_list_list c cuh : parser location_list_list = parse_list (parse_location_list c cuh) let find_location_list dloc n : location_list = - myfindNonPure (fun (n',_)-> n'=n) dloc + myfindNonPure (fun (n',_)-> sym_eq n' n) dloc (* fails if location list not found *) (* interpretation of a location list applies the base_address and LLI_base offsets to give a list indexed by concrete address ranges *) @@ -3446,7 +3551,7 @@ let parse_range_list_list c cuh : parser range_list_list = pr_map2 List.concat (parse_list (parse_range_list c cuh)) let find_range_list dranges n : maybe range_list = - List.find (fun (n',_)-> n'=n) dranges + List.find (fun (n',_)-> sym_eq n' n) dranges (* fails if range list not found *) (* interpretation of a range list applies the base_address and RLI_base offsets to give a list of concrete address ranges *) @@ -3688,7 +3793,7 @@ let rec find_cie fi cie_id = match fi with | [] -> Assert_extra.failwith "find_cie: cie_id not found" | FIE_fde _ :: fi' -> find_cie fi' cie_id - | FIE_cie cie :: fi' -> if cie_id = cie.cie_offset then cie else find_cie fi' cie_id + | FIE_cie cie :: fi' -> if sym_eq cie_id cie.cie_offset then cie else find_cie fi' cie_id end let parse_initial_location c cuh mss mas' : parser ((maybe sym_natural) * sym_natural) = (*(segment selector and target address)*) @@ -4053,7 +4158,7 @@ let line_number_offset_of_compilation_unit c cu = let line_number_program_of_compilation_unit d cu = let c = p_context_of_d d in let offset = line_number_offset_of_compilation_unit c cu in - match List.find (fun lnp -> lnp.lnp_header.lnh_offset = offset) d.d_line_info with + match List.find (fun lnp -> sym_eq lnp.lnp_header.lnh_offset offset) d.d_line_info with | Nothing -> Assert_extra.failwith "compilation unit line number offset not found" | Just lnp ->lnp end @@ -4117,7 +4222,7 @@ let parse_line_number_info c str (d_line: rel_byte_sequence) (cu: compilation_un lnp | PR_fail s pc' -> Assert_extra.failwith ("parse_line_number_header failed: " ^ s) end in - f (sym_unwrap (line_number_offset_of_compilation_unit c cu)) + f (sym_unwrap (line_number_offset_of_compilation_unit c cu) "parse_line_number_info") let parse_line_number_infos c str debug_line_section_body compilation_units = @@ -4187,7 +4292,7 @@ let parse_dwarf c | PR_success cus pc_info' -> cus end in - (*let _ = my_debug5 (pp_compilation_units c debug_str_section_body compilation_units) in*) + let _ = my_debug5 (pp_compilation_units c false debug_str_section_body compilation_units) in (* the DWARF4 spec doesn't seem to specify the address size used in the .debug_loc section, so we (hackishly) take it from the first compilation unit *) @@ -4212,7 +4317,7 @@ let parse_dwarf c let pc_frame = <|pc_bytes = debug_frame_section_body; pc_offset = 0 |> in let fi = - (* let _ = my_debug5 ("debug_frame_section_body:\n" ^ ppbytes2 0 debug_frame_section_body) in *) + let _ = my_debug5 ("debug_frame_section_body:\n" ^ ppbytes2 0 debug_frame_section_body) in match parse_frame_info c cuh_default pc_frame with | PR_fail s pc_info' -> Assert_extra.failwith ("parse_frame_info: " ^ pp_parse_fail s pc_info') @@ -4233,8 +4338,8 @@ let parse_dwarf c |> (* TODO *) -val extract_section_body' : elf_file -> string -> bool -> p_context * sym_natural * byte_sequence -let extract_section_body' (f:elf_file) (section_name:string) (strict: bool) = +val extract_section_body : elf_file -> relocation_interpreter reloc_target_data -> string -> bool -> p_context * sym_natural * rel_byte_sequence +let extract_section_body (f:elf_file) (ri:relocation_interpreter reloc_target_data) (section_name:string) (strict: bool) = let (en: Endianness.endianness) = match f with | ELF_File_32 f32 -> Elf_header.get_elf32_header_endianness f32.Elf_file.elf32_file_header @@ -4250,16 +4355,17 @@ let extract_section_body' (f:elf_file) (section_name:string) (strict: bool) = ) f32.elf32_file_interpreted_sections in match sections with | [section] -> - let section_addr = Absolute section.Elf_interpreted_section.elf32_section_addr in (*TODO symbolic*) + let section_addr = Offset (section_name, 0) in let section_body = section.Elf_interpreted_section.elf32_section_body in (* let _ = my_debug4 (section_name ^ (": \n" ^ (Elf_interpreted_section.string_of_elf32_interpreted_section section ^ "\n" * ^ " body = " ^ ppbytes2 0 section_body ^ "\n"))) in *) + let section_body = Assert_extra.failwith "Not implemented" in (c,section_addr,section_body) | [] -> if strict then Assert_extra.failwith ("" ^ section_name ^ " section not present") else - (c,0,Byte_sequence.empty) + (c,0,<| rbs_bytes = Byte_sequence.empty ; rbs_relocs = [] |>) | _ -> Assert_extra.failwith ("multiple " ^ section_name ^ " sections present") end @@ -4272,38 +4378,44 @@ let extract_section_body' (f:elf_file) (section_name:string) (strict: bool) = ) f64.elf64_file_interpreted_sections in match sections with | [section] -> - let section_addr = Absolute section.Elf_interpreted_section.elf64_section_addr in (*TODO symbolic*) + let section_addr = Offset (section_name, 0) in let section_body = section.Elf_interpreted_section.elf64_section_body in - (c,section_addr,section_body) + let _ = my_debug "extracted section body" in + match extract_elf64_relocations_for_section f64 ri section_name with + | Success relocations -> + let _ = my_debug "extracted relocations" in + let section_body = construct_rel_byte_sequence section_body relocations in + (c,section_addr,section_body) + | Fail err -> Assert_extra.failwith ("failed extracting relocations: " ^ err) + end | [] -> if strict then Assert_extra.failwith ("" ^ section_name ^ " section not present") else - (c,0,Byte_sequence.empty) + (c,0,<| rbs_bytes = Byte_sequence.empty ; rbs_relocs = [] |>) | _ -> Assert_extra.failwith ("multiple " ^ section_name ^ " sections present") end end -val extract_section_body : elf_file -> string -> bool -> p_context * sym_natural * rel_byte_sequence -let extract_section_body (f:elf_file) (section_name:string) (strict: bool) = - let (c,n,bs) = extract_section_body' f section_name strict in (c,n,rbs_no_reloc bs) -val extract_dwarf : elf_file -> maybe dwarf -let extract_dwarf f = - let (c, _, debug_info_section_body) = extract_section_body f ".debug_info" true in - let (c, _, debug_abbrev_section_body) = extract_section_body f ".debug_abbrev" false in - let (c, _, debug_str_section_body) = extract_section_body f ".debug_str" false in - let (c, _, debug_loc_section_body) = extract_section_body f ".debug_loc" false in - let (c, _, debug_ranges_section_body) = extract_section_body f ".debug_ranges" false in - let (c, _, debug_frame_section_body) = extract_section_body f ".debug_frame" false in - let (c, _, debug_line_section_body) = extract_section_body f ".debug_line" false in +val extract_dwarf : elf_file -> relocation_interpreter reloc_target_data -> maybe dwarf +let extract_dwarf f ri = + let _ = my_debug "extract dwarf" in + + let (c, _, debug_info_section_body) = extract_section_body f ri ".debug_info" true in + let (c, _, debug_abbrev_section_body) = extract_section_body f ri ".debug_abbrev" false in + let (c, _, debug_str_section_body) = extract_section_body f ri ".debug_str" false in + let (c, _, debug_loc_section_body) = extract_section_body f ri ".debug_loc" false in + let (c, _, debug_ranges_section_body) = extract_section_body f ri ".debug_ranges" false in + let (c, _, debug_frame_section_body) = extract_section_body f ri ".debug_frame" false in + let (c, _, debug_line_section_body) = extract_section_body f ri ".debug_line" false in let d = parse_dwarf c debug_info_section_body debug_abbrev_section_body debug_str_section_body debug_loc_section_body debug_ranges_section_body debug_frame_section_body debug_line_section_body in Just d -val extract_text : elf_file -> p_context * sym_natural * rel_byte_sequence (* (p_context, elf32/64_section_addr, elf32/64_section_body) *) -let extract_text f = extract_section_body f ".text" true +val extract_text : elf_file -> relocation_interpreter reloc_target_data -> p_context * sym_natural * rel_byte_sequence (* (p_context, elf32/64_section_addr, elf32/64_section_body) *) +let extract_text f ri = extract_section_body f ri ".text" true (** ************************************************************ *) @@ -4422,7 +4534,7 @@ accumulated so far *) let arithmetic_context_of_cuh cuh = - match sym_unwrap cuh.cuh_address_size with + match sym_unwrap cuh.cuh_address_size "arithmetic_context_of_cuh" with | 8 -> <| ac_bitwidth = 64; @@ -5314,7 +5426,7 @@ let analyse_locations_raw c (d: dwarf) = die.die_abbreviation_declaration.ad_attribute_specifications die.die_attribute_values in - let find_ats (s:string) = myfindNonPure (fun (((at: sym_natural), (af: sym_natural)), ((pos: sym_natural),(av:attribute_value))) -> attribute_encode s = at) ats in + let find_ats (s:string) = myfindNonPure (fun (((at: sym_natural), (af: sym_natural)), ((pos: sym_natural),(av:attribute_value))) -> sym_eq (attribute_encode s) at) ats in let ((_,_),(_,av_name)) = find_ats "DW_AT_name" in @@ -5333,7 +5445,7 @@ let analyse_locations_raw c (d: dwarf) = | AV_exprloc n bs -> " "^parse_and_pp_operations c cuh_default bs^"\n" | AV_block n bs -> " "^parse_and_pp_operations c cuh_default bs^"\n" | AV_sec_offset n -> - let location_list = myfindNonPure (fun (n',_)-> n'=n) d.d_loc in + let location_list = myfindNonPure (fun (n',_)-> sym_eq n' n) d.d_loc in pp_location_list c cuh_default location_list | _ -> "av_location AV not understood" end in @@ -6005,7 +6117,7 @@ let evaluate_line_number_program let evaluated_line_info_of_compilation_unit d cu evaluated_line_info = let c = p_context_of_d d in let offset = line_number_offset_of_compilation_unit c cu in - match List.find (fun (lnh,lnrs) -> lnh.lnh_offset = offset) evaluated_line_info with + match List.find (fun (lnh,lnrs) -> sym_eq lnh.lnh_offset offset) evaluated_line_info with | Nothing -> Assert_extra.failwith "compilation unit line number offset not found" | Just (lnh,lnrs) ->lnrs end @@ -6103,12 +6215,12 @@ let source_lines_of_address (ds:dwarf_static) (a: sym_natural) : list ( unpacked (** ** collecting all the statically calculated analysis info *) (** ************************************************************ *) -val extract_dwarf_static : elf_file -> maybe dwarf_static -let extract_dwarf_static f1 = - match extract_dwarf f1 with +val extract_dwarf_static : elf_file -> relocation_interpreter reloc_target_data -> maybe dwarf_static +let extract_dwarf_static f1 ri = + match extract_dwarf f1 ri with | Nothing -> Nothing | Just dwarf -> - (*let _ = my_debug5 (pp_dwarf dwarf) in *) + let _ = my_debug5 (pp_dwarf dwarf) in let ald : analysed_location_data = analyse_locations dwarf in @@ -6680,11 +6792,11 @@ let rec words_of_rel_byte_sequence (addr:sym_natural) (bs:rel_byte_sequence) (ac end let pp_instruction ((addr:sym_natural),(i:sym_natural)) = - hex_string_of_big_int_pad8 (sym_unwrap addr) ^ " " ^ hex_string_of_big_int_pad8 (sym_unwrap i) ^ "\n" + hex_string_of_big_int_pad8 (sym_unwrap addr "pp_instruction") ^ " " ^ hex_string_of_big_int_pad8 (sym_unwrap i "pp_instruction") ^ "\n" -val pp_text_section : elf_file -> string -let pp_text_section f = - let (p_context, addr, bs) = extract_text f in +val pp_text_section : elf_file -> relocation_interpreter reloc_target_data -> string +let pp_text_section f ri = + let (p_context, addr, bs) = extract_text f ri in let instructions : list (sym_natural * sym_natural) = words_of_rel_byte_sequence addr bs [] in String.concat "" (List.map pp_instruction instructions) @@ -6692,9 +6804,9 @@ let pp_text_section f = (** ** top level for main_elf ******************************** *) (** ************************************************************ *) -val harness_string_of_elf_like_objdump : elf_file -> rel_byte_sequence -> string -let harness_string_of_elf_like_objdump f1 bs = - let mds = extract_dwarf_static f1 in +val harness_string_of_elf_like_objdump : elf_file -> relocation_interpreter reloc_target_data -> string +let harness_string_of_elf_like_objdump f1 ri = + let mds = extract_dwarf_static f1 ri in match mds with | Nothing -> "" | Just ds -> @@ -6703,9 +6815,9 @@ let harness_string_of_elf_like_objdump f1 bs = end -val harness_string_of_elf : elf_file -> rel_byte_sequence -> string -let harness_string_of_elf f1 bs = -let mds = extract_dwarf_static f1 in +val harness_string_of_elf : elf_file -> relocation_interpreter reloc_target_data -> string +let harness_string_of_elf f1 ri = +let mds = extract_dwarf_static f1 ri in match mds with | Nothing -> "" | Just ds -> @@ -6741,22 +6853,22 @@ let mds = extract_dwarf_static f1 in end -val harness_string_of_elf64_debug_info_section : elf64_file -> rel_byte_sequence -> (*(sym_natural -> string) -> (sym_natural -> string) -> (sym_natural -> string) -> elf64_header -> elf64_section_header_table -> string_table -> *) string -let {ocaml} harness_string_of_elf64_debug_info_section f1 bs0 (*os proc usr hdr sht stbl*) = - harness_string_of_elf (ELF_File_64 f1) bs0 +val harness_string_of_elf64_debug_info_section : elf64_file -> relocation_interpreter reloc_target_data -> (*(sym_natural -> string) -> (sym_natural -> string) -> (sym_natural -> string) -> elf64_header -> elf64_section_header_table -> string_table -> *) string +let {ocaml} harness_string_of_elf64_debug_info_section f1 (*os proc usr hdr sht stbl*) = + harness_string_of_elf (ELF_File_64 f1) -val harness_string_of_elf32_debug_info_section : elf32_file -> rel_byte_sequence -> (* (sym_natural -> string) -> (sym_natural -> string) -> (sym_natural -> string) -> elf32_header -> elf32_section_header_table -> string_table ->*) string -let {ocaml} harness_string_of_elf32_debug_info_section f1 bs0 (*os proc usr hdr sht stbl*) = - harness_string_of_elf (ELF_File_32 f1) bs0 +val harness_string_of_elf32_debug_info_section : elf32_file -> relocation_interpreter reloc_target_data -> (* (sym_natural -> string) -> (sym_natural -> string) -> (sym_natural -> string) -> elf32_header -> elf32_section_header_table -> string_table ->*) string +let {ocaml} harness_string_of_elf32_debug_info_section f1 (*os proc usr hdr sht stbl*) = + harness_string_of_elf (ELF_File_32 f1) -val harness_string_of_elf64_like_objdump : elf64_file -> rel_byte_sequence -> (*(sym_natural -> string) -> (sym_natural -> string) -> (sym_natural -> string) -> elf64_header -> elf64_section_header_table -> string_table -> *) string -let {ocaml} harness_string_of_elf64_like_objdump f1 bs0 (*os proc usr hdr sht stbl*) = - harness_string_of_elf_like_objdump (ELF_File_64 f1) bs0 +val harness_string_of_elf64_like_objdump : elf64_file -> relocation_interpreter reloc_target_data -> (*(sym_natural -> string) -> (sym_natural -> string) -> (sym_natural -> string) -> elf64_header -> elf64_section_header_table -> string_table -> *) string +let {ocaml} harness_string_of_elf64_like_objdump f1 (*os proc usr hdr sht stbl*) = + harness_string_of_elf_like_objdump (ELF_File_64 f1) -val harness_string_of_elf32_like_objdump : elf32_file -> rel_byte_sequence -> (* (sym_natural -> string) -> (sym_natural -> string) -> (sym_natural -> string) -> elf32_header -> elf32_section_header_table -> string_table ->*) string -let {ocaml} harness_string_of_elf32_like_objdump f1 bs0 (*os proc usr hdr sht stbl*) = - harness_string_of_elf_like_objdump (ELF_File_32 f1) bs0 +val harness_string_of_elf32_like_objdump : elf32_file -> relocation_interpreter reloc_target_data -> (* (sym_natural -> string) -> (sym_natural -> string) -> (sym_natural -> string) -> elf32_header -> elf32_section_header_table -> string_table ->*) string +let {ocaml} harness_string_of_elf32_like_objdump f1 (*os proc usr hdr sht stbl*) = + harness_string_of_elf_like_objdump (ELF_File_32 f1) diff --git a/src/elf_symbolic.lem b/src/elf_symbolic.lem index 07ad94a..9792e4c 100644 --- a/src/elf_symbolic.lem +++ b/src/elf_symbolic.lem @@ -3,6 +3,13 @@ open import Num open import Error open import Byte_sequence open import Bool +open import Maybe +open import String +open import Show + +(* TODO for debugging, remove *) +val print_endline : string -> unit +declare ocaml target_rep function print_endline = `print_endline` open import Elf_types_native_uint @@ -11,6 +18,7 @@ open import Elf_symbol_table open import Elf_file open import Elf_header open import Elf_section_header_table +open import Elf_interpreted_section (* TODO *) type binary_operation @@ -19,13 +27,29 @@ type binary_operation (* TODO *) type symbolic_expression - = Section of elf64_half + = Section of string | Const of integer | BinOp of (symbolic_expression * binary_operation * symbolic_expression) | AssertRange of (symbolic_expression * integer * integer) | Mask of (symbolic_expression * natural * natural) -let section_with_offset sidx offset = BinOp(Section sidx, Add, Const (integerFromNatural (natural_of_elf64_addr offset))) +let rec pp_sym_expr sx = match sx with + | Section s -> s + | Const x -> show x + | BinOp (a, Add, b) -> "(" ^ (pp_sym_expr a) ^ "+" ^ (pp_sym_expr b) ^ ")" + | AssertRange (x, a, b) -> pp_sym_expr x ^ "!" (*TODO*) + | Mask (x, a, b) -> pp_sym_expr x ^ "[" ^ (show a) ^ ":" ^ (show b) ^ "]" +end + +val section_with_offset : elf64_file -> elf64_half -> elf64_addr -> error symbolic_expression +let section_with_offset f sidx offset = + match List.index f.elf64_file_interpreted_sections (natFromNatural (natural_of_elf64_half sidx)) with + | Nothing -> fail ("Invalid secion id " ^ show sidx) + | Just sec -> return (BinOp(Section sec.elf64_section_name_as_string, Add, Const (integerFromNatural (natural_of_elf64_addr offset)))) +end + +let symbolic_address_from_elf64_symbol_table_entry f ste = + section_with_offset f ste.elf64_st_shndx ste.elf64_st_value type abstract_relocation 'a = <| arel_value : symbolic_expression @@ -41,30 +65,53 @@ let reloc_width_bytes : reloc_target_data -> natural = function | Data64 -> 8 end -type relocation_interpreter 'a = elf64_file -> elf64_symbol_table -> elf64_half -> elf64_relocation_a -> error (Map.map elf64_addr (abstract_relocation 'a)) +type relocation_interpreter 'a = elf64_file -> Map.map natural elf64_symbol_table_entry -> elf64_half -> elf64_relocation_a -> error (Map.map elf64_addr (abstract_relocation 'a)) -val extract_elf64_relocations_for_section : forall 'a. elf64_file -> relocation_interpreter 'a -> elf64_half -> byte_sequence -> error (Map.map elf64_addr (abstract_relocation 'a)) -let extract_elf64_relocations_for_section f1 interp sidx bs0 = +val symbol_map_from_elf64_symtab : elf64_file -> elf64_symbol_table -> Map.map natural elf64_symbol_table_entry +let symbol_map_from_elf64_symtab f symtab = + let convert i ste = + (naturalFromNat i, ste) + in + let indexed_list = List.mapi convert symtab in + Map.fromList indexed_list + +val extract_elf64_relocations_for_section' : forall 'a. elf64_file -> relocation_interpreter 'a -> elf64_half -> error (Map.map elf64_addr (abstract_relocation 'a)) +let extract_elf64_relocations_for_section' f1 interp sidx = let hdr = f1.elf64_file_header in - let sht = f1.elf64_file_section_header_table in + let sections = f1.elf64_file_interpreted_sections in let endian = get_elf64_header_endianness hdr in let cond x = - (x.elf64_sh_type = elf64_word_of_natural sht_rela) && (natural_of_elf64_word x.elf64_sh_info = natural_of_elf64_half sidx) + (x.elf64_section_type = sht_rela) && (x.elf64_section_info = natural_of_elf64_half sidx) in - match List.filter cond sht with + match List.filter cond sections with | [] -> return Map.empty | [rel_sec] -> - let off = natural_of_elf64_off rel_sec.elf64_sh_offset in - let siz = natural_of_elf64_xword rel_sec.elf64_sh_size in - let lnk = natural_of_elf64_word rel_sec.elf64_sh_link in - Byte_sequence.offset_and_cut off siz bs0 >>= fun rels -> + let lnk = rel_sec.elf64_section_link in + let rels = rel_sec.elf64_section_body in Elf_relocation.read_elf64_relocation_a_section' endian rels >>= fun rels -> Elf_file.get_elf64_symbol_table_by_index f1 lnk >>= fun symtab -> - mapM (interp f1 symtab sidx) rels >>= fun rel_maps -> - let rel_map = Map.unions rel_maps in + let symtab_map = symbol_map_from_elf64_symtab f1 symtab in + let _ = print_endline "symtab_map generated" in + mapM (interp f1 symtab_map sidx) rels >>= fun rel_maps -> + let _ = print_endline "relocations computed" in + let rel_map = Map.fromList (List.concatMap Map_extra.toList rel_maps) in + let _ = print_endline "why is this slow?" in if Map.size rel_map <> List.length rels then fail "Multiple relocations at the same location" else return rel_map | _ -> fail "Multiple relocation sections for this section" +end + +val extract_elf64_relocations_for_section : forall 'a. elf64_file -> relocation_interpreter 'a -> string -> error (Map.map elf64_addr (abstract_relocation 'a)) +let extract_elf64_relocations_for_section f1 interp section_name = + match List.findIndices + (fun x -> x.elf64_section_name_as_string = section_name) + f1.elf64_file_interpreted_sections + with + | [sidx] -> + let sidx = elf64_half_of_natural (naturalFromNat sidx) in + extract_elf64_relocations_for_section' f1 interp sidx + | [] -> fail ("" ^ section_name ^ " section not present") + | _ -> fail ("multiple " ^ section_name ^ " sections present") end \ No newline at end of file diff --git a/src/main_elf.lem b/src/main_elf.lem index bc4eea3..58f389e 100644 --- a/src/main_elf.lem +++ b/src/main_elf.lem @@ -190,9 +190,9 @@ let obtain_abi_specific_string_of_reloc_type mach = const "Cannot deduce ABI" val interpret_data_relocation : natural -> relocation_interpreter reloc_target_data -let interpret_data_relocation mach ef symtab sidx rel = +let interpret_data_relocation mach ef symtab_map sidx rel = if mach = elf_ma_aarch64 then - abi_aarch64_relocation_to_abstract ef symtab sidx rel >>= fun arels -> + abi_aarch64_relocation_to_abstract ef symtab_map sidx rel >>= fun arels -> map_mapM (fun arel -> aarch64_relocation_target_to_data_target arel.arel_target >>= fun target -> return <| arel_value = arel.arel_value @@ -278,31 +278,9 @@ let _ = return lines end else if flag = "--debug-dump=info" then - Elf_file.read_elf32_file bs0 >>= fun f1 -> - get_elf32_file_section_header_string_table f1 >>= fun stbl -> - return (Dwarf.harness_string_of_elf32_debug_info_section - f1 - (Dwarf.rbs_no_reloc bs0) - (*string_of_gnu_ext_section_type - (fun x -> show x) - (fun x -> show x) - f1.elf32_file_header - f1.elf32_file_section_header_table - stbl*) - ) + Error.fail "not implemented" else if flag = "--debug-dump=dies" then - Elf_file.read_elf32_file bs0 >>= fun f1 -> - get_elf32_file_section_header_string_table f1 >>= fun stbl -> - return (Dwarf.harness_string_of_elf32_like_objdump - f1 - (Dwarf.rbs_no_reloc bs0) - (*string_of_gnu_ext_section_type - (fun x -> show x) - (fun x -> show x) - f1.elf32_file_header - f1.elf32_file_section_header_table - stbl*) - ) + Error.fail "not implemented" else failwith "Unrecognised flag" in @@ -374,7 +352,7 @@ let _ = get_elf64_file_section_header_string_table f1 >>= fun stbl -> return (Dwarf.harness_string_of_elf64_debug_info_section f1 - (Dwarf.rbs_no_reloc bs0) + (interpret_data_relocation (natural_of_elf64_half f1.elf64_file_header.elf64_machine)) (*string_of_gnu_ext_section_type (fun x -> show x) (fun x -> show x) @@ -387,7 +365,7 @@ let _ = get_elf64_file_section_header_string_table f1 >>= fun stbl -> return ("\n"^arg^": file format [...]" ^"\n\n"^ Dwarf.harness_string_of_elf64_like_objdump f1 - (Dwarf.rbs_no_reloc bs0) + (interpret_data_relocation (natural_of_elf64_half f1.elf64_file_header.elf64_machine)) (*string_of_gnu_ext_section_type (fun x -> show x) (fun x -> show x) From 7b22921d8f85e6e5f6acb15b5d6623e44c2dc4a6 Mon Sep 17 00:00:00 2001 From: Matej Urban Date: Fri, 6 Dec 2024 10:48:46 +0000 Subject: [PATCH 08/44] Make it less symbolic where not needed (might revert) --- src/dwarf.lem | 900 +++++++++++++++++++++++++------------------------- 1 file changed, 452 insertions(+), 448 deletions(-) diff --git a/src/dwarf.lem b/src/dwarf.lem index 0bc96e1..88c1e81 100644 --- a/src/dwarf.lem +++ b/src/dwarf.lem @@ -552,7 +552,7 @@ type operation_semantics = | OpSem_not_supported | OpSem_binary of (arithmetic_context -> sym_natural -> sym_natural -> maybe sym_natural) | OpSem_unary of (arithmetic_context -> sym_natural -> maybe sym_natural) - | OpSem_opcode_lit of sym_natural + | OpSem_opcode_lit of natural | OpSem_reg | OpSem_breg | OpSem_bregx @@ -567,7 +567,7 @@ type operation_semantics = type operation = <| - op_code: sym_natural; + op_code: natural; op_string: string; op_argument_values: list operation_argument_value; op_semantics: operation_semantics; @@ -578,7 +578,7 @@ type operation = type simple_location = | SL_memory_address of sym_natural - | SL_register of sym_natural + | SL_register of natural | SL_implicit of rel_byte_sequence (* used for implicit and stack values *) | SL_empty @@ -613,7 +613,7 @@ type memory_read_result 'a = type evaluation_context = <| - read_register: sym_natural -> register_read_result sym_natural; + read_register: natural -> register_read_result sym_natural; read_memory: sym_natural -> sym_natural -> memory_read_result sym_natural; |> @@ -629,9 +629,9 @@ type dwarf_format = type abbreviation_declaration = <| ad_abbreviation_code: sym_natural; - ad_tag: sym_natural; + ad_tag: natural; ad_has_children: bool; - ad_attribute_specifications: list (sym_natural * sym_natural); + ad_attribute_specifications: list (natural * natural); |> type abbreviations_table = @@ -753,7 +753,7 @@ type cfa_address = sym_natural type cfa_block = rel_byte_sequence type cfa_delta = sym_natural type cfa_offset = sym_natural -type cfa_register = sym_natural +type cfa_register = natural type cfa_sfoffset = integer type call_frame_argument_type = @@ -858,7 +858,7 @@ type register_rule = is the current CFA value and N is a signed offset.*) | RR_val_offset of integer (* The previous value of this register is the value CFA+N where CFA is the current CFA value and N is a signed offset.*) - | RR_register of sym_natural (* The previous value of this register is stored in another register numbered R.*) + | RR_register of natural (* The previous value of this register is stored in another register numbered R.*) | RR_expression of single_location_description (* The previous value of this register is located at the address produced by executing the DWARF expression E.*) | RR_val_expression of single_location_description (* The previous value of this register is the value produced by executing the @@ -923,7 +923,7 @@ type line_number_operation = | DW_LNE_define_file of rel_byte_sequence * sym_natural * sym_natural * sym_natural | DW_LNE_set_discriminator of sym_natural (* special *) - | DW_LN_special of sym_natural (* the adjusted opcode *) + | DW_LN_special of natural (* the adjusted opcode *) type line_number_file_entry = <| @@ -945,7 +945,7 @@ type line_number_header = lnh_default_is_stmt: bool; lnh_line_base: integer; lnh_line_range: sym_natural; - lnh_opcode_base: sym_natural; + lnh_opcode_base: natural; lnh_standard_opcode_lengths: list sym_natural; lnh_include_directories: list (rel_byte_sequence); lnh_file_entries: list line_number_file_entry; @@ -1050,7 +1050,7 @@ type enumeration_member = cupdie * (maybe string)(*mname*) * integer(*const_valu type c_type_top 't = | CT_missing of cupdie - | CT_base of cupdie * string(*name*) * sym_natural(*encoding*) * (maybe sym_natural)(*byte_size*) + | CT_base of cupdie * string(*name*) * natural(*encoding*) * (maybe sym_natural)(*byte_size*) | CT_pointer of cupdie * maybe 't | CT_const of cupdie * maybe 't | CT_volatile of cupdie * 't @@ -1191,389 +1191,389 @@ let p_context_of_d (d:dwarf) : p_context = <| endianness = d.d_endianness |> (* tag encoding *) let tag_encodings = [ - ("DW_TAG_array_type" , sym_natural_of_hex "0x01" ); - ("DW_TAG_class_type" , sym_natural_of_hex "0x02" ); - ("DW_TAG_entry_point" , sym_natural_of_hex "0x03" ); - ("DW_TAG_enumeration_type" , sym_natural_of_hex "0x04" ); - ("DW_TAG_formal_parameter" , sym_natural_of_hex "0x05" ); - ("DW_TAG_imported_declaration" , sym_natural_of_hex "0x08" ); - ("DW_TAG_label" , sym_natural_of_hex "0x0a" ); - ("DW_TAG_lexical_block" , sym_natural_of_hex "0x0b" ); - ("DW_TAG_member" , sym_natural_of_hex "0x0d" ); - ("DW_TAG_pointer_type" , sym_natural_of_hex "0x0f" ); - ("DW_TAG_reference_type" , sym_natural_of_hex "0x10" ); - ("DW_TAG_compile_unit" , sym_natural_of_hex "0x11" ); - ("DW_TAG_string_type" , sym_natural_of_hex "0x12" ); - ("DW_TAG_structure_type" , sym_natural_of_hex "0x13" ); - ("DW_TAG_subroutine_type" , sym_natural_of_hex "0x15" ); - ("DW_TAG_typedef" , sym_natural_of_hex "0x16" ); - ("DW_TAG_union_type" , sym_natural_of_hex "0x17" ); - ("DW_TAG_unspecified_parameters" , sym_natural_of_hex "0x18" ); - ("DW_TAG_variant" , sym_natural_of_hex "0x19" ); - ("DW_TAG_common_block" , sym_natural_of_hex "0x1a" ); - ("DW_TAG_common_inclusion" , sym_natural_of_hex "0x1b" ); - ("DW_TAG_inheritance" , sym_natural_of_hex "0x1c" ); - ("DW_TAG_inlined_subroutine" , sym_natural_of_hex "0x1d" ); - ("DW_TAG_module" , sym_natural_of_hex "0x1e" ); - ("DW_TAG_ptr_to_member_type" , sym_natural_of_hex "0x1f" ); - ("DW_TAG_set_type" , sym_natural_of_hex "0x20" ); - ("DW_TAG_subrange_type" , sym_natural_of_hex "0x21" ); - ("DW_TAG_with_stmt" , sym_natural_of_hex "0x22" ); - ("DW_TAG_access_declaration" , sym_natural_of_hex "0x23" ); - ("DW_TAG_base_type" , sym_natural_of_hex "0x24" ); - ("DW_TAG_catch_block" , sym_natural_of_hex "0x25" ); - ("DW_TAG_const_type" , sym_natural_of_hex "0x26" ); - ("DW_TAG_constant" , sym_natural_of_hex "0x27" ); - ("DW_TAG_enumerator" , sym_natural_of_hex "0x28" ); - ("DW_TAG_file_type" , sym_natural_of_hex "0x29" ); - ("DW_TAG_friend" , sym_natural_of_hex "0x2a" ); - ("DW_TAG_namelist" , sym_natural_of_hex "0x2b" ); - ("DW_TAG_namelist_item" , sym_natural_of_hex "0x2c" ); - ("DW_TAG_packed_type" , sym_natural_of_hex "0x2d" ); - ("DW_TAG_subprogram" , sym_natural_of_hex "0x2e" ); - ("DW_TAG_template_type_parameter" , sym_natural_of_hex "0x2f" ); - ("DW_TAG_template_value_parameter" , sym_natural_of_hex "0x30" ); - ("DW_TAG_thrown_type" , sym_natural_of_hex "0x31" ); - ("DW_TAG_try_block" , sym_natural_of_hex "0x32" ); - ("DW_TAG_variant_part" , sym_natural_of_hex "0x33" ); - ("DW_TAG_variable" , sym_natural_of_hex "0x34" ); - ("DW_TAG_volatile_type" , sym_natural_of_hex "0x35" ); - ("DW_TAG_dwarf_procedure" , sym_natural_of_hex "0x36" ); - ("DW_TAG_restrict_type" , sym_natural_of_hex "0x37" ); - ("DW_TAG_interface_type" , sym_natural_of_hex "0x38" ); - ("DW_TAG_namespace" , sym_natural_of_hex "0x39" ); - ("DW_TAG_imported_module" , sym_natural_of_hex "0x3a" ); - ("DW_TAG_unspecified_type" , sym_natural_of_hex "0x3b" ); - ("DW_TAG_partial_unit" , sym_natural_of_hex "0x3c" ); - ("DW_TAG_imported_unit" , sym_natural_of_hex "0x3d" ); - ("DW_TAG_condition" , sym_natural_of_hex "0x3f" ); - ("DW_TAG_shared_type" , sym_natural_of_hex "0x40" ); - ("DW_TAG_type_unit" , sym_natural_of_hex "0x41" ); - ("DW_TAG_rvalue_reference_type" , sym_natural_of_hex "0x42" ); - ("DW_TAG_template_alias" , sym_natural_of_hex "0x43" ); - ("DW_TAG_lo_user" , sym_natural_of_hex "0x4080"); - ("DW_TAG_hi_user" , sym_natural_of_hex "0xffff") + ("DW_TAG_array_type" , natural_of_hex "0x01" ); + ("DW_TAG_class_type" , natural_of_hex "0x02" ); + ("DW_TAG_entry_point" , natural_of_hex "0x03" ); + ("DW_TAG_enumeration_type" , natural_of_hex "0x04" ); + ("DW_TAG_formal_parameter" , natural_of_hex "0x05" ); + ("DW_TAG_imported_declaration" , natural_of_hex "0x08" ); + ("DW_TAG_label" , natural_of_hex "0x0a" ); + ("DW_TAG_lexical_block" , natural_of_hex "0x0b" ); + ("DW_TAG_member" , natural_of_hex "0x0d" ); + ("DW_TAG_pointer_type" , natural_of_hex "0x0f" ); + ("DW_TAG_reference_type" , natural_of_hex "0x10" ); + ("DW_TAG_compile_unit" , natural_of_hex "0x11" ); + ("DW_TAG_string_type" , natural_of_hex "0x12" ); + ("DW_TAG_structure_type" , natural_of_hex "0x13" ); + ("DW_TAG_subroutine_type" , natural_of_hex "0x15" ); + ("DW_TAG_typedef" , natural_of_hex "0x16" ); + ("DW_TAG_union_type" , natural_of_hex "0x17" ); + ("DW_TAG_unspecified_parameters" , natural_of_hex "0x18" ); + ("DW_TAG_variant" , natural_of_hex "0x19" ); + ("DW_TAG_common_block" , natural_of_hex "0x1a" ); + ("DW_TAG_common_inclusion" , natural_of_hex "0x1b" ); + ("DW_TAG_inheritance" , natural_of_hex "0x1c" ); + ("DW_TAG_inlined_subroutine" , natural_of_hex "0x1d" ); + ("DW_TAG_module" , natural_of_hex "0x1e" ); + ("DW_TAG_ptr_to_member_type" , natural_of_hex "0x1f" ); + ("DW_TAG_set_type" , natural_of_hex "0x20" ); + ("DW_TAG_subrange_type" , natural_of_hex "0x21" ); + ("DW_TAG_with_stmt" , natural_of_hex "0x22" ); + ("DW_TAG_access_declaration" , natural_of_hex "0x23" ); + ("DW_TAG_base_type" , natural_of_hex "0x24" ); + ("DW_TAG_catch_block" , natural_of_hex "0x25" ); + ("DW_TAG_const_type" , natural_of_hex "0x26" ); + ("DW_TAG_constant" , natural_of_hex "0x27" ); + ("DW_TAG_enumerator" , natural_of_hex "0x28" ); + ("DW_TAG_file_type" , natural_of_hex "0x29" ); + ("DW_TAG_friend" , natural_of_hex "0x2a" ); + ("DW_TAG_namelist" , natural_of_hex "0x2b" ); + ("DW_TAG_namelist_item" , natural_of_hex "0x2c" ); + ("DW_TAG_packed_type" , natural_of_hex "0x2d" ); + ("DW_TAG_subprogram" , natural_of_hex "0x2e" ); + ("DW_TAG_template_type_parameter" , natural_of_hex "0x2f" ); + ("DW_TAG_template_value_parameter" , natural_of_hex "0x30" ); + ("DW_TAG_thrown_type" , natural_of_hex "0x31" ); + ("DW_TAG_try_block" , natural_of_hex "0x32" ); + ("DW_TAG_variant_part" , natural_of_hex "0x33" ); + ("DW_TAG_variable" , natural_of_hex "0x34" ); + ("DW_TAG_volatile_type" , natural_of_hex "0x35" ); + ("DW_TAG_dwarf_procedure" , natural_of_hex "0x36" ); + ("DW_TAG_restrict_type" , natural_of_hex "0x37" ); + ("DW_TAG_interface_type" , natural_of_hex "0x38" ); + ("DW_TAG_namespace" , natural_of_hex "0x39" ); + ("DW_TAG_imported_module" , natural_of_hex "0x3a" ); + ("DW_TAG_unspecified_type" , natural_of_hex "0x3b" ); + ("DW_TAG_partial_unit" , natural_of_hex "0x3c" ); + ("DW_TAG_imported_unit" , natural_of_hex "0x3d" ); + ("DW_TAG_condition" , natural_of_hex "0x3f" ); + ("DW_TAG_shared_type" , natural_of_hex "0x40" ); + ("DW_TAG_type_unit" , natural_of_hex "0x41" ); + ("DW_TAG_rvalue_reference_type" , natural_of_hex "0x42" ); + ("DW_TAG_template_alias" , natural_of_hex "0x43" ); + ("DW_TAG_lo_user" , natural_of_hex "0x4080"); + ("DW_TAG_hi_user" , natural_of_hex "0xffff") ] (* child determination encoding *) -let vDW_CHILDREN_no = sym_natural_of_hex "0x00" -let vDW_CHILDREN_yes = sym_natural_of_hex "0x01" +let vDW_CHILDREN_no = natural_of_hex "0x00" +let vDW_CHILDREN_yes = natural_of_hex "0x01" (* attribute encoding *) let attribute_encodings = [ - ("DW_AT_sibling" , sym_natural_of_hex "0x01", [DWA_reference]) ; - ("DW_AT_location" , sym_natural_of_hex "0x02", [DWA_exprloc; DWA_loclistptr]) ; - ("DW_AT_name" , sym_natural_of_hex "0x03", [DWA_string]) ; - ("DW_AT_ordering" , sym_natural_of_hex "0x09", [DWA_constant]) ; - ("DW_AT_byte_size" , sym_natural_of_hex "0x0b", [DWA_constant; DWA_exprloc; DWA_reference]) ; - ("DW_AT_bit_offset" , sym_natural_of_hex "0x0c", [DWA_constant; DWA_exprloc; DWA_reference]) ; - ("DW_AT_bit_size" , sym_natural_of_hex "0x0d", [DWA_constant; DWA_exprloc; DWA_reference]) ; - ("DW_AT_stmt_list" , sym_natural_of_hex "0x10", [DWA_lineptr]) ; - ("DW_AT_low_pc" , sym_natural_of_hex "0x11", [DWA_address]) ; - ("DW_AT_high_pc" , sym_natural_of_hex "0x12", [DWA_address; DWA_constant]) ; - ("DW_AT_language" , sym_natural_of_hex "0x13", [DWA_constant]) ; - ("DW_AT_discr" , sym_natural_of_hex "0x15", [DWA_reference]) ; - ("DW_AT_discr_value" , sym_natural_of_hex "0x16", [DWA_constant]) ; - ("DW_AT_visibility" , sym_natural_of_hex "0x17", [DWA_constant]) ; - ("DW_AT_import" , sym_natural_of_hex "0x18", [DWA_reference]) ; - ("DW_AT_string_length" , sym_natural_of_hex "0x19", [DWA_exprloc; DWA_loclistptr]) ; - ("DW_AT_common_reference" , sym_natural_of_hex "0x1a", [DWA_reference]) ; - ("DW_AT_comp_dir" , sym_natural_of_hex "0x1b", [DWA_string]) ; - ("DW_AT_const_value" , sym_natural_of_hex "0x1c", [DWA_block; DWA_constant; DWA_string]) ; - ("DW_AT_containing_type" , sym_natural_of_hex "0x1d", [DWA_reference]) ; - ("DW_AT_default_value" , sym_natural_of_hex "0x1e", [DWA_reference]) ; - ("DW_AT_inline" , sym_natural_of_hex "0x20", [DWA_constant]) ; - ("DW_AT_is_optional" , sym_natural_of_hex "0x21", [DWA_flag]) ; - ("DW_AT_lower_bound" , sym_natural_of_hex "0x22", [DWA_constant; DWA_exprloc; DWA_reference]) ; - ("DW_AT_producer" , sym_natural_of_hex "0x25", [DWA_string]) ; - ("DW_AT_prototyped" , sym_natural_of_hex "0x27", [DWA_flag]) ; - ("DW_AT_return_addr" , sym_natural_of_hex "0x2a", [DWA_exprloc; DWA_loclistptr]) ; - ("DW_AT_start_scope" , sym_natural_of_hex "0x2c", [DWA_constant; DWA_rangelistptr]) ; - ("DW_AT_bit_stride" , sym_natural_of_hex "0x2e", [DWA_constant; DWA_exprloc; DWA_reference]) ; - ("DW_AT_upper_bound" , sym_natural_of_hex "0x2f", [DWA_constant; DWA_exprloc; DWA_reference]) ; - ("DW_AT_abstract_origin" , sym_natural_of_hex "0x31", [DWA_reference]) ; - ("DW_AT_accessibility" , sym_natural_of_hex "0x32", [DWA_constant]) ; - ("DW_AT_address_class" , sym_natural_of_hex "0x33", [DWA_constant]) ; - ("DW_AT_artificial" , sym_natural_of_hex "0x34", [DWA_flag]) ; - ("DW_AT_base_types" , sym_natural_of_hex "0x35", [DWA_reference]) ; - ("DW_AT_calling_convention" , sym_natural_of_hex "0x36", [DWA_constant]) ; - ("DW_AT_count" , sym_natural_of_hex "0x37", [DWA_constant; DWA_exprloc; DWA_reference]) ; - ("DW_AT_data_member_location" , sym_natural_of_hex "0x38", [DWA_constant; DWA_exprloc; DWA_loclistptr]) ; - ("DW_AT_decl_column" , sym_natural_of_hex "0x39", [DWA_constant]) ; - ("DW_AT_decl_file" , sym_natural_of_hex "0x3a", [DWA_constant]) ; - ("DW_AT_decl_line" , sym_natural_of_hex "0x3b", [DWA_constant]) ; - ("DW_AT_declaration" , sym_natural_of_hex "0x3c", [DWA_flag]) ; - ("DW_AT_discr_list" , sym_natural_of_hex "0x3d", [DWA_block]) ; - ("DW_AT_encoding" , sym_natural_of_hex "0x3e", [DWA_constant]) ; - ("DW_AT_external" , sym_natural_of_hex "0x3f", [DWA_flag]) ; - ("DW_AT_frame_base" , sym_natural_of_hex "0x40", [DWA_exprloc; DWA_loclistptr]) ; - ("DW_AT_friend" , sym_natural_of_hex "0x41", [DWA_reference]) ; - ("DW_AT_identifier_case" , sym_natural_of_hex "0x42", [DWA_constant]) ; - ("DW_AT_macro_info" , sym_natural_of_hex "0x43", [DWA_macptr]) ; - ("DW_AT_namelist_item" , sym_natural_of_hex "0x44", [DWA_reference]) ; - ("DW_AT_priority" , sym_natural_of_hex "0x45", [DWA_reference]) ; - ("DW_AT_segment" , sym_natural_of_hex "0x46", [DWA_exprloc; DWA_loclistptr]) ; - ("DW_AT_specification" , sym_natural_of_hex "0x47", [DWA_reference]) ; - ("DW_AT_static_link" , sym_natural_of_hex "0x48", [DWA_exprloc; DWA_loclistptr]) ; - ("DW_AT_type" , sym_natural_of_hex "0x49", [DWA_reference]) ; - ("DW_AT_use_location" , sym_natural_of_hex "0x4a", [DWA_exprloc; DWA_loclistptr]) ; - ("DW_AT_variable_parameter" , sym_natural_of_hex "0x4b", [DWA_flag]) ; - ("DW_AT_virtuality" , sym_natural_of_hex "0x4c", [DWA_constant]) ; - ("DW_AT_vtable_elem_location" , sym_natural_of_hex "0x4d", [DWA_exprloc; DWA_loclistptr]) ; - ("DW_AT_allocated" , sym_natural_of_hex "0x4e", [DWA_constant; DWA_exprloc; DWA_reference]) ; - ("DW_AT_associated" , sym_natural_of_hex "0x4f", [DWA_constant; DWA_exprloc; DWA_reference]) ; - ("DW_AT_data_location" , sym_natural_of_hex "0x50", [DWA_exprloc]) ; - ("DW_AT_byte_stride" , sym_natural_of_hex "0x51", [DWA_constant; DWA_exprloc; DWA_reference]) ; - ("DW_AT_entry_pc" , sym_natural_of_hex "0x52", [DWA_address]) ; - ("DW_AT_use_UTF8" , sym_natural_of_hex "0x53", [DWA_flag]) ; - ("DW_AT_extension" , sym_natural_of_hex "0x54", [DWA_reference]) ; - ("DW_AT_ranges" , sym_natural_of_hex "0x55", [DWA_rangelistptr]) ; - ("DW_AT_trampoline" , sym_natural_of_hex "0x56", [DWA_address; DWA_flag; DWA_reference; DWA_string]); - ("DW_AT_call_column" , sym_natural_of_hex "0x57", [DWA_constant]) ; - ("DW_AT_call_file" , sym_natural_of_hex "0x58", [DWA_constant]) ; - ("DW_AT_call_line" , sym_natural_of_hex "0x59", [DWA_constant]) ; - ("DW_AT_description" , sym_natural_of_hex "0x5a", [DWA_string]) ; - ("DW_AT_binary_scale" , sym_natural_of_hex "0x5b", [DWA_constant]) ; - ("DW_AT_decimal_scale" , sym_natural_of_hex "0x5c", [DWA_constant]) ; - ("DW_AT_small" , sym_natural_of_hex "0x5d", [DWA_reference]) ; - ("DW_AT_decimal_sign" , sym_natural_of_hex "0x5e", [DWA_constant]) ; - ("DW_AT_digit_count" , sym_natural_of_hex "0x5f", [DWA_constant]) ; - ("DW_AT_picture_string" , sym_natural_of_hex "0x60", [DWA_string]) ; - ("DW_AT_mutable" , sym_natural_of_hex "0x61", [DWA_flag]) ; - ("DW_AT_threads_scaled" , sym_natural_of_hex "0x62", [DWA_flag]) ; - ("DW_AT_explicit" , sym_natural_of_hex "0x63", [DWA_flag]) ; - ("DW_AT_object_pointer" , sym_natural_of_hex "0x64", [DWA_reference]) ; - ("DW_AT_endianity" , sym_natural_of_hex "0x65", [DWA_constant]) ; - ("DW_AT_elemental" , sym_natural_of_hex "0x66", [DWA_flag]) ; - ("DW_AT_pure" , sym_natural_of_hex "0x67", [DWA_flag]) ; - ("DW_AT_recursive" , sym_natural_of_hex "0x68", [DWA_flag]) ; - ("DW_AT_signature" , sym_natural_of_hex "0x69", [DWA_reference]) ; - ("DW_AT_main_subprogram" , sym_natural_of_hex "0x6a", [DWA_flag]) ; - ("DW_AT_data_bit_offset" , sym_natural_of_hex "0x6b", [DWA_constant]) ; - ("DW_AT_const_expr" , sym_natural_of_hex "0x6c", [DWA_flag]) ; - ("DW_AT_enum_class" , sym_natural_of_hex "0x6d", [DWA_flag]) ; - ("DW_AT_linkage_name" , sym_natural_of_hex "0x6e", [DWA_string]) ; + ("DW_AT_sibling" , natural_of_hex "0x01", [DWA_reference]) ; + ("DW_AT_location" , natural_of_hex "0x02", [DWA_exprloc; DWA_loclistptr]) ; + ("DW_AT_name" , natural_of_hex "0x03", [DWA_string]) ; + ("DW_AT_ordering" , natural_of_hex "0x09", [DWA_constant]) ; + ("DW_AT_byte_size" , natural_of_hex "0x0b", [DWA_constant; DWA_exprloc; DWA_reference]) ; + ("DW_AT_bit_offset" , natural_of_hex "0x0c", [DWA_constant; DWA_exprloc; DWA_reference]) ; + ("DW_AT_bit_size" , natural_of_hex "0x0d", [DWA_constant; DWA_exprloc; DWA_reference]) ; + ("DW_AT_stmt_list" , natural_of_hex "0x10", [DWA_lineptr]) ; + ("DW_AT_low_pc" , natural_of_hex "0x11", [DWA_address]) ; + ("DW_AT_high_pc" , natural_of_hex "0x12", [DWA_address; DWA_constant]) ; + ("DW_AT_language" , natural_of_hex "0x13", [DWA_constant]) ; + ("DW_AT_discr" , natural_of_hex "0x15", [DWA_reference]) ; + ("DW_AT_discr_value" , natural_of_hex "0x16", [DWA_constant]) ; + ("DW_AT_visibility" , natural_of_hex "0x17", [DWA_constant]) ; + ("DW_AT_import" , natural_of_hex "0x18", [DWA_reference]) ; + ("DW_AT_string_length" , natural_of_hex "0x19", [DWA_exprloc; DWA_loclistptr]) ; + ("DW_AT_common_reference" , natural_of_hex "0x1a", [DWA_reference]) ; + ("DW_AT_comp_dir" , natural_of_hex "0x1b", [DWA_string]) ; + ("DW_AT_const_value" , natural_of_hex "0x1c", [DWA_block; DWA_constant; DWA_string]) ; + ("DW_AT_containing_type" , natural_of_hex "0x1d", [DWA_reference]) ; + ("DW_AT_default_value" , natural_of_hex "0x1e", [DWA_reference]) ; + ("DW_AT_inline" , natural_of_hex "0x20", [DWA_constant]) ; + ("DW_AT_is_optional" , natural_of_hex "0x21", [DWA_flag]) ; + ("DW_AT_lower_bound" , natural_of_hex "0x22", [DWA_constant; DWA_exprloc; DWA_reference]) ; + ("DW_AT_producer" , natural_of_hex "0x25", [DWA_string]) ; + ("DW_AT_prototyped" , natural_of_hex "0x27", [DWA_flag]) ; + ("DW_AT_return_addr" , natural_of_hex "0x2a", [DWA_exprloc; DWA_loclistptr]) ; + ("DW_AT_start_scope" , natural_of_hex "0x2c", [DWA_constant; DWA_rangelistptr]) ; + ("DW_AT_bit_stride" , natural_of_hex "0x2e", [DWA_constant; DWA_exprloc; DWA_reference]) ; + ("DW_AT_upper_bound" , natural_of_hex "0x2f", [DWA_constant; DWA_exprloc; DWA_reference]) ; + ("DW_AT_abstract_origin" , natural_of_hex "0x31", [DWA_reference]) ; + ("DW_AT_accessibility" , natural_of_hex "0x32", [DWA_constant]) ; + ("DW_AT_address_class" , natural_of_hex "0x33", [DWA_constant]) ; + ("DW_AT_artificial" , natural_of_hex "0x34", [DWA_flag]) ; + ("DW_AT_base_types" , natural_of_hex "0x35", [DWA_reference]) ; + ("DW_AT_calling_convention" , natural_of_hex "0x36", [DWA_constant]) ; + ("DW_AT_count" , natural_of_hex "0x37", [DWA_constant; DWA_exprloc; DWA_reference]) ; + ("DW_AT_data_member_location" , natural_of_hex "0x38", [DWA_constant; DWA_exprloc; DWA_loclistptr]) ; + ("DW_AT_decl_column" , natural_of_hex "0x39", [DWA_constant]) ; + ("DW_AT_decl_file" , natural_of_hex "0x3a", [DWA_constant]) ; + ("DW_AT_decl_line" , natural_of_hex "0x3b", [DWA_constant]) ; + ("DW_AT_declaration" , natural_of_hex "0x3c", [DWA_flag]) ; + ("DW_AT_discr_list" , natural_of_hex "0x3d", [DWA_block]) ; + ("DW_AT_encoding" , natural_of_hex "0x3e", [DWA_constant]) ; + ("DW_AT_external" , natural_of_hex "0x3f", [DWA_flag]) ; + ("DW_AT_frame_base" , natural_of_hex "0x40", [DWA_exprloc; DWA_loclistptr]) ; + ("DW_AT_friend" , natural_of_hex "0x41", [DWA_reference]) ; + ("DW_AT_identifier_case" , natural_of_hex "0x42", [DWA_constant]) ; + ("DW_AT_macro_info" , natural_of_hex "0x43", [DWA_macptr]) ; + ("DW_AT_namelist_item" , natural_of_hex "0x44", [DWA_reference]) ; + ("DW_AT_priority" , natural_of_hex "0x45", [DWA_reference]) ; + ("DW_AT_segment" , natural_of_hex "0x46", [DWA_exprloc; DWA_loclistptr]) ; + ("DW_AT_specification" , natural_of_hex "0x47", [DWA_reference]) ; + ("DW_AT_static_link" , natural_of_hex "0x48", [DWA_exprloc; DWA_loclistptr]) ; + ("DW_AT_type" , natural_of_hex "0x49", [DWA_reference]) ; + ("DW_AT_use_location" , natural_of_hex "0x4a", [DWA_exprloc; DWA_loclistptr]) ; + ("DW_AT_variable_parameter" , natural_of_hex "0x4b", [DWA_flag]) ; + ("DW_AT_virtuality" , natural_of_hex "0x4c", [DWA_constant]) ; + ("DW_AT_vtable_elem_location" , natural_of_hex "0x4d", [DWA_exprloc; DWA_loclistptr]) ; + ("DW_AT_allocated" , natural_of_hex "0x4e", [DWA_constant; DWA_exprloc; DWA_reference]) ; + ("DW_AT_associated" , natural_of_hex "0x4f", [DWA_constant; DWA_exprloc; DWA_reference]) ; + ("DW_AT_data_location" , natural_of_hex "0x50", [DWA_exprloc]) ; + ("DW_AT_byte_stride" , natural_of_hex "0x51", [DWA_constant; DWA_exprloc; DWA_reference]) ; + ("DW_AT_entry_pc" , natural_of_hex "0x52", [DWA_address]) ; + ("DW_AT_use_UTF8" , natural_of_hex "0x53", [DWA_flag]) ; + ("DW_AT_extension" , natural_of_hex "0x54", [DWA_reference]) ; + ("DW_AT_ranges" , natural_of_hex "0x55", [DWA_rangelistptr]) ; + ("DW_AT_trampoline" , natural_of_hex "0x56", [DWA_address; DWA_flag; DWA_reference; DWA_string]); + ("DW_AT_call_column" , natural_of_hex "0x57", [DWA_constant]) ; + ("DW_AT_call_file" , natural_of_hex "0x58", [DWA_constant]) ; + ("DW_AT_call_line" , natural_of_hex "0x59", [DWA_constant]) ; + ("DW_AT_description" , natural_of_hex "0x5a", [DWA_string]) ; + ("DW_AT_binary_scale" , natural_of_hex "0x5b", [DWA_constant]) ; + ("DW_AT_decimal_scale" , natural_of_hex "0x5c", [DWA_constant]) ; + ("DW_AT_small" , natural_of_hex "0x5d", [DWA_reference]) ; + ("DW_AT_decimal_sign" , natural_of_hex "0x5e", [DWA_constant]) ; + ("DW_AT_digit_count" , natural_of_hex "0x5f", [DWA_constant]) ; + ("DW_AT_picture_string" , natural_of_hex "0x60", [DWA_string]) ; + ("DW_AT_mutable" , natural_of_hex "0x61", [DWA_flag]) ; + ("DW_AT_threads_scaled" , natural_of_hex "0x62", [DWA_flag]) ; + ("DW_AT_explicit" , natural_of_hex "0x63", [DWA_flag]) ; + ("DW_AT_object_pointer" , natural_of_hex "0x64", [DWA_reference]) ; + ("DW_AT_endianity" , natural_of_hex "0x65", [DWA_constant]) ; + ("DW_AT_elemental" , natural_of_hex "0x66", [DWA_flag]) ; + ("DW_AT_pure" , natural_of_hex "0x67", [DWA_flag]) ; + ("DW_AT_recursive" , natural_of_hex "0x68", [DWA_flag]) ; + ("DW_AT_signature" , natural_of_hex "0x69", [DWA_reference]) ; + ("DW_AT_main_subprogram" , natural_of_hex "0x6a", [DWA_flag]) ; + ("DW_AT_data_bit_offset" , natural_of_hex "0x6b", [DWA_constant]) ; + ("DW_AT_const_expr" , natural_of_hex "0x6c", [DWA_flag]) ; + ("DW_AT_enum_class" , natural_of_hex "0x6d", [DWA_flag]) ; + ("DW_AT_linkage_name" , natural_of_hex "0x6e", [DWA_string]) ; (* DW_AT_noreturn is a gcc extension to support the C11 _Noreturn keyword*) - ("DW_AT_noreturn" , sym_natural_of_hex "0x87", [DWA_flag]) ; - ("DW_AT_alignment" , sym_natural_of_hex "0x88", [DWA_constant]) ; - ("DW_AT_lo_user" , sym_natural_of_hex "0x2000", [DWA_dash]) ; - ("DW_AT_hi_user" , sym_natural_of_hex "0x3fff", [DWA_dash]) + ("DW_AT_noreturn" , natural_of_hex "0x87", [DWA_flag]) ; + ("DW_AT_alignment" , natural_of_hex "0x88", [DWA_constant]) ; + ("DW_AT_lo_user" , natural_of_hex "0x2000", [DWA_dash]) ; + ("DW_AT_hi_user" , natural_of_hex "0x3fff", [DWA_dash]) ] (* attribute form encoding *) let attribute_form_encodings = [ - ("DW_FORM_addr" , sym_natural_of_hex "0x01", [DWA_address]) ; - ("DW_FORM_block2" , sym_natural_of_hex "0x03", [DWA_block]) ; - ("DW_FORM_block4" , sym_natural_of_hex "0x04", [DWA_block]) ; - ("DW_FORM_data2" , sym_natural_of_hex "0x05", [DWA_constant]) ; - ("DW_FORM_data4" , sym_natural_of_hex "0x06", [DWA_constant]) ; - ("DW_FORM_data8" , sym_natural_of_hex "0x07", [DWA_constant]) ; - ("DW_FORM_string" , sym_natural_of_hex "0x08", [DWA_string]) ; - ("DW_FORM_block" , sym_natural_of_hex "0x09", [DWA_block]) ; - ("DW_FORM_block1" , sym_natural_of_hex "0x0a", [DWA_block]) ; - ("DW_FORM_data1" , sym_natural_of_hex "0x0b", [DWA_constant]) ; - ("DW_FORM_flag" , sym_natural_of_hex "0x0c", [DWA_flag]) ; - ("DW_FORM_sdata" , sym_natural_of_hex "0x0d", [DWA_constant]) ; - ("DW_FORM_strp" , sym_natural_of_hex "0x0e", [DWA_string]) ; - ("DW_FORM_udata" , sym_natural_of_hex "0x0f", [DWA_constant]) ; - ("DW_FORM_ref_addr" , sym_natural_of_hex "0x10", [DWA_reference]); - ("DW_FORM_ref1" , sym_natural_of_hex "0x11", [DWA_reference]); - ("DW_FORM_ref2" , sym_natural_of_hex "0x12", [DWA_reference]); - ("DW_FORM_ref4" , sym_natural_of_hex "0x13", [DWA_reference]); - ("DW_FORM_ref8" , sym_natural_of_hex "0x14", [DWA_reference]); - ("DW_FORM_ref_udata" , sym_natural_of_hex "0x15", [DWA_reference]); - ("DW_FORM_indirect" , sym_natural_of_hex "0x16", [DWA_7_5_3]) ; - ("DW_FORM_sec_offset" , sym_natural_of_hex "0x17", [DWA_lineptr; DWA_loclistptr; DWA_macptr; DWA_rangelistptr]) ; - ("DW_FORM_exprloc" , sym_natural_of_hex "0x18", [DWA_exprloc]) ; - ("DW_FORM_flag_present", sym_natural_of_hex "0x19", [DWA_flag]) ; - ("DW_FORM_ref_sig8" , sym_natural_of_hex "0x20", [DWA_reference]) + ("DW_FORM_addr" , natural_of_hex "0x01", [DWA_address]) ; + ("DW_FORM_block2" , natural_of_hex "0x03", [DWA_block]) ; + ("DW_FORM_block4" , natural_of_hex "0x04", [DWA_block]) ; + ("DW_FORM_data2" , natural_of_hex "0x05", [DWA_constant]) ; + ("DW_FORM_data4" , natural_of_hex "0x06", [DWA_constant]) ; + ("DW_FORM_data8" , natural_of_hex "0x07", [DWA_constant]) ; + ("DW_FORM_string" , natural_of_hex "0x08", [DWA_string]) ; + ("DW_FORM_block" , natural_of_hex "0x09", [DWA_block]) ; + ("DW_FORM_block1" , natural_of_hex "0x0a", [DWA_block]) ; + ("DW_FORM_data1" , natural_of_hex "0x0b", [DWA_constant]) ; + ("DW_FORM_flag" , natural_of_hex "0x0c", [DWA_flag]) ; + ("DW_FORM_sdata" , natural_of_hex "0x0d", [DWA_constant]) ; + ("DW_FORM_strp" , natural_of_hex "0x0e", [DWA_string]) ; + ("DW_FORM_udata" , natural_of_hex "0x0f", [DWA_constant]) ; + ("DW_FORM_ref_addr" , natural_of_hex "0x10", [DWA_reference]); + ("DW_FORM_ref1" , natural_of_hex "0x11", [DWA_reference]); + ("DW_FORM_ref2" , natural_of_hex "0x12", [DWA_reference]); + ("DW_FORM_ref4" , natural_of_hex "0x13", [DWA_reference]); + ("DW_FORM_ref8" , natural_of_hex "0x14", [DWA_reference]); + ("DW_FORM_ref_udata" , natural_of_hex "0x15", [DWA_reference]); + ("DW_FORM_indirect" , natural_of_hex "0x16", [DWA_7_5_3]) ; + ("DW_FORM_sec_offset" , natural_of_hex "0x17", [DWA_lineptr; DWA_loclistptr; DWA_macptr; DWA_rangelistptr]) ; + ("DW_FORM_exprloc" , natural_of_hex "0x18", [DWA_exprloc]) ; + ("DW_FORM_flag_present", natural_of_hex "0x19", [DWA_flag]) ; + ("DW_FORM_ref_sig8" , natural_of_hex "0x20", [DWA_reference]) ] (* operation encoding *) let operation_encodings = [ -("DW_OP_addr", sym_natural_of_hex "0x03", [OAT_addr] , OpSem_lit); (*1*) (*constant address (size target specific)*) -("DW_OP_deref", sym_natural_of_hex "0x06", [] , OpSem_deref); (*0*) -("DW_OP_const1u", sym_natural_of_hex "0x08", [OAT_uint8] , OpSem_lit); (*1*) (* 1-byte constant *) -("DW_OP_const1s", sym_natural_of_hex "0x09", [OAT_sint8] , OpSem_lit); (*1*) (* 1-byte constant *) -("DW_OP_const2u", sym_natural_of_hex "0x0a", [OAT_uint16] , OpSem_lit); (*1*) (* 2-byte constant *) -("DW_OP_const2s", sym_natural_of_hex "0x0b", [OAT_sint16] , OpSem_lit); (*1*) (* 2-byte constant *) -("DW_OP_const4u", sym_natural_of_hex "0x0c", [OAT_uint32] , OpSem_lit); (*1*) (* 4-byte constant *) -("DW_OP_const4s", sym_natural_of_hex "0x0d", [OAT_sint32] , OpSem_lit); (*1*) (* 4-byte constant *) -("DW_OP_const8u", sym_natural_of_hex "0x0e", [OAT_uint64] , OpSem_lit); (*1*) (* 8-byte constant *) -("DW_OP_const8s", sym_natural_of_hex "0x0f", [OAT_sint64] , OpSem_lit); (*1*) (* 8-byte constant *) -("DW_OP_constu", sym_natural_of_hex "0x10", [OAT_ULEB128] , OpSem_lit); (*1*) (* ULEB128 constant *) -("DW_OP_consts", sym_natural_of_hex "0x11", [OAT_SLEB128] , OpSem_lit); (*1*) (* SLEB128 constant *) -("DW_OP_dup", sym_natural_of_hex "0x12", [] , OpSem_stack (fun ac vs args -> match vs with v::vs -> Just (v::v::vs) | _ -> Nothing end)); (*0*) -("DW_OP_drop", sym_natural_of_hex "0x13", [] , OpSem_stack (fun ac vs args -> match vs with v::vs -> Just vs | _ -> Nothing end)); (*0*) -("DW_OP_over", sym_natural_of_hex "0x14", [] , OpSem_stack (fun ac vs args -> match vs with v::v'::vs -> Just (v'::v::v'::vs) | _ -> Nothing end)); (*0*) -("DW_OP_pick", sym_natural_of_hex "0x15", [OAT_uint8] , OpSem_stack (fun ac vs args -> match args with [OAV_natural n] -> match index_sym_natural vs n with Just v -> Just (v::vs) | Nothing -> Nothing end | _ -> Nothing end)); (*1*) (* 1-byte stack index *) -("DW_OP_swap", sym_natural_of_hex "0x16", [] , OpSem_stack (fun ac vs args -> match vs with v::v'::vs -> Just (v'::v::vs) | _ -> Nothing end)); (*0*) -("DW_OP_rot", sym_natural_of_hex "0x17", [] , OpSem_stack (fun ac vs args -> match vs with v::v'::v''::vs -> Just (v'::v''::v::vs) | _ -> Nothing end)); (*0*) -("DW_OP_xderef", sym_natural_of_hex "0x18", [] , OpSem_not_supported); (*0*) -("DW_OP_abs", sym_natural_of_hex "0x19", [] , OpSem_unary (fun ac v -> if v < ac.ac_half then Just v else if v=ac.ac_max then Nothing else Just (ac.ac_all-v))); (*0*) -("DW_OP_and", sym_natural_of_hex "0x1a", [] , OpSem_binary (fun ac v1 v2 -> Just (sym_natural_land v1 v2))); (*0*) -("DW_OP_div", sym_natural_of_hex "0x1b", [] , OpSem_not_supported) (*TODO*); (*0*) -("DW_OP_minus", sym_natural_of_hex "0x1c", [] , OpSem_binary (fun ac v1 v2 -> Just (partialSymNaturalFromInteger ((integerFromSymNatural v1 - integerFromSymNatural v2) mod (integerFromSymNatural ac.ac_all))))); (*0*) -("DW_OP_mod", sym_natural_of_hex "0x1d", [] , OpSem_binary (fun ac v1 v2 -> Just (v1 mod v2))); (*0*) -("DW_OP_mul", sym_natural_of_hex "0x1e", [] , OpSem_binary (fun ac v1 v2 -> Just (partialSymNaturalFromInteger ((integerFromSymNatural v1 * integerFromSymNatural v2) mod (integerFromSymNatural ac.ac_all))))); (*0*) -("DW_OP_neg", sym_natural_of_hex "0x1f", [] , OpSem_unary (fun ac v -> if v < ac.ac_half then Just (ac.ac_max - v) else if v=ac.ac_half then Nothing else Just (ac.ac_all - v))); (*0*) -("DW_OP_not", sym_natural_of_hex "0x20", [] , OpSem_unary (fun ac v -> Just (sym_natural_lxor v ac.ac_max))); (*0*) -("DW_OP_or", sym_natural_of_hex "0x21", [] , OpSem_binary (fun ac v1 v2 -> Just (sym_natural_lor v1 v2))); (*0*) -("DW_OP_plus", sym_natural_of_hex "0x22", [] , OpSem_binary (fun ac v1 v2 -> Just ((v1 + v2) mod ac.ac_all))); (*0*) -("DW_OP_plus_uconst", sym_natural_of_hex "0x23", [OAT_ULEB128] , OpSem_stack (fun ac vs args -> match args with [OAV_natural n] -> match vs with v::vs' -> let v' = (v+n) mod ac.ac_all in Just (v'::vs) | [] -> Nothing end | _ -> Nothing end)); (*1*) (* ULEB128 addend *) -("DW_OP_shl", sym_natural_of_hex "0x24", [] , OpSem_binary (fun ac v1 v2 -> if v2 >= ac.ac_bitwidth then Just 0 else Just (sym_natural_nat_shift_left v1 (natFromSymNatural v2)))); (*0*) -("DW_OP_shr", sym_natural_of_hex "0x25", [] , OpSem_binary (fun ac v1 v2 -> if v2 >= ac.ac_bitwidth then Just 0 else Just (sym_natural_nat_shift_right v1 (natFromSymNatural v2)))); (*0*) -("DW_OP_shra", sym_natural_of_hex "0x26", [] , OpSem_binary (fun ac v1 v2 -> if v1 < ac.ac_half then (if v2 >= ac.ac_bitwidth then Just 0 else Just (sym_natural_nat_shift_right v1 (natFromSymNatural v2))) else (if v2 >= ac.ac_bitwidth then Just ac.ac_max else Just (ac.ac_max - (sym_natural_nat_shift_right (ac.ac_max - v1) (natFromSymNatural v2)))))); (*0*) -("DW_OP_xor", sym_natural_of_hex "0x27", [] , OpSem_binary (fun ac v1 v2 -> Just (sym_natural_lxor v1 v2))); (*0*) -("DW_OP_skip", sym_natural_of_hex "0x2f", [OAT_sint16] , OpSem_not_supported); (*1*) (* signed 2-byte constant *) -("DW_OP_bra", sym_natural_of_hex "0x28", [OAT_sint16] , OpSem_not_supported); (*1*) (* signed 2-byte constant *) -("DW_OP_eq", sym_natural_of_hex "0x29", [] , OpSem_not_supported); (*0*) -("DW_OP_ge", sym_natural_of_hex "0x2a", [] , OpSem_not_supported); (*0*) -("DW_OP_gt", sym_natural_of_hex "0x2b", [] , OpSem_not_supported); (*0*) -("DW_OP_le", sym_natural_of_hex "0x2c", [] , OpSem_not_supported); (*0*) -("DW_OP_lt", sym_natural_of_hex "0x2d", [] , OpSem_not_supported); (*0*) -("DW_OP_ne", sym_natural_of_hex "0x2e", [] , OpSem_not_supported); (*0*) -("DW_OP_lit0", sym_natural_of_hex "0x30", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) (* literals 0..31 =(DW_OP_lit0 + literal) *) -("DW_OP_lit1", sym_natural_of_hex "0x31", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit2", sym_natural_of_hex "0x32", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit3", sym_natural_of_hex "0x33", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit4", sym_natural_of_hex "0x34", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit5", sym_natural_of_hex "0x35", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit6", sym_natural_of_hex "0x36", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit7", sym_natural_of_hex "0x37", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit8", sym_natural_of_hex "0x38", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit9", sym_natural_of_hex "0x39", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit10", sym_natural_of_hex "0x3a", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit11", sym_natural_of_hex "0x3b", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit12", sym_natural_of_hex "0x3c", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit13", sym_natural_of_hex "0x3d", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit14", sym_natural_of_hex "0x3e", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit15", sym_natural_of_hex "0x3f", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit16", sym_natural_of_hex "0x40", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit17", sym_natural_of_hex "0x41", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit18", sym_natural_of_hex "0x42", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit19", sym_natural_of_hex "0x43", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit20", sym_natural_of_hex "0x44", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit21", sym_natural_of_hex "0x45", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit22", sym_natural_of_hex "0x46", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit23", sym_natural_of_hex "0x47", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit24", sym_natural_of_hex "0x48", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit25", sym_natural_of_hex "0x49", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit26", sym_natural_of_hex "0x4a", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit27", sym_natural_of_hex "0x4b", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit28", sym_natural_of_hex "0x4c", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit29", sym_natural_of_hex "0x4d", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit30", sym_natural_of_hex "0x4e", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_lit31", sym_natural_of_hex "0x4f", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) -("DW_OP_reg0", sym_natural_of_hex "0x50", [] , OpSem_reg); (*1*) (* reg 0..31 = (DW_OP_reg0 + regnum) *) -("DW_OP_reg1", sym_natural_of_hex "0x51", [] , OpSem_reg); (*1*) -("DW_OP_reg2", sym_natural_of_hex "0x52", [] , OpSem_reg); (*1*) -("DW_OP_reg3", sym_natural_of_hex "0x53", [] , OpSem_reg); (*1*) -("DW_OP_reg4", sym_natural_of_hex "0x54", [] , OpSem_reg); (*1*) -("DW_OP_reg5", sym_natural_of_hex "0x55", [] , OpSem_reg); (*1*) -("DW_OP_reg6", sym_natural_of_hex "0x56", [] , OpSem_reg); (*1*) -("DW_OP_reg7", sym_natural_of_hex "0x57", [] , OpSem_reg); (*1*) -("DW_OP_reg8", sym_natural_of_hex "0x58", [] , OpSem_reg); (*1*) -("DW_OP_reg9", sym_natural_of_hex "0x59", [] , OpSem_reg); (*1*) -("DW_OP_reg10", sym_natural_of_hex "0x5a", [] , OpSem_reg); (*1*) -("DW_OP_reg11", sym_natural_of_hex "0x5b", [] , OpSem_reg); (*1*) -("DW_OP_reg12", sym_natural_of_hex "0x5c", [] , OpSem_reg); (*1*) -("DW_OP_reg13", sym_natural_of_hex "0x5d", [] , OpSem_reg); (*1*) -("DW_OP_reg14", sym_natural_of_hex "0x5e", [] , OpSem_reg); (*1*) -("DW_OP_reg15", sym_natural_of_hex "0x5f", [] , OpSem_reg); (*1*) -("DW_OP_reg16", sym_natural_of_hex "0x60", [] , OpSem_reg); (*1*) -("DW_OP_reg17", sym_natural_of_hex "0x61", [] , OpSem_reg); (*1*) -("DW_OP_reg18", sym_natural_of_hex "0x62", [] , OpSem_reg); (*1*) -("DW_OP_reg19", sym_natural_of_hex "0x63", [] , OpSem_reg); (*1*) -("DW_OP_reg20", sym_natural_of_hex "0x64", [] , OpSem_reg); (*1*) -("DW_OP_reg21", sym_natural_of_hex "0x65", [] , OpSem_reg); (*1*) -("DW_OP_reg22", sym_natural_of_hex "0x66", [] , OpSem_reg); (*1*) -("DW_OP_reg23", sym_natural_of_hex "0x67", [] , OpSem_reg); (*1*) -("DW_OP_reg24", sym_natural_of_hex "0x68", [] , OpSem_reg); (*1*) -("DW_OP_reg25", sym_natural_of_hex "0x69", [] , OpSem_reg); (*1*) -("DW_OP_reg26", sym_natural_of_hex "0x6a", [] , OpSem_reg); (*1*) -("DW_OP_reg27", sym_natural_of_hex "0x6b", [] , OpSem_reg); (*1*) -("DW_OP_reg28", sym_natural_of_hex "0x6c", [] , OpSem_reg); (*1*) -("DW_OP_reg29", sym_natural_of_hex "0x6d", [] , OpSem_reg); (*1*) -("DW_OP_reg30", sym_natural_of_hex "0x6e", [] , OpSem_reg); (*1*) -("DW_OP_reg31", sym_natural_of_hex "0x6f", [] , OpSem_reg); (*1*) -("DW_OP_breg0", sym_natural_of_hex "0x70", [OAT_SLEB128] , OpSem_breg); (*1*) (* base register 0..31 = (DW_OP_breg0 + regnum) *) -("DW_OP_breg1", sym_natural_of_hex "0x71", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg2", sym_natural_of_hex "0x72", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg3", sym_natural_of_hex "0x73", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg4", sym_natural_of_hex "0x74", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg5", sym_natural_of_hex "0x75", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg6", sym_natural_of_hex "0x76", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg7", sym_natural_of_hex "0x77", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg8", sym_natural_of_hex "0x78", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg9", sym_natural_of_hex "0x79", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg10", sym_natural_of_hex "0x7a", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg11", sym_natural_of_hex "0x7b", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg12", sym_natural_of_hex "0x7c", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg13", sym_natural_of_hex "0x7d", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg14", sym_natural_of_hex "0x7e", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg15", sym_natural_of_hex "0x7f", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg16", sym_natural_of_hex "0x80", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg17", sym_natural_of_hex "0x81", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg18", sym_natural_of_hex "0x82", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg19", sym_natural_of_hex "0x83", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg20", sym_natural_of_hex "0x84", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg21", sym_natural_of_hex "0x85", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg22", sym_natural_of_hex "0x86", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg23", sym_natural_of_hex "0x87", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg24", sym_natural_of_hex "0x88", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg25", sym_natural_of_hex "0x89", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg26", sym_natural_of_hex "0x8a", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg27", sym_natural_of_hex "0x8b", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg28", sym_natural_of_hex "0x8c", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg29", sym_natural_of_hex "0x8d", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg30", sym_natural_of_hex "0x8e", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg31", sym_natural_of_hex "0x8f", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_regx", sym_natural_of_hex "0x90", [OAT_ULEB128] , OpSem_lit); (*1*) (* ULEB128 register *) -("DW_OP_fbreg", sym_natural_of_hex "0x91", [OAT_SLEB128] , OpSem_fbreg); (*1*) (* SLEB128 offset *) -("DW_OP_bregx", sym_natural_of_hex "0x92", [OAT_ULEB128; OAT_SLEB128] , OpSem_bregx); (*2*) (* ULEB128 register followed by SLEB128 offset *) -("DW_OP_piece", sym_natural_of_hex "0x93", [OAT_ULEB128] , OpSem_piece); (*1*) (* ULEB128 size of piece addressed *) -("DW_OP_deref_size", sym_natural_of_hex "0x94", [OAT_uint8] , OpSem_deref_size); (*1*) (* 1-byte size of data retrieved *) -("DW_OP_xderef_size", sym_natural_of_hex "0x95", [OAT_uint8] , OpSem_not_supported); (*1*) (* 1-byte size of data retrieved *) -("DW_OP_nop", sym_natural_of_hex "0x96", [] , OpSem_nop); (*0*) -("DW_OP_push_object_address", sym_natural_of_hex "0x97", [] , OpSem_not_supported); (*0*) -("DW_OP_call2", sym_natural_of_hex "0x98", [OAT_uint16] , OpSem_not_supported); (*1*) (* 2-byte offset of DIE *) -("DW_OP_call4", sym_natural_of_hex "0x99", [OAT_uint32] , OpSem_not_supported); (*1*) (* 4-byte offset of DIE *) -("DW_OP_call_ref", sym_natural_of_hex "0x9a", [OAT_dwarf_format_t] , OpSem_not_supported); (*1*) (* 4- or 8-byte offset of DIE *) -("DW_OP_form_tls_address", sym_natural_of_hex "0x9b", [] , OpSem_not_supported); (*0*) -("DW_OP_call_frame_cfa", sym_natural_of_hex "0x9c", [] , OpSem_call_frame_cfa); (*0*) -("DW_OP_bit_piece", sym_natural_of_hex "0x9d", [OAT_ULEB128; OAT_ULEB128] , OpSem_bit_piece); (*2*) (* ULEB128 size followed by ULEB128 offset *) -("DW_OP_implicit_value", sym_natural_of_hex "0x9e", [OAT_block] , OpSem_implicit_value); (*2*) (* ULEB128 size followed by block of that size *) -("DW_OP_stack_value", sym_natural_of_hex "0x9f", [] , OpSem_stack_value); (*0*) +("DW_OP_addr", natural_of_hex "0x03", [OAT_addr] , OpSem_lit); (*1*) (*constant address (size target specific)*) +("DW_OP_deref", natural_of_hex "0x06", [] , OpSem_deref); (*0*) +("DW_OP_const1u", natural_of_hex "0x08", [OAT_uint8] , OpSem_lit); (*1*) (* 1-byte constant *) +("DW_OP_const1s", natural_of_hex "0x09", [OAT_sint8] , OpSem_lit); (*1*) (* 1-byte constant *) +("DW_OP_const2u", natural_of_hex "0x0a", [OAT_uint16] , OpSem_lit); (*1*) (* 2-byte constant *) +("DW_OP_const2s", natural_of_hex "0x0b", [OAT_sint16] , OpSem_lit); (*1*) (* 2-byte constant *) +("DW_OP_const4u", natural_of_hex "0x0c", [OAT_uint32] , OpSem_lit); (*1*) (* 4-byte constant *) +("DW_OP_const4s", natural_of_hex "0x0d", [OAT_sint32] , OpSem_lit); (*1*) (* 4-byte constant *) +("DW_OP_const8u", natural_of_hex "0x0e", [OAT_uint64] , OpSem_lit); (*1*) (* 8-byte constant *) +("DW_OP_const8s", natural_of_hex "0x0f", [OAT_sint64] , OpSem_lit); (*1*) (* 8-byte constant *) +("DW_OP_constu", natural_of_hex "0x10", [OAT_ULEB128] , OpSem_lit); (*1*) (* ULEB128 constant *) +("DW_OP_consts", natural_of_hex "0x11", [OAT_SLEB128] , OpSem_lit); (*1*) (* SLEB128 constant *) +("DW_OP_dup", natural_of_hex "0x12", [] , OpSem_stack (fun ac vs args -> match vs with v::vs -> Just (v::v::vs) | _ -> Nothing end)); (*0*) +("DW_OP_drop", natural_of_hex "0x13", [] , OpSem_stack (fun ac vs args -> match vs with v::vs -> Just vs | _ -> Nothing end)); (*0*) +("DW_OP_over", natural_of_hex "0x14", [] , OpSem_stack (fun ac vs args -> match vs with v::v'::vs -> Just (v'::v::v'::vs) | _ -> Nothing end)); (*0*) +("DW_OP_pick", natural_of_hex "0x15", [OAT_uint8] , OpSem_stack (fun ac vs args -> match args with [OAV_natural n] -> match index_sym_natural vs n with Just v -> Just (v::vs) | Nothing -> Nothing end | _ -> Nothing end)); (*1*) (* 1-byte stack index *) +("DW_OP_swap", natural_of_hex "0x16", [] , OpSem_stack (fun ac vs args -> match vs with v::v'::vs -> Just (v'::v::vs) | _ -> Nothing end)); (*0*) +("DW_OP_rot", natural_of_hex "0x17", [] , OpSem_stack (fun ac vs args -> match vs with v::v'::v''::vs -> Just (v'::v''::v::vs) | _ -> Nothing end)); (*0*) +("DW_OP_xderef", natural_of_hex "0x18", [] , OpSem_not_supported); (*0*) +("DW_OP_abs", natural_of_hex "0x19", [] , OpSem_unary (fun ac v -> if v < ac.ac_half then Just v else if v=ac.ac_max then Nothing else Just (ac.ac_all-v))); (*0*) +("DW_OP_and", natural_of_hex "0x1a", [] , OpSem_binary (fun ac v1 v2 -> Just (sym_natural_land v1 v2))); (*0*) +("DW_OP_div", natural_of_hex "0x1b", [] , OpSem_not_supported) (*TODO*); (*0*) +("DW_OP_minus", natural_of_hex "0x1c", [] , OpSem_binary (fun ac v1 v2 -> Just (partialSymNaturalFromInteger ((integerFromSymNatural v1 - integerFromSymNatural v2) mod (integerFromSymNatural ac.ac_all))))); (*0*) +("DW_OP_mod", natural_of_hex "0x1d", [] , OpSem_binary (fun ac v1 v2 -> Just (v1 mod v2))); (*0*) +("DW_OP_mul", natural_of_hex "0x1e", [] , OpSem_binary (fun ac v1 v2 -> Just (partialSymNaturalFromInteger ((integerFromSymNatural v1 * integerFromSymNatural v2) mod (integerFromSymNatural ac.ac_all))))); (*0*) +("DW_OP_neg", natural_of_hex "0x1f", [] , OpSem_unary (fun ac v -> if v < ac.ac_half then Just (ac.ac_max - v) else if v=ac.ac_half then Nothing else Just (ac.ac_all - v))); (*0*) +("DW_OP_not", natural_of_hex "0x20", [] , OpSem_unary (fun ac v -> Just (sym_natural_lxor v ac.ac_max))); (*0*) +("DW_OP_or", natural_of_hex "0x21", [] , OpSem_binary (fun ac v1 v2 -> Just (sym_natural_lor v1 v2))); (*0*) +("DW_OP_plus", natural_of_hex "0x22", [] , OpSem_binary (fun ac v1 v2 -> Just ((v1 + v2) mod ac.ac_all))); (*0*) +("DW_OP_plus_uconst", natural_of_hex "0x23", [OAT_ULEB128] , OpSem_stack (fun ac vs args -> match args with [OAV_natural n] -> match vs with v::vs' -> let v' = (v+n) mod ac.ac_all in Just (v'::vs) | [] -> Nothing end | _ -> Nothing end)); (*1*) (* ULEB128 addend *) +("DW_OP_shl", natural_of_hex "0x24", [] , OpSem_binary (fun ac v1 v2 -> if v2 >= ac.ac_bitwidth then Just 0 else Just (sym_natural_nat_shift_left v1 (natFromSymNatural v2)))); (*0*) +("DW_OP_shr", natural_of_hex "0x25", [] , OpSem_binary (fun ac v1 v2 -> if v2 >= ac.ac_bitwidth then Just 0 else Just (sym_natural_nat_shift_right v1 (natFromSymNatural v2)))); (*0*) +("DW_OP_shra", natural_of_hex "0x26", [] , OpSem_binary (fun ac v1 v2 -> if v1 < ac.ac_half then (if v2 >= ac.ac_bitwidth then Just 0 else Just (sym_natural_nat_shift_right v1 (natFromSymNatural v2))) else (if v2 >= ac.ac_bitwidth then Just ac.ac_max else Just (ac.ac_max - (sym_natural_nat_shift_right (ac.ac_max - v1) (natFromSymNatural v2)))))); (*0*) +("DW_OP_xor", natural_of_hex "0x27", [] , OpSem_binary (fun ac v1 v2 -> Just (sym_natural_lxor v1 v2))); (*0*) +("DW_OP_skip", natural_of_hex "0x2f", [OAT_sint16] , OpSem_not_supported); (*1*) (* signed 2-byte constant *) +("DW_OP_bra", natural_of_hex "0x28", [OAT_sint16] , OpSem_not_supported); (*1*) (* signed 2-byte constant *) +("DW_OP_eq", natural_of_hex "0x29", [] , OpSem_not_supported); (*0*) +("DW_OP_ge", natural_of_hex "0x2a", [] , OpSem_not_supported); (*0*) +("DW_OP_gt", natural_of_hex "0x2b", [] , OpSem_not_supported); (*0*) +("DW_OP_le", natural_of_hex "0x2c", [] , OpSem_not_supported); (*0*) +("DW_OP_lt", natural_of_hex "0x2d", [] , OpSem_not_supported); (*0*) +("DW_OP_ne", natural_of_hex "0x2e", [] , OpSem_not_supported); (*0*) +("DW_OP_lit0", natural_of_hex "0x30", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) (* literals 0..31 =(DW_OP_lit0 + literal) *) +("DW_OP_lit1", natural_of_hex "0x31", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) +("DW_OP_lit2", natural_of_hex "0x32", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) +("DW_OP_lit3", natural_of_hex "0x33", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) +("DW_OP_lit4", natural_of_hex "0x34", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) +("DW_OP_lit5", natural_of_hex "0x35", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) +("DW_OP_lit6", natural_of_hex "0x36", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) +("DW_OP_lit7", natural_of_hex "0x37", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) +("DW_OP_lit8", natural_of_hex "0x38", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) +("DW_OP_lit9", natural_of_hex "0x39", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) +("DW_OP_lit10", natural_of_hex "0x3a", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) +("DW_OP_lit11", natural_of_hex "0x3b", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) +("DW_OP_lit12", natural_of_hex "0x3c", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) +("DW_OP_lit13", natural_of_hex "0x3d", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) +("DW_OP_lit14", natural_of_hex "0x3e", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) +("DW_OP_lit15", natural_of_hex "0x3f", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) +("DW_OP_lit16", natural_of_hex "0x40", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) +("DW_OP_lit17", natural_of_hex "0x41", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) +("DW_OP_lit18", natural_of_hex "0x42", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) +("DW_OP_lit19", natural_of_hex "0x43", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) +("DW_OP_lit20", natural_of_hex "0x44", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) +("DW_OP_lit21", natural_of_hex "0x45", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) +("DW_OP_lit22", natural_of_hex "0x46", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) +("DW_OP_lit23", natural_of_hex "0x47", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) +("DW_OP_lit24", natural_of_hex "0x48", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) +("DW_OP_lit25", natural_of_hex "0x49", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) +("DW_OP_lit26", natural_of_hex "0x4a", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) +("DW_OP_lit27", natural_of_hex "0x4b", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) +("DW_OP_lit28", natural_of_hex "0x4c", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) +("DW_OP_lit29", natural_of_hex "0x4d", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) +("DW_OP_lit30", natural_of_hex "0x4e", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) +("DW_OP_lit31", natural_of_hex "0x4f", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) +("DW_OP_reg0", natural_of_hex "0x50", [] , OpSem_reg); (*1*) (* reg 0..31 = (DW_OP_reg0 + regnum) *) +("DW_OP_reg1", natural_of_hex "0x51", [] , OpSem_reg); (*1*) +("DW_OP_reg2", natural_of_hex "0x52", [] , OpSem_reg); (*1*) +("DW_OP_reg3", natural_of_hex "0x53", [] , OpSem_reg); (*1*) +("DW_OP_reg4", natural_of_hex "0x54", [] , OpSem_reg); (*1*) +("DW_OP_reg5", natural_of_hex "0x55", [] , OpSem_reg); (*1*) +("DW_OP_reg6", natural_of_hex "0x56", [] , OpSem_reg); (*1*) +("DW_OP_reg7", natural_of_hex "0x57", [] , OpSem_reg); (*1*) +("DW_OP_reg8", natural_of_hex "0x58", [] , OpSem_reg); (*1*) +("DW_OP_reg9", natural_of_hex "0x59", [] , OpSem_reg); (*1*) +("DW_OP_reg10", natural_of_hex "0x5a", [] , OpSem_reg); (*1*) +("DW_OP_reg11", natural_of_hex "0x5b", [] , OpSem_reg); (*1*) +("DW_OP_reg12", natural_of_hex "0x5c", [] , OpSem_reg); (*1*) +("DW_OP_reg13", natural_of_hex "0x5d", [] , OpSem_reg); (*1*) +("DW_OP_reg14", natural_of_hex "0x5e", [] , OpSem_reg); (*1*) +("DW_OP_reg15", natural_of_hex "0x5f", [] , OpSem_reg); (*1*) +("DW_OP_reg16", natural_of_hex "0x60", [] , OpSem_reg); (*1*) +("DW_OP_reg17", natural_of_hex "0x61", [] , OpSem_reg); (*1*) +("DW_OP_reg18", natural_of_hex "0x62", [] , OpSem_reg); (*1*) +("DW_OP_reg19", natural_of_hex "0x63", [] , OpSem_reg); (*1*) +("DW_OP_reg20", natural_of_hex "0x64", [] , OpSem_reg); (*1*) +("DW_OP_reg21", natural_of_hex "0x65", [] , OpSem_reg); (*1*) +("DW_OP_reg22", natural_of_hex "0x66", [] , OpSem_reg); (*1*) +("DW_OP_reg23", natural_of_hex "0x67", [] , OpSem_reg); (*1*) +("DW_OP_reg24", natural_of_hex "0x68", [] , OpSem_reg); (*1*) +("DW_OP_reg25", natural_of_hex "0x69", [] , OpSem_reg); (*1*) +("DW_OP_reg26", natural_of_hex "0x6a", [] , OpSem_reg); (*1*) +("DW_OP_reg27", natural_of_hex "0x6b", [] , OpSem_reg); (*1*) +("DW_OP_reg28", natural_of_hex "0x6c", [] , OpSem_reg); (*1*) +("DW_OP_reg29", natural_of_hex "0x6d", [] , OpSem_reg); (*1*) +("DW_OP_reg30", natural_of_hex "0x6e", [] , OpSem_reg); (*1*) +("DW_OP_reg31", natural_of_hex "0x6f", [] , OpSem_reg); (*1*) +("DW_OP_breg0", natural_of_hex "0x70", [OAT_SLEB128] , OpSem_breg); (*1*) (* base register 0..31 = (DW_OP_breg0 + regnum) *) +("DW_OP_breg1", natural_of_hex "0x71", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg2", natural_of_hex "0x72", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg3", natural_of_hex "0x73", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg4", natural_of_hex "0x74", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg5", natural_of_hex "0x75", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg6", natural_of_hex "0x76", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg7", natural_of_hex "0x77", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg8", natural_of_hex "0x78", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg9", natural_of_hex "0x79", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg10", natural_of_hex "0x7a", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg11", natural_of_hex "0x7b", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg12", natural_of_hex "0x7c", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg13", natural_of_hex "0x7d", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg14", natural_of_hex "0x7e", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg15", natural_of_hex "0x7f", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg16", natural_of_hex "0x80", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg17", natural_of_hex "0x81", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg18", natural_of_hex "0x82", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg19", natural_of_hex "0x83", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg20", natural_of_hex "0x84", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg21", natural_of_hex "0x85", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg22", natural_of_hex "0x86", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg23", natural_of_hex "0x87", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg24", natural_of_hex "0x88", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg25", natural_of_hex "0x89", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg26", natural_of_hex "0x8a", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg27", natural_of_hex "0x8b", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg28", natural_of_hex "0x8c", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg29", natural_of_hex "0x8d", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg30", natural_of_hex "0x8e", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg31", natural_of_hex "0x8f", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_regx", natural_of_hex "0x90", [OAT_ULEB128] , OpSem_lit); (*1*) (* ULEB128 register *) +("DW_OP_fbreg", natural_of_hex "0x91", [OAT_SLEB128] , OpSem_fbreg); (*1*) (* SLEB128 offset *) +("DW_OP_bregx", natural_of_hex "0x92", [OAT_ULEB128; OAT_SLEB128] , OpSem_bregx); (*2*) (* ULEB128 register followed by SLEB128 offset *) +("DW_OP_piece", natural_of_hex "0x93", [OAT_ULEB128] , OpSem_piece); (*1*) (* ULEB128 size of piece addressed *) +("DW_OP_deref_size", natural_of_hex "0x94", [OAT_uint8] , OpSem_deref_size); (*1*) (* 1-byte size of data retrieved *) +("DW_OP_xderef_size", natural_of_hex "0x95", [OAT_uint8] , OpSem_not_supported); (*1*) (* 1-byte size of data retrieved *) +("DW_OP_nop", natural_of_hex "0x96", [] , OpSem_nop); (*0*) +("DW_OP_push_object_address", natural_of_hex "0x97", [] , OpSem_not_supported); (*0*) +("DW_OP_call2", natural_of_hex "0x98", [OAT_uint16] , OpSem_not_supported); (*1*) (* 2-byte offset of DIE *) +("DW_OP_call4", natural_of_hex "0x99", [OAT_uint32] , OpSem_not_supported); (*1*) (* 4-byte offset of DIE *) +("DW_OP_call_ref", natural_of_hex "0x9a", [OAT_dwarf_format_t] , OpSem_not_supported); (*1*) (* 4- or 8-byte offset of DIE *) +("DW_OP_form_tls_address", natural_of_hex "0x9b", [] , OpSem_not_supported); (*0*) +("DW_OP_call_frame_cfa", natural_of_hex "0x9c", [] , OpSem_call_frame_cfa); (*0*) +("DW_OP_bit_piece", natural_of_hex "0x9d", [OAT_ULEB128; OAT_ULEB128] , OpSem_bit_piece); (*2*) (* ULEB128 size followed by ULEB128 offset *) +("DW_OP_implicit_value", natural_of_hex "0x9e", [OAT_block] , OpSem_implicit_value); (*2*) (* ULEB128 size followed by block of that size *) +("DW_OP_stack_value", natural_of_hex "0x9f", [] , OpSem_stack_value); (*0*) (* these aren't real operations -("DW_OP_lo_user", sym_natural_of_hex "0xe0", [] , ); -("DW_OP_hi_user", sym_natural_of_hex "0xff", [] , ); +("DW_OP_lo_user", natural_of_hex "0xe0", [] , ); +("DW_OP_hi_user", natural_of_hex "0xff", [] , ); *) (* GCC also produces these for our example: https://fedorahosted.org/elfutils/wiki/DwarfExtensions http://dwarfstd.org/ShowIssue.php?issue=100909.1 *) -("DW_GNU_OP_entry_value", sym_natural_of_hex "0xf3", [OAT_block], OpSem_not_supported); (*2*) (* ULEB128 size followed by DWARF expression block of that size*) -("DW_OP_GNU_implicit_pointer", sym_natural_of_hex "0xf2", [OAT_dwarf_format_t;OAT_SLEB128], OpSem_not_supported) +("DW_GNU_OP_entry_value", natural_of_hex "0xf3", [OAT_block], OpSem_not_supported); (*2*) (* ULEB128 size followed by DWARF expression block of that size*) +("DW_OP_GNU_implicit_pointer", natural_of_hex "0xf2", [OAT_dwarf_format_t;OAT_SLEB128], OpSem_not_supported) ] -let vDW_OP_reg0 = sym_natural_of_hex "0x50" -let vDW_OP_breg0 = sym_natural_of_hex "0x70" +let vDW_OP_reg0 = natural_of_hex "0x50" +let vDW_OP_breg0 = natural_of_hex "0x70" (* call frame instruction encoding *) -let call_frame_instruction_encoding : list (string * sym_natural * sym_natural * list call_frame_argument_type * ((list call_frame_argument_value) -> maybe call_frame_instruction)) = [ +let call_frame_instruction_encoding : list (string * natural * natural * list call_frame_argument_type * ((list call_frame_argument_value) -> maybe call_frame_instruction)) = [ (* high-order 2 bits low-order 6 bits uniformly parsed arguments *) (* instructions using low-order 6 bits for first argument *) @@ -1583,53 +1583,53 @@ let call_frame_instruction_encoding : list (string * sym_natural * sym_natural * ("DW_CFA_restore", 3, 0,(*register*) []); *) (* instructions using low-order 6 bits as part of opcode *) -("DW_CFA_nop", 0, sym_natural_of_hex "0x00", [], (* *) +("DW_CFA_nop", 0, natural_of_hex "0x00", [], (* *) fun avs -> match avs with [] -> Just (DW_CFA_nop) | _ -> Nothing end); -("DW_CFA_set_loc", 0, sym_natural_of_hex "0x01", [CFAT_address], (* address *) +("DW_CFA_set_loc", 0, natural_of_hex "0x01", [CFAT_address], (* address *) fun avs -> match avs with [CFAV_address a] -> Just (DW_CFA_set_loc a) | _ -> Nothing end); -("DW_CFA_advance_loc1", 0, sym_natural_of_hex "0x02", [CFAT_delta1], (* 1-byte delta *) +("DW_CFA_advance_loc1", 0, natural_of_hex "0x02", [CFAT_delta1], (* 1-byte delta *) fun avs -> match avs with [CFAV_delta d] -> Just (DW_CFA_advance_loc1 d) | _ -> Nothing end); -("DW_CFA_advance_loc2", 0, sym_natural_of_hex "0x03", [CFAT_delta2], (* 2-byte delta *) +("DW_CFA_advance_loc2", 0, natural_of_hex "0x03", [CFAT_delta2], (* 2-byte delta *) fun avs -> match avs with [CFAV_delta d] -> Just (DW_CFA_advance_loc2 d) | _ -> Nothing end); -("DW_CFA_advance_loc4", 0, sym_natural_of_hex "0x04", [CFAT_delta4], (* 4-byte delta *) +("DW_CFA_advance_loc4", 0, natural_of_hex "0x04", [CFAT_delta4], (* 4-byte delta *) fun avs -> match avs with [CFAV_delta d] -> Just (DW_CFA_advance_loc4 d) | _ -> Nothing end); -("DW_CFA_offset_extended", 0, sym_natural_of_hex "0x05", [CFAT_register; CFAT_offset], (* ULEB128 register ULEB128 offset *) +("DW_CFA_offset_extended", 0, natural_of_hex "0x05", [CFAT_register; CFAT_offset], (* ULEB128 register ULEB128 offset *) fun avs -> match avs with [CFAV_register r; CFAV_offset n] -> Just (DW_CFA_offset_extended r n) | _ -> Nothing end); -("DW_CFA_restore_extended", 0, sym_natural_of_hex "0x06", [CFAT_register], (* ULEB128 register *) +("DW_CFA_restore_extended", 0, natural_of_hex "0x06", [CFAT_register], (* ULEB128 register *) fun avs -> match avs with [CFAV_register r] -> Just (DW_CFA_restore_extended r) | _ -> Nothing end); -("DW_CFA_undefined", 0, sym_natural_of_hex "0x07", [CFAT_register], (* ULEB128 register *) +("DW_CFA_undefined", 0, natural_of_hex "0x07", [CFAT_register], (* ULEB128 register *) fun avs -> match avs with [CFAV_register r] -> Just (DW_CFA_undefined r) | _ -> Nothing end); -("DW_CFA_same_value", 0, sym_natural_of_hex "0x08", [CFAT_register], (* ULEB128 register *) +("DW_CFA_same_value", 0, natural_of_hex "0x08", [CFAT_register], (* ULEB128 register *) fun avs -> match avs with [CFAV_register r] -> Just (DW_CFA_same_value r) | _ -> Nothing end); -("DW_CFA_register", 0, sym_natural_of_hex "0x09", [CFAT_register; CFAT_register], (* ULEB128 register ULEB128 register *) +("DW_CFA_register", 0, natural_of_hex "0x09", [CFAT_register; CFAT_register], (* ULEB128 register ULEB128 register *) fun avs -> match avs with [CFAV_register r1; CFAV_register r2] -> Just (DW_CFA_register r1 r2) | _ -> Nothing end); -("DW_CFA_remember_state", 0, sym_natural_of_hex "0x0a", [], (* *) +("DW_CFA_remember_state", 0, natural_of_hex "0x0a", [], (* *) fun avs -> match avs with [] -> Just (DW_CFA_remember_state) | _ -> Nothing end); -("DW_CFA_restore_state", 0, sym_natural_of_hex "0x0b", [], (* *) +("DW_CFA_restore_state", 0, natural_of_hex "0x0b", [], (* *) fun avs -> match avs with [] -> Just (DW_CFA_restore_state) | _ -> Nothing end); -("DW_CFA_def_cfa", 0, sym_natural_of_hex "0x0c", [CFAT_register; CFAT_offset], (* ULEB128 register ULEB128 offset *) +("DW_CFA_def_cfa", 0, natural_of_hex "0x0c", [CFAT_register; CFAT_offset], (* ULEB128 register ULEB128 offset *) fun avs -> match avs with [CFAV_register r; CFAV_offset n] -> Just (DW_CFA_def_cfa r n) | _ -> Nothing end); -("DW_CFA_def_cfa_register", 0, sym_natural_of_hex "0x0d", [CFAT_register], (* ULEB128 register *) +("DW_CFA_def_cfa_register", 0, natural_of_hex "0x0d", [CFAT_register], (* ULEB128 register *) fun avs -> match avs with [CFAV_register r] -> Just (DW_CFA_def_cfa_register r) | _ -> Nothing end); -("DW_CFA_def_cfa_offset", 0, sym_natural_of_hex "0x0e", [CFAT_offset], (* ULEB128 offset *) +("DW_CFA_def_cfa_offset", 0, natural_of_hex "0x0e", [CFAT_offset], (* ULEB128 offset *) fun avs -> match avs with [CFAV_offset n] -> Just (DW_CFA_def_cfa_offset n) | _ -> Nothing end); -("DW_CFA_def_cfa_expression", 0, sym_natural_of_hex "0x0f", [CFAT_block], (* BLOCK *) +("DW_CFA_def_cfa_expression", 0, natural_of_hex "0x0f", [CFAT_block], (* BLOCK *) fun avs -> match avs with [CFAV_block b] -> Just (DW_CFA_def_cfa_expression b) | _ -> Nothing end); -("DW_CFA_expression", 0, sym_natural_of_hex "0x10", [CFAT_register; CFAT_block], (* ULEB128 register BLOCK *) +("DW_CFA_expression", 0, natural_of_hex "0x10", [CFAT_register; CFAT_block], (* ULEB128 register BLOCK *) fun avs -> match avs with [CFAV_register r; CFAV_block b] -> Just (DW_CFA_expression r b) | _ -> Nothing end); -("DW_CFA_offset_extended_sf", 0, sym_natural_of_hex "0x11", [CFAT_register; CFAT_sfoffset], (* ULEB128 register SLEB128 offset *) +("DW_CFA_offset_extended_sf", 0, natural_of_hex "0x11", [CFAT_register; CFAT_sfoffset], (* ULEB128 register SLEB128 offset *) fun avs -> match avs with [CFAV_register r; CFAV_sfoffset i] -> Just (DW_CFA_offset_extended_sf r i) | _ -> Nothing end); -("DW_CFA_def_cfa_sf", 0, sym_natural_of_hex "0x12", [CFAT_register; CFAT_sfoffset], (* ULEB128 register SLEB128 offset *) +("DW_CFA_def_cfa_sf", 0, natural_of_hex "0x12", [CFAT_register; CFAT_sfoffset], (* ULEB128 register SLEB128 offset *) fun avs -> match avs with [CFAV_register r; CFAV_sfoffset i] -> Just (DW_CFA_def_cfa_sf r i) | _ -> Nothing end); -("DW_CFA_def_cfa_offset_sf", 0, sym_natural_of_hex "0x13", [CFAT_sfoffset], (* SLEB128 offset *) +("DW_CFA_def_cfa_offset_sf", 0, natural_of_hex "0x13", [CFAT_sfoffset], (* SLEB128 offset *) fun avs -> match avs with [CFAV_sfoffset i] -> Just (DW_CFA_def_cfa_offset_sf i) | _ -> Nothing end); -("DW_CFA_val_offset", 0, sym_natural_of_hex "0x14", [CFAT_register; CFAT_offset], (* ULEB128 ULEB128 *) +("DW_CFA_val_offset", 0, natural_of_hex "0x14", [CFAT_register; CFAT_offset], (* ULEB128 ULEB128 *) fun avs -> match avs with [CFAV_register r; CFAV_offset n] -> Just (DW_CFA_val_offset r n) | _ -> Nothing end); -("DW_CFA_val_offset_sf", 0, sym_natural_of_hex "0x15", [CFAT_register; CFAT_sfoffset], (* ULEB128 SLEB128 *) +("DW_CFA_val_offset_sf", 0, natural_of_hex "0x15", [CFAT_register; CFAT_sfoffset], (* ULEB128 SLEB128 *) fun avs -> match avs with [CFAV_register r; CFAV_sfoffset i] -> Just (DW_CFA_val_offset_sf r i) | _ -> Nothing end); -("DW_CFA_val_expression", 0, sym_natural_of_hex "0x16", [CFAT_register; CFAT_block], (* ULEB128 BLOCK *) +("DW_CFA_val_expression", 0, natural_of_hex "0x16", [CFAT_register; CFAT_block], (* ULEB128 BLOCK *) fun avs -> match avs with [CFAV_register r; CFAV_block b] -> Just (DW_CFA_val_expression r b) | _ -> Nothing end); -("DW_CFA_AARCH64_negate_ra_state", 0, sym_natural_of_hex "0x2d", [], (* *) +("DW_CFA_AARCH64_negate_ra_state", 0, natural_of_hex "0x2d", [], (* *) fun avs -> match avs with [] -> Just (DW_CFA_AARCH64_negate_ra_state) | _ -> Nothing end); ] (* @@ -1646,55 +1646,55 @@ p10 says "The RA_SIGN_STATE pseudo-register records whether the return address h For our purposes it seems fine to nop-this. *) (* -("DW_CFA_lo_user", 0, sym_natural_of_hex "0x1c", []); (* *) -("DW_CFA_hi_user", 0, sym_natural_of_hex "0x3f", []); (* *) +("DW_CFA_lo_user", 0, natural_of_hex "0x1c", []); (* *) +("DW_CFA_hi_user", 0, natural_of_hex "0x3f", []); (* *) *) (* line number encodings *) let line_number_standard_encodings = [ - ("DW_LNS_copy" , sym_natural_of_hex "0x01", [ ], + ("DW_LNS_copy" , natural_of_hex "0x01", [ ], fun lnvs -> match lnvs with [] -> Just DW_LNS_copy | _ -> Nothing end); - ("DW_LNS_advance_pc" , sym_natural_of_hex "0x02", [LNAT_ULEB128 ], + ("DW_LNS_advance_pc" , natural_of_hex "0x02", [LNAT_ULEB128 ], fun lnvs -> match lnvs with [LNAV_ULEB128 n] -> Just (DW_LNS_advance_pc n) | _ -> Nothing end); - ("DW_LNS_advance_line" , sym_natural_of_hex "0x03", [LNAT_SLEB128 ], + ("DW_LNS_advance_line" , natural_of_hex "0x03", [LNAT_SLEB128 ], fun lnvs -> match lnvs with [LNAV_SLEB128 i] -> Just (DW_LNS_advance_line i) | _ -> Nothing end); - ("DW_LNS_set_file" , sym_natural_of_hex "0x04", [LNAT_ULEB128 ], + ("DW_LNS_set_file" , natural_of_hex "0x04", [LNAT_ULEB128 ], fun lnvs -> match lnvs with [LNAV_ULEB128 n] -> Just (DW_LNS_set_file n) | _ -> Nothing end); - ("DW_LNS_set_column" , sym_natural_of_hex "0x05", [LNAT_ULEB128 ], + ("DW_LNS_set_column" , natural_of_hex "0x05", [LNAT_ULEB128 ], fun lnvs -> match lnvs with [LNAV_ULEB128 n] -> Just (DW_LNS_set_column n) | _ -> Nothing end); - ("DW_LNS_negate_stmt" , sym_natural_of_hex "0x06", [ ], + ("DW_LNS_negate_stmt" , natural_of_hex "0x06", [ ], fun lnvs -> match lnvs with [] -> Just (DW_LNS_negate_stmt) | _ -> Nothing end); - ("DW_LNS_set_basic_block" , sym_natural_of_hex "0x07", [ ], + ("DW_LNS_set_basic_block" , natural_of_hex "0x07", [ ], fun lnvs -> match lnvs with [] -> Just (DW_LNS_set_basic_block) | _ -> Nothing end); - ("DW_LNS_const_add_pc" , sym_natural_of_hex "0x08", [ ], + ("DW_LNS_const_add_pc" , natural_of_hex "0x08", [ ], fun lnvs -> match lnvs with [] -> Just (DW_LNS_const_add_pc) | _ -> Nothing end); - ("DW_LNS_fixed_advance_pc" , sym_natural_of_hex "0x09", [LNAT_uint16 ], + ("DW_LNS_fixed_advance_pc" , natural_of_hex "0x09", [LNAT_uint16 ], fun lnvs -> match lnvs with [LNAV_uint16 n] -> Just (DW_LNS_fixed_advance_pc n) | _ -> Nothing end); - ("DW_LNS_set_prologue_end" , sym_natural_of_hex "0x0a", [ ], + ("DW_LNS_set_prologue_end" , natural_of_hex "0x0a", [ ], fun lnvs -> match lnvs with [] -> Just (DW_LNS_set_prologue_end) | _ -> Nothing end); - ("DW_LNS_set_epilogue_begin" , sym_natural_of_hex "0x0b", [ ], + ("DW_LNS_set_epilogue_begin" , natural_of_hex "0x0b", [ ], fun lnvs -> match lnvs with [] -> Just (DW_LNS_set_epilogue_begin) | _ -> Nothing end); - ("DW_LNS_set_isa" , sym_natural_of_hex "0x0c", [LNAT_ULEB128 ], + ("DW_LNS_set_isa" , natural_of_hex "0x0c", [LNAT_ULEB128 ], fun lnvs -> match lnvs with [LNAV_ULEB128 n] -> Just (DW_LNS_set_isa n) | _ -> Nothing end) ] let line_number_extended_encodings = [ - ("DW_LNE_end_sequence" , sym_natural_of_hex "0x01", [], + ("DW_LNE_end_sequence" , natural_of_hex "0x01", [], fun lnvs -> match lnvs with [] -> Just (DW_LNE_end_sequence) | _ -> Nothing end); - ("DW_LNE_set_address" , sym_natural_of_hex "0x02", [LNAT_address], + ("DW_LNE_set_address" , natural_of_hex "0x02", [LNAT_address], fun lnvs -> match lnvs with [LNAV_address n] -> Just (DW_LNE_set_address n) | _ -> Nothing end); - ("DW_LNE_define_file" , sym_natural_of_hex "0x03", [LNAT_string; LNAT_ULEB128; LNAT_ULEB128; LNAT_ULEB128], + ("DW_LNE_define_file" , natural_of_hex "0x03", [LNAT_string; LNAT_ULEB128; LNAT_ULEB128; LNAT_ULEB128], fun lnvs -> match lnvs with [LNAV_string s; LNAV_ULEB128 n1; LNAV_ULEB128 n2; LNAV_ULEB128 n3] -> Just (DW_LNE_define_file s n1 n2 n3) | _ -> Nothing end); - ("DW_LNE_set_discriminator" , sym_natural_of_hex "0x04", [LNAT_ULEB128], + ("DW_LNE_set_discriminator" , natural_of_hex "0x04", [LNAT_ULEB128], fun lnvs -> match lnvs with [LNAV_ULEB128 n] -> Just (DW_LNE_set_discriminator n) | _ -> Nothing end) (* new in Dwarf 4*) ] (* -(DW_LNE_lo_user , sym_natural_of_hex "0x80", "DW_LNE_lo_user"); -(DW_LNE_hi_user , sym_natural_of_hex "0xff", "DW_LNE_hi_user"); +(DW_LNE_lo_user , natural_of_hex "0x80", "DW_LNE_lo_user"); +(DW_LNE_hi_user , natural_of_hex "0xff", "DW_LNE_hi_user"); *) @@ -1703,26 +1703,26 @@ let line_number_extended_encodings = [ (* base type attribute encoding *) let base_type_attribute_encodings = [ - ("DW_ATE_address" , sym_natural_of_hex "0x01"); - ("DW_ATE_boolean" , sym_natural_of_hex "0x02"); - ("DW_ATE_complex_float" , sym_natural_of_hex "0x03"); - ("DW_ATE_float" , sym_natural_of_hex "0x04"); - ("DW_ATE_signed" , sym_natural_of_hex "0x05"); - ("DW_ATE_signed_char" , sym_natural_of_hex "0x06"); - ("DW_ATE_unsigned" , sym_natural_of_hex "0x07"); - ("DW_ATE_unsigned_char" , sym_natural_of_hex "0x08"); - ("DW_ATE_imaginary_float" , sym_natural_of_hex "0x09"); - ("DW_ATE_packed_decimal" , sym_natural_of_hex "0x0a"); - ("DW_ATE_numeric_string" , sym_natural_of_hex "0x0b"); - ("DW_ATE_edited" , sym_natural_of_hex "0x0c"); - ("DW_ATE_signed_fixed" , sym_natural_of_hex "0x0d"); - ("DW_ATE_unsigned_fixed" , sym_natural_of_hex "0x0e"); - ("DW_ATE_decimal_float" , sym_natural_of_hex "0x0f"); - ("DW_ATE_UTF" , sym_natural_of_hex "0x10"); - ("DW_ATE_lo_user" , sym_natural_of_hex "0x80"); - ("DW_ATE_signed_capability_hack_a0" , sym_natural_of_hex "0xa0"); - ("DW_ATE_unsigned_capability_hack_a1" , sym_natural_of_hex "0xa1"); - ("DW_ATE_hi_user" , sym_natural_of_hex "0xff") + ("DW_ATE_address" , natural_of_hex "0x01"); + ("DW_ATE_boolean" , natural_of_hex "0x02"); + ("DW_ATE_complex_float" , natural_of_hex "0x03"); + ("DW_ATE_float" , natural_of_hex "0x04"); + ("DW_ATE_signed" , natural_of_hex "0x05"); + ("DW_ATE_signed_char" , natural_of_hex "0x06"); + ("DW_ATE_unsigned" , natural_of_hex "0x07"); + ("DW_ATE_unsigned_char" , natural_of_hex "0x08"); + ("DW_ATE_imaginary_float" , natural_of_hex "0x09"); + ("DW_ATE_packed_decimal" , natural_of_hex "0x0a"); + ("DW_ATE_numeric_string" , natural_of_hex "0x0b"); + ("DW_ATE_edited" , natural_of_hex "0x0c"); + ("DW_ATE_signed_fixed" , natural_of_hex "0x0d"); + ("DW_ATE_unsigned_fixed" , natural_of_hex "0x0e"); + ("DW_ATE_decimal_float" , natural_of_hex "0x0f"); + ("DW_ATE_UTF" , natural_of_hex "0x10"); + ("DW_ATE_lo_user" , natural_of_hex "0x80"); + ("DW_ATE_signed_capability_hack_a0" , natural_of_hex "0xa0"); + ("DW_ATE_unsigned_capability_hack_a1" , natural_of_hex "0xa1"); + ("DW_ATE_hi_user" , natural_of_hex "0xff") ] (** ************************************************************ *) @@ -1995,32 +1995,32 @@ let rec lookup_abCde_de z0 xyzwus = end -let pp_maybe ppf n = match ppf n with Just s -> s | Nothing -> "Unknown AT value: " ^ pphexplain_sym n (*encoding not found: "" ^ pphex n*) end +let pp_maybe ppf n = match ppf n with Just s -> s | Nothing -> "Unknown AT value: " ^ pphexplain n (*encoding not found: "" ^ pphex n*) end let pp_tag_encoding n = pp_maybe (fun n -> lookup_aB_a n tag_encodings) n let pp_attribute_encoding n = pp_maybe (fun n -> lookup_aBc_a n attribute_encodings) n let pp_attribute_form_encoding n = pp_maybe (fun n -> lookup_aBc_a n attribute_form_encodings) n let pp_operation_encoding n = pp_maybe (fun n -> lookup_aBcd_a n operation_encodings) n -let tag_encode (s: string) : sym_natural = +let tag_encode (s: string) : natural = match lookup_Ab_b s tag_encodings with | Just n -> n | Nothing -> Assert_extra.failwith ("tag_encode: \""^s^"\"") end -let attribute_encode (s: string) : sym_natural = +let attribute_encode (s: string) : natural = match lookup_Abc_b s attribute_encodings with | Just n -> n | Nothing -> Assert_extra.failwith ("attribute_encode: \""^s^"\"") end -let attribute_form_encode (s: string) : sym_natural = +let attribute_form_encode (s: string) : natural = match lookup_Abc_b s attribute_form_encodings with | Just n -> n | Nothing -> Assert_extra.failwith "attribute_form_encode" end -let base_type_attribute_encode (s: string) : sym_natural = +let base_type_attribute_encode (s: string) : natural = match lookup_Ab_b s base_type_attribute_encodings with | Just n -> n | Nothing -> Assert_extra.failwith "base_type_attribute_encode" @@ -2466,9 +2466,9 @@ let parse_abbreviation_declaration c : parser (maybe abbreviation_declaration) = Just ( let ad = <| ad_abbreviation_code = n1; - ad_tag = n2; + ad_tag = sym_unwrap n2 "as_tag"; ad_has_children = (c<>0); - ad_attribute_specifications = l; + ad_attribute_specifications = List.map (fun (a, b) -> (sym_unwrap a "attribute", sym_unwrap b "attribute_form")) l; |> in (* let _ = my_debug2 (pp_abbreviation_declaration ad) in *) ad) )))) @@ -2564,8 +2564,9 @@ let parse_operation c cuh pc = match parse_uint8 pc with | PR_fail s pc' -> PR_success Nothing pc | PR_success code pc' -> + let code = sym_unwrap code "opcode" in match lookup_aBcd_acd code operation_encodings with - | Nothing -> PR_fail ("encoding not found: " ^ pphex_sym code) pc + | Nothing -> PR_fail ("encoding not found: " ^ pphex code) pc | Just (s,oats,opsem) -> let ps = List.map (parser_of_operation_argument_type c cuh) oats in (pr_post_map @@ -2624,7 +2625,7 @@ let pp_attribute_value_plain av = end -val pp_attribute_value : p_context -> compilation_unit_header -> rel_byte_sequence -> sym_natural (*attribute tag*) -> attribute_value -> string +val pp_attribute_value : p_context -> compilation_unit_header -> rel_byte_sequence -> natural (*attribute tag*) -> attribute_value -> string let pp_attribute_value c cuh str at av = match av with | AV_addr x -> "AV_addr " ^ pphex_sym x @@ -2645,7 +2646,7 @@ let pp_attribute_value c cuh str at av = ^ pp_debug_str_entry str n end -val pp_attribute_value_like_objdump : p_context -> compilation_unit_header -> rel_byte_sequence -> sym_natural (*attribute tag*) -> attribute_value -> string +val pp_attribute_value_like_objdump : p_context -> compilation_unit_header -> rel_byte_sequence -> natural (*attribute tag*) -> attribute_value -> string let pp_attribute_value_like_objdump c cuh str at av = match av with | AV_addr x -> (*"AV_addr " ^*) pphex_sym x @@ -2673,7 +2674,7 @@ let pp_attribute_value_like_objdump c cuh str at av = -val parser_of_attribute_form_non_indirect : p_context -> compilation_unit_header -> sym_natural -> parser attribute_value +val parser_of_attribute_form_non_indirect : p_context -> compilation_unit_header -> natural -> parser attribute_value let parser_of_attribute_form_non_indirect c cuh n = (* address*) if n = attribute_form_encode "DW_FORM_addr" then @@ -2749,7 +2750,7 @@ let parser_of_attribute_form_non_indirect c cuh n = let parser_of_attribute_form c cuh n = if n = attribute_form_encode "DW_FORM_indirect" then (fun pc -> pr_bind (parse_ULEB128 pc) (fun n -> - parser_of_attribute_form_non_indirect c cuh n) ) + parser_of_attribute_form_non_indirect c cuh(sym_unwrap n "attribute form")) ) else parser_of_attribute_form_non_indirect c cuh n @@ -2867,7 +2868,7 @@ let find_attribute_value (an: string) (die:die) : maybe attribute_value = die.die_abbreviation_declaration.ad_attribute_specifications die.die_attribute_values in myfindmaybe - (fun (((at': sym_natural), (af: sym_natural)), ((pos: sym_natural),(av:attribute_value))) -> + (fun (((at': natural), (af: natural)), ((pos: sym_natural),(av:attribute_value))) -> if at' = at then Just av else Nothing) ats @@ -3086,7 +3087,7 @@ let indent_level_plus_one indent level = else " "^" " -let pp_die_attribute c (cuh:compilation_unit_header) (str : rel_byte_sequence) (indent:bool) (level: natural) (((at: sym_natural), (af: sym_natural)), ((pos: sym_natural),(av:attribute_value))) : string = +let pp_die_attribute c (cuh:compilation_unit_header) (str : rel_byte_sequence) (indent:bool) (level: natural) (((at: natural), (af: natural)), ((pos: sym_natural),(av:attribute_value))) : string = indent_level_plus_one indent level ^ pp_pos pos ^ " " ^ right_space_padded_to 18 (pp_attribute_encoding at) ^ ": " ^ @@ -3680,7 +3681,7 @@ let parser_of_call_frame_argument_type c cuh (cfat: call_frame_argument_type) : | CFAT_delta_ULEB128 -> pr_map2 (fun n -> CFAV_delta n) (parse_ULEB128) | CFAT_offset -> pr_map2 (fun n -> CFAV_offset n) (parse_ULEB128) | CFAT_sfoffset -> pr_map2 (fun n -> CFAV_sfoffset n) (parse_SLEB128) - | CFAT_register -> pr_map2 (fun n -> CFAV_register n) (parse_ULEB128) + | CFAT_register -> pr_map2 (fun n -> CFAV_register (sym_unwrap n "register")) (parse_ULEB128) | CFAT_block -> (fun pc -> pr_bind (parse_ULEB128 pc) (fun n pc' -> pr_map (fun bs -> CFAV_block bs) (parse_n_bytes n pc'))) @@ -3694,7 +3695,7 @@ let parse_call_frame_instruction c cuh : parser (maybe call_frame_instruction) = let pc' = <| pc_bytes = bs'; pc_offset = pc.pc_offset + 1 |> in let ch = unsigned_char_of_byte b in let high_bits = unsigned_char_land ch (unsigned_char_of_natural 192) in - let low_bits = Absolute (natural_of_unsigned_char (unsigned_char_land ch (unsigned_char_of_natural 63))) in + let low_bits = natural_of_unsigned_char (unsigned_char_land ch (unsigned_char_of_natural 63)) in if high_bits = unsigned_char_of_natural 0 then match lookup_abCde_de low_bits call_frame_instruction_encoding with | Just ((args: list call_frame_argument_type), result) -> @@ -3714,7 +3715,7 @@ let parse_call_frame_instruction c cuh : parser (maybe call_frame_instruction) = end else if high_bits = unsigned_char_of_natural 64 then - PR_success (Just (DW_CFA_advance_loc low_bits)) pc' + PR_success (Just (DW_CFA_advance_loc (Absolute low_bits))) pc' else if high_bits = unsigned_char_of_natural 192 then PR_success (Just (DW_CFA_restore low_bits)) pc' else @@ -3854,7 +3855,7 @@ let parse_frame_info_element c cuh (fi: list frame_info_element) : parser frame_ cie_segment_size = mss; cie_code_alignment_factor = caf; cie_data_alignment_factor = daf; - cie_return_address_register = rar; + cie_return_address_register = sym_unwrap rar "register"; cie_initial_instructions_bytes = bs; cie_initial_instructions = is; |>) @@ -4059,7 +4060,7 @@ let parse_line_number_header c (comp_dir:maybe string) : parser line_number_head lnh_default_is_stmt = (dis<>0); lnh_line_base = lb; lnh_line_range = lr; - lnh_opcode_base = ob; + lnh_opcode_base = (sym_unwrap ob "opcode base"); lnh_standard_opcode_lengths = sols; lnh_include_directories = ids; lnh_file_entries = fns; @@ -4083,6 +4084,7 @@ let parse_line_number_operation c (cuh: compilation_unit_header) (lnh: line_numb parse_dependent parse_uint8 (fun opcode -> + let opcode = sym_unwrap opcode "opcode" in if opcode=0 then (* parse extended opcode *) parse_dependent @@ -4090,7 +4092,7 @@ let parse_line_number_operation c (cuh: compilation_unit_header) (lnh: line_numb parse_ULEB128 parse_uint8) (fun (size,opcode') -> - match lookup_aBcd_acd opcode' line_number_extended_encodings with + match lookup_aBcd_acd (sym_unwrap opcode' "opcode") line_number_extended_encodings with | Just (_, arg_types, result) -> let ps = List.map (parser_of_line_number_argument_type c cuh) arg_types in parse_demaybe ("parse_line_number_operation fail") @@ -4635,18 +4637,18 @@ let rec evaluate_operation_list (c:p_context) (dloc: location_list_list) (evalua end | (OpSem_opcode_lit base, []) -> if op.op_code >= base && op.op_code < base + 32 then - push_memory_address (op.op_code - base) s.s_stack + push_memory_address (Absolute (op.op_code - base)) s.s_stack else Fail "OpSem_opcode_lit opcode not within [base,base+32)" | (OpSem_reg, []) -> (* TODO: unclear whether this should push the register id or not *) let r = op.op_code - vDW_OP_reg0 in - Success <| s with s_stack = r :: s.s_stack; s_value = SL_register r |> + Success <| s with s_stack = (Absolute r) :: s.s_stack; s_value = SL_register r |> | (OpSem_breg, [OAV_integer i]) -> let r = op.op_code - vDW_OP_breg0 in bregxi r i | (OpSem_bregx, [OAV_natural r; OAV_integer i]) -> - bregxi r i + bregxi (sym_unwrap r "register") i | (OpSem_deref, []) -> deref_size cuh.cuh_address_size | (OpSem_deref_size, [OAV_natural n]) -> @@ -5081,6 +5083,7 @@ let analyse_type_info_top c (d: dwarf) (r:bool(*recurse into members*)) (cupdie: if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_base_type" then let encoding = let n = strict s (find_natural_attribute_value_of_die c "DW_AT_encoding" die) in + let n = sym_unwrap n "attribute encoding" in if not(List.any (fun (s,n')->n=n') base_type_attribute_encodings) then strict s Nothing else n in (* TODO: handle user encodings correctly *) let mbyte_size = find_natural_attribute_value_of_die c "DW_AT_byte_size" die in @@ -5209,7 +5212,7 @@ let analyse_type_info_top c (d: dwarf) (r:bool(*recurse into members*)) (cupdie: else - Assert_extra.failwith ("analyse_type_info_top didn't recognise tag: " ^ pphex_sym die.die_abbreviation_declaration.ad_tag ^ " for DIE " ^ pp_cupdie3 cupdie) + Assert_extra.failwith ("analyse_type_info_top didn't recognise tag: " ^ pphex die.die_abbreviation_declaration.ad_tag ^ " for DIE " ^ pp_cupdie3 cupdie) let rec analyse_type_info_deep (d: dwarf) (r:bool(*recurse_into_members*)) cupdie : c_type = @@ -5426,7 +5429,7 @@ let analyse_locations_raw c (d: dwarf) = die.die_abbreviation_declaration.ad_attribute_specifications die.die_attribute_values in - let find_ats (s:string) = myfindNonPure (fun (((at: sym_natural), (af: sym_natural)), ((pos: sym_natural),(av:attribute_value))) -> sym_eq (attribute_encode s) at) ats in + let find_ats (s:string) = myfindNonPure (fun (((at: natural), (af: natural)), ((pos: sym_natural),(av:attribute_value))) -> (attribute_encode s) = at) ats in let ((_,_),(_,av_name)) = find_ats "DW_AT_name" in @@ -6010,6 +6013,7 @@ let evaluate_line_number_operation match lno with | DW_LN_special adjusted_opcode -> + let adjusted_opcode = Absolute adjusted_opcode in (* TODO probably doesn't have to be symbolic *) let operation_advance = adjusted_opcode / lnh.lnh_line_range in let line_increment = lnh.lnh_line_base + integerFromSymNatural (adjusted_opcode mod lnh.lnh_line_range) in let s' = @@ -6056,7 +6060,7 @@ let evaluate_line_number_operation let s' = <| s with lnr_basic_block = true |> in (s', lnrs) | DW_LNS_const_add_pc -> let opcode = 255 in - let adjusted_opcode = opcode - lnh.lnh_opcode_base in + let adjusted_opcode = Absolute (opcode - lnh.lnh_opcode_base) in let operation_advance = adjusted_opcode / lnh.lnh_line_range in let s' = <| s with @@ -6726,7 +6730,7 @@ let rec pp_inlined_subroutine_parents (ds:list die) : string = pp_pos die.die_offset ^ ":" ^ pp_inlined_subroutine_parents ds' else if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_lexical_block" then ":" ^ pp_inlined_subroutine_parents ds' else if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_subprogram" then "" - else "" + else "" end From 6d307efd920d26dc18610f891357a58193fde80e Mon Sep 17 00:00:00 2001 From: Matej Urban Date: Sat, 7 Dec 2024 13:00:06 +0000 Subject: [PATCH 09/44] extract section body without relocations --- src/dwarf.lem | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/dwarf.lem b/src/dwarf.lem index 88c1e81..6bbc482 100644 --- a/src/dwarf.lem +++ b/src/dwarf.lem @@ -4339,7 +4339,6 @@ let parse_dwarf c d_line_info = li; |> -(* TODO *) val extract_section_body : elf_file -> relocation_interpreter reloc_target_data -> string -> bool -> p_context * sym_natural * rel_byte_sequence let extract_section_body (f:elf_file) (ri:relocation_interpreter reloc_target_data) (section_name:string) (strict: bool) = let (en: Endianness.endianness) = @@ -4399,6 +4398,10 @@ let extract_section_body (f:elf_file) (ri:relocation_interpreter reloc_target_da end end +let extract_section_body_without_relocations f section_name strict = + let err_on_relocation ef symtab_map sidx rel = Assert_extra.failwith "Relocation found while extracting a section without relocations" in + let (c, addr, body) = extract_section_body f err_on_relocation section_name strict in + (c, sym_unwrap addr "", rbs_unwrap body) val extract_dwarf : elf_file -> relocation_interpreter reloc_target_data -> maybe dwarf let extract_dwarf f ri = From 92d2164dbb77423cabc2211e3d9d28cc197b901a Mon Sep 17 00:00:00 2001 From: Matej Urban Date: Sat, 28 Dec 2024 16:02:44 +0000 Subject: [PATCH 10/44] Make constructing reloc map tail recursive --- src/dwarf.lem | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/dwarf.lem b/src/dwarf.lem index 6bbc482..49436f0 100644 --- a/src/dwarf.lem +++ b/src/dwarf.lem @@ -378,18 +378,18 @@ let pad_no_reloc n rels = end (* TODO strict mode? *) -val reloc_map_to_reloc_list' : Map.map elf64_addr (abstract_relocation reloc_target_data) -> natural -> natural -> list next_reloc -let rec reloc_map_to_reloc_list' rels i l = +val reloc_map_to_reloc_list' : Map.map elf64_addr (abstract_relocation reloc_target_data) -> natural -> natural -> list next_reloc -> list next_reloc +let rec reloc_map_to_reloc_list' rels i l acc = if i = l then - [] + List.reverse acc else match Map.lookup (elf64_addr_of_natural i) rels with - | Nothing -> pad_no_reloc 1 (reloc_map_to_reloc_list' rels (i+1) l) - | Just x -> Reloc x :: reloc_map_to_reloc_list' rels (i + reloc_width_bytes x.arel_target) l + | Nothing -> reloc_map_to_reloc_list' rels (i+1) l (pad_no_reloc 1 acc) + | Just x -> reloc_map_to_reloc_list' rels (i + reloc_width_bytes x.arel_target) l (Reloc x :: acc) end let reloc_map_to_reloc_list rels l = - reloc_map_to_reloc_list' rels 0 l + reloc_map_to_reloc_list' rels 0 l [] let construct_rel_byte_sequence bs rel = <| rbs_bytes = bs ; rbs_relocs = reloc_map_to_reloc_list rel (Byte_sequence.length bs) |> From 2d0a2e15b5416f2cb2dd43aa54965d69b1852eab Mon Sep 17 00:00:00 2001 From: Matej Urban Date: Sat, 28 Dec 2024 16:11:28 +0000 Subject: [PATCH 11/44] sym minus --- src/dwarf.lem | 44 +++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 41 insertions(+), 3 deletions(-) diff --git a/src/dwarf.lem b/src/dwarf.lem index 49436f0..a0bb989 100644 --- a/src/dwarf.lem +++ b/src/dwarf.lem @@ -169,6 +169,44 @@ let sym_add x y= | _ -> Unknown end +class ( MaybeMinus 'a ) + val mminus : 'a -> 'a -> maybe 'a +end + +instance (MaybeMinus natural) + let mminus = fun x y -> if x >= y then Just (x - y) else Nothing +end + +instance (MaybeMinus integer) + let mminus = fun x y -> Just (x-y) +end + +val sym_minus : forall 'a. MaybeMinus 'a, NumMinus 'a => (sym 'a -> sym 'a -> sym 'a) +let sym_minus x y= + match (x, y) with + | (Absolute x, Absolute y) -> Absolute (x - y) + | (Offset (s, x), Absolute y) -> + match mminus x y with + | Just v -> Offset (s, v) + | Nothing -> Unknown + end + | (Offset (s, x), Offset (t, y)) -> + if s = t then + match mminus x y with + | Just v -> Absolute v + | Nothing -> Unknown + end + else + Unknown + | _ -> Unknown + end + +val sym_natural_minus : sym_natural -> sym_natural -> sym_natural +let sym_natural_minus = sym_minus + +val sym_integer_minus : sym_integer -> sym_integer -> sym_integer +let sym_integer_minus = sym_minus + val sym_bind : forall 'a. sym 'a -> ('a -> sym 'a) -> sym 'a let sym_bind x f = match x with | Absolute x -> f x @@ -205,11 +243,11 @@ instance forall 'a. Show 'a => (Show (sym 'a)) end instance forall 'a. NumAdd 'a => (NumAdd (sym 'a)) - let (+) = sym_add + let (+) = sym_add end -instance forall 'a. NumMinus 'a => (NumMinus (sym 'a)) - let (-) = sym_map2 (-) +instance forall 'a. MaybeMinus 'a, NumMinus 'a => (NumMinus (sym 'a)) + let (-) = sym_minus end instance forall 'a. NumMult 'a => (NumMult (sym 'a)) From d5c3879e3d5ff5d201c44cdb8b88096a5f40160d Mon Sep 17 00:00:00 2001 From: Matej Urban Date: Thu, 2 Jan 2025 17:50:19 +0100 Subject: [PATCH 12/44] add TODO --- src/elf_symbolic.lem | 1 + 1 file changed, 1 insertion(+) diff --git a/src/elf_symbolic.lem b/src/elf_symbolic.lem index 9792e4c..013f7e8 100644 --- a/src/elf_symbolic.lem +++ b/src/elf_symbolic.lem @@ -48,6 +48,7 @@ let section_with_offset f sidx offset = | Just sec -> return (BinOp(Section sec.elf64_section_name_as_string, Add, Const (integerFromNatural (natural_of_elf64_addr offset)))) end +(* TODO handle special shndx *) let symbolic_address_from_elf64_symbol_table_entry f ste = section_with_offset f ste.elf64_st_shndx ste.elf64_st_value From 5108c49c9aaf0c31dd5d1bf8d414acd171438bb7 Mon Sep 17 00:00:00 2001 From: Matej Urban Date: Thu, 2 Jan 2025 18:34:33 +0100 Subject: [PATCH 13/44] produce non-symbolic dwarf --- src/dwarf.lem | 257 ++++++++++---------------------------------------- 1 file changed, 52 insertions(+), 205 deletions(-) diff --git a/src/dwarf.lem b/src/dwarf.lem index a0bb989..c5ab038 100644 --- a/src/dwarf.lem +++ b/src/dwarf.lem @@ -151,133 +151,12 @@ declare ocaml target_rep function natural_nat_shift_left = `Nat_big_num.shift val natural_nat_shift_right : natural -> nat -> natural declare ocaml target_rep function natural_nat_shift_right = `Nat_big_num.shift_right` -(* Symbolic types *) -type sym 'a = - | Offset of (string * 'a) - | Absolute of 'a - | Unknown - -type sym_natural = sym natural -type sym_integer = sym integer - -val sym_add : forall 'a. NumAdd 'a => (sym 'a -> sym 'a -> sym 'a) -let sym_add x y= - match (x, y) with - | (Absolute x, Absolute y) -> Absolute (x + y) - | (Offset (s, x), Absolute y) -> Offset (s, x + y) - | (Absolute x, Offset (s, y)) -> Offset (s, x + y) - | _ -> Unknown - end - -class ( MaybeMinus 'a ) - val mminus : 'a -> 'a -> maybe 'a -end - -instance (MaybeMinus natural) - let mminus = fun x y -> if x >= y then Just (x - y) else Nothing -end - -instance (MaybeMinus integer) - let mminus = fun x y -> Just (x-y) -end - -val sym_minus : forall 'a. MaybeMinus 'a, NumMinus 'a => (sym 'a -> sym 'a -> sym 'a) -let sym_minus x y= - match (x, y) with - | (Absolute x, Absolute y) -> Absolute (x - y) - | (Offset (s, x), Absolute y) -> - match mminus x y with - | Just v -> Offset (s, v) - | Nothing -> Unknown - end - | (Offset (s, x), Offset (t, y)) -> - if s = t then - match mminus x y with - | Just v -> Absolute v - | Nothing -> Unknown - end - else - Unknown - | _ -> Unknown - end - -val sym_natural_minus : sym_natural -> sym_natural -> sym_natural -let sym_natural_minus = sym_minus - -val sym_integer_minus : sym_integer -> sym_integer -> sym_integer -let sym_integer_minus = sym_minus - -val sym_bind : forall 'a. sym 'a -> ('a -> sym 'a) -> sym 'a -let sym_bind x f = match x with - | Absolute x -> f x - | _ -> Unknown -end - -let sym_map f x = sym_bind x (fun x -> Absolute(f x)) - -let sym_map2 f x y = sym_bind x (fun x -> sym_map (f x) y) - -(* TODO add everywhere or handle differently *) -let simplify = function - | Offset (s, x) -> match toCharList s with - | #'.'::#'d'::#'e'::#'b'::#'u'::#'g'::_ -> Absolute x (* HACK should be lookup in context *) - | _ -> Offset (s, x) - end - | x -> x -end - -let sym_unwrap sym_val ctx = match simplify sym_val with - | Absolute x -> x - | Offset (s, x) -> Assert_extra.failwith ("sym_unwrap (Offset from " ^ s ^ ") in " ^ ctx) - | Unknown -> Assert_extra.failwith ("sym_unwrap Unknown in " ^ ctx) -end - -let pp_sym ppf = function -| Absolute x -> ppf x -| Offset (s, x) -> s ^ "+" ^ ppf x -| Unknown -> "Unknown" -end - -instance forall 'a. Show 'a => (Show (sym 'a)) - let show = pp_sym show -end +type sym_natural = natural +type sym_integer = integer -instance forall 'a. NumAdd 'a => (NumAdd (sym 'a)) - let (+) = sym_add -end - -instance forall 'a. MaybeMinus 'a, NumMinus 'a => (NumMinus (sym 'a)) - let (-) = sym_minus -end - -instance forall 'a. NumMult 'a => (NumMult (sym 'a)) - let ( * ) = sym_map2 ( * ) -end - -instance forall 'a. NumDivision 'a => (NumDivision (sym 'a)) - let (/) = sym_map2 (/) -end +let sym_unwrap sym_val ctx = sym_val -instance forall 'a. NumRemainder 'a => (NumRemainder (sym 'a)) - let (mod) = sym_map2 (mod) -end - -let sym_comp f a b = match (simplify a, simplify b) with - | (Absolute a, Absolute b) -> f a b - | (Offset (s, a), Offset(t, b)) -> if s = t then - f a b - else - Assert_extra.failwith ("offsets of different sections " ^ s ^ " and " ^ t) - | _ -> Assert_extra.failwith "sym_comp" (* TODO should probably figure out better errors*) -end - -instance forall 'a. Ord 'a => (Ord (sym 'a)) - let compare = sym_comp compare - let (<) = sym_comp (<) - let (<=) = sym_comp (<=) - let (>) = sym_comp (>) - let (>=) = sym_comp (>=) -end +let pp_sym ppf = ppf (* instance forall 'a. Ord 'a, Show 'a => (Ord (sym 'a)) let compare = (fun x -> fun y -> compare (sym_unwrap x ((show x) ^ "compare" ^ (show y))) (sym_unwrap y ((show x) ^ "compare" ^ (show y)))) @@ -287,77 +166,45 @@ end let (>=) = (fun x -> fun y -> (sym_unwrap x ((show x) ^ ">=" ^ (show y))) >= (sym_unwrap y ((show x) ^ ">=" ^ (show y)))) end *) +let sym_eq a b = a = b -class ( NumeralSym 'a ) - val fromNumeralSym : numeral -> sym 'a -end - -instance (NumeralSym integer) - let fromNumeralSym = fun x -> Absolute (fromNumeral x) -end - -instance (NumeralSym natural) - let fromNumeralSym = fun x -> Absolute (fromNumeral x) -end - -instance forall 'a. NumeralSym 'a => (Numeral (sym 'a)) - let fromNumeral = fromNumeralSym -end - -val sym_eq : forall 'a. Eq 'a => sym 'a -> sym 'a -> bool -let sym_eq a b = match (simplify a, simplify b) with -| (Absolute x, Absolute y) -> x = y -| (Offset (s,x), Offset (t, y)) -> s=t && x=y -| _ -> Assert_extra.failwith "sym_eq" -end - - -let rec sym_integer_of_symbolic_expression x = match x with - | Section s -> Offset (s, 0) - | Const x -> Absolute x +(* some arbitrary concrete section addresses *) +let rec sym_integer_of_symbolic_expression x : sym_integer = match x with + | Section ".data" -> 1000000 + | Section s -> 0 + | Const x -> x | BinOp (x, Add, y) -> (sym_integer_of_symbolic_expression x) + (sym_integer_of_symbolic_expression y) | BinOp (x, Sub, y) -> (sym_integer_of_symbolic_expression x) - (sym_integer_of_symbolic_expression y) | AssertRange (x, _, _) -> sym_integer_of_symbolic_expression x (*TODO*) | Mask (x, _, _) -> sym_integer_of_symbolic_expression x (*TODO*) end -let sym_natural_of_symbolic_expression x = - match sym_integer_of_symbolic_expression x with - | Offset (s, x) -> Offset (s, partialNaturalFromInteger x) - | Absolute x -> Absolute (partialNaturalFromInteger x) - | Unknown -> Unknown -end +let sym_natural_of_symbolic_expression x : sym_natural = partialNaturalFromInteger (sym_integer_of_symbolic_expression x) -let sym_natural_land = sym_map2 natural_land -let sym_natural_lxor = sym_map2 natural_lxor -let sym_natural_lor = sym_map2 natural_lor +let sym_natural_land = natural_land +let sym_natural_lxor = natural_lxor +let sym_natural_lor = natural_lor -let integerFromSymNatural = function - | Absolute x -> integerFromNatural x - | _ -> Assert_extra.failwith "integerFromSymNatural" -end +let integerFromSymNatural = integerFromNatural -let natFromSymNatural = function - | Absolute x -> natFromNatural x - | _ -> Assert_extra.failwith "integerFromSymNatural" -end +let natFromSymNatural = natFromNatural -let symNaturalFromNat x = Absolute (naturalFromNat x) +let symNaturalFromNat x = naturalFromNat x -let sym_natural_of_hex x = Absolute(natural_of_hex x) +let sym_natural_of_hex x = natural_of_hex x -let sym_natural_of_byte x = Absolute(natural_of_byte x) +let sym_natural_of_byte x = natural_of_byte x -let symNaturalPow x y = sym_map (fun x -> naturalPow x y) x +let symNaturalPow x y = naturalPow x y -let symNaturalFromInteger x = Absolute(naturalFromInteger x) +let symNaturalFromInteger x = naturalFromInteger x let index_sym_natural l n = index_natural l (sym_unwrap n "index_sym_natural") -let partialSymNaturalFromInteger i = Absolute (partialNaturalFromInteger i) +let partialSymNaturalFromInteger i = partialNaturalFromInteger i -let sym_natural_nat_shift_left x sh = sym_map (fun x -> natural_nat_shift_left x sh) x -let sym_natural_nat_shift_right x sh = sym_map (fun x -> natural_nat_shift_right x sh) x +let sym_natural_nat_shift_left x sh = natural_nat_shift_left x sh +let sym_natural_nat_shift_right x sh = natural_nat_shift_right x sh (* byte sequence *) @@ -1844,7 +1691,7 @@ let natural_of_bytes en bs = | Big -> natural_of_bytes_big 0 bs end -let sym_natural_of_bytes en bs = Absolute (natural_of_bytes en bs) +let sym_natural_of_bytes en bs = natural_of_bytes en bs (* TODO: generalise *) @@ -2126,7 +1973,7 @@ let pr_post_map p f = fun (pc: parse_context) -> pr_map f (p pc) val pr_with_pos : forall 'a. (parser 'a) -> (parser (sym_natural * 'a)) -let pr_with_pos p = fun pc -> pr_map (fun x -> (Absolute pc.pc_offset,x)) (p pc) +let pr_with_pos p = fun pc -> pr_map (fun x -> ( pc.pc_offset,x)) (p pc) val parse_pair : forall 'a 'b. (parser 'a) -> (parser 'b) -> (parser ('a * 'b)) @@ -2253,7 +2100,7 @@ let parse_string : parser (rel_byte_sequence) = match rbs_find_byte pc.pc_bytes bzero with | Nothing -> PR_fail "parse_string" pc | Just n -> - pr_bind (parse_n_bytes (Absolute n) pc) (fun res pc -> (*todo find byte should respect relocs*) + pr_bind (parse_n_bytes ( n) pc) (fun res pc -> (*todo find byte should respect relocs*) pr_bind (parse_byte pc) (fun _ pc -> pr_return res pc)) end @@ -2275,7 +2122,7 @@ let parse_uint8 : parser sym_natural= match rbs_read_char pc.pc_bytes with | Success (b, bytes) -> let v = natural_of_byte b in - PR_success (Absolute v) (<| pc_bytes = bytes; pc_offset = pc.pc_offset + 1 |>) + PR_success ( v) (<| pc_bytes = bytes; pc_offset = pc.pc_offset + 1 |>) | _ -> PR_fail "parse_uint32 not given enough bytes" pc end @@ -2295,7 +2142,7 @@ let parse_uint16 c : parser sym_natural= natural_of_byte b0 + 256*natural_of_byte b1 else natural_of_byte b1 + 256*natural_of_byte b0 in - PR_success (Absolute v) (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 2 |>) + PR_success ( v) (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 2 |>) | _ -> PR_fail "parse_uint32 not given enough bytes" pc end @@ -2309,7 +2156,7 @@ let parse_uint32 c : parser sym_natural= natural_of_byte b0 + 256*natural_of_byte b1 + 256*256*natural_of_byte b2 + 256*256*256*natural_of_byte b3 else natural_of_byte b3 + 256*natural_of_byte b2 + 256*256*natural_of_byte b1 + 256*256*256*natural_of_byte b0 in - PR_success (Absolute v) (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 4 |>) + PR_success ( v) (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 4 |>) | Success (ReadReloc r, bytes') -> if r.arel_target = Data32 then PR_success (sym_natural_of_symbolic_expression r.arel_value) (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 4 |>) @@ -2331,7 +2178,7 @@ let parse_uint64 c : parser sym_natural= natural_of_byte b7 + 256*natural_of_byte b6 + 256*256*natural_of_byte b5 + 256*256*256*natural_of_byte b4 + (256*256*256*256*(natural_of_byte b3 + 256*natural_of_byte b2 + 256*256*natural_of_byte b1 + 256*256*256*natural_of_byte b0)) in - PR_success (Absolute v) (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 8 |>) + PR_success ( v) (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 8 |>) | Success (ReadReloc r, bytes') -> if r.arel_target = Data64 then PR_success (sym_natural_of_symbolic_expression r.arel_value) (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 8 |>) @@ -2349,7 +2196,7 @@ let partialTwosComplementNaturalFromInteger (i:integer) (half: natural) (all:int else if i >= (0-integerFromNatural half) && i < 0 then partialNaturalFromInteger (all + i) else Assert_extra.failwith "partialTwosComplementNaturalFromInteger" -let partialTwosComplementSymNaturalFromInteger i half all = sym_map (fun x -> partialTwosComplementNaturalFromInteger i x all) half +let partialTwosComplementSymNaturalFromInteger i half all = partialTwosComplementNaturalFromInteger i half all let parse_sint8 : parser integer = pr_post_map (parse_uint8) (fun n -> integerFromTwosComplementNatural (sym_unwrap n "parse_sint8") 128 256) @@ -2382,7 +2229,7 @@ let rec parse_ULEB128' (acc: natural) (shift_factor: natural) : parser natural = let parse_ULEB128 : parser sym_natural = fun (pc:parse_context) -> - pr_map (fun x -> Absolute x) (parse_ULEB128' 0 1 pc) + pr_map (fun x -> x) (parse_ULEB128' 0 1 pc) let rec parse_SLEB128' (acc: natural) (shift_factor: natural) : parser (bool * natural * natural) = fun (pc:parse_context) -> @@ -3240,7 +3087,7 @@ let rec parse_die c str cuh find_abbreviation_declaration = (fun dies pc''' -> PR_success (Just ( let die = <| - die_offset = Absolute pc.pc_offset; + die_offset = pc.pc_offset; die_abbreviation_code = abbreviation_code; die_abbreviation_declaration = ad; die_attribute_values = avs; @@ -3307,7 +3154,7 @@ let _ = my_debug4 (pp_compilation_unit_header cuh) in let abbreviations_table = match parse_abbreviations_table c pc_abbrev with | PR_fail s pc_abbrev' -> Assert_extra.failwith ("parse_abbrevations_table fail: " ^ pp_parse_fail s pc_abbrev') - | PR_success at pc_abbrev' -> <| at_offset=Absolute pc_abbrev.pc_offset; at_table= at|> + | PR_success at pc_abbrev' -> <| at_offset= pc_abbrev.pc_offset; at_table= at|> end in let _ = my_debug4 (pp_abbreviations_table abbreviations_table) in @@ -3366,7 +3213,7 @@ let parse_type_unit c (debug_str_section_body: rel_byte_sequence) (debug_abbrev_ let abbreviations_table = match parse_abbreviations_table c pc_abbrev with | PR_fail s pc_abbrev' -> Assert_extra.failwith ("parse_abbrevations_table fail: " ^ pp_parse_fail s pc_abbrev') - | PR_success at pc_abbrev' -> <| at_offset=Absolute pc_abbrev.pc_offset; at_table= at|> + | PR_success at pc_abbrev' -> <| at_offset= pc_abbrev.pc_offset; at_table= at|> end in (* let _ = my_debug4 (pp_abbreviations_table abbreviations_table) in *) @@ -3481,7 +3328,7 @@ let parse_location_list c cuh : parser (maybe location_list) = else pr_post_map1 (parse_list (parse_location_list_item c cuh) pc) - (fun llis -> (Just (Absolute pc.pc_offset, llis))) + (fun llis -> (Just ( pc.pc_offset, llis))) let parse_location_list_list c cuh : parser location_list_list = parse_list (parse_location_list c cuh) @@ -3584,7 +3431,7 @@ let parse_range_list c cuh : parser (maybe (list range_list)) = else pr_post_map1 (parse_list (parse_range_list_item c cuh) pc) - (fun rlis -> (Just (expand_range_list_suffixes cuh (Absolute pc.pc_offset, rlis)))) + (fun rlis -> (Just (expand_range_list_suffixes cuh ( pc.pc_offset, rlis)))) let parse_range_list_list c cuh : parser range_list_list = pr_map2 List.concat (parse_list (parse_range_list c cuh)) @@ -3753,7 +3600,7 @@ let parse_call_frame_instruction c cuh : parser (maybe call_frame_instruction) = end else if high_bits = unsigned_char_of_natural 64 then - PR_success (Just (DW_CFA_advance_loc (Absolute low_bits))) pc' + PR_success (Just (DW_CFA_advance_loc ( low_bits))) pc' else if high_bits = unsigned_char_of_natural 192 then PR_success (Just (DW_CFA_restore low_bits)) pc' else @@ -3844,7 +3691,7 @@ let parse_initial_location c cuh mss mas' : parser ((maybe sym_natural) * sym_na let parse_call_frame_instruction_bytes offset' ul = fun (pc: parse_context) -> - parse_n_bytes (ul - (Absolute pc.pc_offset - offset')) pc + parse_n_bytes (ul - ( pc.pc_offset - offset')) pc let parse_frame_info_element c cuh (fi: list frame_info_element) : parser frame_info_element = parse_dependent @@ -4068,8 +3915,8 @@ let parse_line_number_header c (comp_dir:maybe string) : parser line_number_head (parse_triple (parse_uintDwarfN c df) (* header_length *) (parse_uint8) (* minimum_instruction_length *) - (if v pr_post_map (parse_triple - (pr_post_map (parse_n_bytes (ob-Absolute 1)) (fun bs -> List.map sym_natural_of_byte (byte_list_of_rel_byte_sequence bs))) (* standard_opcode_lengths *) + (pr_post_map (parse_n_bytes (ob- 1)) (fun bs -> List.map sym_natural_of_byte (byte_list_of_rel_byte_sequence bs))) (* standard_opcode_lengths *) ((*pr_return [[]]*) parse_list parse_non_empty_string) (* include_directories *) (parse_list parse_line_number_file_entry) (* file names *) ) @@ -4394,7 +4241,7 @@ let extract_section_body (f:elf_file) (ri:relocation_interpreter reloc_target_da ) f32.elf32_file_interpreted_sections in match sections with | [section] -> - let section_addr = Offset (section_name, 0) in + let section_addr = sym_natural_of_symbolic_expression (Section section_name) in let section_body = section.Elf_interpreted_section.elf32_section_body in (* let _ = my_debug4 (section_name ^ (": \n" ^ (Elf_interpreted_section.string_of_elf32_interpreted_section section ^ "\n" * ^ " body = " ^ ppbytes2 0 section_body ^ "\n"))) in *) @@ -4417,7 +4264,7 @@ let extract_section_body (f:elf_file) (ri:relocation_interpreter reloc_target_da ) f64.elf64_file_interpreted_sections in match sections with | [section] -> - let section_addr = Offset (section_name, 0) in + let section_addr = sym_natural_of_symbolic_expression (Section section_name) in let section_body = section.Elf_interpreted_section.elf64_section_body in let _ = my_debug "extracted section body" in match extract_elf64_relocations_for_section f64 ri section_name with @@ -4678,13 +4525,13 @@ let rec evaluate_operation_list (c:p_context) (dloc: location_list_list) (evalua end | (OpSem_opcode_lit base, []) -> if op.op_code >= base && op.op_code < base + 32 then - push_memory_address (Absolute (op.op_code - base)) s.s_stack + push_memory_address ( (op.op_code - base)) s.s_stack else Fail "OpSem_opcode_lit opcode not within [base,base+32)" | (OpSem_reg, []) -> (* TODO: unclear whether this should push the register id or not *) let r = op.op_code - vDW_OP_reg0 in - Success <| s with s_stack = (Absolute r) :: s.s_stack; s_value = SL_register r |> + Success <| s with s_stack = ( r) :: s.s_stack; s_value = SL_register r |> | (OpSem_breg, [OAV_integer i]) -> let r = op.op_code - vDW_OP_breg0 in bregxi r i @@ -5521,7 +5368,7 @@ if there's a DW_AT_location that's a location list (DW_FORM_sec_offset/AV_sec_of if there's a DW_AT_location that's a location expression (DW_FORM_exprloc/AV_exprloc or DW_block/AV_block), look for the closest enclosing range: - DW_AT_low_pc (AV_addr) and no DW_AT_high_pc or DW_AT_ranges: just the singleton address - - DW_AT_low_pc (AV_addr) and DW_AT_high_pc (either an absolute AV_addr or an offset AV_constantN/AV_constant_SLEB128/AV_constantULEB128) : that range + - DW_AT_low_pc (AV_addr) and DW_AT_high_pc (either an AV_addr or an offset AV_constantN/AV_constant_SLEB128/AV_constantULEB128) : that range - DW_AT_ranges (DW_FORM_sec_offset/AV_sec_offset) : get a range list from .debug_ranges; interpret wrt the applicable base address of the compilation unit - for compilation units: a DW_AT_ranges together with a DW_AT_low_pc to specify the default base address to use in interpeting location and range lists @@ -6054,7 +5901,7 @@ let evaluate_line_number_operation match lno with | DW_LN_special adjusted_opcode -> - let adjusted_opcode = Absolute adjusted_opcode in (* TODO probably doesn't have to be symbolic *) + let adjusted_opcode = adjusted_opcode in (* TODO probably doesn't have to be symbolic *) let operation_advance = adjusted_opcode / lnh.lnh_line_range in let line_increment = lnh.lnh_line_base + integerFromSymNatural (adjusted_opcode mod lnh.lnh_line_range) in let s' = @@ -6101,7 +5948,7 @@ let evaluate_line_number_operation let s' = <| s with lnr_basic_block = true |> in (s', lnrs) | DW_LNS_const_add_pc -> let opcode = 255 in - let adjusted_opcode = Absolute (opcode - lnh.lnh_opcode_base) in + let adjusted_opcode = (opcode - lnh.lnh_opcode_base) in let operation_advance = adjusted_opcode / lnh.lnh_line_range in let s' = <| s with @@ -6813,7 +6660,7 @@ let pp_inlined_subroutines ds iss = let pp_inlined_subroutine_by_range ds ((n1,n2),((m:sym_natural),(n:sym_natural)),is) = pphex_sym n1 ^ " " ^ pphex_sym n2 ^ " " - ^ (if n<>(Absolute 1) then "("^show m^" of "^show n^") " else "") + ^ (if n<>( 1) then "("^show m^" of "^show n^") " else "") ^ pp_inlined_subroutine_header ds is ^"\n" ^ (if m=0 then pp_inlined_subroutine_const_params ds.ds_dwarf is else "") @@ -6831,7 +6678,7 @@ let pp_inlined_subroutines_by_range ds iss = let rec words_of_rel_byte_sequence (addr:sym_natural) (bs:rel_byte_sequence) (acc:list (sym_natural * sym_natural)) : list (sym_natural * sym_natural) = match rbs_read_4_bytes_be bs with | Success (ReadValue (b0,b1,b2,b3), bs') -> (*TODO*) - let i : sym_natural = Absolute (natural_of_byte b0 + 256*natural_of_byte b1 + 65536*natural_of_byte b2 + 65536*256*natural_of_byte b3) in + let i : sym_natural = (natural_of_byte b0 + 256*natural_of_byte b1 + 65536*natural_of_byte b2 + 65536*256*natural_of_byte b3) in words_of_rel_byte_sequence (addr+4) bs' ((addr,i)::acc) | Fail _ -> List.reverse acc end From b20a60ca972d0a35bd650dfdcc921117dba9d7a2 Mon Sep 17 00:00:00 2001 From: Matej Urban Date: Thu, 2 Jan 2025 19:33:30 +0100 Subject: [PATCH 14/44] move relocation interpreter to aarch64 --- src/abis/aarch64/abi_aarch64_symbolic_relocation.lem | 11 ++++++++++- src/main_elf.lem | 8 +------- 2 files changed, 11 insertions(+), 8 deletions(-) diff --git a/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem b/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem index 5980ad9..a6dafaa 100644 --- a/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem +++ b/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem @@ -142,4 +142,13 @@ let aarch64_relocation_target_to_data_target = function | Data32 -> return Elf_symbolic.Data32 | Data64 -> return Elf_symbolic.Data64 | _ -> fail "Not a data relocation" -end \ No newline at end of file +end + +let aarch64_data_relocation_interpreter ef symtab_map sidx rel = + abi_aarch64_relocation_to_abstract ef symtab_map sidx rel >>= fun arels -> + map_mapM (fun arel -> + aarch64_relocation_target_to_data_target arel.arel_target >>= fun target -> + return <| arel_value = arel.arel_value + ; arel_target = target + |> + ) arels \ No newline at end of file diff --git a/src/main_elf.lem b/src/main_elf.lem index 58f389e..bbcbb35 100644 --- a/src/main_elf.lem +++ b/src/main_elf.lem @@ -192,13 +192,7 @@ let obtain_abi_specific_string_of_reloc_type mach = val interpret_data_relocation : natural -> relocation_interpreter reloc_target_data let interpret_data_relocation mach ef symtab_map sidx rel = if mach = elf_ma_aarch64 then - abi_aarch64_relocation_to_abstract ef symtab_map sidx rel >>= fun arels -> - map_mapM (fun arel -> - aarch64_relocation_target_to_data_target arel.arel_target >>= fun target -> - return <| arel_value = arel.arel_value - ; arel_target = target - |> - ) arels + aarch64_data_relocation_interpreter ef symtab_map sidx rel else Error.fail "Unsupported machine" From f6806912026b8e2774b486947321d1aaa12084a0 Mon Sep 17 00:00:00 2001 From: Matej Urban Date: Wed, 8 Jan 2025 14:16:07 +0100 Subject: [PATCH 15/44] Support page reolcations --- src/abis/abi_symbolic_relocation.lem | 3 +++ src/elf_symbolic.lem | 7 +++++++ 2 files changed, 10 insertions(+) diff --git a/src/abis/abi_symbolic_relocation.lem b/src/abis/abi_symbolic_relocation.lem index cc11c47..128c5b4 100644 --- a/src/abis/abi_symbolic_relocation.lem +++ b/src/abis/abi_symbolic_relocation.lem @@ -28,6 +28,9 @@ let rec eval_op_exp op: error symbolic_expression = eval_op_exp x >>= fun a -> eval_op_exp y >>= fun b -> return (BinOp (a, Sub, b)) + | Apply(Page, x) -> + eval_op_exp x >>= fun a -> + return (BinOp (a, And, UnOp (Not, Const 4095 (*0xFFF*)))) | _ -> fail "Not supported" end diff --git a/src/elf_symbolic.lem b/src/elf_symbolic.lem index 013f7e8..a3829a5 100644 --- a/src/elf_symbolic.lem +++ b/src/elf_symbolic.lem @@ -24,12 +24,16 @@ open import Elf_interpreted_section type binary_operation = Add | Sub + | And + +type unary_operation = | Not (* TODO *) type symbolic_expression = Section of string | Const of integer | BinOp of (symbolic_expression * binary_operation * symbolic_expression) + | UnOp of (unary_operation * symbolic_expression) | AssertRange of (symbolic_expression * integer * integer) | Mask of (symbolic_expression * natural * natural) @@ -37,6 +41,9 @@ let rec pp_sym_expr sx = match sx with | Section s -> s | Const x -> show x | BinOp (a, Add, b) -> "(" ^ (pp_sym_expr a) ^ "+" ^ (pp_sym_expr b) ^ ")" + | BinOp (a, Sub, b) -> "(" ^ (pp_sym_expr a) ^ "-" ^ (pp_sym_expr b) ^ ")" + | BinOp (a, Sub, b) -> "(" ^ (pp_sym_expr a) ^ "&" ^ (pp_sym_expr b) ^ ")" + | UnOp (Not, b) -> "(" ^ "~" ^ (pp_sym_expr b) ^ ")" | AssertRange (x, a, b) -> pp_sym_expr x ^ "!" (*TODO*) | Mask (x, a, b) -> pp_sym_expr x ^ "[" ^ (show a) ^ ":" ^ (show b) ^ "]" end From 1097f90d5caa0b9c88400f4664a29b61d8002e1f Mon Sep 17 00:00:00 2001 From: Matej Urban Date: Thu, 9 Jan 2025 18:15:01 +0100 Subject: [PATCH 16/44] fix --- src/elf_symbolic.lem | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/elf_symbolic.lem b/src/elf_symbolic.lem index a3829a5..1819e40 100644 --- a/src/elf_symbolic.lem +++ b/src/elf_symbolic.lem @@ -42,7 +42,7 @@ let rec pp_sym_expr sx = match sx with | Const x -> show x | BinOp (a, Add, b) -> "(" ^ (pp_sym_expr a) ^ "+" ^ (pp_sym_expr b) ^ ")" | BinOp (a, Sub, b) -> "(" ^ (pp_sym_expr a) ^ "-" ^ (pp_sym_expr b) ^ ")" - | BinOp (a, Sub, b) -> "(" ^ (pp_sym_expr a) ^ "&" ^ (pp_sym_expr b) ^ ")" + | BinOp (a, And, b) -> "(" ^ (pp_sym_expr a) ^ "&" ^ (pp_sym_expr b) ^ ")" | UnOp (Not, b) -> "(" ^ "~" ^ (pp_sym_expr b) ^ ")" | AssertRange (x, a, b) -> pp_sym_expr x ^ "!" (*TODO*) | Mask (x, a, b) -> pp_sym_expr x ^ "[" ^ (show a) ^ ":" ^ (show b) ^ "]" From 8da23eca43d7dc60dfd0903df08f1e9a2df2532b Mon Sep 17 00:00:00 2001 From: Matej Urban Date: Wed, 15 Jan 2025 17:20:02 +0100 Subject: [PATCH 17/44] Check range in relocations --- .../abi_aarch64_symbolic_relocation.lem | 27 ++++++++++++------- src/abis/abi_symbolic_relocation.lem | 18 ++++++------- 2 files changed, 27 insertions(+), 18 deletions(-) diff --git a/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem b/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem index a6dafaa..955ed10 100644 --- a/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem +++ b/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem @@ -42,7 +42,8 @@ let abi_aarch64_apply_relocation_symbolic rel s_val p_val ef = let result = Plus(Lift s_val, Lift a_val) in let addr = rel.elf64_ra_offset in return (Map.singleton addr - <| rel_desc_operation = (result, I64, CannotFail) + <| rel_desc_operation = result + ; rel_desc_range = Nothing ; rel_desc_mask = (63, 0) ; rel_desc_target = Data64 |> @@ -52,7 +53,8 @@ let abi_aarch64_apply_relocation_symbolic rel s_val p_val ef = let result = Plus(Lift s_val, Lift a_val) in let addr = rel.elf64_ra_offset in return (Map.singleton addr - <| rel_desc_operation = (result, I32, CanFail) + <| rel_desc_operation = result + ; rel_desc_range = Just (~2**31, 2**32) ; rel_desc_mask = (31, 0) ; rel_desc_target = Data32 |> @@ -62,7 +64,8 @@ let abi_aarch64_apply_relocation_symbolic rel s_val p_val ef = let result = Minus(Plus(Lift s_val, Lift a_val), Lift p_val) in let addr = rel.elf64_ra_offset in return (Map.singleton addr - <| rel_desc_operation = (result, I64, CannotFail) + <| rel_desc_operation = result + ; rel_desc_range = Nothing ; rel_desc_mask = (63, 0) ; rel_desc_target = Data64 |> @@ -72,7 +75,8 @@ let abi_aarch64_apply_relocation_symbolic rel s_val p_val ef = let result = Minus(Plus(Lift s_val, Lift a_val), Lift p_val) in let addr = rel.elf64_ra_offset in return (Map.singleton addr - <| rel_desc_operation = (result, I32, CanFail) + <| rel_desc_operation = result + ; rel_desc_range = Just (~2**31, 2**32) ; rel_desc_mask = (31, 0) ; rel_desc_target = Data32 |> @@ -81,7 +85,8 @@ let abi_aarch64_apply_relocation_symbolic rel s_val p_val ef = let result = Minus(Apply(Page, Plus(Lift s_val, Lift a_val)), Apply(Page, Lift p_val)) in let addr = rel.elf64_ra_offset in return (Map.singleton addr - <| rel_desc_operation = (result, I32, CanFail) + <| rel_desc_operation = result + ; rel_desc_range = Just (~2**32, 2**32) ; rel_desc_mask = (32, 12) ; rel_desc_target = ADRP |> @@ -90,7 +95,8 @@ let abi_aarch64_apply_relocation_symbolic rel s_val p_val ef = let result = Plus(Lift s_val, Lift a_val) in let addr = rel.elf64_ra_offset in return (Map.singleton addr - <| rel_desc_operation = (result, I32, CannotFail) + <| rel_desc_operation = result + ; rel_desc_range = Nothing ; rel_desc_mask = (11, 0) ; rel_desc_target = ADD |> @@ -99,7 +105,8 @@ let abi_aarch64_apply_relocation_symbolic rel s_val p_val ef = let result = Plus(Lift s_val, Lift a_val) in let addr = rel.elf64_ra_offset in return (Map.singleton addr - <| rel_desc_operation = (result, I32, CannotFail) + <| rel_desc_operation = result + ; rel_desc_range = Nothing ; rel_desc_mask = (11, 2) ; rel_desc_target = LDST |> @@ -108,7 +115,8 @@ let abi_aarch64_apply_relocation_symbolic rel s_val p_val ef = let result = Plus(Lift s_val, Lift a_val) in let addr = rel.elf64_ra_offset in return (Map.singleton addr - <| rel_desc_operation = (result, I32, CannotFail) + <| rel_desc_operation = result + ; rel_desc_range = Nothing ; rel_desc_mask = (11, 3) ; rel_desc_target = LDST |> @@ -117,7 +125,8 @@ let abi_aarch64_apply_relocation_symbolic rel s_val p_val ef = let result = Minus(Plus(Lift s_val, Lift a_val), Lift p_val) in let addr = rel.elf64_ra_offset in return (Map.singleton addr - <| rel_desc_operation = (result, I27, CanFail) + <| rel_desc_operation = result + ; rel_desc_range = Just (~2**27, 2**27) ; rel_desc_mask = (27, 2) ; rel_desc_target = CALL |> diff --git a/src/abis/abi_symbolic_relocation.lem b/src/abis/abi_symbolic_relocation.lem index 128c5b4..c8a2ad4 100644 --- a/src/abis/abi_symbolic_relocation.lem +++ b/src/abis/abi_symbolic_relocation.lem @@ -1,4 +1,5 @@ open import Num +open import Maybe open import Error @@ -10,7 +11,8 @@ open import Elf_symbolic type relocation_description 'res 'tar = - <| rel_desc_operation : (relocation_operator_expression 'res * integer_bit_width * can_fail 'res) + <| rel_desc_operation : (relocation_operator_expression 'res) + ; rel_desc_range : maybe (integer * integer) ; rel_desc_mask : (natural * natural) ; rel_desc_target : 'tar |> @@ -36,15 +38,13 @@ let rec eval_op_exp op: error symbolic_expression = let eval_relocation desc = - let (exp, bit_width, can_fail) = desc.rel_desc_operation in - let (lo, hi) = desc.rel_desc_mask in + let (hi, lo) = desc.rel_desc_mask in - eval_op_exp exp >>= fun value -> - match can_fail with - | CanFail -> return (AssertRange(value, 0, 0)) (*todo*) - | CannotFail -> return value - | CanFailOnTest -> fail "Not supported" + eval_op_exp desc.rel_desc_operation >>= fun value -> + match desc.rel_desc_range with + | Just (min, max) -> return (AssertRange(value, min, max)) + | Nothing -> return value end >>= fun value -> - return <| arel_value = Mask(value, lo, hi) ; arel_target = desc.rel_desc_target |> + return <| arel_value = Mask(value, hi, lo) ; arel_target = desc.rel_desc_target |> From 54765938870173e0dc0448780f3e0c0bed134455 Mon Sep 17 00:00:00 2001 From: Matej Urban Date: Wed, 15 Jan 2025 20:35:59 +0100 Subject: [PATCH 18/44] FIx (operator precence) --- src/abis/aarch64/abi_aarch64_symbolic_relocation.lem | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem b/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem index 955ed10..a56f463 100644 --- a/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem +++ b/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem @@ -54,7 +54,7 @@ let abi_aarch64_apply_relocation_symbolic rel s_val p_val ef = let addr = rel.elf64_ra_offset in return (Map.singleton addr <| rel_desc_operation = result - ; rel_desc_range = Just (~2**31, 2**32) + ; rel_desc_range = Just (~(2**31), 2**32) ; rel_desc_mask = (31, 0) ; rel_desc_target = Data32 |> @@ -76,7 +76,7 @@ let abi_aarch64_apply_relocation_symbolic rel s_val p_val ef = let addr = rel.elf64_ra_offset in return (Map.singleton addr <| rel_desc_operation = result - ; rel_desc_range = Just (~2**31, 2**32) + ; rel_desc_range = Just (~(2**31), 2**32) ; rel_desc_mask = (31, 0) ; rel_desc_target = Data32 |> @@ -86,7 +86,7 @@ let abi_aarch64_apply_relocation_symbolic rel s_val p_val ef = let addr = rel.elf64_ra_offset in return (Map.singleton addr <| rel_desc_operation = result - ; rel_desc_range = Just (~2**32, 2**32) + ; rel_desc_range = Just (~(2**32), 2**32) ; rel_desc_mask = (32, 12) ; rel_desc_target = ADRP |> @@ -126,7 +126,7 @@ let abi_aarch64_apply_relocation_symbolic rel s_val p_val ef = let addr = rel.elf64_ra_offset in return (Map.singleton addr <| rel_desc_operation = result - ; rel_desc_range = Just (~2**27, 2**27) + ; rel_desc_range = Just (~(2**27), 2**27) ; rel_desc_mask = (27, 2) ; rel_desc_target = CALL |> From 5a408544dfa98aa37bba65c540aa8e8237d7f63f Mon Sep 17 00:00:00 2001 From: Matej Urban Date: Thu, 16 Jan 2025 17:44:19 +0100 Subject: [PATCH 19/44] Ensure relocation alignment --- src/abis/aarch64/abi_aarch64_symbolic_relocation.lem | 9 +++++++++ src/abis/abi_symbolic_relocation.lem | 6 ++++++ src/dwarf.lem | 1 + src/elf_symbolic.lem | 2 ++ 4 files changed, 18 insertions(+) diff --git a/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem b/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem index a56f463..c01ef41 100644 --- a/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem +++ b/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem @@ -44,6 +44,7 @@ let abi_aarch64_apply_relocation_symbolic rel s_val p_val ef = return (Map.singleton addr <| rel_desc_operation = result ; rel_desc_range = Nothing + ; rel_desc_alignment_bits = 0 ; rel_desc_mask = (63, 0) ; rel_desc_target = Data64 |> @@ -55,6 +56,7 @@ let abi_aarch64_apply_relocation_symbolic rel s_val p_val ef = return (Map.singleton addr <| rel_desc_operation = result ; rel_desc_range = Just (~(2**31), 2**32) + ; rel_desc_alignment_bits = 0 ; rel_desc_mask = (31, 0) ; rel_desc_target = Data32 |> @@ -66,6 +68,7 @@ let abi_aarch64_apply_relocation_symbolic rel s_val p_val ef = return (Map.singleton addr <| rel_desc_operation = result ; rel_desc_range = Nothing + ; rel_desc_alignment_bits = 0 ; rel_desc_mask = (63, 0) ; rel_desc_target = Data64 |> @@ -77,6 +80,7 @@ let abi_aarch64_apply_relocation_symbolic rel s_val p_val ef = return (Map.singleton addr <| rel_desc_operation = result ; rel_desc_range = Just (~(2**31), 2**32) + ; rel_desc_alignment_bits = 0 ; rel_desc_mask = (31, 0) ; rel_desc_target = Data32 |> @@ -87,6 +91,7 @@ let abi_aarch64_apply_relocation_symbolic rel s_val p_val ef = return (Map.singleton addr <| rel_desc_operation = result ; rel_desc_range = Just (~(2**32), 2**32) + ; rel_desc_alignment_bits = 0 ; rel_desc_mask = (32, 12) ; rel_desc_target = ADRP |> @@ -97,6 +102,7 @@ let abi_aarch64_apply_relocation_symbolic rel s_val p_val ef = return (Map.singleton addr <| rel_desc_operation = result ; rel_desc_range = Nothing + ; rel_desc_alignment_bits = 0 ; rel_desc_mask = (11, 0) ; rel_desc_target = ADD |> @@ -107,6 +113,7 @@ let abi_aarch64_apply_relocation_symbolic rel s_val p_val ef = return (Map.singleton addr <| rel_desc_operation = result ; rel_desc_range = Nothing + ; rel_desc_alignment_bits = 2 ; rel_desc_mask = (11, 2) ; rel_desc_target = LDST |> @@ -117,6 +124,7 @@ let abi_aarch64_apply_relocation_symbolic rel s_val p_val ef = return (Map.singleton addr <| rel_desc_operation = result ; rel_desc_range = Nothing + ; rel_desc_alignment_bits = 3 ; rel_desc_mask = (11, 3) ; rel_desc_target = LDST |> @@ -127,6 +135,7 @@ let abi_aarch64_apply_relocation_symbolic rel s_val p_val ef = return (Map.singleton addr <| rel_desc_operation = result ; rel_desc_range = Just (~(2**27), 2**27) + ; rel_desc_alignment_bits = 2 ; rel_desc_mask = (27, 2) ; rel_desc_target = CALL |> diff --git a/src/abis/abi_symbolic_relocation.lem b/src/abis/abi_symbolic_relocation.lem index c8a2ad4..d11e712 100644 --- a/src/abis/abi_symbolic_relocation.lem +++ b/src/abis/abi_symbolic_relocation.lem @@ -13,6 +13,7 @@ open import Elf_symbolic type relocation_description 'res 'tar = <| rel_desc_operation : (relocation_operator_expression 'res) ; rel_desc_range : maybe (integer * integer) + ; rel_desc_alignment_bits : natural ; rel_desc_mask : (natural * natural) ; rel_desc_target : 'tar |> @@ -45,6 +46,11 @@ let eval_relocation desc = | Just (min, max) -> return (AssertRange(value, min, max)) | Nothing -> return value end + >>= fun value -> + match desc.rel_desc_alignment_bits with + | 0 -> return value + | x -> return (AssertAlignment(value, x)) + end >>= fun value -> return <| arel_value = Mask(value, hi, lo) ; arel_target = desc.rel_desc_target |> diff --git a/src/dwarf.lem b/src/dwarf.lem index c5ab038..710bc70 100644 --- a/src/dwarf.lem +++ b/src/dwarf.lem @@ -176,6 +176,7 @@ let rec sym_integer_of_symbolic_expression x : sym_integer = match x with | BinOp (x, Add, y) -> (sym_integer_of_symbolic_expression x) + (sym_integer_of_symbolic_expression y) | BinOp (x, Sub, y) -> (sym_integer_of_symbolic_expression x) - (sym_integer_of_symbolic_expression y) | AssertRange (x, _, _) -> sym_integer_of_symbolic_expression x (*TODO*) + | AssertAlignment (x, _) -> sym_integer_of_symbolic_expression x (*TODO*) | Mask (x, _, _) -> sym_integer_of_symbolic_expression x (*TODO*) end diff --git a/src/elf_symbolic.lem b/src/elf_symbolic.lem index 1819e40..1966c8f 100644 --- a/src/elf_symbolic.lem +++ b/src/elf_symbolic.lem @@ -35,6 +35,7 @@ type symbolic_expression | BinOp of (symbolic_expression * binary_operation * symbolic_expression) | UnOp of (unary_operation * symbolic_expression) | AssertRange of (symbolic_expression * integer * integer) + | AssertAlignment of (symbolic_expression * natural) | Mask of (symbolic_expression * natural * natural) let rec pp_sym_expr sx = match sx with @@ -45,6 +46,7 @@ let rec pp_sym_expr sx = match sx with | BinOp (a, And, b) -> "(" ^ (pp_sym_expr a) ^ "&" ^ (pp_sym_expr b) ^ ")" | UnOp (Not, b) -> "(" ^ "~" ^ (pp_sym_expr b) ^ ")" | AssertRange (x, a, b) -> pp_sym_expr x ^ "!" (*TODO*) + | AssertAlignment (x, a) -> pp_sym_expr x ^ "!" (*TODO*) | Mask (x, a, b) -> pp_sym_expr x ^ "[" ^ (show a) ^ ":" ^ (show b) ^ "]" end From 63124a52f904fbbb1109b21d2bffab99bcfe16dc Mon Sep 17 00:00:00 2001 From: Matej Urban Date: Tue, 21 Jan 2025 13:07:27 +0000 Subject: [PATCH 20/44] Revert to symbolic dwarf --- src/dwarf.lem | 257 ++++++++++++++++++++++++++++++++++++++++---------- 1 file changed, 205 insertions(+), 52 deletions(-) diff --git a/src/dwarf.lem b/src/dwarf.lem index 710bc70..34737a1 100644 --- a/src/dwarf.lem +++ b/src/dwarf.lem @@ -151,12 +151,133 @@ declare ocaml target_rep function natural_nat_shift_left = `Nat_big_num.shift val natural_nat_shift_right : natural -> nat -> natural declare ocaml target_rep function natural_nat_shift_right = `Nat_big_num.shift_right` -type sym_natural = natural -type sym_integer = integer +(* Symbolic types *) +type sym 'a = + | Offset of (string * 'a) + | Absolute of 'a + | Unknown + +type sym_natural = sym natural +type sym_integer = sym integer + +val sym_add : forall 'a. NumAdd 'a => (sym 'a -> sym 'a -> sym 'a) +let sym_add x y= + match (x, y) with + | (Absolute x, Absolute y) -> Absolute (x + y) + | (Offset (s, x), Absolute y) -> Offset (s, x + y) + | (Absolute x, Offset (s, y)) -> Offset (s, x + y) + | _ -> Unknown + end + +class ( MaybeMinus 'a ) + val mminus : 'a -> 'a -> maybe 'a +end + +instance (MaybeMinus natural) + let mminus = fun x y -> if x >= y then Just (x - y) else Nothing +end + +instance (MaybeMinus integer) + let mminus = fun x y -> Just (x-y) +end + +val sym_minus : forall 'a. MaybeMinus 'a, NumMinus 'a => (sym 'a -> sym 'a -> sym 'a) +let sym_minus x y= + match (x, y) with + | (Absolute x, Absolute y) -> Absolute (x - y) + | (Offset (s, x), Absolute y) -> + match mminus x y with + | Just v -> Offset (s, v) + | Nothing -> Unknown + end + | (Offset (s, x), Offset (t, y)) -> + if s = t then + match mminus x y with + | Just v -> Absolute v + | Nothing -> Unknown + end + else + Unknown + | _ -> Unknown + end + +val sym_natural_minus : sym_natural -> sym_natural -> sym_natural +let sym_natural_minus = sym_minus + +val sym_integer_minus : sym_integer -> sym_integer -> sym_integer +let sym_integer_minus = sym_minus + +val sym_bind : forall 'a. sym 'a -> ('a -> sym 'a) -> sym 'a +let sym_bind x f = match x with + | Absolute x -> f x + | _ -> Unknown +end + +let sym_map f x = sym_bind x (fun x -> Absolute(f x)) + +let sym_map2 f x y = sym_bind x (fun x -> sym_map (f x) y) + +(* TODO add everywhere or handle differently *) +let simplify = function + | Offset (s, x) -> match toCharList s with + | #'.'::#'d'::#'e'::#'b'::#'u'::#'g'::_ -> Absolute x (* HACK should be lookup in context *) + | _ -> Offset (s, x) + end + | x -> x +end + +let sym_unwrap sym_val ctx = match simplify sym_val with + | Absolute x -> x + | Offset (s, x) -> Assert_extra.failwith ("sym_unwrap (Offset from " ^ s ^ ") in " ^ ctx) + | Unknown -> Assert_extra.failwith ("sym_unwrap Unknown in " ^ ctx) +end + +let pp_sym ppf = function +| Absolute x -> ppf x +| Offset (s, x) -> s ^ "+" ^ ppf x +| Unknown -> "Unknown" +end + +instance forall 'a. Show 'a => (Show (sym 'a)) + let show = pp_sym show +end -let sym_unwrap sym_val ctx = sym_val +instance forall 'a. NumAdd 'a => (NumAdd (sym 'a)) + let (+) = sym_add +end + +instance forall 'a. MaybeMinus 'a, NumMinus 'a => (NumMinus (sym 'a)) + let (-) = sym_minus +end + +instance forall 'a. NumMult 'a => (NumMult (sym 'a)) + let ( * ) = sym_map2 ( * ) +end + +instance forall 'a. NumDivision 'a => (NumDivision (sym 'a)) + let (/) = sym_map2 (/) +end -let pp_sym ppf = ppf +instance forall 'a. NumRemainder 'a => (NumRemainder (sym 'a)) + let (mod) = sym_map2 (mod) +end + +let sym_comp f a b = match (simplify a, simplify b) with + | (Absolute a, Absolute b) -> f a b + | (Offset (s, a), Offset(t, b)) -> if s = t then + f a b + else + Assert_extra.failwith ("offsets of different sections " ^ s ^ " and " ^ t) + | _ -> Assert_extra.failwith "sym_comp" (* TODO should probably figure out better errors*) +end + +instance forall 'a. Ord 'a => (Ord (sym 'a)) + let compare = sym_comp compare + let (<) = sym_comp (<) + let (<=) = sym_comp (<=) + let (>) = sym_comp (>) + let (>=) = sym_comp (>=) +end (* instance forall 'a. Ord 'a, Show 'a => (Ord (sym 'a)) let compare = (fun x -> fun y -> compare (sym_unwrap x ((show x) ^ "compare" ^ (show y))) (sym_unwrap y ((show x) ^ "compare" ^ (show y)))) @@ -166,13 +287,34 @@ let pp_sym ppf = ppf let (>=) = (fun x -> fun y -> (sym_unwrap x ((show x) ^ ">=" ^ (show y))) >= (sym_unwrap y ((show x) ^ ">=" ^ (show y)))) end *) -let sym_eq a b = a = b -(* some arbitrary concrete section addresses *) -let rec sym_integer_of_symbolic_expression x : sym_integer = match x with - | Section ".data" -> 1000000 - | Section s -> 0 - | Const x -> x +class ( NumeralSym 'a ) + val fromNumeralSym : numeral -> sym 'a +end + +instance (NumeralSym integer) + let fromNumeralSym = fun x -> Absolute (fromNumeral x) +end + +instance (NumeralSym natural) + let fromNumeralSym = fun x -> Absolute (fromNumeral x) +end + +instance forall 'a. NumeralSym 'a => (Numeral (sym 'a)) + let fromNumeral = fromNumeralSym +end + +val sym_eq : forall 'a. Eq 'a => sym 'a -> sym 'a -> bool +let sym_eq a b = match (simplify a, simplify b) with +| (Absolute x, Absolute y) -> x = y +| (Offset (s,x), Offset (t, y)) -> s=t && x=y +| _ -> Assert_extra.failwith "sym_eq" +end + + +let rec sym_integer_of_symbolic_expression x = match x with + | Section s -> Offset (s, 0) + | Const x -> Absolute x | BinOp (x, Add, y) -> (sym_integer_of_symbolic_expression x) + (sym_integer_of_symbolic_expression y) | BinOp (x, Sub, y) -> (sym_integer_of_symbolic_expression x) - (sym_integer_of_symbolic_expression y) | AssertRange (x, _, _) -> sym_integer_of_symbolic_expression x (*TODO*) @@ -180,32 +322,43 @@ let rec sym_integer_of_symbolic_expression x : sym_integer = match x with | Mask (x, _, _) -> sym_integer_of_symbolic_expression x (*TODO*) end -let sym_natural_of_symbolic_expression x : sym_natural = partialNaturalFromInteger (sym_integer_of_symbolic_expression x) +let sym_natural_of_symbolic_expression x = + match sym_integer_of_symbolic_expression x with + | Offset (s, x) -> Offset (s, partialNaturalFromInteger x) + | Absolute x -> Absolute (partialNaturalFromInteger x) + | Unknown -> Unknown +end -let sym_natural_land = natural_land -let sym_natural_lxor = natural_lxor -let sym_natural_lor = natural_lor +let sym_natural_land = sym_map2 natural_land +let sym_natural_lxor = sym_map2 natural_lxor +let sym_natural_lor = sym_map2 natural_lor -let integerFromSymNatural = integerFromNatural +let integerFromSymNatural = function + | Absolute x -> integerFromNatural x + | _ -> Assert_extra.failwith "integerFromSymNatural" +end -let natFromSymNatural = natFromNatural +let natFromSymNatural = function + | Absolute x -> natFromNatural x + | _ -> Assert_extra.failwith "integerFromSymNatural" +end -let symNaturalFromNat x = naturalFromNat x +let symNaturalFromNat x = Absolute (naturalFromNat x) -let sym_natural_of_hex x = natural_of_hex x +let sym_natural_of_hex x = Absolute(natural_of_hex x) -let sym_natural_of_byte x = natural_of_byte x +let sym_natural_of_byte x = Absolute(natural_of_byte x) -let symNaturalPow x y = naturalPow x y +let symNaturalPow x y = sym_map (fun x -> naturalPow x y) x -let symNaturalFromInteger x = naturalFromInteger x +let symNaturalFromInteger x = Absolute(naturalFromInteger x) let index_sym_natural l n = index_natural l (sym_unwrap n "index_sym_natural") -let partialSymNaturalFromInteger i = partialNaturalFromInteger i +let partialSymNaturalFromInteger i = Absolute (partialNaturalFromInteger i) -let sym_natural_nat_shift_left x sh = natural_nat_shift_left x sh -let sym_natural_nat_shift_right x sh = natural_nat_shift_right x sh +let sym_natural_nat_shift_left x sh = sym_map (fun x -> natural_nat_shift_left x sh) x +let sym_natural_nat_shift_right x sh = sym_map (fun x -> natural_nat_shift_right x sh) x (* byte sequence *) @@ -1692,7 +1845,7 @@ let natural_of_bytes en bs = | Big -> natural_of_bytes_big 0 bs end -let sym_natural_of_bytes en bs = natural_of_bytes en bs +let sym_natural_of_bytes en bs = Absolute (natural_of_bytes en bs) (* TODO: generalise *) @@ -1974,7 +2127,7 @@ let pr_post_map p f = fun (pc: parse_context) -> pr_map f (p pc) val pr_with_pos : forall 'a. (parser 'a) -> (parser (sym_natural * 'a)) -let pr_with_pos p = fun pc -> pr_map (fun x -> ( pc.pc_offset,x)) (p pc) +let pr_with_pos p = fun pc -> pr_map (fun x -> (Absolute pc.pc_offset,x)) (p pc) val parse_pair : forall 'a 'b. (parser 'a) -> (parser 'b) -> (parser ('a * 'b)) @@ -2101,7 +2254,7 @@ let parse_string : parser (rel_byte_sequence) = match rbs_find_byte pc.pc_bytes bzero with | Nothing -> PR_fail "parse_string" pc | Just n -> - pr_bind (parse_n_bytes ( n) pc) (fun res pc -> (*todo find byte should respect relocs*) + pr_bind (parse_n_bytes (Absolute n) pc) (fun res pc -> (*todo find byte should respect relocs*) pr_bind (parse_byte pc) (fun _ pc -> pr_return res pc)) end @@ -2123,7 +2276,7 @@ let parse_uint8 : parser sym_natural= match rbs_read_char pc.pc_bytes with | Success (b, bytes) -> let v = natural_of_byte b in - PR_success ( v) (<| pc_bytes = bytes; pc_offset = pc.pc_offset + 1 |>) + PR_success (Absolute v) (<| pc_bytes = bytes; pc_offset = pc.pc_offset + 1 |>) | _ -> PR_fail "parse_uint32 not given enough bytes" pc end @@ -2143,7 +2296,7 @@ let parse_uint16 c : parser sym_natural= natural_of_byte b0 + 256*natural_of_byte b1 else natural_of_byte b1 + 256*natural_of_byte b0 in - PR_success ( v) (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 2 |>) + PR_success (Absolute v) (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 2 |>) | _ -> PR_fail "parse_uint32 not given enough bytes" pc end @@ -2157,7 +2310,7 @@ let parse_uint32 c : parser sym_natural= natural_of_byte b0 + 256*natural_of_byte b1 + 256*256*natural_of_byte b2 + 256*256*256*natural_of_byte b3 else natural_of_byte b3 + 256*natural_of_byte b2 + 256*256*natural_of_byte b1 + 256*256*256*natural_of_byte b0 in - PR_success ( v) (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 4 |>) + PR_success (Absolute v) (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 4 |>) | Success (ReadReloc r, bytes') -> if r.arel_target = Data32 then PR_success (sym_natural_of_symbolic_expression r.arel_value) (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 4 |>) @@ -2179,7 +2332,7 @@ let parse_uint64 c : parser sym_natural= natural_of_byte b7 + 256*natural_of_byte b6 + 256*256*natural_of_byte b5 + 256*256*256*natural_of_byte b4 + (256*256*256*256*(natural_of_byte b3 + 256*natural_of_byte b2 + 256*256*natural_of_byte b1 + 256*256*256*natural_of_byte b0)) in - PR_success ( v) (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 8 |>) + PR_success (Absolute v) (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 8 |>) | Success (ReadReloc r, bytes') -> if r.arel_target = Data64 then PR_success (sym_natural_of_symbolic_expression r.arel_value) (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 8 |>) @@ -2197,7 +2350,7 @@ let partialTwosComplementNaturalFromInteger (i:integer) (half: natural) (all:int else if i >= (0-integerFromNatural half) && i < 0 then partialNaturalFromInteger (all + i) else Assert_extra.failwith "partialTwosComplementNaturalFromInteger" -let partialTwosComplementSymNaturalFromInteger i half all = partialTwosComplementNaturalFromInteger i half all +let partialTwosComplementSymNaturalFromInteger i half all = sym_map (fun x -> partialTwosComplementNaturalFromInteger i x all) half let parse_sint8 : parser integer = pr_post_map (parse_uint8) (fun n -> integerFromTwosComplementNatural (sym_unwrap n "parse_sint8") 128 256) @@ -2230,7 +2383,7 @@ let rec parse_ULEB128' (acc: natural) (shift_factor: natural) : parser natural = let parse_ULEB128 : parser sym_natural = fun (pc:parse_context) -> - pr_map (fun x -> x) (parse_ULEB128' 0 1 pc) + pr_map (fun x -> Absolute x) (parse_ULEB128' 0 1 pc) let rec parse_SLEB128' (acc: natural) (shift_factor: natural) : parser (bool * natural * natural) = fun (pc:parse_context) -> @@ -3088,7 +3241,7 @@ let rec parse_die c str cuh find_abbreviation_declaration = (fun dies pc''' -> PR_success (Just ( let die = <| - die_offset = pc.pc_offset; + die_offset = Absolute pc.pc_offset; die_abbreviation_code = abbreviation_code; die_abbreviation_declaration = ad; die_attribute_values = avs; @@ -3155,7 +3308,7 @@ let _ = my_debug4 (pp_compilation_unit_header cuh) in let abbreviations_table = match parse_abbreviations_table c pc_abbrev with | PR_fail s pc_abbrev' -> Assert_extra.failwith ("parse_abbrevations_table fail: " ^ pp_parse_fail s pc_abbrev') - | PR_success at pc_abbrev' -> <| at_offset= pc_abbrev.pc_offset; at_table= at|> + | PR_success at pc_abbrev' -> <| at_offset=Absolute pc_abbrev.pc_offset; at_table= at|> end in let _ = my_debug4 (pp_abbreviations_table abbreviations_table) in @@ -3214,7 +3367,7 @@ let parse_type_unit c (debug_str_section_body: rel_byte_sequence) (debug_abbrev_ let abbreviations_table = match parse_abbreviations_table c pc_abbrev with | PR_fail s pc_abbrev' -> Assert_extra.failwith ("parse_abbrevations_table fail: " ^ pp_parse_fail s pc_abbrev') - | PR_success at pc_abbrev' -> <| at_offset= pc_abbrev.pc_offset; at_table= at|> + | PR_success at pc_abbrev' -> <| at_offset=Absolute pc_abbrev.pc_offset; at_table= at|> end in (* let _ = my_debug4 (pp_abbreviations_table abbreviations_table) in *) @@ -3329,7 +3482,7 @@ let parse_location_list c cuh : parser (maybe location_list) = else pr_post_map1 (parse_list (parse_location_list_item c cuh) pc) - (fun llis -> (Just ( pc.pc_offset, llis))) + (fun llis -> (Just (Absolute pc.pc_offset, llis))) let parse_location_list_list c cuh : parser location_list_list = parse_list (parse_location_list c cuh) @@ -3432,7 +3585,7 @@ let parse_range_list c cuh : parser (maybe (list range_list)) = else pr_post_map1 (parse_list (parse_range_list_item c cuh) pc) - (fun rlis -> (Just (expand_range_list_suffixes cuh ( pc.pc_offset, rlis)))) + (fun rlis -> (Just (expand_range_list_suffixes cuh (Absolute pc.pc_offset, rlis)))) let parse_range_list_list c cuh : parser range_list_list = pr_map2 List.concat (parse_list (parse_range_list c cuh)) @@ -3601,7 +3754,7 @@ let parse_call_frame_instruction c cuh : parser (maybe call_frame_instruction) = end else if high_bits = unsigned_char_of_natural 64 then - PR_success (Just (DW_CFA_advance_loc ( low_bits))) pc' + PR_success (Just (DW_CFA_advance_loc (Absolute low_bits))) pc' else if high_bits = unsigned_char_of_natural 192 then PR_success (Just (DW_CFA_restore low_bits)) pc' else @@ -3692,7 +3845,7 @@ let parse_initial_location c cuh mss mas' : parser ((maybe sym_natural) * sym_na let parse_call_frame_instruction_bytes offset' ul = fun (pc: parse_context) -> - parse_n_bytes (ul - ( pc.pc_offset - offset')) pc + parse_n_bytes (ul - (Absolute pc.pc_offset - offset')) pc let parse_frame_info_element c cuh (fi: list frame_info_element) : parser frame_info_element = parse_dependent @@ -3916,8 +4069,8 @@ let parse_line_number_header c (comp_dir:maybe string) : parser line_number_head (parse_triple (parse_uintDwarfN c df) (* header_length *) (parse_uint8) (* minimum_instruction_length *) - (if v< 4 then (* maximum_operations_per_instruction*)(* NOT IN DWARF 2 or 3; in DWARF 4*) - (parse_uint8_constant ( 1)) + (if v pr_post_map (parse_triple - (pr_post_map (parse_n_bytes (ob- 1)) (fun bs -> List.map sym_natural_of_byte (byte_list_of_rel_byte_sequence bs))) (* standard_opcode_lengths *) + (pr_post_map (parse_n_bytes (ob-Absolute 1)) (fun bs -> List.map sym_natural_of_byte (byte_list_of_rel_byte_sequence bs))) (* standard_opcode_lengths *) ((*pr_return [[]]*) parse_list parse_non_empty_string) (* include_directories *) (parse_list parse_line_number_file_entry) (* file names *) ) @@ -4242,7 +4395,7 @@ let extract_section_body (f:elf_file) (ri:relocation_interpreter reloc_target_da ) f32.elf32_file_interpreted_sections in match sections with | [section] -> - let section_addr = sym_natural_of_symbolic_expression (Section section_name) in + let section_addr = Offset (section_name, 0) in let section_body = section.Elf_interpreted_section.elf32_section_body in (* let _ = my_debug4 (section_name ^ (": \n" ^ (Elf_interpreted_section.string_of_elf32_interpreted_section section ^ "\n" * ^ " body = " ^ ppbytes2 0 section_body ^ "\n"))) in *) @@ -4265,7 +4418,7 @@ let extract_section_body (f:elf_file) (ri:relocation_interpreter reloc_target_da ) f64.elf64_file_interpreted_sections in match sections with | [section] -> - let section_addr = sym_natural_of_symbolic_expression (Section section_name) in + let section_addr = Offset (section_name, 0) in let section_body = section.Elf_interpreted_section.elf64_section_body in let _ = my_debug "extracted section body" in match extract_elf64_relocations_for_section f64 ri section_name with @@ -4526,13 +4679,13 @@ let rec evaluate_operation_list (c:p_context) (dloc: location_list_list) (evalua end | (OpSem_opcode_lit base, []) -> if op.op_code >= base && op.op_code < base + 32 then - push_memory_address ( (op.op_code - base)) s.s_stack + push_memory_address (Absolute (op.op_code - base)) s.s_stack else Fail "OpSem_opcode_lit opcode not within [base,base+32)" | (OpSem_reg, []) -> (* TODO: unclear whether this should push the register id or not *) let r = op.op_code - vDW_OP_reg0 in - Success <| s with s_stack = ( r) :: s.s_stack; s_value = SL_register r |> + Success <| s with s_stack = (Absolute r) :: s.s_stack; s_value = SL_register r |> | (OpSem_breg, [OAV_integer i]) -> let r = op.op_code - vDW_OP_breg0 in bregxi r i @@ -5369,7 +5522,7 @@ if there's a DW_AT_location that's a location list (DW_FORM_sec_offset/AV_sec_of if there's a DW_AT_location that's a location expression (DW_FORM_exprloc/AV_exprloc or DW_block/AV_block), look for the closest enclosing range: - DW_AT_low_pc (AV_addr) and no DW_AT_high_pc or DW_AT_ranges: just the singleton address - - DW_AT_low_pc (AV_addr) and DW_AT_high_pc (either an AV_addr or an offset AV_constantN/AV_constant_SLEB128/AV_constantULEB128) : that range + - DW_AT_low_pc (AV_addr) and DW_AT_high_pc (either an absolute AV_addr or an offset AV_constantN/AV_constant_SLEB128/AV_constantULEB128) : that range - DW_AT_ranges (DW_FORM_sec_offset/AV_sec_offset) : get a range list from .debug_ranges; interpret wrt the applicable base address of the compilation unit - for compilation units: a DW_AT_ranges together with a DW_AT_low_pc to specify the default base address to use in interpeting location and range lists @@ -5902,7 +6055,7 @@ let evaluate_line_number_operation match lno with | DW_LN_special adjusted_opcode -> - let adjusted_opcode = adjusted_opcode in (* TODO probably doesn't have to be symbolic *) + let adjusted_opcode = Absolute adjusted_opcode in (* TODO probably doesn't have to be symbolic *) let operation_advance = adjusted_opcode / lnh.lnh_line_range in let line_increment = lnh.lnh_line_base + integerFromSymNatural (adjusted_opcode mod lnh.lnh_line_range) in let s' = @@ -5949,7 +6102,7 @@ let evaluate_line_number_operation let s' = <| s with lnr_basic_block = true |> in (s', lnrs) | DW_LNS_const_add_pc -> let opcode = 255 in - let adjusted_opcode = (opcode - lnh.lnh_opcode_base) in + let adjusted_opcode = Absolute (opcode - lnh.lnh_opcode_base) in let operation_advance = adjusted_opcode / lnh.lnh_line_range in let s' = <| s with @@ -6661,7 +6814,7 @@ let pp_inlined_subroutines ds iss = let pp_inlined_subroutine_by_range ds ((n1,n2),((m:sym_natural),(n:sym_natural)),is) = pphex_sym n1 ^ " " ^ pphex_sym n2 ^ " " - ^ (if n<>( 1) then "("^show m^" of "^show n^") " else "") + ^ (if n<>(Absolute 1) then "("^show m^" of "^show n^") " else "") ^ pp_inlined_subroutine_header ds is ^"\n" ^ (if m=0 then pp_inlined_subroutine_const_params ds.ds_dwarf is else "") @@ -6679,7 +6832,7 @@ let pp_inlined_subroutines_by_range ds iss = let rec words_of_rel_byte_sequence (addr:sym_natural) (bs:rel_byte_sequence) (acc:list (sym_natural * sym_natural)) : list (sym_natural * sym_natural) = match rbs_read_4_bytes_be bs with | Success (ReadValue (b0,b1,b2,b3), bs') -> (*TODO*) - let i : sym_natural = (natural_of_byte b0 + 256*natural_of_byte b1 + 65536*natural_of_byte b2 + 65536*256*natural_of_byte b3) in + let i : sym_natural = Absolute (natural_of_byte b0 + 256*natural_of_byte b1 + 65536*natural_of_byte b2 + 65536*256*natural_of_byte b3) in words_of_rel_byte_sequence (addr+4) bs' ((addr,i)::acc) | Fail _ -> List.reverse acc end From 870ff7aee41ce0f33ab36807e074e475b7b113ac Mon Sep 17 00:00:00 2001 From: Matej Urban Date: Tue, 21 Jan 2025 13:08:58 +0000 Subject: [PATCH 21/44] Revert "Make it less symbolic where not needed (might revert)" This reverts commit 7b22921d8f85e6e5f6acb15b5d6623e44c2dc4a6. --- src/dwarf.lem | 900 +++++++++++++++++++++++++------------------------- 1 file changed, 448 insertions(+), 452 deletions(-) diff --git a/src/dwarf.lem b/src/dwarf.lem index 34737a1..3b64c83 100644 --- a/src/dwarf.lem +++ b/src/dwarf.lem @@ -591,7 +591,7 @@ type operation_semantics = | OpSem_not_supported | OpSem_binary of (arithmetic_context -> sym_natural -> sym_natural -> maybe sym_natural) | OpSem_unary of (arithmetic_context -> sym_natural -> maybe sym_natural) - | OpSem_opcode_lit of natural + | OpSem_opcode_lit of sym_natural | OpSem_reg | OpSem_breg | OpSem_bregx @@ -606,7 +606,7 @@ type operation_semantics = type operation = <| - op_code: natural; + op_code: sym_natural; op_string: string; op_argument_values: list operation_argument_value; op_semantics: operation_semantics; @@ -617,7 +617,7 @@ type operation = type simple_location = | SL_memory_address of sym_natural - | SL_register of natural + | SL_register of sym_natural | SL_implicit of rel_byte_sequence (* used for implicit and stack values *) | SL_empty @@ -652,7 +652,7 @@ type memory_read_result 'a = type evaluation_context = <| - read_register: natural -> register_read_result sym_natural; + read_register: sym_natural -> register_read_result sym_natural; read_memory: sym_natural -> sym_natural -> memory_read_result sym_natural; |> @@ -668,9 +668,9 @@ type dwarf_format = type abbreviation_declaration = <| ad_abbreviation_code: sym_natural; - ad_tag: natural; + ad_tag: sym_natural; ad_has_children: bool; - ad_attribute_specifications: list (natural * natural); + ad_attribute_specifications: list (sym_natural * sym_natural); |> type abbreviations_table = @@ -792,7 +792,7 @@ type cfa_address = sym_natural type cfa_block = rel_byte_sequence type cfa_delta = sym_natural type cfa_offset = sym_natural -type cfa_register = natural +type cfa_register = sym_natural type cfa_sfoffset = integer type call_frame_argument_type = @@ -897,7 +897,7 @@ type register_rule = is the current CFA value and N is a signed offset.*) | RR_val_offset of integer (* The previous value of this register is the value CFA+N where CFA is the current CFA value and N is a signed offset.*) - | RR_register of natural (* The previous value of this register is stored in another register numbered R.*) + | RR_register of sym_natural (* The previous value of this register is stored in another register numbered R.*) | RR_expression of single_location_description (* The previous value of this register is located at the address produced by executing the DWARF expression E.*) | RR_val_expression of single_location_description (* The previous value of this register is the value produced by executing the @@ -962,7 +962,7 @@ type line_number_operation = | DW_LNE_define_file of rel_byte_sequence * sym_natural * sym_natural * sym_natural | DW_LNE_set_discriminator of sym_natural (* special *) - | DW_LN_special of natural (* the adjusted opcode *) + | DW_LN_special of sym_natural (* the adjusted opcode *) type line_number_file_entry = <| @@ -984,7 +984,7 @@ type line_number_header = lnh_default_is_stmt: bool; lnh_line_base: integer; lnh_line_range: sym_natural; - lnh_opcode_base: natural; + lnh_opcode_base: sym_natural; lnh_standard_opcode_lengths: list sym_natural; lnh_include_directories: list (rel_byte_sequence); lnh_file_entries: list line_number_file_entry; @@ -1089,7 +1089,7 @@ type enumeration_member = cupdie * (maybe string)(*mname*) * integer(*const_valu type c_type_top 't = | CT_missing of cupdie - | CT_base of cupdie * string(*name*) * natural(*encoding*) * (maybe sym_natural)(*byte_size*) + | CT_base of cupdie * string(*name*) * sym_natural(*encoding*) * (maybe sym_natural)(*byte_size*) | CT_pointer of cupdie * maybe 't | CT_const of cupdie * maybe 't | CT_volatile of cupdie * 't @@ -1230,389 +1230,389 @@ let p_context_of_d (d:dwarf) : p_context = <| endianness = d.d_endianness |> (* tag encoding *) let tag_encodings = [ - ("DW_TAG_array_type" , natural_of_hex "0x01" ); - ("DW_TAG_class_type" , natural_of_hex "0x02" ); - ("DW_TAG_entry_point" , natural_of_hex "0x03" ); - ("DW_TAG_enumeration_type" , natural_of_hex "0x04" ); - ("DW_TAG_formal_parameter" , natural_of_hex "0x05" ); - ("DW_TAG_imported_declaration" , natural_of_hex "0x08" ); - ("DW_TAG_label" , natural_of_hex "0x0a" ); - ("DW_TAG_lexical_block" , natural_of_hex "0x0b" ); - ("DW_TAG_member" , natural_of_hex "0x0d" ); - ("DW_TAG_pointer_type" , natural_of_hex "0x0f" ); - ("DW_TAG_reference_type" , natural_of_hex "0x10" ); - ("DW_TAG_compile_unit" , natural_of_hex "0x11" ); - ("DW_TAG_string_type" , natural_of_hex "0x12" ); - ("DW_TAG_structure_type" , natural_of_hex "0x13" ); - ("DW_TAG_subroutine_type" , natural_of_hex "0x15" ); - ("DW_TAG_typedef" , natural_of_hex "0x16" ); - ("DW_TAG_union_type" , natural_of_hex "0x17" ); - ("DW_TAG_unspecified_parameters" , natural_of_hex "0x18" ); - ("DW_TAG_variant" , natural_of_hex "0x19" ); - ("DW_TAG_common_block" , natural_of_hex "0x1a" ); - ("DW_TAG_common_inclusion" , natural_of_hex "0x1b" ); - ("DW_TAG_inheritance" , natural_of_hex "0x1c" ); - ("DW_TAG_inlined_subroutine" , natural_of_hex "0x1d" ); - ("DW_TAG_module" , natural_of_hex "0x1e" ); - ("DW_TAG_ptr_to_member_type" , natural_of_hex "0x1f" ); - ("DW_TAG_set_type" , natural_of_hex "0x20" ); - ("DW_TAG_subrange_type" , natural_of_hex "0x21" ); - ("DW_TAG_with_stmt" , natural_of_hex "0x22" ); - ("DW_TAG_access_declaration" , natural_of_hex "0x23" ); - ("DW_TAG_base_type" , natural_of_hex "0x24" ); - ("DW_TAG_catch_block" , natural_of_hex "0x25" ); - ("DW_TAG_const_type" , natural_of_hex "0x26" ); - ("DW_TAG_constant" , natural_of_hex "0x27" ); - ("DW_TAG_enumerator" , natural_of_hex "0x28" ); - ("DW_TAG_file_type" , natural_of_hex "0x29" ); - ("DW_TAG_friend" , natural_of_hex "0x2a" ); - ("DW_TAG_namelist" , natural_of_hex "0x2b" ); - ("DW_TAG_namelist_item" , natural_of_hex "0x2c" ); - ("DW_TAG_packed_type" , natural_of_hex "0x2d" ); - ("DW_TAG_subprogram" , natural_of_hex "0x2e" ); - ("DW_TAG_template_type_parameter" , natural_of_hex "0x2f" ); - ("DW_TAG_template_value_parameter" , natural_of_hex "0x30" ); - ("DW_TAG_thrown_type" , natural_of_hex "0x31" ); - ("DW_TAG_try_block" , natural_of_hex "0x32" ); - ("DW_TAG_variant_part" , natural_of_hex "0x33" ); - ("DW_TAG_variable" , natural_of_hex "0x34" ); - ("DW_TAG_volatile_type" , natural_of_hex "0x35" ); - ("DW_TAG_dwarf_procedure" , natural_of_hex "0x36" ); - ("DW_TAG_restrict_type" , natural_of_hex "0x37" ); - ("DW_TAG_interface_type" , natural_of_hex "0x38" ); - ("DW_TAG_namespace" , natural_of_hex "0x39" ); - ("DW_TAG_imported_module" , natural_of_hex "0x3a" ); - ("DW_TAG_unspecified_type" , natural_of_hex "0x3b" ); - ("DW_TAG_partial_unit" , natural_of_hex "0x3c" ); - ("DW_TAG_imported_unit" , natural_of_hex "0x3d" ); - ("DW_TAG_condition" , natural_of_hex "0x3f" ); - ("DW_TAG_shared_type" , natural_of_hex "0x40" ); - ("DW_TAG_type_unit" , natural_of_hex "0x41" ); - ("DW_TAG_rvalue_reference_type" , natural_of_hex "0x42" ); - ("DW_TAG_template_alias" , natural_of_hex "0x43" ); - ("DW_TAG_lo_user" , natural_of_hex "0x4080"); - ("DW_TAG_hi_user" , natural_of_hex "0xffff") + ("DW_TAG_array_type" , sym_natural_of_hex "0x01" ); + ("DW_TAG_class_type" , sym_natural_of_hex "0x02" ); + ("DW_TAG_entry_point" , sym_natural_of_hex "0x03" ); + ("DW_TAG_enumeration_type" , sym_natural_of_hex "0x04" ); + ("DW_TAG_formal_parameter" , sym_natural_of_hex "0x05" ); + ("DW_TAG_imported_declaration" , sym_natural_of_hex "0x08" ); + ("DW_TAG_label" , sym_natural_of_hex "0x0a" ); + ("DW_TAG_lexical_block" , sym_natural_of_hex "0x0b" ); + ("DW_TAG_member" , sym_natural_of_hex "0x0d" ); + ("DW_TAG_pointer_type" , sym_natural_of_hex "0x0f" ); + ("DW_TAG_reference_type" , sym_natural_of_hex "0x10" ); + ("DW_TAG_compile_unit" , sym_natural_of_hex "0x11" ); + ("DW_TAG_string_type" , sym_natural_of_hex "0x12" ); + ("DW_TAG_structure_type" , sym_natural_of_hex "0x13" ); + ("DW_TAG_subroutine_type" , sym_natural_of_hex "0x15" ); + ("DW_TAG_typedef" , sym_natural_of_hex "0x16" ); + ("DW_TAG_union_type" , sym_natural_of_hex "0x17" ); + ("DW_TAG_unspecified_parameters" , sym_natural_of_hex "0x18" ); + ("DW_TAG_variant" , sym_natural_of_hex "0x19" ); + ("DW_TAG_common_block" , sym_natural_of_hex "0x1a" ); + ("DW_TAG_common_inclusion" , sym_natural_of_hex "0x1b" ); + ("DW_TAG_inheritance" , sym_natural_of_hex "0x1c" ); + ("DW_TAG_inlined_subroutine" , sym_natural_of_hex "0x1d" ); + ("DW_TAG_module" , sym_natural_of_hex "0x1e" ); + ("DW_TAG_ptr_to_member_type" , sym_natural_of_hex "0x1f" ); + ("DW_TAG_set_type" , sym_natural_of_hex "0x20" ); + ("DW_TAG_subrange_type" , sym_natural_of_hex "0x21" ); + ("DW_TAG_with_stmt" , sym_natural_of_hex "0x22" ); + ("DW_TAG_access_declaration" , sym_natural_of_hex "0x23" ); + ("DW_TAG_base_type" , sym_natural_of_hex "0x24" ); + ("DW_TAG_catch_block" , sym_natural_of_hex "0x25" ); + ("DW_TAG_const_type" , sym_natural_of_hex "0x26" ); + ("DW_TAG_constant" , sym_natural_of_hex "0x27" ); + ("DW_TAG_enumerator" , sym_natural_of_hex "0x28" ); + ("DW_TAG_file_type" , sym_natural_of_hex "0x29" ); + ("DW_TAG_friend" , sym_natural_of_hex "0x2a" ); + ("DW_TAG_namelist" , sym_natural_of_hex "0x2b" ); + ("DW_TAG_namelist_item" , sym_natural_of_hex "0x2c" ); + ("DW_TAG_packed_type" , sym_natural_of_hex "0x2d" ); + ("DW_TAG_subprogram" , sym_natural_of_hex "0x2e" ); + ("DW_TAG_template_type_parameter" , sym_natural_of_hex "0x2f" ); + ("DW_TAG_template_value_parameter" , sym_natural_of_hex "0x30" ); + ("DW_TAG_thrown_type" , sym_natural_of_hex "0x31" ); + ("DW_TAG_try_block" , sym_natural_of_hex "0x32" ); + ("DW_TAG_variant_part" , sym_natural_of_hex "0x33" ); + ("DW_TAG_variable" , sym_natural_of_hex "0x34" ); + ("DW_TAG_volatile_type" , sym_natural_of_hex "0x35" ); + ("DW_TAG_dwarf_procedure" , sym_natural_of_hex "0x36" ); + ("DW_TAG_restrict_type" , sym_natural_of_hex "0x37" ); + ("DW_TAG_interface_type" , sym_natural_of_hex "0x38" ); + ("DW_TAG_namespace" , sym_natural_of_hex "0x39" ); + ("DW_TAG_imported_module" , sym_natural_of_hex "0x3a" ); + ("DW_TAG_unspecified_type" , sym_natural_of_hex "0x3b" ); + ("DW_TAG_partial_unit" , sym_natural_of_hex "0x3c" ); + ("DW_TAG_imported_unit" , sym_natural_of_hex "0x3d" ); + ("DW_TAG_condition" , sym_natural_of_hex "0x3f" ); + ("DW_TAG_shared_type" , sym_natural_of_hex "0x40" ); + ("DW_TAG_type_unit" , sym_natural_of_hex "0x41" ); + ("DW_TAG_rvalue_reference_type" , sym_natural_of_hex "0x42" ); + ("DW_TAG_template_alias" , sym_natural_of_hex "0x43" ); + ("DW_TAG_lo_user" , sym_natural_of_hex "0x4080"); + ("DW_TAG_hi_user" , sym_natural_of_hex "0xffff") ] (* child determination encoding *) -let vDW_CHILDREN_no = natural_of_hex "0x00" -let vDW_CHILDREN_yes = natural_of_hex "0x01" +let vDW_CHILDREN_no = sym_natural_of_hex "0x00" +let vDW_CHILDREN_yes = sym_natural_of_hex "0x01" (* attribute encoding *) let attribute_encodings = [ - ("DW_AT_sibling" , natural_of_hex "0x01", [DWA_reference]) ; - ("DW_AT_location" , natural_of_hex "0x02", [DWA_exprloc; DWA_loclistptr]) ; - ("DW_AT_name" , natural_of_hex "0x03", [DWA_string]) ; - ("DW_AT_ordering" , natural_of_hex "0x09", [DWA_constant]) ; - ("DW_AT_byte_size" , natural_of_hex "0x0b", [DWA_constant; DWA_exprloc; DWA_reference]) ; - ("DW_AT_bit_offset" , natural_of_hex "0x0c", [DWA_constant; DWA_exprloc; DWA_reference]) ; - ("DW_AT_bit_size" , natural_of_hex "0x0d", [DWA_constant; DWA_exprloc; DWA_reference]) ; - ("DW_AT_stmt_list" , natural_of_hex "0x10", [DWA_lineptr]) ; - ("DW_AT_low_pc" , natural_of_hex "0x11", [DWA_address]) ; - ("DW_AT_high_pc" , natural_of_hex "0x12", [DWA_address; DWA_constant]) ; - ("DW_AT_language" , natural_of_hex "0x13", [DWA_constant]) ; - ("DW_AT_discr" , natural_of_hex "0x15", [DWA_reference]) ; - ("DW_AT_discr_value" , natural_of_hex "0x16", [DWA_constant]) ; - ("DW_AT_visibility" , natural_of_hex "0x17", [DWA_constant]) ; - ("DW_AT_import" , natural_of_hex "0x18", [DWA_reference]) ; - ("DW_AT_string_length" , natural_of_hex "0x19", [DWA_exprloc; DWA_loclistptr]) ; - ("DW_AT_common_reference" , natural_of_hex "0x1a", [DWA_reference]) ; - ("DW_AT_comp_dir" , natural_of_hex "0x1b", [DWA_string]) ; - ("DW_AT_const_value" , natural_of_hex "0x1c", [DWA_block; DWA_constant; DWA_string]) ; - ("DW_AT_containing_type" , natural_of_hex "0x1d", [DWA_reference]) ; - ("DW_AT_default_value" , natural_of_hex "0x1e", [DWA_reference]) ; - ("DW_AT_inline" , natural_of_hex "0x20", [DWA_constant]) ; - ("DW_AT_is_optional" , natural_of_hex "0x21", [DWA_flag]) ; - ("DW_AT_lower_bound" , natural_of_hex "0x22", [DWA_constant; DWA_exprloc; DWA_reference]) ; - ("DW_AT_producer" , natural_of_hex "0x25", [DWA_string]) ; - ("DW_AT_prototyped" , natural_of_hex "0x27", [DWA_flag]) ; - ("DW_AT_return_addr" , natural_of_hex "0x2a", [DWA_exprloc; DWA_loclistptr]) ; - ("DW_AT_start_scope" , natural_of_hex "0x2c", [DWA_constant; DWA_rangelistptr]) ; - ("DW_AT_bit_stride" , natural_of_hex "0x2e", [DWA_constant; DWA_exprloc; DWA_reference]) ; - ("DW_AT_upper_bound" , natural_of_hex "0x2f", [DWA_constant; DWA_exprloc; DWA_reference]) ; - ("DW_AT_abstract_origin" , natural_of_hex "0x31", [DWA_reference]) ; - ("DW_AT_accessibility" , natural_of_hex "0x32", [DWA_constant]) ; - ("DW_AT_address_class" , natural_of_hex "0x33", [DWA_constant]) ; - ("DW_AT_artificial" , natural_of_hex "0x34", [DWA_flag]) ; - ("DW_AT_base_types" , natural_of_hex "0x35", [DWA_reference]) ; - ("DW_AT_calling_convention" , natural_of_hex "0x36", [DWA_constant]) ; - ("DW_AT_count" , natural_of_hex "0x37", [DWA_constant; DWA_exprloc; DWA_reference]) ; - ("DW_AT_data_member_location" , natural_of_hex "0x38", [DWA_constant; DWA_exprloc; DWA_loclistptr]) ; - ("DW_AT_decl_column" , natural_of_hex "0x39", [DWA_constant]) ; - ("DW_AT_decl_file" , natural_of_hex "0x3a", [DWA_constant]) ; - ("DW_AT_decl_line" , natural_of_hex "0x3b", [DWA_constant]) ; - ("DW_AT_declaration" , natural_of_hex "0x3c", [DWA_flag]) ; - ("DW_AT_discr_list" , natural_of_hex "0x3d", [DWA_block]) ; - ("DW_AT_encoding" , natural_of_hex "0x3e", [DWA_constant]) ; - ("DW_AT_external" , natural_of_hex "0x3f", [DWA_flag]) ; - ("DW_AT_frame_base" , natural_of_hex "0x40", [DWA_exprloc; DWA_loclistptr]) ; - ("DW_AT_friend" , natural_of_hex "0x41", [DWA_reference]) ; - ("DW_AT_identifier_case" , natural_of_hex "0x42", [DWA_constant]) ; - ("DW_AT_macro_info" , natural_of_hex "0x43", [DWA_macptr]) ; - ("DW_AT_namelist_item" , natural_of_hex "0x44", [DWA_reference]) ; - ("DW_AT_priority" , natural_of_hex "0x45", [DWA_reference]) ; - ("DW_AT_segment" , natural_of_hex "0x46", [DWA_exprloc; DWA_loclistptr]) ; - ("DW_AT_specification" , natural_of_hex "0x47", [DWA_reference]) ; - ("DW_AT_static_link" , natural_of_hex "0x48", [DWA_exprloc; DWA_loclistptr]) ; - ("DW_AT_type" , natural_of_hex "0x49", [DWA_reference]) ; - ("DW_AT_use_location" , natural_of_hex "0x4a", [DWA_exprloc; DWA_loclistptr]) ; - ("DW_AT_variable_parameter" , natural_of_hex "0x4b", [DWA_flag]) ; - ("DW_AT_virtuality" , natural_of_hex "0x4c", [DWA_constant]) ; - ("DW_AT_vtable_elem_location" , natural_of_hex "0x4d", [DWA_exprloc; DWA_loclistptr]) ; - ("DW_AT_allocated" , natural_of_hex "0x4e", [DWA_constant; DWA_exprloc; DWA_reference]) ; - ("DW_AT_associated" , natural_of_hex "0x4f", [DWA_constant; DWA_exprloc; DWA_reference]) ; - ("DW_AT_data_location" , natural_of_hex "0x50", [DWA_exprloc]) ; - ("DW_AT_byte_stride" , natural_of_hex "0x51", [DWA_constant; DWA_exprloc; DWA_reference]) ; - ("DW_AT_entry_pc" , natural_of_hex "0x52", [DWA_address]) ; - ("DW_AT_use_UTF8" , natural_of_hex "0x53", [DWA_flag]) ; - ("DW_AT_extension" , natural_of_hex "0x54", [DWA_reference]) ; - ("DW_AT_ranges" , natural_of_hex "0x55", [DWA_rangelistptr]) ; - ("DW_AT_trampoline" , natural_of_hex "0x56", [DWA_address; DWA_flag; DWA_reference; DWA_string]); - ("DW_AT_call_column" , natural_of_hex "0x57", [DWA_constant]) ; - ("DW_AT_call_file" , natural_of_hex "0x58", [DWA_constant]) ; - ("DW_AT_call_line" , natural_of_hex "0x59", [DWA_constant]) ; - ("DW_AT_description" , natural_of_hex "0x5a", [DWA_string]) ; - ("DW_AT_binary_scale" , natural_of_hex "0x5b", [DWA_constant]) ; - ("DW_AT_decimal_scale" , natural_of_hex "0x5c", [DWA_constant]) ; - ("DW_AT_small" , natural_of_hex "0x5d", [DWA_reference]) ; - ("DW_AT_decimal_sign" , natural_of_hex "0x5e", [DWA_constant]) ; - ("DW_AT_digit_count" , natural_of_hex "0x5f", [DWA_constant]) ; - ("DW_AT_picture_string" , natural_of_hex "0x60", [DWA_string]) ; - ("DW_AT_mutable" , natural_of_hex "0x61", [DWA_flag]) ; - ("DW_AT_threads_scaled" , natural_of_hex "0x62", [DWA_flag]) ; - ("DW_AT_explicit" , natural_of_hex "0x63", [DWA_flag]) ; - ("DW_AT_object_pointer" , natural_of_hex "0x64", [DWA_reference]) ; - ("DW_AT_endianity" , natural_of_hex "0x65", [DWA_constant]) ; - ("DW_AT_elemental" , natural_of_hex "0x66", [DWA_flag]) ; - ("DW_AT_pure" , natural_of_hex "0x67", [DWA_flag]) ; - ("DW_AT_recursive" , natural_of_hex "0x68", [DWA_flag]) ; - ("DW_AT_signature" , natural_of_hex "0x69", [DWA_reference]) ; - ("DW_AT_main_subprogram" , natural_of_hex "0x6a", [DWA_flag]) ; - ("DW_AT_data_bit_offset" , natural_of_hex "0x6b", [DWA_constant]) ; - ("DW_AT_const_expr" , natural_of_hex "0x6c", [DWA_flag]) ; - ("DW_AT_enum_class" , natural_of_hex "0x6d", [DWA_flag]) ; - ("DW_AT_linkage_name" , natural_of_hex "0x6e", [DWA_string]) ; + ("DW_AT_sibling" , sym_natural_of_hex "0x01", [DWA_reference]) ; + ("DW_AT_location" , sym_natural_of_hex "0x02", [DWA_exprloc; DWA_loclistptr]) ; + ("DW_AT_name" , sym_natural_of_hex "0x03", [DWA_string]) ; + ("DW_AT_ordering" , sym_natural_of_hex "0x09", [DWA_constant]) ; + ("DW_AT_byte_size" , sym_natural_of_hex "0x0b", [DWA_constant; DWA_exprloc; DWA_reference]) ; + ("DW_AT_bit_offset" , sym_natural_of_hex "0x0c", [DWA_constant; DWA_exprloc; DWA_reference]) ; + ("DW_AT_bit_size" , sym_natural_of_hex "0x0d", [DWA_constant; DWA_exprloc; DWA_reference]) ; + ("DW_AT_stmt_list" , sym_natural_of_hex "0x10", [DWA_lineptr]) ; + ("DW_AT_low_pc" , sym_natural_of_hex "0x11", [DWA_address]) ; + ("DW_AT_high_pc" , sym_natural_of_hex "0x12", [DWA_address; DWA_constant]) ; + ("DW_AT_language" , sym_natural_of_hex "0x13", [DWA_constant]) ; + ("DW_AT_discr" , sym_natural_of_hex "0x15", [DWA_reference]) ; + ("DW_AT_discr_value" , sym_natural_of_hex "0x16", [DWA_constant]) ; + ("DW_AT_visibility" , sym_natural_of_hex "0x17", [DWA_constant]) ; + ("DW_AT_import" , sym_natural_of_hex "0x18", [DWA_reference]) ; + ("DW_AT_string_length" , sym_natural_of_hex "0x19", [DWA_exprloc; DWA_loclistptr]) ; + ("DW_AT_common_reference" , sym_natural_of_hex "0x1a", [DWA_reference]) ; + ("DW_AT_comp_dir" , sym_natural_of_hex "0x1b", [DWA_string]) ; + ("DW_AT_const_value" , sym_natural_of_hex "0x1c", [DWA_block; DWA_constant; DWA_string]) ; + ("DW_AT_containing_type" , sym_natural_of_hex "0x1d", [DWA_reference]) ; + ("DW_AT_default_value" , sym_natural_of_hex "0x1e", [DWA_reference]) ; + ("DW_AT_inline" , sym_natural_of_hex "0x20", [DWA_constant]) ; + ("DW_AT_is_optional" , sym_natural_of_hex "0x21", [DWA_flag]) ; + ("DW_AT_lower_bound" , sym_natural_of_hex "0x22", [DWA_constant; DWA_exprloc; DWA_reference]) ; + ("DW_AT_producer" , sym_natural_of_hex "0x25", [DWA_string]) ; + ("DW_AT_prototyped" , sym_natural_of_hex "0x27", [DWA_flag]) ; + ("DW_AT_return_addr" , sym_natural_of_hex "0x2a", [DWA_exprloc; DWA_loclistptr]) ; + ("DW_AT_start_scope" , sym_natural_of_hex "0x2c", [DWA_constant; DWA_rangelistptr]) ; + ("DW_AT_bit_stride" , sym_natural_of_hex "0x2e", [DWA_constant; DWA_exprloc; DWA_reference]) ; + ("DW_AT_upper_bound" , sym_natural_of_hex "0x2f", [DWA_constant; DWA_exprloc; DWA_reference]) ; + ("DW_AT_abstract_origin" , sym_natural_of_hex "0x31", [DWA_reference]) ; + ("DW_AT_accessibility" , sym_natural_of_hex "0x32", [DWA_constant]) ; + ("DW_AT_address_class" , sym_natural_of_hex "0x33", [DWA_constant]) ; + ("DW_AT_artificial" , sym_natural_of_hex "0x34", [DWA_flag]) ; + ("DW_AT_base_types" , sym_natural_of_hex "0x35", [DWA_reference]) ; + ("DW_AT_calling_convention" , sym_natural_of_hex "0x36", [DWA_constant]) ; + ("DW_AT_count" , sym_natural_of_hex "0x37", [DWA_constant; DWA_exprloc; DWA_reference]) ; + ("DW_AT_data_member_location" , sym_natural_of_hex "0x38", [DWA_constant; DWA_exprloc; DWA_loclistptr]) ; + ("DW_AT_decl_column" , sym_natural_of_hex "0x39", [DWA_constant]) ; + ("DW_AT_decl_file" , sym_natural_of_hex "0x3a", [DWA_constant]) ; + ("DW_AT_decl_line" , sym_natural_of_hex "0x3b", [DWA_constant]) ; + ("DW_AT_declaration" , sym_natural_of_hex "0x3c", [DWA_flag]) ; + ("DW_AT_discr_list" , sym_natural_of_hex "0x3d", [DWA_block]) ; + ("DW_AT_encoding" , sym_natural_of_hex "0x3e", [DWA_constant]) ; + ("DW_AT_external" , sym_natural_of_hex "0x3f", [DWA_flag]) ; + ("DW_AT_frame_base" , sym_natural_of_hex "0x40", [DWA_exprloc; DWA_loclistptr]) ; + ("DW_AT_friend" , sym_natural_of_hex "0x41", [DWA_reference]) ; + ("DW_AT_identifier_case" , sym_natural_of_hex "0x42", [DWA_constant]) ; + ("DW_AT_macro_info" , sym_natural_of_hex "0x43", [DWA_macptr]) ; + ("DW_AT_namelist_item" , sym_natural_of_hex "0x44", [DWA_reference]) ; + ("DW_AT_priority" , sym_natural_of_hex "0x45", [DWA_reference]) ; + ("DW_AT_segment" , sym_natural_of_hex "0x46", [DWA_exprloc; DWA_loclistptr]) ; + ("DW_AT_specification" , sym_natural_of_hex "0x47", [DWA_reference]) ; + ("DW_AT_static_link" , sym_natural_of_hex "0x48", [DWA_exprloc; DWA_loclistptr]) ; + ("DW_AT_type" , sym_natural_of_hex "0x49", [DWA_reference]) ; + ("DW_AT_use_location" , sym_natural_of_hex "0x4a", [DWA_exprloc; DWA_loclistptr]) ; + ("DW_AT_variable_parameter" , sym_natural_of_hex "0x4b", [DWA_flag]) ; + ("DW_AT_virtuality" , sym_natural_of_hex "0x4c", [DWA_constant]) ; + ("DW_AT_vtable_elem_location" , sym_natural_of_hex "0x4d", [DWA_exprloc; DWA_loclistptr]) ; + ("DW_AT_allocated" , sym_natural_of_hex "0x4e", [DWA_constant; DWA_exprloc; DWA_reference]) ; + ("DW_AT_associated" , sym_natural_of_hex "0x4f", [DWA_constant; DWA_exprloc; DWA_reference]) ; + ("DW_AT_data_location" , sym_natural_of_hex "0x50", [DWA_exprloc]) ; + ("DW_AT_byte_stride" , sym_natural_of_hex "0x51", [DWA_constant; DWA_exprloc; DWA_reference]) ; + ("DW_AT_entry_pc" , sym_natural_of_hex "0x52", [DWA_address]) ; + ("DW_AT_use_UTF8" , sym_natural_of_hex "0x53", [DWA_flag]) ; + ("DW_AT_extension" , sym_natural_of_hex "0x54", [DWA_reference]) ; + ("DW_AT_ranges" , sym_natural_of_hex "0x55", [DWA_rangelistptr]) ; + ("DW_AT_trampoline" , sym_natural_of_hex "0x56", [DWA_address; DWA_flag; DWA_reference; DWA_string]); + ("DW_AT_call_column" , sym_natural_of_hex "0x57", [DWA_constant]) ; + ("DW_AT_call_file" , sym_natural_of_hex "0x58", [DWA_constant]) ; + ("DW_AT_call_line" , sym_natural_of_hex "0x59", [DWA_constant]) ; + ("DW_AT_description" , sym_natural_of_hex "0x5a", [DWA_string]) ; + ("DW_AT_binary_scale" , sym_natural_of_hex "0x5b", [DWA_constant]) ; + ("DW_AT_decimal_scale" , sym_natural_of_hex "0x5c", [DWA_constant]) ; + ("DW_AT_small" , sym_natural_of_hex "0x5d", [DWA_reference]) ; + ("DW_AT_decimal_sign" , sym_natural_of_hex "0x5e", [DWA_constant]) ; + ("DW_AT_digit_count" , sym_natural_of_hex "0x5f", [DWA_constant]) ; + ("DW_AT_picture_string" , sym_natural_of_hex "0x60", [DWA_string]) ; + ("DW_AT_mutable" , sym_natural_of_hex "0x61", [DWA_flag]) ; + ("DW_AT_threads_scaled" , sym_natural_of_hex "0x62", [DWA_flag]) ; + ("DW_AT_explicit" , sym_natural_of_hex "0x63", [DWA_flag]) ; + ("DW_AT_object_pointer" , sym_natural_of_hex "0x64", [DWA_reference]) ; + ("DW_AT_endianity" , sym_natural_of_hex "0x65", [DWA_constant]) ; + ("DW_AT_elemental" , sym_natural_of_hex "0x66", [DWA_flag]) ; + ("DW_AT_pure" , sym_natural_of_hex "0x67", [DWA_flag]) ; + ("DW_AT_recursive" , sym_natural_of_hex "0x68", [DWA_flag]) ; + ("DW_AT_signature" , sym_natural_of_hex "0x69", [DWA_reference]) ; + ("DW_AT_main_subprogram" , sym_natural_of_hex "0x6a", [DWA_flag]) ; + ("DW_AT_data_bit_offset" , sym_natural_of_hex "0x6b", [DWA_constant]) ; + ("DW_AT_const_expr" , sym_natural_of_hex "0x6c", [DWA_flag]) ; + ("DW_AT_enum_class" , sym_natural_of_hex "0x6d", [DWA_flag]) ; + ("DW_AT_linkage_name" , sym_natural_of_hex "0x6e", [DWA_string]) ; (* DW_AT_noreturn is a gcc extension to support the C11 _Noreturn keyword*) - ("DW_AT_noreturn" , natural_of_hex "0x87", [DWA_flag]) ; - ("DW_AT_alignment" , natural_of_hex "0x88", [DWA_constant]) ; - ("DW_AT_lo_user" , natural_of_hex "0x2000", [DWA_dash]) ; - ("DW_AT_hi_user" , natural_of_hex "0x3fff", [DWA_dash]) + ("DW_AT_noreturn" , sym_natural_of_hex "0x87", [DWA_flag]) ; + ("DW_AT_alignment" , sym_natural_of_hex "0x88", [DWA_constant]) ; + ("DW_AT_lo_user" , sym_natural_of_hex "0x2000", [DWA_dash]) ; + ("DW_AT_hi_user" , sym_natural_of_hex "0x3fff", [DWA_dash]) ] (* attribute form encoding *) let attribute_form_encodings = [ - ("DW_FORM_addr" , natural_of_hex "0x01", [DWA_address]) ; - ("DW_FORM_block2" , natural_of_hex "0x03", [DWA_block]) ; - ("DW_FORM_block4" , natural_of_hex "0x04", [DWA_block]) ; - ("DW_FORM_data2" , natural_of_hex "0x05", [DWA_constant]) ; - ("DW_FORM_data4" , natural_of_hex "0x06", [DWA_constant]) ; - ("DW_FORM_data8" , natural_of_hex "0x07", [DWA_constant]) ; - ("DW_FORM_string" , natural_of_hex "0x08", [DWA_string]) ; - ("DW_FORM_block" , natural_of_hex "0x09", [DWA_block]) ; - ("DW_FORM_block1" , natural_of_hex "0x0a", [DWA_block]) ; - ("DW_FORM_data1" , natural_of_hex "0x0b", [DWA_constant]) ; - ("DW_FORM_flag" , natural_of_hex "0x0c", [DWA_flag]) ; - ("DW_FORM_sdata" , natural_of_hex "0x0d", [DWA_constant]) ; - ("DW_FORM_strp" , natural_of_hex "0x0e", [DWA_string]) ; - ("DW_FORM_udata" , natural_of_hex "0x0f", [DWA_constant]) ; - ("DW_FORM_ref_addr" , natural_of_hex "0x10", [DWA_reference]); - ("DW_FORM_ref1" , natural_of_hex "0x11", [DWA_reference]); - ("DW_FORM_ref2" , natural_of_hex "0x12", [DWA_reference]); - ("DW_FORM_ref4" , natural_of_hex "0x13", [DWA_reference]); - ("DW_FORM_ref8" , natural_of_hex "0x14", [DWA_reference]); - ("DW_FORM_ref_udata" , natural_of_hex "0x15", [DWA_reference]); - ("DW_FORM_indirect" , natural_of_hex "0x16", [DWA_7_5_3]) ; - ("DW_FORM_sec_offset" , natural_of_hex "0x17", [DWA_lineptr; DWA_loclistptr; DWA_macptr; DWA_rangelistptr]) ; - ("DW_FORM_exprloc" , natural_of_hex "0x18", [DWA_exprloc]) ; - ("DW_FORM_flag_present", natural_of_hex "0x19", [DWA_flag]) ; - ("DW_FORM_ref_sig8" , natural_of_hex "0x20", [DWA_reference]) + ("DW_FORM_addr" , sym_natural_of_hex "0x01", [DWA_address]) ; + ("DW_FORM_block2" , sym_natural_of_hex "0x03", [DWA_block]) ; + ("DW_FORM_block4" , sym_natural_of_hex "0x04", [DWA_block]) ; + ("DW_FORM_data2" , sym_natural_of_hex "0x05", [DWA_constant]) ; + ("DW_FORM_data4" , sym_natural_of_hex "0x06", [DWA_constant]) ; + ("DW_FORM_data8" , sym_natural_of_hex "0x07", [DWA_constant]) ; + ("DW_FORM_string" , sym_natural_of_hex "0x08", [DWA_string]) ; + ("DW_FORM_block" , sym_natural_of_hex "0x09", [DWA_block]) ; + ("DW_FORM_block1" , sym_natural_of_hex "0x0a", [DWA_block]) ; + ("DW_FORM_data1" , sym_natural_of_hex "0x0b", [DWA_constant]) ; + ("DW_FORM_flag" , sym_natural_of_hex "0x0c", [DWA_flag]) ; + ("DW_FORM_sdata" , sym_natural_of_hex "0x0d", [DWA_constant]) ; + ("DW_FORM_strp" , sym_natural_of_hex "0x0e", [DWA_string]) ; + ("DW_FORM_udata" , sym_natural_of_hex "0x0f", [DWA_constant]) ; + ("DW_FORM_ref_addr" , sym_natural_of_hex "0x10", [DWA_reference]); + ("DW_FORM_ref1" , sym_natural_of_hex "0x11", [DWA_reference]); + ("DW_FORM_ref2" , sym_natural_of_hex "0x12", [DWA_reference]); + ("DW_FORM_ref4" , sym_natural_of_hex "0x13", [DWA_reference]); + ("DW_FORM_ref8" , sym_natural_of_hex "0x14", [DWA_reference]); + ("DW_FORM_ref_udata" , sym_natural_of_hex "0x15", [DWA_reference]); + ("DW_FORM_indirect" , sym_natural_of_hex "0x16", [DWA_7_5_3]) ; + ("DW_FORM_sec_offset" , sym_natural_of_hex "0x17", [DWA_lineptr; DWA_loclistptr; DWA_macptr; DWA_rangelistptr]) ; + ("DW_FORM_exprloc" , sym_natural_of_hex "0x18", [DWA_exprloc]) ; + ("DW_FORM_flag_present", sym_natural_of_hex "0x19", [DWA_flag]) ; + ("DW_FORM_ref_sig8" , sym_natural_of_hex "0x20", [DWA_reference]) ] (* operation encoding *) let operation_encodings = [ -("DW_OP_addr", natural_of_hex "0x03", [OAT_addr] , OpSem_lit); (*1*) (*constant address (size target specific)*) -("DW_OP_deref", natural_of_hex "0x06", [] , OpSem_deref); (*0*) -("DW_OP_const1u", natural_of_hex "0x08", [OAT_uint8] , OpSem_lit); (*1*) (* 1-byte constant *) -("DW_OP_const1s", natural_of_hex "0x09", [OAT_sint8] , OpSem_lit); (*1*) (* 1-byte constant *) -("DW_OP_const2u", natural_of_hex "0x0a", [OAT_uint16] , OpSem_lit); (*1*) (* 2-byte constant *) -("DW_OP_const2s", natural_of_hex "0x0b", [OAT_sint16] , OpSem_lit); (*1*) (* 2-byte constant *) -("DW_OP_const4u", natural_of_hex "0x0c", [OAT_uint32] , OpSem_lit); (*1*) (* 4-byte constant *) -("DW_OP_const4s", natural_of_hex "0x0d", [OAT_sint32] , OpSem_lit); (*1*) (* 4-byte constant *) -("DW_OP_const8u", natural_of_hex "0x0e", [OAT_uint64] , OpSem_lit); (*1*) (* 8-byte constant *) -("DW_OP_const8s", natural_of_hex "0x0f", [OAT_sint64] , OpSem_lit); (*1*) (* 8-byte constant *) -("DW_OP_constu", natural_of_hex "0x10", [OAT_ULEB128] , OpSem_lit); (*1*) (* ULEB128 constant *) -("DW_OP_consts", natural_of_hex "0x11", [OAT_SLEB128] , OpSem_lit); (*1*) (* SLEB128 constant *) -("DW_OP_dup", natural_of_hex "0x12", [] , OpSem_stack (fun ac vs args -> match vs with v::vs -> Just (v::v::vs) | _ -> Nothing end)); (*0*) -("DW_OP_drop", natural_of_hex "0x13", [] , OpSem_stack (fun ac vs args -> match vs with v::vs -> Just vs | _ -> Nothing end)); (*0*) -("DW_OP_over", natural_of_hex "0x14", [] , OpSem_stack (fun ac vs args -> match vs with v::v'::vs -> Just (v'::v::v'::vs) | _ -> Nothing end)); (*0*) -("DW_OP_pick", natural_of_hex "0x15", [OAT_uint8] , OpSem_stack (fun ac vs args -> match args with [OAV_natural n] -> match index_sym_natural vs n with Just v -> Just (v::vs) | Nothing -> Nothing end | _ -> Nothing end)); (*1*) (* 1-byte stack index *) -("DW_OP_swap", natural_of_hex "0x16", [] , OpSem_stack (fun ac vs args -> match vs with v::v'::vs -> Just (v'::v::vs) | _ -> Nothing end)); (*0*) -("DW_OP_rot", natural_of_hex "0x17", [] , OpSem_stack (fun ac vs args -> match vs with v::v'::v''::vs -> Just (v'::v''::v::vs) | _ -> Nothing end)); (*0*) -("DW_OP_xderef", natural_of_hex "0x18", [] , OpSem_not_supported); (*0*) -("DW_OP_abs", natural_of_hex "0x19", [] , OpSem_unary (fun ac v -> if v < ac.ac_half then Just v else if v=ac.ac_max then Nothing else Just (ac.ac_all-v))); (*0*) -("DW_OP_and", natural_of_hex "0x1a", [] , OpSem_binary (fun ac v1 v2 -> Just (sym_natural_land v1 v2))); (*0*) -("DW_OP_div", natural_of_hex "0x1b", [] , OpSem_not_supported) (*TODO*); (*0*) -("DW_OP_minus", natural_of_hex "0x1c", [] , OpSem_binary (fun ac v1 v2 -> Just (partialSymNaturalFromInteger ((integerFromSymNatural v1 - integerFromSymNatural v2) mod (integerFromSymNatural ac.ac_all))))); (*0*) -("DW_OP_mod", natural_of_hex "0x1d", [] , OpSem_binary (fun ac v1 v2 -> Just (v1 mod v2))); (*0*) -("DW_OP_mul", natural_of_hex "0x1e", [] , OpSem_binary (fun ac v1 v2 -> Just (partialSymNaturalFromInteger ((integerFromSymNatural v1 * integerFromSymNatural v2) mod (integerFromSymNatural ac.ac_all))))); (*0*) -("DW_OP_neg", natural_of_hex "0x1f", [] , OpSem_unary (fun ac v -> if v < ac.ac_half then Just (ac.ac_max - v) else if v=ac.ac_half then Nothing else Just (ac.ac_all - v))); (*0*) -("DW_OP_not", natural_of_hex "0x20", [] , OpSem_unary (fun ac v -> Just (sym_natural_lxor v ac.ac_max))); (*0*) -("DW_OP_or", natural_of_hex "0x21", [] , OpSem_binary (fun ac v1 v2 -> Just (sym_natural_lor v1 v2))); (*0*) -("DW_OP_plus", natural_of_hex "0x22", [] , OpSem_binary (fun ac v1 v2 -> Just ((v1 + v2) mod ac.ac_all))); (*0*) -("DW_OP_plus_uconst", natural_of_hex "0x23", [OAT_ULEB128] , OpSem_stack (fun ac vs args -> match args with [OAV_natural n] -> match vs with v::vs' -> let v' = (v+n) mod ac.ac_all in Just (v'::vs) | [] -> Nothing end | _ -> Nothing end)); (*1*) (* ULEB128 addend *) -("DW_OP_shl", natural_of_hex "0x24", [] , OpSem_binary (fun ac v1 v2 -> if v2 >= ac.ac_bitwidth then Just 0 else Just (sym_natural_nat_shift_left v1 (natFromSymNatural v2)))); (*0*) -("DW_OP_shr", natural_of_hex "0x25", [] , OpSem_binary (fun ac v1 v2 -> if v2 >= ac.ac_bitwidth then Just 0 else Just (sym_natural_nat_shift_right v1 (natFromSymNatural v2)))); (*0*) -("DW_OP_shra", natural_of_hex "0x26", [] , OpSem_binary (fun ac v1 v2 -> if v1 < ac.ac_half then (if v2 >= ac.ac_bitwidth then Just 0 else Just (sym_natural_nat_shift_right v1 (natFromSymNatural v2))) else (if v2 >= ac.ac_bitwidth then Just ac.ac_max else Just (ac.ac_max - (sym_natural_nat_shift_right (ac.ac_max - v1) (natFromSymNatural v2)))))); (*0*) -("DW_OP_xor", natural_of_hex "0x27", [] , OpSem_binary (fun ac v1 v2 -> Just (sym_natural_lxor v1 v2))); (*0*) -("DW_OP_skip", natural_of_hex "0x2f", [OAT_sint16] , OpSem_not_supported); (*1*) (* signed 2-byte constant *) -("DW_OP_bra", natural_of_hex "0x28", [OAT_sint16] , OpSem_not_supported); (*1*) (* signed 2-byte constant *) -("DW_OP_eq", natural_of_hex "0x29", [] , OpSem_not_supported); (*0*) -("DW_OP_ge", natural_of_hex "0x2a", [] , OpSem_not_supported); (*0*) -("DW_OP_gt", natural_of_hex "0x2b", [] , OpSem_not_supported); (*0*) -("DW_OP_le", natural_of_hex "0x2c", [] , OpSem_not_supported); (*0*) -("DW_OP_lt", natural_of_hex "0x2d", [] , OpSem_not_supported); (*0*) -("DW_OP_ne", natural_of_hex "0x2e", [] , OpSem_not_supported); (*0*) -("DW_OP_lit0", natural_of_hex "0x30", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) (* literals 0..31 =(DW_OP_lit0 + literal) *) -("DW_OP_lit1", natural_of_hex "0x31", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit2", natural_of_hex "0x32", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit3", natural_of_hex "0x33", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit4", natural_of_hex "0x34", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit5", natural_of_hex "0x35", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit6", natural_of_hex "0x36", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit7", natural_of_hex "0x37", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit8", natural_of_hex "0x38", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit9", natural_of_hex "0x39", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit10", natural_of_hex "0x3a", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit11", natural_of_hex "0x3b", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit12", natural_of_hex "0x3c", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit13", natural_of_hex "0x3d", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit14", natural_of_hex "0x3e", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit15", natural_of_hex "0x3f", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit16", natural_of_hex "0x40", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit17", natural_of_hex "0x41", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit18", natural_of_hex "0x42", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit19", natural_of_hex "0x43", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit20", natural_of_hex "0x44", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit21", natural_of_hex "0x45", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit22", natural_of_hex "0x46", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit23", natural_of_hex "0x47", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit24", natural_of_hex "0x48", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit25", natural_of_hex "0x49", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit26", natural_of_hex "0x4a", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit27", natural_of_hex "0x4b", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit28", natural_of_hex "0x4c", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit29", natural_of_hex "0x4d", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit30", natural_of_hex "0x4e", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_lit31", natural_of_hex "0x4f", [] , OpSem_opcode_lit (natural_of_hex "0x30")); (*0*) -("DW_OP_reg0", natural_of_hex "0x50", [] , OpSem_reg); (*1*) (* reg 0..31 = (DW_OP_reg0 + regnum) *) -("DW_OP_reg1", natural_of_hex "0x51", [] , OpSem_reg); (*1*) -("DW_OP_reg2", natural_of_hex "0x52", [] , OpSem_reg); (*1*) -("DW_OP_reg3", natural_of_hex "0x53", [] , OpSem_reg); (*1*) -("DW_OP_reg4", natural_of_hex "0x54", [] , OpSem_reg); (*1*) -("DW_OP_reg5", natural_of_hex "0x55", [] , OpSem_reg); (*1*) -("DW_OP_reg6", natural_of_hex "0x56", [] , OpSem_reg); (*1*) -("DW_OP_reg7", natural_of_hex "0x57", [] , OpSem_reg); (*1*) -("DW_OP_reg8", natural_of_hex "0x58", [] , OpSem_reg); (*1*) -("DW_OP_reg9", natural_of_hex "0x59", [] , OpSem_reg); (*1*) -("DW_OP_reg10", natural_of_hex "0x5a", [] , OpSem_reg); (*1*) -("DW_OP_reg11", natural_of_hex "0x5b", [] , OpSem_reg); (*1*) -("DW_OP_reg12", natural_of_hex "0x5c", [] , OpSem_reg); (*1*) -("DW_OP_reg13", natural_of_hex "0x5d", [] , OpSem_reg); (*1*) -("DW_OP_reg14", natural_of_hex "0x5e", [] , OpSem_reg); (*1*) -("DW_OP_reg15", natural_of_hex "0x5f", [] , OpSem_reg); (*1*) -("DW_OP_reg16", natural_of_hex "0x60", [] , OpSem_reg); (*1*) -("DW_OP_reg17", natural_of_hex "0x61", [] , OpSem_reg); (*1*) -("DW_OP_reg18", natural_of_hex "0x62", [] , OpSem_reg); (*1*) -("DW_OP_reg19", natural_of_hex "0x63", [] , OpSem_reg); (*1*) -("DW_OP_reg20", natural_of_hex "0x64", [] , OpSem_reg); (*1*) -("DW_OP_reg21", natural_of_hex "0x65", [] , OpSem_reg); (*1*) -("DW_OP_reg22", natural_of_hex "0x66", [] , OpSem_reg); (*1*) -("DW_OP_reg23", natural_of_hex "0x67", [] , OpSem_reg); (*1*) -("DW_OP_reg24", natural_of_hex "0x68", [] , OpSem_reg); (*1*) -("DW_OP_reg25", natural_of_hex "0x69", [] , OpSem_reg); (*1*) -("DW_OP_reg26", natural_of_hex "0x6a", [] , OpSem_reg); (*1*) -("DW_OP_reg27", natural_of_hex "0x6b", [] , OpSem_reg); (*1*) -("DW_OP_reg28", natural_of_hex "0x6c", [] , OpSem_reg); (*1*) -("DW_OP_reg29", natural_of_hex "0x6d", [] , OpSem_reg); (*1*) -("DW_OP_reg30", natural_of_hex "0x6e", [] , OpSem_reg); (*1*) -("DW_OP_reg31", natural_of_hex "0x6f", [] , OpSem_reg); (*1*) -("DW_OP_breg0", natural_of_hex "0x70", [OAT_SLEB128] , OpSem_breg); (*1*) (* base register 0..31 = (DW_OP_breg0 + regnum) *) -("DW_OP_breg1", natural_of_hex "0x71", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg2", natural_of_hex "0x72", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg3", natural_of_hex "0x73", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg4", natural_of_hex "0x74", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg5", natural_of_hex "0x75", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg6", natural_of_hex "0x76", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg7", natural_of_hex "0x77", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg8", natural_of_hex "0x78", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg9", natural_of_hex "0x79", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg10", natural_of_hex "0x7a", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg11", natural_of_hex "0x7b", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg12", natural_of_hex "0x7c", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg13", natural_of_hex "0x7d", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg14", natural_of_hex "0x7e", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg15", natural_of_hex "0x7f", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg16", natural_of_hex "0x80", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg17", natural_of_hex "0x81", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg18", natural_of_hex "0x82", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg19", natural_of_hex "0x83", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg20", natural_of_hex "0x84", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg21", natural_of_hex "0x85", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg22", natural_of_hex "0x86", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg23", natural_of_hex "0x87", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg24", natural_of_hex "0x88", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg25", natural_of_hex "0x89", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg26", natural_of_hex "0x8a", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg27", natural_of_hex "0x8b", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg28", natural_of_hex "0x8c", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg29", natural_of_hex "0x8d", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg30", natural_of_hex "0x8e", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_breg31", natural_of_hex "0x8f", [OAT_SLEB128] , OpSem_breg); (*1*) -("DW_OP_regx", natural_of_hex "0x90", [OAT_ULEB128] , OpSem_lit); (*1*) (* ULEB128 register *) -("DW_OP_fbreg", natural_of_hex "0x91", [OAT_SLEB128] , OpSem_fbreg); (*1*) (* SLEB128 offset *) -("DW_OP_bregx", natural_of_hex "0x92", [OAT_ULEB128; OAT_SLEB128] , OpSem_bregx); (*2*) (* ULEB128 register followed by SLEB128 offset *) -("DW_OP_piece", natural_of_hex "0x93", [OAT_ULEB128] , OpSem_piece); (*1*) (* ULEB128 size of piece addressed *) -("DW_OP_deref_size", natural_of_hex "0x94", [OAT_uint8] , OpSem_deref_size); (*1*) (* 1-byte size of data retrieved *) -("DW_OP_xderef_size", natural_of_hex "0x95", [OAT_uint8] , OpSem_not_supported); (*1*) (* 1-byte size of data retrieved *) -("DW_OP_nop", natural_of_hex "0x96", [] , OpSem_nop); (*0*) -("DW_OP_push_object_address", natural_of_hex "0x97", [] , OpSem_not_supported); (*0*) -("DW_OP_call2", natural_of_hex "0x98", [OAT_uint16] , OpSem_not_supported); (*1*) (* 2-byte offset of DIE *) -("DW_OP_call4", natural_of_hex "0x99", [OAT_uint32] , OpSem_not_supported); (*1*) (* 4-byte offset of DIE *) -("DW_OP_call_ref", natural_of_hex "0x9a", [OAT_dwarf_format_t] , OpSem_not_supported); (*1*) (* 4- or 8-byte offset of DIE *) -("DW_OP_form_tls_address", natural_of_hex "0x9b", [] , OpSem_not_supported); (*0*) -("DW_OP_call_frame_cfa", natural_of_hex "0x9c", [] , OpSem_call_frame_cfa); (*0*) -("DW_OP_bit_piece", natural_of_hex "0x9d", [OAT_ULEB128; OAT_ULEB128] , OpSem_bit_piece); (*2*) (* ULEB128 size followed by ULEB128 offset *) -("DW_OP_implicit_value", natural_of_hex "0x9e", [OAT_block] , OpSem_implicit_value); (*2*) (* ULEB128 size followed by block of that size *) -("DW_OP_stack_value", natural_of_hex "0x9f", [] , OpSem_stack_value); (*0*) +("DW_OP_addr", sym_natural_of_hex "0x03", [OAT_addr] , OpSem_lit); (*1*) (*constant address (size target specific)*) +("DW_OP_deref", sym_natural_of_hex "0x06", [] , OpSem_deref); (*0*) +("DW_OP_const1u", sym_natural_of_hex "0x08", [OAT_uint8] , OpSem_lit); (*1*) (* 1-byte constant *) +("DW_OP_const1s", sym_natural_of_hex "0x09", [OAT_sint8] , OpSem_lit); (*1*) (* 1-byte constant *) +("DW_OP_const2u", sym_natural_of_hex "0x0a", [OAT_uint16] , OpSem_lit); (*1*) (* 2-byte constant *) +("DW_OP_const2s", sym_natural_of_hex "0x0b", [OAT_sint16] , OpSem_lit); (*1*) (* 2-byte constant *) +("DW_OP_const4u", sym_natural_of_hex "0x0c", [OAT_uint32] , OpSem_lit); (*1*) (* 4-byte constant *) +("DW_OP_const4s", sym_natural_of_hex "0x0d", [OAT_sint32] , OpSem_lit); (*1*) (* 4-byte constant *) +("DW_OP_const8u", sym_natural_of_hex "0x0e", [OAT_uint64] , OpSem_lit); (*1*) (* 8-byte constant *) +("DW_OP_const8s", sym_natural_of_hex "0x0f", [OAT_sint64] , OpSem_lit); (*1*) (* 8-byte constant *) +("DW_OP_constu", sym_natural_of_hex "0x10", [OAT_ULEB128] , OpSem_lit); (*1*) (* ULEB128 constant *) +("DW_OP_consts", sym_natural_of_hex "0x11", [OAT_SLEB128] , OpSem_lit); (*1*) (* SLEB128 constant *) +("DW_OP_dup", sym_natural_of_hex "0x12", [] , OpSem_stack (fun ac vs args -> match vs with v::vs -> Just (v::v::vs) | _ -> Nothing end)); (*0*) +("DW_OP_drop", sym_natural_of_hex "0x13", [] , OpSem_stack (fun ac vs args -> match vs with v::vs -> Just vs | _ -> Nothing end)); (*0*) +("DW_OP_over", sym_natural_of_hex "0x14", [] , OpSem_stack (fun ac vs args -> match vs with v::v'::vs -> Just (v'::v::v'::vs) | _ -> Nothing end)); (*0*) +("DW_OP_pick", sym_natural_of_hex "0x15", [OAT_uint8] , OpSem_stack (fun ac vs args -> match args with [OAV_natural n] -> match index_sym_natural vs n with Just v -> Just (v::vs) | Nothing -> Nothing end | _ -> Nothing end)); (*1*) (* 1-byte stack index *) +("DW_OP_swap", sym_natural_of_hex "0x16", [] , OpSem_stack (fun ac vs args -> match vs with v::v'::vs -> Just (v'::v::vs) | _ -> Nothing end)); (*0*) +("DW_OP_rot", sym_natural_of_hex "0x17", [] , OpSem_stack (fun ac vs args -> match vs with v::v'::v''::vs -> Just (v'::v''::v::vs) | _ -> Nothing end)); (*0*) +("DW_OP_xderef", sym_natural_of_hex "0x18", [] , OpSem_not_supported); (*0*) +("DW_OP_abs", sym_natural_of_hex "0x19", [] , OpSem_unary (fun ac v -> if v < ac.ac_half then Just v else if v=ac.ac_max then Nothing else Just (ac.ac_all-v))); (*0*) +("DW_OP_and", sym_natural_of_hex "0x1a", [] , OpSem_binary (fun ac v1 v2 -> Just (sym_natural_land v1 v2))); (*0*) +("DW_OP_div", sym_natural_of_hex "0x1b", [] , OpSem_not_supported) (*TODO*); (*0*) +("DW_OP_minus", sym_natural_of_hex "0x1c", [] , OpSem_binary (fun ac v1 v2 -> Just (partialSymNaturalFromInteger ((integerFromSymNatural v1 - integerFromSymNatural v2) mod (integerFromSymNatural ac.ac_all))))); (*0*) +("DW_OP_mod", sym_natural_of_hex "0x1d", [] , OpSem_binary (fun ac v1 v2 -> Just (v1 mod v2))); (*0*) +("DW_OP_mul", sym_natural_of_hex "0x1e", [] , OpSem_binary (fun ac v1 v2 -> Just (partialSymNaturalFromInteger ((integerFromSymNatural v1 * integerFromSymNatural v2) mod (integerFromSymNatural ac.ac_all))))); (*0*) +("DW_OP_neg", sym_natural_of_hex "0x1f", [] , OpSem_unary (fun ac v -> if v < ac.ac_half then Just (ac.ac_max - v) else if v=ac.ac_half then Nothing else Just (ac.ac_all - v))); (*0*) +("DW_OP_not", sym_natural_of_hex "0x20", [] , OpSem_unary (fun ac v -> Just (sym_natural_lxor v ac.ac_max))); (*0*) +("DW_OP_or", sym_natural_of_hex "0x21", [] , OpSem_binary (fun ac v1 v2 -> Just (sym_natural_lor v1 v2))); (*0*) +("DW_OP_plus", sym_natural_of_hex "0x22", [] , OpSem_binary (fun ac v1 v2 -> Just ((v1 + v2) mod ac.ac_all))); (*0*) +("DW_OP_plus_uconst", sym_natural_of_hex "0x23", [OAT_ULEB128] , OpSem_stack (fun ac vs args -> match args with [OAV_natural n] -> match vs with v::vs' -> let v' = (v+n) mod ac.ac_all in Just (v'::vs) | [] -> Nothing end | _ -> Nothing end)); (*1*) (* ULEB128 addend *) +("DW_OP_shl", sym_natural_of_hex "0x24", [] , OpSem_binary (fun ac v1 v2 -> if v2 >= ac.ac_bitwidth then Just 0 else Just (sym_natural_nat_shift_left v1 (natFromSymNatural v2)))); (*0*) +("DW_OP_shr", sym_natural_of_hex "0x25", [] , OpSem_binary (fun ac v1 v2 -> if v2 >= ac.ac_bitwidth then Just 0 else Just (sym_natural_nat_shift_right v1 (natFromSymNatural v2)))); (*0*) +("DW_OP_shra", sym_natural_of_hex "0x26", [] , OpSem_binary (fun ac v1 v2 -> if v1 < ac.ac_half then (if v2 >= ac.ac_bitwidth then Just 0 else Just (sym_natural_nat_shift_right v1 (natFromSymNatural v2))) else (if v2 >= ac.ac_bitwidth then Just ac.ac_max else Just (ac.ac_max - (sym_natural_nat_shift_right (ac.ac_max - v1) (natFromSymNatural v2)))))); (*0*) +("DW_OP_xor", sym_natural_of_hex "0x27", [] , OpSem_binary (fun ac v1 v2 -> Just (sym_natural_lxor v1 v2))); (*0*) +("DW_OP_skip", sym_natural_of_hex "0x2f", [OAT_sint16] , OpSem_not_supported); (*1*) (* signed 2-byte constant *) +("DW_OP_bra", sym_natural_of_hex "0x28", [OAT_sint16] , OpSem_not_supported); (*1*) (* signed 2-byte constant *) +("DW_OP_eq", sym_natural_of_hex "0x29", [] , OpSem_not_supported); (*0*) +("DW_OP_ge", sym_natural_of_hex "0x2a", [] , OpSem_not_supported); (*0*) +("DW_OP_gt", sym_natural_of_hex "0x2b", [] , OpSem_not_supported); (*0*) +("DW_OP_le", sym_natural_of_hex "0x2c", [] , OpSem_not_supported); (*0*) +("DW_OP_lt", sym_natural_of_hex "0x2d", [] , OpSem_not_supported); (*0*) +("DW_OP_ne", sym_natural_of_hex "0x2e", [] , OpSem_not_supported); (*0*) +("DW_OP_lit0", sym_natural_of_hex "0x30", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) (* literals 0..31 =(DW_OP_lit0 + literal) *) +("DW_OP_lit1", sym_natural_of_hex "0x31", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit2", sym_natural_of_hex "0x32", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit3", sym_natural_of_hex "0x33", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit4", sym_natural_of_hex "0x34", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit5", sym_natural_of_hex "0x35", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit6", sym_natural_of_hex "0x36", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit7", sym_natural_of_hex "0x37", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit8", sym_natural_of_hex "0x38", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit9", sym_natural_of_hex "0x39", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit10", sym_natural_of_hex "0x3a", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit11", sym_natural_of_hex "0x3b", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit12", sym_natural_of_hex "0x3c", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit13", sym_natural_of_hex "0x3d", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit14", sym_natural_of_hex "0x3e", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit15", sym_natural_of_hex "0x3f", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit16", sym_natural_of_hex "0x40", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit17", sym_natural_of_hex "0x41", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit18", sym_natural_of_hex "0x42", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit19", sym_natural_of_hex "0x43", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit20", sym_natural_of_hex "0x44", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit21", sym_natural_of_hex "0x45", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit22", sym_natural_of_hex "0x46", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit23", sym_natural_of_hex "0x47", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit24", sym_natural_of_hex "0x48", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit25", sym_natural_of_hex "0x49", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit26", sym_natural_of_hex "0x4a", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit27", sym_natural_of_hex "0x4b", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit28", sym_natural_of_hex "0x4c", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit29", sym_natural_of_hex "0x4d", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit30", sym_natural_of_hex "0x4e", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_lit31", sym_natural_of_hex "0x4f", [] , OpSem_opcode_lit (sym_natural_of_hex "0x30")); (*0*) +("DW_OP_reg0", sym_natural_of_hex "0x50", [] , OpSem_reg); (*1*) (* reg 0..31 = (DW_OP_reg0 + regnum) *) +("DW_OP_reg1", sym_natural_of_hex "0x51", [] , OpSem_reg); (*1*) +("DW_OP_reg2", sym_natural_of_hex "0x52", [] , OpSem_reg); (*1*) +("DW_OP_reg3", sym_natural_of_hex "0x53", [] , OpSem_reg); (*1*) +("DW_OP_reg4", sym_natural_of_hex "0x54", [] , OpSem_reg); (*1*) +("DW_OP_reg5", sym_natural_of_hex "0x55", [] , OpSem_reg); (*1*) +("DW_OP_reg6", sym_natural_of_hex "0x56", [] , OpSem_reg); (*1*) +("DW_OP_reg7", sym_natural_of_hex "0x57", [] , OpSem_reg); (*1*) +("DW_OP_reg8", sym_natural_of_hex "0x58", [] , OpSem_reg); (*1*) +("DW_OP_reg9", sym_natural_of_hex "0x59", [] , OpSem_reg); (*1*) +("DW_OP_reg10", sym_natural_of_hex "0x5a", [] , OpSem_reg); (*1*) +("DW_OP_reg11", sym_natural_of_hex "0x5b", [] , OpSem_reg); (*1*) +("DW_OP_reg12", sym_natural_of_hex "0x5c", [] , OpSem_reg); (*1*) +("DW_OP_reg13", sym_natural_of_hex "0x5d", [] , OpSem_reg); (*1*) +("DW_OP_reg14", sym_natural_of_hex "0x5e", [] , OpSem_reg); (*1*) +("DW_OP_reg15", sym_natural_of_hex "0x5f", [] , OpSem_reg); (*1*) +("DW_OP_reg16", sym_natural_of_hex "0x60", [] , OpSem_reg); (*1*) +("DW_OP_reg17", sym_natural_of_hex "0x61", [] , OpSem_reg); (*1*) +("DW_OP_reg18", sym_natural_of_hex "0x62", [] , OpSem_reg); (*1*) +("DW_OP_reg19", sym_natural_of_hex "0x63", [] , OpSem_reg); (*1*) +("DW_OP_reg20", sym_natural_of_hex "0x64", [] , OpSem_reg); (*1*) +("DW_OP_reg21", sym_natural_of_hex "0x65", [] , OpSem_reg); (*1*) +("DW_OP_reg22", sym_natural_of_hex "0x66", [] , OpSem_reg); (*1*) +("DW_OP_reg23", sym_natural_of_hex "0x67", [] , OpSem_reg); (*1*) +("DW_OP_reg24", sym_natural_of_hex "0x68", [] , OpSem_reg); (*1*) +("DW_OP_reg25", sym_natural_of_hex "0x69", [] , OpSem_reg); (*1*) +("DW_OP_reg26", sym_natural_of_hex "0x6a", [] , OpSem_reg); (*1*) +("DW_OP_reg27", sym_natural_of_hex "0x6b", [] , OpSem_reg); (*1*) +("DW_OP_reg28", sym_natural_of_hex "0x6c", [] , OpSem_reg); (*1*) +("DW_OP_reg29", sym_natural_of_hex "0x6d", [] , OpSem_reg); (*1*) +("DW_OP_reg30", sym_natural_of_hex "0x6e", [] , OpSem_reg); (*1*) +("DW_OP_reg31", sym_natural_of_hex "0x6f", [] , OpSem_reg); (*1*) +("DW_OP_breg0", sym_natural_of_hex "0x70", [OAT_SLEB128] , OpSem_breg); (*1*) (* base register 0..31 = (DW_OP_breg0 + regnum) *) +("DW_OP_breg1", sym_natural_of_hex "0x71", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg2", sym_natural_of_hex "0x72", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg3", sym_natural_of_hex "0x73", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg4", sym_natural_of_hex "0x74", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg5", sym_natural_of_hex "0x75", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg6", sym_natural_of_hex "0x76", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg7", sym_natural_of_hex "0x77", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg8", sym_natural_of_hex "0x78", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg9", sym_natural_of_hex "0x79", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg10", sym_natural_of_hex "0x7a", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg11", sym_natural_of_hex "0x7b", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg12", sym_natural_of_hex "0x7c", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg13", sym_natural_of_hex "0x7d", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg14", sym_natural_of_hex "0x7e", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg15", sym_natural_of_hex "0x7f", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg16", sym_natural_of_hex "0x80", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg17", sym_natural_of_hex "0x81", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg18", sym_natural_of_hex "0x82", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg19", sym_natural_of_hex "0x83", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg20", sym_natural_of_hex "0x84", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg21", sym_natural_of_hex "0x85", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg22", sym_natural_of_hex "0x86", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg23", sym_natural_of_hex "0x87", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg24", sym_natural_of_hex "0x88", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg25", sym_natural_of_hex "0x89", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg26", sym_natural_of_hex "0x8a", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg27", sym_natural_of_hex "0x8b", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg28", sym_natural_of_hex "0x8c", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg29", sym_natural_of_hex "0x8d", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg30", sym_natural_of_hex "0x8e", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_breg31", sym_natural_of_hex "0x8f", [OAT_SLEB128] , OpSem_breg); (*1*) +("DW_OP_regx", sym_natural_of_hex "0x90", [OAT_ULEB128] , OpSem_lit); (*1*) (* ULEB128 register *) +("DW_OP_fbreg", sym_natural_of_hex "0x91", [OAT_SLEB128] , OpSem_fbreg); (*1*) (* SLEB128 offset *) +("DW_OP_bregx", sym_natural_of_hex "0x92", [OAT_ULEB128; OAT_SLEB128] , OpSem_bregx); (*2*) (* ULEB128 register followed by SLEB128 offset *) +("DW_OP_piece", sym_natural_of_hex "0x93", [OAT_ULEB128] , OpSem_piece); (*1*) (* ULEB128 size of piece addressed *) +("DW_OP_deref_size", sym_natural_of_hex "0x94", [OAT_uint8] , OpSem_deref_size); (*1*) (* 1-byte size of data retrieved *) +("DW_OP_xderef_size", sym_natural_of_hex "0x95", [OAT_uint8] , OpSem_not_supported); (*1*) (* 1-byte size of data retrieved *) +("DW_OP_nop", sym_natural_of_hex "0x96", [] , OpSem_nop); (*0*) +("DW_OP_push_object_address", sym_natural_of_hex "0x97", [] , OpSem_not_supported); (*0*) +("DW_OP_call2", sym_natural_of_hex "0x98", [OAT_uint16] , OpSem_not_supported); (*1*) (* 2-byte offset of DIE *) +("DW_OP_call4", sym_natural_of_hex "0x99", [OAT_uint32] , OpSem_not_supported); (*1*) (* 4-byte offset of DIE *) +("DW_OP_call_ref", sym_natural_of_hex "0x9a", [OAT_dwarf_format_t] , OpSem_not_supported); (*1*) (* 4- or 8-byte offset of DIE *) +("DW_OP_form_tls_address", sym_natural_of_hex "0x9b", [] , OpSem_not_supported); (*0*) +("DW_OP_call_frame_cfa", sym_natural_of_hex "0x9c", [] , OpSem_call_frame_cfa); (*0*) +("DW_OP_bit_piece", sym_natural_of_hex "0x9d", [OAT_ULEB128; OAT_ULEB128] , OpSem_bit_piece); (*2*) (* ULEB128 size followed by ULEB128 offset *) +("DW_OP_implicit_value", sym_natural_of_hex "0x9e", [OAT_block] , OpSem_implicit_value); (*2*) (* ULEB128 size followed by block of that size *) +("DW_OP_stack_value", sym_natural_of_hex "0x9f", [] , OpSem_stack_value); (*0*) (* these aren't real operations -("DW_OP_lo_user", natural_of_hex "0xe0", [] , ); -("DW_OP_hi_user", natural_of_hex "0xff", [] , ); +("DW_OP_lo_user", sym_natural_of_hex "0xe0", [] , ); +("DW_OP_hi_user", sym_natural_of_hex "0xff", [] , ); *) (* GCC also produces these for our example: https://fedorahosted.org/elfutils/wiki/DwarfExtensions http://dwarfstd.org/ShowIssue.php?issue=100909.1 *) -("DW_GNU_OP_entry_value", natural_of_hex "0xf3", [OAT_block], OpSem_not_supported); (*2*) (* ULEB128 size followed by DWARF expression block of that size*) -("DW_OP_GNU_implicit_pointer", natural_of_hex "0xf2", [OAT_dwarf_format_t;OAT_SLEB128], OpSem_not_supported) +("DW_GNU_OP_entry_value", sym_natural_of_hex "0xf3", [OAT_block], OpSem_not_supported); (*2*) (* ULEB128 size followed by DWARF expression block of that size*) +("DW_OP_GNU_implicit_pointer", sym_natural_of_hex "0xf2", [OAT_dwarf_format_t;OAT_SLEB128], OpSem_not_supported) ] -let vDW_OP_reg0 = natural_of_hex "0x50" -let vDW_OP_breg0 = natural_of_hex "0x70" +let vDW_OP_reg0 = sym_natural_of_hex "0x50" +let vDW_OP_breg0 = sym_natural_of_hex "0x70" (* call frame instruction encoding *) -let call_frame_instruction_encoding : list (string * natural * natural * list call_frame_argument_type * ((list call_frame_argument_value) -> maybe call_frame_instruction)) = [ +let call_frame_instruction_encoding : list (string * sym_natural * sym_natural * list call_frame_argument_type * ((list call_frame_argument_value) -> maybe call_frame_instruction)) = [ (* high-order 2 bits low-order 6 bits uniformly parsed arguments *) (* instructions using low-order 6 bits for first argument *) @@ -1622,53 +1622,53 @@ let call_frame_instruction_encoding : list (string * natural * natural * list ca ("DW_CFA_restore", 3, 0,(*register*) []); *) (* instructions using low-order 6 bits as part of opcode *) -("DW_CFA_nop", 0, natural_of_hex "0x00", [], (* *) +("DW_CFA_nop", 0, sym_natural_of_hex "0x00", [], (* *) fun avs -> match avs with [] -> Just (DW_CFA_nop) | _ -> Nothing end); -("DW_CFA_set_loc", 0, natural_of_hex "0x01", [CFAT_address], (* address *) +("DW_CFA_set_loc", 0, sym_natural_of_hex "0x01", [CFAT_address], (* address *) fun avs -> match avs with [CFAV_address a] -> Just (DW_CFA_set_loc a) | _ -> Nothing end); -("DW_CFA_advance_loc1", 0, natural_of_hex "0x02", [CFAT_delta1], (* 1-byte delta *) +("DW_CFA_advance_loc1", 0, sym_natural_of_hex "0x02", [CFAT_delta1], (* 1-byte delta *) fun avs -> match avs with [CFAV_delta d] -> Just (DW_CFA_advance_loc1 d) | _ -> Nothing end); -("DW_CFA_advance_loc2", 0, natural_of_hex "0x03", [CFAT_delta2], (* 2-byte delta *) +("DW_CFA_advance_loc2", 0, sym_natural_of_hex "0x03", [CFAT_delta2], (* 2-byte delta *) fun avs -> match avs with [CFAV_delta d] -> Just (DW_CFA_advance_loc2 d) | _ -> Nothing end); -("DW_CFA_advance_loc4", 0, natural_of_hex "0x04", [CFAT_delta4], (* 4-byte delta *) +("DW_CFA_advance_loc4", 0, sym_natural_of_hex "0x04", [CFAT_delta4], (* 4-byte delta *) fun avs -> match avs with [CFAV_delta d] -> Just (DW_CFA_advance_loc4 d) | _ -> Nothing end); -("DW_CFA_offset_extended", 0, natural_of_hex "0x05", [CFAT_register; CFAT_offset], (* ULEB128 register ULEB128 offset *) +("DW_CFA_offset_extended", 0, sym_natural_of_hex "0x05", [CFAT_register; CFAT_offset], (* ULEB128 register ULEB128 offset *) fun avs -> match avs with [CFAV_register r; CFAV_offset n] -> Just (DW_CFA_offset_extended r n) | _ -> Nothing end); -("DW_CFA_restore_extended", 0, natural_of_hex "0x06", [CFAT_register], (* ULEB128 register *) +("DW_CFA_restore_extended", 0, sym_natural_of_hex "0x06", [CFAT_register], (* ULEB128 register *) fun avs -> match avs with [CFAV_register r] -> Just (DW_CFA_restore_extended r) | _ -> Nothing end); -("DW_CFA_undefined", 0, natural_of_hex "0x07", [CFAT_register], (* ULEB128 register *) +("DW_CFA_undefined", 0, sym_natural_of_hex "0x07", [CFAT_register], (* ULEB128 register *) fun avs -> match avs with [CFAV_register r] -> Just (DW_CFA_undefined r) | _ -> Nothing end); -("DW_CFA_same_value", 0, natural_of_hex "0x08", [CFAT_register], (* ULEB128 register *) +("DW_CFA_same_value", 0, sym_natural_of_hex "0x08", [CFAT_register], (* ULEB128 register *) fun avs -> match avs with [CFAV_register r] -> Just (DW_CFA_same_value r) | _ -> Nothing end); -("DW_CFA_register", 0, natural_of_hex "0x09", [CFAT_register; CFAT_register], (* ULEB128 register ULEB128 register *) +("DW_CFA_register", 0, sym_natural_of_hex "0x09", [CFAT_register; CFAT_register], (* ULEB128 register ULEB128 register *) fun avs -> match avs with [CFAV_register r1; CFAV_register r2] -> Just (DW_CFA_register r1 r2) | _ -> Nothing end); -("DW_CFA_remember_state", 0, natural_of_hex "0x0a", [], (* *) +("DW_CFA_remember_state", 0, sym_natural_of_hex "0x0a", [], (* *) fun avs -> match avs with [] -> Just (DW_CFA_remember_state) | _ -> Nothing end); -("DW_CFA_restore_state", 0, natural_of_hex "0x0b", [], (* *) +("DW_CFA_restore_state", 0, sym_natural_of_hex "0x0b", [], (* *) fun avs -> match avs with [] -> Just (DW_CFA_restore_state) | _ -> Nothing end); -("DW_CFA_def_cfa", 0, natural_of_hex "0x0c", [CFAT_register; CFAT_offset], (* ULEB128 register ULEB128 offset *) +("DW_CFA_def_cfa", 0, sym_natural_of_hex "0x0c", [CFAT_register; CFAT_offset], (* ULEB128 register ULEB128 offset *) fun avs -> match avs with [CFAV_register r; CFAV_offset n] -> Just (DW_CFA_def_cfa r n) | _ -> Nothing end); -("DW_CFA_def_cfa_register", 0, natural_of_hex "0x0d", [CFAT_register], (* ULEB128 register *) +("DW_CFA_def_cfa_register", 0, sym_natural_of_hex "0x0d", [CFAT_register], (* ULEB128 register *) fun avs -> match avs with [CFAV_register r] -> Just (DW_CFA_def_cfa_register r) | _ -> Nothing end); -("DW_CFA_def_cfa_offset", 0, natural_of_hex "0x0e", [CFAT_offset], (* ULEB128 offset *) +("DW_CFA_def_cfa_offset", 0, sym_natural_of_hex "0x0e", [CFAT_offset], (* ULEB128 offset *) fun avs -> match avs with [CFAV_offset n] -> Just (DW_CFA_def_cfa_offset n) | _ -> Nothing end); -("DW_CFA_def_cfa_expression", 0, natural_of_hex "0x0f", [CFAT_block], (* BLOCK *) +("DW_CFA_def_cfa_expression", 0, sym_natural_of_hex "0x0f", [CFAT_block], (* BLOCK *) fun avs -> match avs with [CFAV_block b] -> Just (DW_CFA_def_cfa_expression b) | _ -> Nothing end); -("DW_CFA_expression", 0, natural_of_hex "0x10", [CFAT_register; CFAT_block], (* ULEB128 register BLOCK *) +("DW_CFA_expression", 0, sym_natural_of_hex "0x10", [CFAT_register; CFAT_block], (* ULEB128 register BLOCK *) fun avs -> match avs with [CFAV_register r; CFAV_block b] -> Just (DW_CFA_expression r b) | _ -> Nothing end); -("DW_CFA_offset_extended_sf", 0, natural_of_hex "0x11", [CFAT_register; CFAT_sfoffset], (* ULEB128 register SLEB128 offset *) +("DW_CFA_offset_extended_sf", 0, sym_natural_of_hex "0x11", [CFAT_register; CFAT_sfoffset], (* ULEB128 register SLEB128 offset *) fun avs -> match avs with [CFAV_register r; CFAV_sfoffset i] -> Just (DW_CFA_offset_extended_sf r i) | _ -> Nothing end); -("DW_CFA_def_cfa_sf", 0, natural_of_hex "0x12", [CFAT_register; CFAT_sfoffset], (* ULEB128 register SLEB128 offset *) +("DW_CFA_def_cfa_sf", 0, sym_natural_of_hex "0x12", [CFAT_register; CFAT_sfoffset], (* ULEB128 register SLEB128 offset *) fun avs -> match avs with [CFAV_register r; CFAV_sfoffset i] -> Just (DW_CFA_def_cfa_sf r i) | _ -> Nothing end); -("DW_CFA_def_cfa_offset_sf", 0, natural_of_hex "0x13", [CFAT_sfoffset], (* SLEB128 offset *) +("DW_CFA_def_cfa_offset_sf", 0, sym_natural_of_hex "0x13", [CFAT_sfoffset], (* SLEB128 offset *) fun avs -> match avs with [CFAV_sfoffset i] -> Just (DW_CFA_def_cfa_offset_sf i) | _ -> Nothing end); -("DW_CFA_val_offset", 0, natural_of_hex "0x14", [CFAT_register; CFAT_offset], (* ULEB128 ULEB128 *) +("DW_CFA_val_offset", 0, sym_natural_of_hex "0x14", [CFAT_register; CFAT_offset], (* ULEB128 ULEB128 *) fun avs -> match avs with [CFAV_register r; CFAV_offset n] -> Just (DW_CFA_val_offset r n) | _ -> Nothing end); -("DW_CFA_val_offset_sf", 0, natural_of_hex "0x15", [CFAT_register; CFAT_sfoffset], (* ULEB128 SLEB128 *) +("DW_CFA_val_offset_sf", 0, sym_natural_of_hex "0x15", [CFAT_register; CFAT_sfoffset], (* ULEB128 SLEB128 *) fun avs -> match avs with [CFAV_register r; CFAV_sfoffset i] -> Just (DW_CFA_val_offset_sf r i) | _ -> Nothing end); -("DW_CFA_val_expression", 0, natural_of_hex "0x16", [CFAT_register; CFAT_block], (* ULEB128 BLOCK *) +("DW_CFA_val_expression", 0, sym_natural_of_hex "0x16", [CFAT_register; CFAT_block], (* ULEB128 BLOCK *) fun avs -> match avs with [CFAV_register r; CFAV_block b] -> Just (DW_CFA_val_expression r b) | _ -> Nothing end); -("DW_CFA_AARCH64_negate_ra_state", 0, natural_of_hex "0x2d", [], (* *) +("DW_CFA_AARCH64_negate_ra_state", 0, sym_natural_of_hex "0x2d", [], (* *) fun avs -> match avs with [] -> Just (DW_CFA_AARCH64_negate_ra_state) | _ -> Nothing end); ] (* @@ -1685,55 +1685,55 @@ p10 says "The RA_SIGN_STATE pseudo-register records whether the return address h For our purposes it seems fine to nop-this. *) (* -("DW_CFA_lo_user", 0, natural_of_hex "0x1c", []); (* *) -("DW_CFA_hi_user", 0, natural_of_hex "0x3f", []); (* *) +("DW_CFA_lo_user", 0, sym_natural_of_hex "0x1c", []); (* *) +("DW_CFA_hi_user", 0, sym_natural_of_hex "0x3f", []); (* *) *) (* line number encodings *) let line_number_standard_encodings = [ - ("DW_LNS_copy" , natural_of_hex "0x01", [ ], + ("DW_LNS_copy" , sym_natural_of_hex "0x01", [ ], fun lnvs -> match lnvs with [] -> Just DW_LNS_copy | _ -> Nothing end); - ("DW_LNS_advance_pc" , natural_of_hex "0x02", [LNAT_ULEB128 ], + ("DW_LNS_advance_pc" , sym_natural_of_hex "0x02", [LNAT_ULEB128 ], fun lnvs -> match lnvs with [LNAV_ULEB128 n] -> Just (DW_LNS_advance_pc n) | _ -> Nothing end); - ("DW_LNS_advance_line" , natural_of_hex "0x03", [LNAT_SLEB128 ], + ("DW_LNS_advance_line" , sym_natural_of_hex "0x03", [LNAT_SLEB128 ], fun lnvs -> match lnvs with [LNAV_SLEB128 i] -> Just (DW_LNS_advance_line i) | _ -> Nothing end); - ("DW_LNS_set_file" , natural_of_hex "0x04", [LNAT_ULEB128 ], + ("DW_LNS_set_file" , sym_natural_of_hex "0x04", [LNAT_ULEB128 ], fun lnvs -> match lnvs with [LNAV_ULEB128 n] -> Just (DW_LNS_set_file n) | _ -> Nothing end); - ("DW_LNS_set_column" , natural_of_hex "0x05", [LNAT_ULEB128 ], + ("DW_LNS_set_column" , sym_natural_of_hex "0x05", [LNAT_ULEB128 ], fun lnvs -> match lnvs with [LNAV_ULEB128 n] -> Just (DW_LNS_set_column n) | _ -> Nothing end); - ("DW_LNS_negate_stmt" , natural_of_hex "0x06", [ ], + ("DW_LNS_negate_stmt" , sym_natural_of_hex "0x06", [ ], fun lnvs -> match lnvs with [] -> Just (DW_LNS_negate_stmt) | _ -> Nothing end); - ("DW_LNS_set_basic_block" , natural_of_hex "0x07", [ ], + ("DW_LNS_set_basic_block" , sym_natural_of_hex "0x07", [ ], fun lnvs -> match lnvs with [] -> Just (DW_LNS_set_basic_block) | _ -> Nothing end); - ("DW_LNS_const_add_pc" , natural_of_hex "0x08", [ ], + ("DW_LNS_const_add_pc" , sym_natural_of_hex "0x08", [ ], fun lnvs -> match lnvs with [] -> Just (DW_LNS_const_add_pc) | _ -> Nothing end); - ("DW_LNS_fixed_advance_pc" , natural_of_hex "0x09", [LNAT_uint16 ], + ("DW_LNS_fixed_advance_pc" , sym_natural_of_hex "0x09", [LNAT_uint16 ], fun lnvs -> match lnvs with [LNAV_uint16 n] -> Just (DW_LNS_fixed_advance_pc n) | _ -> Nothing end); - ("DW_LNS_set_prologue_end" , natural_of_hex "0x0a", [ ], + ("DW_LNS_set_prologue_end" , sym_natural_of_hex "0x0a", [ ], fun lnvs -> match lnvs with [] -> Just (DW_LNS_set_prologue_end) | _ -> Nothing end); - ("DW_LNS_set_epilogue_begin" , natural_of_hex "0x0b", [ ], + ("DW_LNS_set_epilogue_begin" , sym_natural_of_hex "0x0b", [ ], fun lnvs -> match lnvs with [] -> Just (DW_LNS_set_epilogue_begin) | _ -> Nothing end); - ("DW_LNS_set_isa" , natural_of_hex "0x0c", [LNAT_ULEB128 ], + ("DW_LNS_set_isa" , sym_natural_of_hex "0x0c", [LNAT_ULEB128 ], fun lnvs -> match lnvs with [LNAV_ULEB128 n] -> Just (DW_LNS_set_isa n) | _ -> Nothing end) ] let line_number_extended_encodings = [ - ("DW_LNE_end_sequence" , natural_of_hex "0x01", [], + ("DW_LNE_end_sequence" , sym_natural_of_hex "0x01", [], fun lnvs -> match lnvs with [] -> Just (DW_LNE_end_sequence) | _ -> Nothing end); - ("DW_LNE_set_address" , natural_of_hex "0x02", [LNAT_address], + ("DW_LNE_set_address" , sym_natural_of_hex "0x02", [LNAT_address], fun lnvs -> match lnvs with [LNAV_address n] -> Just (DW_LNE_set_address n) | _ -> Nothing end); - ("DW_LNE_define_file" , natural_of_hex "0x03", [LNAT_string; LNAT_ULEB128; LNAT_ULEB128; LNAT_ULEB128], + ("DW_LNE_define_file" , sym_natural_of_hex "0x03", [LNAT_string; LNAT_ULEB128; LNAT_ULEB128; LNAT_ULEB128], fun lnvs -> match lnvs with [LNAV_string s; LNAV_ULEB128 n1; LNAV_ULEB128 n2; LNAV_ULEB128 n3] -> Just (DW_LNE_define_file s n1 n2 n3) | _ -> Nothing end); - ("DW_LNE_set_discriminator" , natural_of_hex "0x04", [LNAT_ULEB128], + ("DW_LNE_set_discriminator" , sym_natural_of_hex "0x04", [LNAT_ULEB128], fun lnvs -> match lnvs with [LNAV_ULEB128 n] -> Just (DW_LNE_set_discriminator n) | _ -> Nothing end) (* new in Dwarf 4*) ] (* -(DW_LNE_lo_user , natural_of_hex "0x80", "DW_LNE_lo_user"); -(DW_LNE_hi_user , natural_of_hex "0xff", "DW_LNE_hi_user"); +(DW_LNE_lo_user , sym_natural_of_hex "0x80", "DW_LNE_lo_user"); +(DW_LNE_hi_user , sym_natural_of_hex "0xff", "DW_LNE_hi_user"); *) @@ -1742,26 +1742,26 @@ let line_number_extended_encodings = [ (* base type attribute encoding *) let base_type_attribute_encodings = [ - ("DW_ATE_address" , natural_of_hex "0x01"); - ("DW_ATE_boolean" , natural_of_hex "0x02"); - ("DW_ATE_complex_float" , natural_of_hex "0x03"); - ("DW_ATE_float" , natural_of_hex "0x04"); - ("DW_ATE_signed" , natural_of_hex "0x05"); - ("DW_ATE_signed_char" , natural_of_hex "0x06"); - ("DW_ATE_unsigned" , natural_of_hex "0x07"); - ("DW_ATE_unsigned_char" , natural_of_hex "0x08"); - ("DW_ATE_imaginary_float" , natural_of_hex "0x09"); - ("DW_ATE_packed_decimal" , natural_of_hex "0x0a"); - ("DW_ATE_numeric_string" , natural_of_hex "0x0b"); - ("DW_ATE_edited" , natural_of_hex "0x0c"); - ("DW_ATE_signed_fixed" , natural_of_hex "0x0d"); - ("DW_ATE_unsigned_fixed" , natural_of_hex "0x0e"); - ("DW_ATE_decimal_float" , natural_of_hex "0x0f"); - ("DW_ATE_UTF" , natural_of_hex "0x10"); - ("DW_ATE_lo_user" , natural_of_hex "0x80"); - ("DW_ATE_signed_capability_hack_a0" , natural_of_hex "0xa0"); - ("DW_ATE_unsigned_capability_hack_a1" , natural_of_hex "0xa1"); - ("DW_ATE_hi_user" , natural_of_hex "0xff") + ("DW_ATE_address" , sym_natural_of_hex "0x01"); + ("DW_ATE_boolean" , sym_natural_of_hex "0x02"); + ("DW_ATE_complex_float" , sym_natural_of_hex "0x03"); + ("DW_ATE_float" , sym_natural_of_hex "0x04"); + ("DW_ATE_signed" , sym_natural_of_hex "0x05"); + ("DW_ATE_signed_char" , sym_natural_of_hex "0x06"); + ("DW_ATE_unsigned" , sym_natural_of_hex "0x07"); + ("DW_ATE_unsigned_char" , sym_natural_of_hex "0x08"); + ("DW_ATE_imaginary_float" , sym_natural_of_hex "0x09"); + ("DW_ATE_packed_decimal" , sym_natural_of_hex "0x0a"); + ("DW_ATE_numeric_string" , sym_natural_of_hex "0x0b"); + ("DW_ATE_edited" , sym_natural_of_hex "0x0c"); + ("DW_ATE_signed_fixed" , sym_natural_of_hex "0x0d"); + ("DW_ATE_unsigned_fixed" , sym_natural_of_hex "0x0e"); + ("DW_ATE_decimal_float" , sym_natural_of_hex "0x0f"); + ("DW_ATE_UTF" , sym_natural_of_hex "0x10"); + ("DW_ATE_lo_user" , sym_natural_of_hex "0x80"); + ("DW_ATE_signed_capability_hack_a0" , sym_natural_of_hex "0xa0"); + ("DW_ATE_unsigned_capability_hack_a1" , sym_natural_of_hex "0xa1"); + ("DW_ATE_hi_user" , sym_natural_of_hex "0xff") ] (** ************************************************************ *) @@ -2034,32 +2034,32 @@ let rec lookup_abCde_de z0 xyzwus = end -let pp_maybe ppf n = match ppf n with Just s -> s | Nothing -> "Unknown AT value: " ^ pphexplain n (*encoding not found: "" ^ pphex n*) end +let pp_maybe ppf n = match ppf n with Just s -> s | Nothing -> "Unknown AT value: " ^ pphexplain_sym n (*encoding not found: "" ^ pphex n*) end let pp_tag_encoding n = pp_maybe (fun n -> lookup_aB_a n tag_encodings) n let pp_attribute_encoding n = pp_maybe (fun n -> lookup_aBc_a n attribute_encodings) n let pp_attribute_form_encoding n = pp_maybe (fun n -> lookup_aBc_a n attribute_form_encodings) n let pp_operation_encoding n = pp_maybe (fun n -> lookup_aBcd_a n operation_encodings) n -let tag_encode (s: string) : natural = +let tag_encode (s: string) : sym_natural = match lookup_Ab_b s tag_encodings with | Just n -> n | Nothing -> Assert_extra.failwith ("tag_encode: \""^s^"\"") end -let attribute_encode (s: string) : natural = +let attribute_encode (s: string) : sym_natural = match lookup_Abc_b s attribute_encodings with | Just n -> n | Nothing -> Assert_extra.failwith ("attribute_encode: \""^s^"\"") end -let attribute_form_encode (s: string) : natural = +let attribute_form_encode (s: string) : sym_natural = match lookup_Abc_b s attribute_form_encodings with | Just n -> n | Nothing -> Assert_extra.failwith "attribute_form_encode" end -let base_type_attribute_encode (s: string) : natural = +let base_type_attribute_encode (s: string) : sym_natural = match lookup_Ab_b s base_type_attribute_encodings with | Just n -> n | Nothing -> Assert_extra.failwith "base_type_attribute_encode" @@ -2505,9 +2505,9 @@ let parse_abbreviation_declaration c : parser (maybe abbreviation_declaration) = Just ( let ad = <| ad_abbreviation_code = n1; - ad_tag = sym_unwrap n2 "as_tag"; + ad_tag = n2; ad_has_children = (c<>0); - ad_attribute_specifications = List.map (fun (a, b) -> (sym_unwrap a "attribute", sym_unwrap b "attribute_form")) l; + ad_attribute_specifications = l; |> in (* let _ = my_debug2 (pp_abbreviation_declaration ad) in *) ad) )))) @@ -2603,9 +2603,8 @@ let parse_operation c cuh pc = match parse_uint8 pc with | PR_fail s pc' -> PR_success Nothing pc | PR_success code pc' -> - let code = sym_unwrap code "opcode" in match lookup_aBcd_acd code operation_encodings with - | Nothing -> PR_fail ("encoding not found: " ^ pphex code) pc + | Nothing -> PR_fail ("encoding not found: " ^ pphex_sym code) pc | Just (s,oats,opsem) -> let ps = List.map (parser_of_operation_argument_type c cuh) oats in (pr_post_map @@ -2664,7 +2663,7 @@ let pp_attribute_value_plain av = end -val pp_attribute_value : p_context -> compilation_unit_header -> rel_byte_sequence -> natural (*attribute tag*) -> attribute_value -> string +val pp_attribute_value : p_context -> compilation_unit_header -> rel_byte_sequence -> sym_natural (*attribute tag*) -> attribute_value -> string let pp_attribute_value c cuh str at av = match av with | AV_addr x -> "AV_addr " ^ pphex_sym x @@ -2685,7 +2684,7 @@ let pp_attribute_value c cuh str at av = ^ pp_debug_str_entry str n end -val pp_attribute_value_like_objdump : p_context -> compilation_unit_header -> rel_byte_sequence -> natural (*attribute tag*) -> attribute_value -> string +val pp_attribute_value_like_objdump : p_context -> compilation_unit_header -> rel_byte_sequence -> sym_natural (*attribute tag*) -> attribute_value -> string let pp_attribute_value_like_objdump c cuh str at av = match av with | AV_addr x -> (*"AV_addr " ^*) pphex_sym x @@ -2713,7 +2712,7 @@ let pp_attribute_value_like_objdump c cuh str at av = -val parser_of_attribute_form_non_indirect : p_context -> compilation_unit_header -> natural -> parser attribute_value +val parser_of_attribute_form_non_indirect : p_context -> compilation_unit_header -> sym_natural -> parser attribute_value let parser_of_attribute_form_non_indirect c cuh n = (* address*) if n = attribute_form_encode "DW_FORM_addr" then @@ -2789,7 +2788,7 @@ let parser_of_attribute_form_non_indirect c cuh n = let parser_of_attribute_form c cuh n = if n = attribute_form_encode "DW_FORM_indirect" then (fun pc -> pr_bind (parse_ULEB128 pc) (fun n -> - parser_of_attribute_form_non_indirect c cuh(sym_unwrap n "attribute form")) ) + parser_of_attribute_form_non_indirect c cuh n) ) else parser_of_attribute_form_non_indirect c cuh n @@ -2907,7 +2906,7 @@ let find_attribute_value (an: string) (die:die) : maybe attribute_value = die.die_abbreviation_declaration.ad_attribute_specifications die.die_attribute_values in myfindmaybe - (fun (((at': natural), (af: natural)), ((pos: sym_natural),(av:attribute_value))) -> + (fun (((at': sym_natural), (af: sym_natural)), ((pos: sym_natural),(av:attribute_value))) -> if at' = at then Just av else Nothing) ats @@ -3126,7 +3125,7 @@ let indent_level_plus_one indent level = else " "^" " -let pp_die_attribute c (cuh:compilation_unit_header) (str : rel_byte_sequence) (indent:bool) (level: natural) (((at: natural), (af: natural)), ((pos: sym_natural),(av:attribute_value))) : string = +let pp_die_attribute c (cuh:compilation_unit_header) (str : rel_byte_sequence) (indent:bool) (level: natural) (((at: sym_natural), (af: sym_natural)), ((pos: sym_natural),(av:attribute_value))) : string = indent_level_plus_one indent level ^ pp_pos pos ^ " " ^ right_space_padded_to 18 (pp_attribute_encoding at) ^ ": " ^ @@ -3720,7 +3719,7 @@ let parser_of_call_frame_argument_type c cuh (cfat: call_frame_argument_type) : | CFAT_delta_ULEB128 -> pr_map2 (fun n -> CFAV_delta n) (parse_ULEB128) | CFAT_offset -> pr_map2 (fun n -> CFAV_offset n) (parse_ULEB128) | CFAT_sfoffset -> pr_map2 (fun n -> CFAV_sfoffset n) (parse_SLEB128) - | CFAT_register -> pr_map2 (fun n -> CFAV_register (sym_unwrap n "register")) (parse_ULEB128) + | CFAT_register -> pr_map2 (fun n -> CFAV_register n) (parse_ULEB128) | CFAT_block -> (fun pc -> pr_bind (parse_ULEB128 pc) (fun n pc' -> pr_map (fun bs -> CFAV_block bs) (parse_n_bytes n pc'))) @@ -3734,7 +3733,7 @@ let parse_call_frame_instruction c cuh : parser (maybe call_frame_instruction) = let pc' = <| pc_bytes = bs'; pc_offset = pc.pc_offset + 1 |> in let ch = unsigned_char_of_byte b in let high_bits = unsigned_char_land ch (unsigned_char_of_natural 192) in - let low_bits = natural_of_unsigned_char (unsigned_char_land ch (unsigned_char_of_natural 63)) in + let low_bits = Absolute (natural_of_unsigned_char (unsigned_char_land ch (unsigned_char_of_natural 63))) in if high_bits = unsigned_char_of_natural 0 then match lookup_abCde_de low_bits call_frame_instruction_encoding with | Just ((args: list call_frame_argument_type), result) -> @@ -3754,7 +3753,7 @@ let parse_call_frame_instruction c cuh : parser (maybe call_frame_instruction) = end else if high_bits = unsigned_char_of_natural 64 then - PR_success (Just (DW_CFA_advance_loc (Absolute low_bits))) pc' + PR_success (Just (DW_CFA_advance_loc low_bits)) pc' else if high_bits = unsigned_char_of_natural 192 then PR_success (Just (DW_CFA_restore low_bits)) pc' else @@ -3894,7 +3893,7 @@ let parse_frame_info_element c cuh (fi: list frame_info_element) : parser frame_ cie_segment_size = mss; cie_code_alignment_factor = caf; cie_data_alignment_factor = daf; - cie_return_address_register = sym_unwrap rar "register"; + cie_return_address_register = rar; cie_initial_instructions_bytes = bs; cie_initial_instructions = is; |>) @@ -4099,7 +4098,7 @@ let parse_line_number_header c (comp_dir:maybe string) : parser line_number_head lnh_default_is_stmt = (dis<>0); lnh_line_base = lb; lnh_line_range = lr; - lnh_opcode_base = (sym_unwrap ob "opcode base"); + lnh_opcode_base = ob; lnh_standard_opcode_lengths = sols; lnh_include_directories = ids; lnh_file_entries = fns; @@ -4123,7 +4122,6 @@ let parse_line_number_operation c (cuh: compilation_unit_header) (lnh: line_numb parse_dependent parse_uint8 (fun opcode -> - let opcode = sym_unwrap opcode "opcode" in if opcode=0 then (* parse extended opcode *) parse_dependent @@ -4131,7 +4129,7 @@ let parse_line_number_operation c (cuh: compilation_unit_header) (lnh: line_numb parse_ULEB128 parse_uint8) (fun (size,opcode') -> - match lookup_aBcd_acd (sym_unwrap opcode' "opcode") line_number_extended_encodings with + match lookup_aBcd_acd opcode' line_number_extended_encodings with | Just (_, arg_types, result) -> let ps = List.map (parser_of_line_number_argument_type c cuh) arg_types in parse_demaybe ("parse_line_number_operation fail") @@ -4679,18 +4677,18 @@ let rec evaluate_operation_list (c:p_context) (dloc: location_list_list) (evalua end | (OpSem_opcode_lit base, []) -> if op.op_code >= base && op.op_code < base + 32 then - push_memory_address (Absolute (op.op_code - base)) s.s_stack + push_memory_address (op.op_code - base) s.s_stack else Fail "OpSem_opcode_lit opcode not within [base,base+32)" | (OpSem_reg, []) -> (* TODO: unclear whether this should push the register id or not *) let r = op.op_code - vDW_OP_reg0 in - Success <| s with s_stack = (Absolute r) :: s.s_stack; s_value = SL_register r |> + Success <| s with s_stack = r :: s.s_stack; s_value = SL_register r |> | (OpSem_breg, [OAV_integer i]) -> let r = op.op_code - vDW_OP_breg0 in bregxi r i | (OpSem_bregx, [OAV_natural r; OAV_integer i]) -> - bregxi (sym_unwrap r "register") i + bregxi r i | (OpSem_deref, []) -> deref_size cuh.cuh_address_size | (OpSem_deref_size, [OAV_natural n]) -> @@ -5125,7 +5123,6 @@ let analyse_type_info_top c (d: dwarf) (r:bool(*recurse into members*)) (cupdie: if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_base_type" then let encoding = let n = strict s (find_natural_attribute_value_of_die c "DW_AT_encoding" die) in - let n = sym_unwrap n "attribute encoding" in if not(List.any (fun (s,n')->n=n') base_type_attribute_encodings) then strict s Nothing else n in (* TODO: handle user encodings correctly *) let mbyte_size = find_natural_attribute_value_of_die c "DW_AT_byte_size" die in @@ -5254,7 +5251,7 @@ let analyse_type_info_top c (d: dwarf) (r:bool(*recurse into members*)) (cupdie: else - Assert_extra.failwith ("analyse_type_info_top didn't recognise tag: " ^ pphex die.die_abbreviation_declaration.ad_tag ^ " for DIE " ^ pp_cupdie3 cupdie) + Assert_extra.failwith ("analyse_type_info_top didn't recognise tag: " ^ pphex_sym die.die_abbreviation_declaration.ad_tag ^ " for DIE " ^ pp_cupdie3 cupdie) let rec analyse_type_info_deep (d: dwarf) (r:bool(*recurse_into_members*)) cupdie : c_type = @@ -5471,7 +5468,7 @@ let analyse_locations_raw c (d: dwarf) = die.die_abbreviation_declaration.ad_attribute_specifications die.die_attribute_values in - let find_ats (s:string) = myfindNonPure (fun (((at: natural), (af: natural)), ((pos: sym_natural),(av:attribute_value))) -> (attribute_encode s) = at) ats in + let find_ats (s:string) = myfindNonPure (fun (((at: sym_natural), (af: sym_natural)), ((pos: sym_natural),(av:attribute_value))) -> sym_eq (attribute_encode s) at) ats in let ((_,_),(_,av_name)) = find_ats "DW_AT_name" in @@ -6055,7 +6052,6 @@ let evaluate_line_number_operation match lno with | DW_LN_special adjusted_opcode -> - let adjusted_opcode = Absolute adjusted_opcode in (* TODO probably doesn't have to be symbolic *) let operation_advance = adjusted_opcode / lnh.lnh_line_range in let line_increment = lnh.lnh_line_base + integerFromSymNatural (adjusted_opcode mod lnh.lnh_line_range) in let s' = @@ -6102,7 +6098,7 @@ let evaluate_line_number_operation let s' = <| s with lnr_basic_block = true |> in (s', lnrs) | DW_LNS_const_add_pc -> let opcode = 255 in - let adjusted_opcode = Absolute (opcode - lnh.lnh_opcode_base) in + let adjusted_opcode = opcode - lnh.lnh_opcode_base in let operation_advance = adjusted_opcode / lnh.lnh_line_range in let s' = <| s with @@ -6772,7 +6768,7 @@ let rec pp_inlined_subroutine_parents (ds:list die) : string = pp_pos die.die_offset ^ ":" ^ pp_inlined_subroutine_parents ds' else if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_lexical_block" then ":" ^ pp_inlined_subroutine_parents ds' else if die.die_abbreviation_declaration.ad_tag = tag_encode "DW_TAG_subprogram" then "" - else "" + else "" end From 7939d91c3524fa589985109a06a4aed437ea8540 Mon Sep 17 00:00:00 2001 From: Matej Urban Date: Sun, 26 Jan 2025 16:50:04 +0000 Subject: [PATCH 22/44] Make integers symbolic --- src/dwarf.lem | 125 ++++++++++++++++++++++++-------------------------- 1 file changed, 60 insertions(+), 65 deletions(-) diff --git a/src/dwarf.lem b/src/dwarf.lem index 3b64c83..336ded3 100644 --- a/src/dwarf.lem +++ b/src/dwarf.lem @@ -207,7 +207,7 @@ let sym_natural_minus = sym_minus val sym_integer_minus : sym_integer -> sym_integer -> sym_integer let sym_integer_minus = sym_minus -val sym_bind : forall 'a. sym 'a -> ('a -> sym 'a) -> sym 'a +val sym_bind : forall 'a 'b. sym 'a -> ('a -> sym 'b) -> sym 'b let sym_bind x f = match x with | Absolute x -> f x | _ -> Unknown @@ -333,14 +333,11 @@ let sym_natural_land = sym_map2 natural_land let sym_natural_lxor = sym_map2 natural_lxor let sym_natural_lor = sym_map2 natural_lor -let integerFromSymNatural = function - | Absolute x -> integerFromNatural x - | _ -> Assert_extra.failwith "integerFromSymNatural" -end +let symIntegerFromSymNatural = sym_map integerFromNatural let natFromSymNatural = function | Absolute x -> natFromNatural x - | _ -> Assert_extra.failwith "integerFromSymNatural" + | _ -> Assert_extra.failwith "symIntegerFromSymNatural" end let symNaturalFromNat x = Absolute (naturalFromNat x) @@ -351,11 +348,11 @@ let sym_natural_of_byte x = Absolute(natural_of_byte x) let symNaturalPow x y = sym_map (fun x -> naturalPow x y) x -let symNaturalFromInteger x = Absolute(naturalFromInteger x) +let symNaturalFromSymInteger = sym_map naturalFromInteger let index_sym_natural l n = index_natural l (sym_unwrap n "index_sym_natural") -let partialSymNaturalFromInteger i = Absolute (partialNaturalFromInteger i) +let partialSymNaturalFromSymInteger = sym_map partialNaturalFromInteger let sym_natural_nat_shift_left x sh = sym_map (fun x -> natural_nat_shift_left x sh) x let sym_natural_nat_shift_right x sh = sym_map (fun x -> natural_nat_shift_right x sh) x @@ -571,7 +568,7 @@ type operation_argument_type = type operation_argument_value = | OAV_natural of sym_natural - | OAV_integer of integer + | OAV_integer of sym_integer | OAV_block of sym_natural * rel_byte_sequence type operation_stack = list sym_natural @@ -685,7 +682,7 @@ type attribute_value = (* following Figure 3 *) | AV_addr of sym_natural | AV_block of sym_natural * rel_byte_sequence | AV_constantN of sym_natural * rel_byte_sequence - | AV_constant_SLEB128 of integer + | AV_constant_SLEB128 of sym_integer | AV_constant_ULEB128 of sym_natural | AV_exprloc of sym_natural * rel_byte_sequence | AV_flag of bool @@ -793,7 +790,7 @@ type cfa_block = rel_byte_sequence type cfa_delta = sym_natural type cfa_offset = sym_natural type cfa_register = sym_natural -type cfa_sfoffset = integer +type cfa_sfoffset = sym_integer type call_frame_argument_type = | CFAT_address @@ -856,7 +853,7 @@ type cie = cie_address_size: maybe sym_natural; cie_segment_size: maybe sym_natural; cie_code_alignment_factor: sym_natural; - cie_data_alignment_factor: integer; + cie_data_alignment_factor: sym_integer; cie_return_address_register: cfa_register; cie_initial_instructions_bytes: rel_byte_sequence; cie_initial_instructions: list call_frame_instruction; @@ -885,7 +882,7 @@ type frame_info = list frame_info_element type cfa_rule = | CR_undefined - | CR_register of cfa_register * integer + | CR_register of cfa_register * sym_integer | CR_expression of single_location_description type register_rule = @@ -893,9 +890,9 @@ type register_rule = (By convention, it is not preserved by a callee.)*) | RR_same_value (*This register has not been modified from the previous frame. (By convention, it is preserved by the callee, but the callee has not modified it.)*) - | RR_offset of integer (* The previous value of this register is saved at the address CFA+N where CFA + | RR_offset of sym_integer (* The previous value of this register is saved at the address CFA+N where CFA is the current CFA value and N is a signed offset.*) - | RR_val_offset of integer (* The previous value of this register is the value CFA+N where CFA is the + | RR_val_offset of sym_integer (* The previous value of this register is the value CFA+N where CFA is the current CFA value and N is a signed offset.*) | RR_register of sym_natural (* The previous value of this register is stored in another register numbered R.*) | RR_expression of single_location_description (* The previous value of this register is located at the address produced by @@ -938,7 +935,7 @@ type line_number_argument_type = type line_number_argument_value = | LNAV_address of sym_natural | LNAV_ULEB128 of sym_natural - | LNAV_SLEB128 of integer + | LNAV_SLEB128 of sym_integer | LNAV_uint16 of sym_natural | LNAV_string of rel_byte_sequence (* not including terminating null *) @@ -946,7 +943,7 @@ type line_number_operation = (* standard *) | DW_LNS_copy | DW_LNS_advance_pc of sym_natural - | DW_LNS_advance_line of integer + | DW_LNS_advance_line of sym_integer | DW_LNS_set_file of sym_natural | DW_LNS_set_column of sym_natural | DW_LNS_negate_stmt @@ -982,7 +979,7 @@ type line_number_header = lnh_minimum_instruction_length: sym_natural; lnh_maximum_operations_per_instruction: sym_natural; lnh_default_is_stmt: bool; - lnh_line_base: integer; + lnh_line_base: sym_integer; lnh_line_range: sym_natural; lnh_opcode_base: sym_natural; lnh_standard_opcode_lengths: list sym_natural; @@ -1085,7 +1082,7 @@ type struct_union_type_kind = | Atk_structure | Atk_union -type enumeration_member = cupdie * (maybe string)(*mname*) * integer(*const_value*) +type enumeration_member = cupdie * (maybe string)(*mname*) * sym_integer(*const_value*) type c_type_top 't = | CT_missing of cupdie @@ -1128,7 +1125,7 @@ type sdt_variable_or_formal_parameter = svfp_kind : variable_or_formal_parameter_kind; svfp_type : maybe c_type; svfp_abstract_origin : maybe sdt_variable_or_formal_parameter; (* invariant: non-Nothing iff inlined *) - svfp_const_value : maybe integer; + svfp_const_value : maybe sym_integer; svfp_external : bool; svfp_declaration : bool; svfp_locations : maybe (list (sym_natural * sym_natural * list operation (*the parsed single_location_description*))); @@ -1186,7 +1183,7 @@ type sdt_dwarf = type inlined_subroutine_const_param = <| iscp_abstract_origin: compilation_unit * (list die) * die; - iscp_value: integer; + iscp_value: sym_integer; |> type inlined_subroutine = @@ -1460,9 +1457,9 @@ let operation_encodings = [ ("DW_OP_abs", sym_natural_of_hex "0x19", [] , OpSem_unary (fun ac v -> if v < ac.ac_half then Just v else if v=ac.ac_max then Nothing else Just (ac.ac_all-v))); (*0*) ("DW_OP_and", sym_natural_of_hex "0x1a", [] , OpSem_binary (fun ac v1 v2 -> Just (sym_natural_land v1 v2))); (*0*) ("DW_OP_div", sym_natural_of_hex "0x1b", [] , OpSem_not_supported) (*TODO*); (*0*) -("DW_OP_minus", sym_natural_of_hex "0x1c", [] , OpSem_binary (fun ac v1 v2 -> Just (partialSymNaturalFromInteger ((integerFromSymNatural v1 - integerFromSymNatural v2) mod (integerFromSymNatural ac.ac_all))))); (*0*) +("DW_OP_minus", sym_natural_of_hex "0x1c", [] , OpSem_binary (fun ac v1 v2 -> Just (partialSymNaturalFromSymInteger ((symIntegerFromSymNatural v1 - symIntegerFromSymNatural v2) mod (symIntegerFromSymNatural ac.ac_all))))); (*0*) ("DW_OP_mod", sym_natural_of_hex "0x1d", [] , OpSem_binary (fun ac v1 v2 -> Just (v1 mod v2))); (*0*) -("DW_OP_mul", sym_natural_of_hex "0x1e", [] , OpSem_binary (fun ac v1 v2 -> Just (partialSymNaturalFromInteger ((integerFromSymNatural v1 * integerFromSymNatural v2) mod (integerFromSymNatural ac.ac_all))))); (*0*) +("DW_OP_mul", sym_natural_of_hex "0x1e", [] , OpSem_binary (fun ac v1 v2 -> Just (partialSymNaturalFromSymInteger ((symIntegerFromSymNatural v1 * symIntegerFromSymNatural v2) mod (symIntegerFromSymNatural ac.ac_all))))); (*0*) ("DW_OP_neg", sym_natural_of_hex "0x1f", [] , OpSem_unary (fun ac v -> if v < ac.ac_half then Just (ac.ac_max - v) else if v=ac.ac_half then Nothing else Just (ac.ac_all - v))); (*0*) ("DW_OP_not", sym_natural_of_hex "0x20", [] , OpSem_unary (fun ac v -> Just (sym_natural_lxor v ac.ac_max))); (*0*) ("DW_OP_or", sym_natural_of_hex "0x21", [] , OpSem_binary (fun ac v1 v2 -> Just (sym_natural_lor v1 v2))); (*0*) @@ -2342,27 +2339,25 @@ let parse_uint64 c : parser sym_natural= end -let integerFromTwosComplementNatural (n:natural) (half: natural) (all:integer) : integer = - if n < half then integerFromNatural n else integerFromNatural n - all +let integerFromTwosComplementNatural (n:sym_natural) (half: sym_natural) (all:sym_integer) : sym_integer = + if n < half then symIntegerFromSymNatural n else symIntegerFromSymNatural n - all -let partialTwosComplementNaturalFromInteger (i:integer) (half: natural) (all:integer) : natural = - if i >=0 && i < integerFromNatural half then partialNaturalFromInteger i - else if i >= (0-integerFromNatural half) && i < 0 then partialNaturalFromInteger (all + i) +let partialTwosComplementNaturalFromInteger (i:sym_integer) (half: sym_natural) (all:sym_integer) : sym_natural = + if i >=0 && i < symIntegerFromSymNatural half then partialSymNaturalFromSymInteger i + else if i >= (0-symIntegerFromSymNatural half) && i < 0 then partialSymNaturalFromSymInteger (all + i) else Assert_extra.failwith "partialTwosComplementNaturalFromInteger" -let partialTwosComplementSymNaturalFromInteger i half all = sym_map (fun x -> partialTwosComplementNaturalFromInteger i x all) half - -let parse_sint8 : parser integer = - pr_post_map (parse_uint8) (fun n -> integerFromTwosComplementNatural (sym_unwrap n "parse_sint8") 128 256) +let parse_sint8 : parser sym_integer = + pr_post_map (parse_uint8) (fun n -> integerFromTwosComplementNatural n 128 256) -let parse_sint16 c : parser integer = - pr_post_map (parse_uint16 c) (fun n -> integerFromTwosComplementNatural (sym_unwrap n "parse_sint16") (128*256) (256*256)) +let parse_sint16 c : parser sym_integer = + pr_post_map (parse_uint16 c) (fun n -> integerFromTwosComplementNatural n (128*256) (256*256)) -let parse_sint32 c : parser integer = - pr_post_map (parse_uint32 c) (fun n -> integerFromTwosComplementNatural (sym_unwrap n "parse_sint32") (128*256*256*256) (256*256*256*256)) +let parse_sint32 c : parser sym_integer = + pr_post_map (parse_uint32 c) (fun n -> integerFromTwosComplementNatural n (128*256*256*256) (256*256*256*256)) -let parse_sint64 c : parser integer = - pr_post_map (parse_uint64 c) (fun n -> integerFromTwosComplementNatural (sym_unwrap n "parse_sint64") (128*256*256*256*256*256*256*256) (256*256*256*256*256*256*256*256)) +let parse_sint64 c : parser sym_integer = + pr_post_map (parse_uint64 c) (fun n -> integerFromTwosComplementNatural n (128*256*256*256*256*256*256*256) (256*256*256*256*256*256*256*256)) let rec parse_ULEB128' (acc: natural) (shift_factor: natural) : parser natural = fun (pc:parse_context) -> @@ -2404,9 +2399,9 @@ let rec parse_SLEB128' (acc: natural) (shift_factor: natural) : parser (bool * n PR_fail "parse_SLEB128' not given enough bytes" pc end -let parse_SLEB128 : parser integer = +let parse_SLEB128 : parser sym_integer = pr_post_map (parse_SLEB128' 0 1) (fun (positive, shift_factor, acc) -> - if positive then integerFromNatural acc else integerFromNatural acc - integerFromNatural shift_factor) + Absolute (if positive then integerFromNatural acc else integerFromNatural acc - integerFromNatural shift_factor)) let parse_nonzero_ULEB128_pair : parser (maybe (sym_natural*sym_natural)) = let _ = my_debug "nonzero_ULEB128_pair " in @@ -2538,7 +2533,7 @@ let pp_debug_str_entry (str: rel_byte_sequence) (n: sym_natural) : string = let pp_operation_argument_value (oav:operation_argument_value) : string = match oav with | OAV_natural n -> pphex_sym n - | OAV_integer n -> pphex_integer n (* show n*) + | OAV_integer n -> pp_sym pphex_integer n (* show n*) | OAV_block n bs -> pphex_sym n ^ " " ^ ppbytes bs end @@ -2863,12 +2858,12 @@ let natural_of_constant_attribute_value die1 c av : sym_natural = | Nothing -> Assert_extra.failwith ("natural_of_constant_attribute_value fail at " ^ (pp_pos die1.die_offset ^ (" with av= " ^ pp_attribute_value_plain av))) end -let integer_of_constant_attribute_value c av : integer = +let integer_of_constant_attribute_value c av : sym_integer = match av with - | AV_constantN n bs -> integerFromSymNatural n - | AV_constant_ULEB128 n -> integerFromSymNatural n + | AV_constantN n bs -> symIntegerFromSymNatural n + | AV_constant_ULEB128 n -> symIntegerFromSymNatural n | AV_constant_SLEB128 n -> n - | AV_block n bs -> integerFromNatural (natural_of_bytes c.endianness bs) + | AV_block n bs -> symIntegerFromSymNatural (sym_natural_of_bytes c.endianness bs) | _ -> Assert_extra.failwith ("integer_of_constant_attribute_value fail") end @@ -2929,7 +2924,7 @@ let find_natural_attribute_value_of_die c (an: string) (die:die) : maybe sym_nat Nothing end -let find_integer_attribute_value_of_die c (an: string) (die:die) : maybe integer = +let find_integer_attribute_value_of_die c (an: string) (die:die) : maybe sym_integer = match find_attribute_value an die with | Just av -> let n = integer_of_constant_attribute_value c av in @@ -3652,7 +3647,7 @@ let pp_cfa_sfoffset i = show i let pp_cfa_register r = "r"^show r (*TODO: arch-specific register names *) -let pp_cfa_offset (i:integer) = if i=0 then "" else if i<0 then show i else "+" ^ show i +let pp_cfa_offset (i:sym_integer) = if i=0 then "" else if i<0 then show i else "+" ^ show i let pp_cfa_rule (cr:cfa_rule) : string = match cr with @@ -3678,29 +3673,29 @@ let pp_register_rule (rr:register_rule) : string = (*TODO make this more readel let pp_call_frame_instruction i = match i with | DW_CFA_advance_loc d -> "DW_CFA_advance_loc" ^ " " ^ pp_cfa_delta d - | DW_CFA_offset r n -> "DW_CFA_offset" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_offset (integerFromSymNatural n) + | DW_CFA_offset r n -> "DW_CFA_offset" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_offset (symIntegerFromSymNatural n) | DW_CFA_restore r -> "DW_CFA_restore" ^ " " ^ pp_cfa_register r | DW_CFA_nop -> "DW_CFA_nop" | DW_CFA_set_loc a -> "DW_CFA_set_loc" ^ " " ^ pp_cfa_address a | DW_CFA_advance_loc1 d -> "DW_CFA_advance_loc1" ^ " " ^ pp_cfa_delta d | DW_CFA_advance_loc2 d -> "DW_CFA_advance_loc2" ^ " " ^ pp_cfa_delta d | DW_CFA_advance_loc4 d -> "DW_CFA_advance_loc4" ^ " " ^ pp_cfa_delta d - | DW_CFA_offset_extended r n -> "DW_CFA_offset_extended" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_offset (integerFromSymNatural n) + | DW_CFA_offset_extended r n -> "DW_CFA_offset_extended" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_offset (symIntegerFromSymNatural n) | DW_CFA_restore_extended r -> "DW_CFA_restore_extended" ^ " " ^ pp_cfa_register r | DW_CFA_undefined r -> "DW_CFA_undefined" ^ " " ^ pp_cfa_register r | DW_CFA_same_value r -> "DW_CFA_same_value" ^ " " ^ pp_cfa_register r | DW_CFA_register r1 r2 -> "DW_CFA_register" ^ " " ^ pp_cfa_register r1 ^ " " ^ pp_cfa_register r2 | DW_CFA_remember_state -> "DW_CFA_remember_state" | DW_CFA_restore_state -> "DW_CFA_restore_state" - | DW_CFA_def_cfa r n -> "DW_CFA_def_cfa" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_offset (integerFromSymNatural n) + | DW_CFA_def_cfa r n -> "DW_CFA_def_cfa" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_offset (symIntegerFromSymNatural n) | DW_CFA_def_cfa_register r -> "DW_CFA_def_cfa_register" ^ " " ^ pp_cfa_register r - | DW_CFA_def_cfa_offset n -> "DW_CFA_def_cfa_offset" ^ " " ^ pp_cfa_offset (integerFromSymNatural n) + | DW_CFA_def_cfa_offset n -> "DW_CFA_def_cfa_offset" ^ " " ^ pp_cfa_offset (symIntegerFromSymNatural n) | DW_CFA_def_cfa_expression b -> "DW_CFA_def_cfa_expression" ^ " " ^ pp_cfa_block b | DW_CFA_expression r b -> "DW_CFA_expression" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_block b | DW_CFA_offset_extended_sf r i -> "DW_CFA_offset_extended_sf" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_sfoffset i | DW_CFA_def_cfa_sf r i -> "DW_CFA_def_cfa_sf" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_sfoffset i | DW_CFA_def_cfa_offset_sf i -> "DW_CFA_def_cfa_offset_sf" ^ " " ^ pp_cfa_sfoffset i - | DW_CFA_val_offset r n -> "DW_CFA_val_offset" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_offset (integerFromSymNatural n) + | DW_CFA_val_offset r n -> "DW_CFA_val_offset" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_offset (symIntegerFromSymNatural n) | DW_CFA_val_offset_sf r i -> "DW_CFA_val_offset_sf" ^ pp_cfa_register r ^ " " ^ pp_cfa_sfoffset i | DW_CFA_val_expression r b -> "DW_CFA_val_expression" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_block b | DW_CFA_AARCH64_negate_ra_state -> "DW_CFA_AARCH64_negate_ra_state" @@ -4621,7 +4616,7 @@ let rec evaluate_operation_list (c:p_context) (dloc: location_list_list) (evalua let bregxi r i = match ev.read_register r with - | RRR_result v -> push_memory_address (partialSymNaturalFromInteger ((integerFromSymNatural v+i) mod (integerFromSymNatural ac.ac_all))) s.s_stack + | RRR_result v -> push_memory_address (partialSymNaturalFromSymInteger ((symIntegerFromSymNatural v+i) mod (symIntegerFromSymNatural ac.ac_all))) s.s_stack | RRR_not_currently_available -> Fail "RRR_not_currently_available" | RRR_bad_register_number -> Fail ("RRR_bad_register_number " ^ show r) end in @@ -4655,7 +4650,7 @@ let rec evaluate_operation_list (c:p_context) (dloc: location_list_list) (evalua | (OpSem_lit, [OAV_natural n]) -> push_memory_address n s.s_stack | (OpSem_lit, [OAV_integer i]) -> - push_memory_address (partialTwosComplementSymNaturalFromInteger i ac.ac_half (integerFromSymNatural ac.ac_all)) s.s_stack + push_memory_address (partialTwosComplementNaturalFromInteger i ac.ac_half (symIntegerFromSymNatural ac.ac_all)) s.s_stack | (OpSem_stack f, []) -> match f ac s.s_stack op.op_argument_values with | Just stack' -> @@ -4703,9 +4698,9 @@ let rec evaluate_operation_list (c:p_context) (dloc: location_list_list) (evalua match l with | SL_simple (SL_memory_address a) -> (*let _ = my_debug5 ("OpSem_fbreg: a = "^ pphex a ^ "\n") in*) - let vi = ((integerFromSymNatural a) + i) mod (integerFromSymNatural ac.ac_all) in + let vi = ((symIntegerFromSymNatural a) + i) mod (symIntegerFromSymNatural ac.ac_all) in (*let _ = my_debug5 ("OpSem_fbreg: v = "^ show vi ^ "\n") in*) - let v = partialSymNaturalFromInteger vi (*ac.ac_half (integerFromSymNatural ac.ac_all)*) in + let v = partialSymNaturalFromSymInteger vi (*ac.ac_half (symIntegerFromSymNatural ac.ac_all)*) in push_memory_address v s.s_stack | _ -> Fail "OpSem_fbreg got a non-SL_simple (SL_memory_address _) result" @@ -4969,7 +4964,7 @@ let evaluate_call_frame_instruction (fi: frame_info) (cie: cie) (state: cfa_stat (* CFA Definition Instructions *) | DW_CFA_def_cfa r n -> - update_cfa (CR_register r (integerFromSymNatural n)) + update_cfa (CR_register r (symIntegerFromSymNatural n)) | DW_CFA_def_cfa_sf r i -> update_cfa (CR_register r (i * cie.cie_data_alignment_factor)) | DW_CFA_def_cfa_register r -> @@ -4988,7 +4983,7 @@ let evaluate_call_frame_instruction (fi: frame_info) (cie: cie) (state: cfa_stat | DW_CFA_def_cfa_offset n -> match state.cs_current_row.ctr_cfa with | CR_register r i -> - update_cfa (CR_register r (integerFromSymNatural n)) + update_cfa (CR_register r (symIntegerFromSymNatural n)) | _ -> Assert_extra.failwith "DW_CFA_def_cfa_offset: current rule is not CR_register" end | DW_CFA_def_cfa_offset_sf i -> @@ -5006,13 +5001,13 @@ let evaluate_call_frame_instruction (fi: frame_info) (cie: cie) (state: cfa_stat | DW_CFA_same_value r -> update_reg r (RR_same_value) | DW_CFA_offset r n -> - update_reg r (RR_offset ((integerFromSymNatural n) * cie.cie_data_alignment_factor)) + update_reg r (RR_offset ((symIntegerFromSymNatural n) * cie.cie_data_alignment_factor)) | DW_CFA_offset_extended r n -> - update_reg r (RR_offset ((integerFromSymNatural n) * cie.cie_data_alignment_factor)) + update_reg r (RR_offset ((symIntegerFromSymNatural n) * cie.cie_data_alignment_factor)) | DW_CFA_offset_extended_sf r i -> update_reg r (RR_offset (i * cie.cie_data_alignment_factor)) | DW_CFA_val_offset r n -> - update_reg r (RR_val_offset ((integerFromSymNatural n) * cie.cie_data_alignment_factor)) + update_reg r (RR_val_offset ((symIntegerFromSymNatural n) * cie.cie_data_alignment_factor)) | DW_CFA_val_offset_sf r i -> update_reg r (RR_val_offset (i * cie.cie_data_alignment_factor)) | DW_CFA_register r1 r2 -> @@ -5543,7 +5538,7 @@ let range_of_die c cuh str (dranges: range_list_list) (cu_base_address: sym_natu | (Just (AV_addr n), Nothing, Nothing ) -> Just [(n,n+1)] (* unclear if this case is used? *) | (Just (AV_addr n1), Just (AV_addr n2), Nothing ) -> Just [(n1,n2)] | (Just (AV_addr n1), Just (AV_constant_ULEB128 n2), Nothing ) -> Just [(n1, n1+n2)] (* should be mod all? *) - | (Just (AV_addr n1), Just (AV_constant_SLEB128 i2), Nothing ) -> Just [(n1, symNaturalFromInteger (integerFromSymNatural n1 + i2))] (* should be mod all? *) + | (Just (AV_addr n1), Just (AV_constant_SLEB128 i2), Nothing ) -> Just [(n1, symNaturalFromSymInteger (symIntegerFromSymNatural n1 + i2))] (* should be mod all? *) | (Just (AV_addr n1), Just (AV_constantN _ _), Nothing ) -> Assert_extra.failwith "AV_constantN in range_of_die" | (Just (AV_addr n1), Just (AV_block n bs), Nothing ) -> let n2 = sym_natural_of_bytes c.endianness bs in Just [(n1, n1+n2)] (* should be mod all? *) (* signed or unsigned interp? *) @@ -6053,10 +6048,10 @@ let evaluate_line_number_operation match lno with | DW_LN_special adjusted_opcode -> let operation_advance = adjusted_opcode / lnh.lnh_line_range in - let line_increment = lnh.lnh_line_base + integerFromSymNatural (adjusted_opcode mod lnh.lnh_line_range) in + let line_increment = lnh.lnh_line_base + symIntegerFromSymNatural (adjusted_opcode mod lnh.lnh_line_range) in let s' = <| s with - lnr_line = partialSymNaturalFromInteger ((integerFromSymNatural s.lnr_line) + line_increment); + lnr_line = partialSymNaturalFromSymInteger ((symIntegerFromSymNatural s.lnr_line) + line_increment); lnr_address = new_address s operation_advance; lnr_op_index = new_op_index s operation_advance; |> in @@ -6087,7 +6082,7 @@ let evaluate_line_number_operation |> in (s', lnrs) | DW_LNS_advance_line line_increment -> - let s' = <| s with lnr_line = partialSymNaturalFromInteger ((integerFromSymNatural s.lnr_line) + line_increment) |> in (s', lnrs) + let s' = <| s with lnr_line = partialSymNaturalFromSymInteger ((symIntegerFromSymNatural s.lnr_line) + line_increment) |> in (s', lnrs) | DW_LNS_set_file n -> let s' = <| s with lnr_file = n |> in (s', lnrs) | DW_LNS_set_column n -> From 2b24f23968629985e029e0fb757824fb19f68b54 Mon Sep 17 00:00:00 2001 From: Matej Urban Date: Sun, 26 Jan 2025 22:40:30 +0000 Subject: [PATCH 23/44] Keep address symbolic when extracting section with no relocations --- src/dwarf.lem | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/dwarf.lem b/src/dwarf.lem index 336ded3..f14eea1 100644 --- a/src/dwarf.lem +++ b/src/dwarf.lem @@ -4433,7 +4433,7 @@ let extract_section_body (f:elf_file) (ri:relocation_interpreter reloc_target_da let extract_section_body_without_relocations f section_name strict = let err_on_relocation ef symtab_map sidx rel = Assert_extra.failwith "Relocation found while extracting a section without relocations" in let (c, addr, body) = extract_section_body f err_on_relocation section_name strict in - (c, sym_unwrap addr "", rbs_unwrap body) + (c, addr, rbs_unwrap body) val extract_dwarf : elf_file -> relocation_interpreter reloc_target_data -> maybe dwarf let extract_dwarf f ri = From a59cdacf3774c07555a4fba67ba5dd45731573c9 Mon Sep 17 00:00:00 2001 From: Matej Urban Date: Mon, 27 Jan 2025 15:31:22 +0000 Subject: [PATCH 24/44] mod hack --- src/dwarf.lem | 30 ++++++++++++++++++++++++++++-- 1 file changed, 28 insertions(+), 2 deletions(-) diff --git a/src/dwarf.lem b/src/dwarf.lem index f14eea1..79c8ece 100644 --- a/src/dwarf.lem +++ b/src/dwarf.lem @@ -258,8 +258,34 @@ instance forall 'a. NumDivision 'a => (NumDivision (sym 'a)) let (/) = sym_map2 (/) end -instance forall 'a. NumRemainder 'a => (NumRemainder (sym 'a)) - let (mod) = sym_map2 (mod) +class ( ModSym 'a ) + val sym_mod: sym 'a -> sym 'a -> sym 'a +end + +(* TODO this is hacky *) +instance (ModSym integer) + let sym_mod x y = if match y with + | Absolute(y) -> y >= integerFromNatural (natural_of_hex "0x10000000000000000") + | _ -> false + end then + x + else + sym_map2 (mod) x y +end + +instance (ModSym natural) + let sym_mod x y = if match y with + | Absolute(y) -> y >= natural_of_hex "0x10000000000000000" + | _ -> false + end then + x + else + sym_map2 (mod) x y +end + + +instance forall 'a. ModSym 'a => (NumRemainder (sym 'a)) + let (mod) = sym_mod end let sym_comp f a b = match (simplify a, simplify b) with From 5dfe185b94ef9c971958215c70a2a36c1e2abdb6 Mon Sep 17 00:00:00 2001 From: Matej Urban Date: Mon, 27 Jan 2025 17:55:12 +0000 Subject: [PATCH 25/44] remove debug prints --- src/dwarf.lem | 4 ++-- src/elf_symbolic.lem | 3 --- 2 files changed, 2 insertions(+), 5 deletions(-) diff --git a/src/dwarf.lem b/src/dwarf.lem index 79c8ece..7ba0b62 100644 --- a/src/dwarf.lem +++ b/src/dwarf.lem @@ -128,8 +128,8 @@ declare ocaml target_rep function print_endline = `print_endline` let my_debug s = () (*print_endline s*) let my_debug2 s = () (*print_endline s*) let my_debug3 s = () (*print_endline s*) -let my_debug4 s = print_endline s -let my_debug5 s = print_endline s +let my_debug4 s = () (*print_endline s*) +let my_debug5 s = () (*print_endline s*) (** ************************************************************ *) (** ** missing pervasives ************************************ *) diff --git a/src/elf_symbolic.lem b/src/elf_symbolic.lem index 1966c8f..a50dbcb 100644 --- a/src/elf_symbolic.lem +++ b/src/elf_symbolic.lem @@ -101,11 +101,8 @@ let extract_elf64_relocations_for_section' f1 interp sidx = Elf_relocation.read_elf64_relocation_a_section' endian rels >>= fun rels -> Elf_file.get_elf64_symbol_table_by_index f1 lnk >>= fun symtab -> let symtab_map = symbol_map_from_elf64_symtab f1 symtab in - let _ = print_endline "symtab_map generated" in mapM (interp f1 symtab_map sidx) rels >>= fun rel_maps -> - let _ = print_endline "relocations computed" in let rel_map = Map.fromList (List.concatMap Map_extra.toList rel_maps) in - let _ = print_endline "why is this slow?" in if Map.size rel_map <> List.length rels then fail "Multiple relocations at the same location" else From cf10bdea33ddf6d2f9a56b4992c8354e77095cbc Mon Sep 17 00:00:00 2001 From: Matej Urban Date: Mon, 27 Jan 2025 23:46:04 +0000 Subject: [PATCH 26/44] Report unsupported relocation --- src/abis/aarch64/abi_aarch64_symbolic_relocation.lem | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem b/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem index c01ef41..2e1e14c 100644 --- a/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem +++ b/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem @@ -4,6 +4,7 @@ open import Maybe open import Num open import Basic_classes +open import String open import Elf_types_native_uint open import Elf_file @@ -141,7 +142,7 @@ let abi_aarch64_apply_relocation_symbolic rel s_val p_val ef = |> ) else - fail "Invalid AARCH64 relocation type" + fail ("Unsupported AARCH64 relocation type " ^ (string_of_aarch64_relocation_type rel_type)) else fail "abi_aarch64_apply_relocation: not a relocatable file" From e20f2ce56a9e1e08981561d89fb8ffa3db6beb1c Mon Sep 17 00:00:00 2001 From: Matej Urban Date: Sat, 1 Feb 2025 19:58:11 +0000 Subject: [PATCH 27/44] Make ldst target dependent on size --- src/abis/aarch64/abi_aarch64_symbolic_relocation.lem | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem b/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem index 2e1e14c..ecd7a10 100644 --- a/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem +++ b/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem @@ -21,7 +21,7 @@ type aarch64_relocation_target | Data32 | ADRP | ADD - | LDST + | LDST of int | CALL (* TODO fix sizes and stuff *) @@ -116,7 +116,7 @@ let abi_aarch64_apply_relocation_symbolic rel s_val p_val ef = ; rel_desc_range = Nothing ; rel_desc_alignment_bits = 2 ; rel_desc_mask = (11, 2) - ; rel_desc_target = LDST + ; rel_desc_target = LDST 2 |> ) else if rel_type = r_aarch64_ldst64_abs_lo12_nc then @@ -127,7 +127,7 @@ let abi_aarch64_apply_relocation_symbolic rel s_val p_val ef = ; rel_desc_range = Nothing ; rel_desc_alignment_bits = 3 ; rel_desc_mask = (11, 3) - ; rel_desc_target = LDST + ; rel_desc_target = LDST 3 |> ) else if rel_type = r_aarch64_call26 then From 26df8fa21f570e527d86bd991a54a7a64ca9a5db Mon Sep 17 00:00:00 2001 From: Matej Urban Date: Wed, 5 Mar 2025 16:26:26 +0000 Subject: [PATCH 28/44] wip --- .gitignore | 1 + buildoutput | 5 + src/dwarf.lem | 317 +++++++----------------------------- src/dwarf_byte_sequence.lem | 108 ++++++++++++ src/lem.mk | 8 +- src/sym.lem | 207 +++++++++++++++++++++++ src/sym_ocaml.ml | 163 ++++++++++++++++++ 7 files changed, 552 insertions(+), 257 deletions(-) create mode 100644 buildoutput create mode 100644 src/dwarf_byte_sequence.lem create mode 100644 src/sym.lem create mode 100644 src/sym_ocaml.ml diff --git a/.gitignore b/.gitignore index ba315b0..8faed00 100644 --- a/.gitignore +++ b/.gitignore @@ -9,6 +9,7 @@ src/**/*.ml !src/utility.ml !src/uint32_wrapper.ml !src/uint64_wrapper.ml +!src/sym_ocaml.ml !src/ml_bindings.ml !src/byte_sequence_wrapper.ml !src/filesystem_wrapper.ml diff --git a/buildoutput b/buildoutput new file mode 100644 index 0000000..8744884 --- /dev/null +++ b/buildoutput @@ -0,0 +1,5 @@ +make -C src +make[1]: Entering directory '/home/matej/Documents/cam/IIproj/linksem/src' +OCAMLPATH is +make[1]: Nothing to be done for 'default'. +make[1]: Leaving directory '/home/matej/Documents/cam/IIproj/linksem/src' diff --git a/src/dwarf.lem b/src/dwarf.lem index 7ba0b62..b0a2dcc 100644 --- a/src/dwarf.lem +++ b/src/dwarf.lem @@ -29,6 +29,9 @@ open import Elf_symbol_table open import Elf_types_native_uint open import Elf_symbolic +open import Sym +open import Dwarf_byte_sequence + (** ***************** experimental DWARF reading *********** *) (* @@ -135,7 +138,7 @@ let my_debug5 s = () (*print_endline s*) (** ** missing pervasives ************************************ *) (** ************************************************************ *) -(* sym_natural version of List.index *) +(* natural version of List.index *) val index_natural : forall 'a. list 'a -> natural -> maybe 'a let rec index_natural l n = match l with | [] -> Nothing @@ -151,196 +154,9 @@ declare ocaml target_rep function natural_nat_shift_left = `Nat_big_num.shift val natural_nat_shift_right : natural -> nat -> natural declare ocaml target_rep function natural_nat_shift_right = `Nat_big_num.shift_right` -(* Symbolic types *) -type sym 'a = - | Offset of (string * 'a) - | Absolute of 'a - | Unknown - -type sym_natural = sym natural -type sym_integer = sym integer - -val sym_add : forall 'a. NumAdd 'a => (sym 'a -> sym 'a -> sym 'a) -let sym_add x y= - match (x, y) with - | (Absolute x, Absolute y) -> Absolute (x + y) - | (Offset (s, x), Absolute y) -> Offset (s, x + y) - | (Absolute x, Offset (s, y)) -> Offset (s, x + y) - | _ -> Unknown - end - -class ( MaybeMinus 'a ) - val mminus : 'a -> 'a -> maybe 'a -end - -instance (MaybeMinus natural) - let mminus = fun x y -> if x >= y then Just (x - y) else Nothing -end - -instance (MaybeMinus integer) - let mminus = fun x y -> Just (x-y) -end - -val sym_minus : forall 'a. MaybeMinus 'a, NumMinus 'a => (sym 'a -> sym 'a -> sym 'a) -let sym_minus x y= - match (x, y) with - | (Absolute x, Absolute y) -> Absolute (x - y) - | (Offset (s, x), Absolute y) -> - match mminus x y with - | Just v -> Offset (s, v) - | Nothing -> Unknown - end - | (Offset (s, x), Offset (t, y)) -> - if s = t then - match mminus x y with - | Just v -> Absolute v - | Nothing -> Unknown - end - else - Unknown - | _ -> Unknown - end - -val sym_natural_minus : sym_natural -> sym_natural -> sym_natural -let sym_natural_minus = sym_minus - -val sym_integer_minus : sym_integer -> sym_integer -> sym_integer -let sym_integer_minus = sym_minus - -val sym_bind : forall 'a 'b. sym 'a -> ('a -> sym 'b) -> sym 'b -let sym_bind x f = match x with - | Absolute x -> f x - | _ -> Unknown -end - -let sym_map f x = sym_bind x (fun x -> Absolute(f x)) - -let sym_map2 f x y = sym_bind x (fun x -> sym_map (f x) y) - -(* TODO add everywhere or handle differently *) -let simplify = function - | Offset (s, x) -> match toCharList s with - | #'.'::#'d'::#'e'::#'b'::#'u'::#'g'::_ -> Absolute x (* HACK should be lookup in context *) - | _ -> Offset (s, x) - end - | x -> x -end - -let sym_unwrap sym_val ctx = match simplify sym_val with - | Absolute x -> x - | Offset (s, x) -> Assert_extra.failwith ("sym_unwrap (Offset from " ^ s ^ ") in " ^ ctx) - | Unknown -> Assert_extra.failwith ("sym_unwrap Unknown in " ^ ctx) -end - -let pp_sym ppf = function -| Absolute x -> ppf x -| Offset (s, x) -> s ^ "+" ^ ppf x -| Unknown -> "Unknown" -end - -instance forall 'a. Show 'a => (Show (sym 'a)) - let show = pp_sym show -end - -instance forall 'a. NumAdd 'a => (NumAdd (sym 'a)) - let (+) = sym_add -end - -instance forall 'a. MaybeMinus 'a, NumMinus 'a => (NumMinus (sym 'a)) - let (-) = sym_minus -end - -instance forall 'a. NumMult 'a => (NumMult (sym 'a)) - let ( * ) = sym_map2 ( * ) -end - -instance forall 'a. NumDivision 'a => (NumDivision (sym 'a)) - let (/) = sym_map2 (/) -end - -class ( ModSym 'a ) - val sym_mod: sym 'a -> sym 'a -> sym 'a -end - -(* TODO this is hacky *) -instance (ModSym integer) - let sym_mod x y = if match y with - | Absolute(y) -> y >= integerFromNatural (natural_of_hex "0x10000000000000000") - | _ -> false - end then - x - else - sym_map2 (mod) x y -end - -instance (ModSym natural) - let sym_mod x y = if match y with - | Absolute(y) -> y >= natural_of_hex "0x10000000000000000" - | _ -> false - end then - x - else - sym_map2 (mod) x y -end - - -instance forall 'a. ModSym 'a => (NumRemainder (sym 'a)) - let (mod) = sym_mod -end - -let sym_comp f a b = match (simplify a, simplify b) with - | (Absolute a, Absolute b) -> f a b - | (Offset (s, a), Offset(t, b)) -> if s = t then - f a b - else - Assert_extra.failwith ("offsets of different sections " ^ s ^ " and " ^ t) - | _ -> Assert_extra.failwith "sym_comp" (* TODO should probably figure out better errors*) -end - -instance forall 'a. Ord 'a => (Ord (sym 'a)) - let compare = sym_comp compare - let (<) = sym_comp (<) - let (<=) = sym_comp (<=) - let (>) = sym_comp (>) - let (>=) = sym_comp (>=) -end - -(* instance forall 'a. Ord 'a, Show 'a => (Ord (sym 'a)) - let compare = (fun x -> fun y -> compare (sym_unwrap x ((show x) ^ "compare" ^ (show y))) (sym_unwrap y ((show x) ^ "compare" ^ (show y)))) - let (<) = (fun x -> fun y -> (sym_unwrap x ((show x) ^ "<" ^ (show y))) < (sym_unwrap y ((show x) ^ "<" ^ (show y)))) - let (<=) = (fun x -> fun y -> (sym_unwrap x ((show x) ^ "<=" ^ (show y))) <= (sym_unwrap y ((show x) ^ "<=" ^ (show y)))) - let (>) = (fun x -> fun y -> (sym_unwrap x ((show x) ^ ">" ^ (show y))) > (sym_unwrap y ((show x) ^ ">" ^ (show y)))) - let (>=) = (fun x -> fun y -> (sym_unwrap x ((show x) ^ ">=" ^ (show y))) >= (sym_unwrap y ((show x) ^ ">=" ^ (show y)))) -end *) - - -class ( NumeralSym 'a ) - val fromNumeralSym : numeral -> sym 'a -end - -instance (NumeralSym integer) - let fromNumeralSym = fun x -> Absolute (fromNumeral x) -end - -instance (NumeralSym natural) - let fromNumeralSym = fun x -> Absolute (fromNumeral x) -end - -instance forall 'a. NumeralSym 'a => (Numeral (sym 'a)) - let fromNumeral = fromNumeralSym -end - -val sym_eq : forall 'a. Eq 'a => sym 'a -> sym 'a -> bool -let sym_eq a b = match (simplify a, simplify b) with -| (Absolute x, Absolute y) -> x = y -| (Offset (s,x), Offset (t, y)) -> s=t && x=y -| _ -> Assert_extra.failwith "sym_eq" -end - - let rec sym_integer_of_symbolic_expression x = match x with - | Section s -> Offset (s, 0) - | Const x -> Absolute x + | Section s -> sym_integer_section s + | Const x -> sym_integer_const x | BinOp (x, Add, y) -> (sym_integer_of_symbolic_expression x) + (sym_integer_of_symbolic_expression y) | BinOp (x, Sub, y) -> (sym_integer_of_symbolic_expression x) - (sym_integer_of_symbolic_expression y) | AssertRange (x, _, _) -> sym_integer_of_symbolic_expression x (*TODO*) @@ -349,39 +165,32 @@ let rec sym_integer_of_symbolic_expression x = match x with end let sym_natural_of_symbolic_expression x = - match sym_integer_of_symbolic_expression x with - | Offset (s, x) -> Offset (s, partialNaturalFromInteger x) - | Absolute x -> Absolute (partialNaturalFromInteger x) - | Unknown -> Unknown -end + partialSymNaturalFromInteger (sym_integer_of_symbolic_expression x) -let sym_natural_land = sym_map2 natural_land -let sym_natural_lxor = sym_map2 natural_lxor -let sym_natural_lor = sym_map2 natural_lor +let sym_natural_land = sym_natural_map2 natural_land +let sym_natural_lxor = sym_natural_map2 natural_lxor +let sym_natural_lor = sym_natural_map2 natural_lor -let symIntegerFromSymNatural = sym_map integerFromNatural +let symIntegerFromSymNatural = symIntegerFromNatural -let natFromSymNatural = function - | Absolute x -> natFromNatural x - | _ -> Assert_extra.failwith "symIntegerFromSymNatural" -end +let natFromSymNatural x = natFromNatural (sym_natural_expect_const x (*"symIntegerFromSymNatural"*)) -let symNaturalFromNat x = Absolute (naturalFromNat x) +let symNaturalFromNat x = sym_natural_const (naturalFromNat x) -let sym_natural_of_hex x = Absolute(natural_of_hex x) +let sym_natural_of_hex x = sym_natural_const (natural_of_hex x) -let sym_natural_of_byte x = Absolute(natural_of_byte x) +let sym_natural_of_byte x = sym_natural_const (natural_of_byte x) -let symNaturalPow x y = sym_map (fun x -> naturalPow x y) x +let symNaturalPow x y = sym_natural_map (fun x -> naturalPow x y) x -let symNaturalFromSymInteger = sym_map naturalFromInteger +let symNaturalFromSymInteger = partialSymNaturalFromInteger -let index_sym_natural l n = index_natural l (sym_unwrap n "index_sym_natural") +let index_sym_natural l n = index_natural l (sym_natural_expect_const n (*"index_sym_natural"*)) -let partialSymNaturalFromSymInteger = sym_map partialNaturalFromInteger +let partialSymNaturalFromSymInteger = partialSymNaturalFromInteger -let sym_natural_nat_shift_left x sh = sym_map (fun x -> natural_nat_shift_left x sh) x -let sym_natural_nat_shift_right x sh = sym_map (fun x -> natural_nat_shift_right x sh) x +let sym_natural_nat_shift_left x sh = sym_natural_map (fun x -> natural_nat_shift_left x sh) x +let sym_natural_nat_shift_right x sh = sym_natural_map (fun x -> natural_nat_shift_right x sh) x (* byte sequence *) @@ -1847,7 +1656,7 @@ let bytes_of_natural en size n = else Assert_extra.failwith "bytes_of_natural given size that is not 4 or 8") -let bytes_of_sym_natural en size n = bytes_of_natural en (sym_unwrap size "bytes_of_sym_natural size") (sym_unwrap n "bytes_of_sym_natural n") +let bytes_of_sym_natural en size n = bytes_of_natural en (sym_natural_expect_const size (*"bytes_of_sym_natural size"*)) (sym_natural_expect_const n (*"bytes_of_sym_natural n"*)) let rec natural_of_bytes_little bs : natural = match rbs_read_char bs with @@ -1868,7 +1677,7 @@ let natural_of_bytes en bs = | Big -> natural_of_bytes_big 0 bs end -let sym_natural_of_bytes en bs = Absolute (natural_of_bytes en bs) +let sym_natural_of_bytes en bs = sym_natural_const (natural_of_bytes en bs) (* TODO: generalise *) @@ -1920,11 +1729,11 @@ let rec mytake' (n:natural) acc xs = end val mytake : forall 'a. sym_natural -> (list 'a) -> maybe (list 'a * list 'a) -let mytake n xs = mytake' (sym_unwrap n "mytake") [] xs +let mytake n xs = mytake' (sym_natural_expect_const n (*"mytake"*)) [] xs val mynth : forall 'a. sym_natural -> (list 'a) -> maybe 'a let rec mynth (n:sym_natural) xs = - match (sym_unwrap n "mynth",xs) with + match (sym_natural_expect_const n (*"mynth"*),xs) with | (0, x::xs') -> Just x | (0, []) -> Nothing (*Assert_extra.failwith "mynth"*) | (_, x::xs') -> mynth (n-1) xs' @@ -1936,8 +1745,8 @@ let rec mynth (n:sym_natural) xs = let pphexplain n = unsafe_hex_string_of_natural 0 n let pphex n = "0x" ^ pphexplain n -let pphexplain_sym = pp_sym pphexplain -let pphex_sym = pp_sym pphex +let pphexplain_sym = sym_natural_pp pphexplain +let pphex_sym = sym_natural_pp pphex val abs : integer -> natural (*declare hol target_rep function abs = `int_of_num` *) @@ -1980,14 +1789,14 @@ let just_one s xs = let max_address (as': sym_natural) : sym_natural = - match sym_unwrap as' "max_addres" with + match sym_natural_expect_const as' (*"max_addres"*) with | 4 -> sym_natural_of_hex "0xffffffff" | 8 -> sym_natural_of_hex "0xffffffffffffffff" | _ -> Assert_extra.failwith "max_address size not 4 or 8" end let range_address (as': sym_natural) : sym_natural = - match sym_unwrap as' "max_addres" with + match sym_natural_expect_const as' (*"max_addres"*) with | 4 -> sym_natural_of_hex "0x100000000" | 8 -> sym_natural_of_hex "0x10000000000000000" | _ -> Assert_extra.failwith "range_address size not 4 or 8" @@ -2150,7 +1959,7 @@ let pr_post_map p f = fun (pc: parse_context) -> pr_map f (p pc) val pr_with_pos : forall 'a. (parser 'a) -> (parser (sym_natural * 'a)) -let pr_with_pos p = fun pc -> pr_map (fun x -> (Absolute pc.pc_offset,x)) (p pc) +let pr_with_pos p = fun pc -> pr_map (fun x -> (sym_natural_const pc.pc_offset,x)) (p pc) val parse_pair : forall 'a 'b. (parser 'a) -> (parser 'b) -> (parser ('a * 'b)) @@ -2245,7 +2054,7 @@ let parse_demaybe s p = val parse_restrict_length : forall 'a. sym_natural -> parser 'a -> parser 'a let parse_restrict_length n p = fun pc -> - match rbs_partition (sym_unwrap n "parse_strict_length") pc.pc_bytes with + match rbs_partition (sym_natural_expect_const n (*"parse_strict_length"*)) pc.pc_bytes with | Fail _ -> Assert_extra.failwith "parse_restrict_length not given enough bytes" | Success (xs,ys) -> let pc' = <| pc_bytes = xs; pc_offset = pc.pc_offset |> in @@ -2264,7 +2073,7 @@ let parse_byte : parser(byte) = let parse_n_bytes (n:sym_natural) : parser (rel_byte_sequence) = fun (pc:parse_context) -> - match rbs_partition (sym_unwrap n "parse_n_bytes") pc.pc_bytes with + match rbs_partition (sym_natural_expect_const n (*"parse_n_bytes"*)) pc.pc_bytes with | Fail _ -> PR_fail ("parse_n_bytes n=" ^ pphex_sym n) pc | Success (xs,bs) -> PR_success xs (<|pc_bytes=bs; pc_offset= pc.pc_offset + (rbs_length xs) |> ) @@ -2277,7 +2086,7 @@ let parse_string : parser (rel_byte_sequence) = match rbs_find_byte pc.pc_bytes bzero with | Nothing -> PR_fail "parse_string" pc | Just n -> - pr_bind (parse_n_bytes (Absolute n) pc) (fun res pc -> (*todo find byte should respect relocs*) + pr_bind (parse_n_bytes (sym_natural_const n) pc) (fun res pc -> (*todo find byte should respect relocs*) pr_bind (parse_byte pc) (fun _ pc -> pr_return res pc)) end @@ -2299,7 +2108,7 @@ let parse_uint8 : parser sym_natural= match rbs_read_char pc.pc_bytes with | Success (b, bytes) -> let v = natural_of_byte b in - PR_success (Absolute v) (<| pc_bytes = bytes; pc_offset = pc.pc_offset + 1 |>) + PR_success (sym_natural_const v) (<| pc_bytes = bytes; pc_offset = pc.pc_offset + 1 |>) | _ -> PR_fail "parse_uint32 not given enough bytes" pc end @@ -2319,7 +2128,7 @@ let parse_uint16 c : parser sym_natural= natural_of_byte b0 + 256*natural_of_byte b1 else natural_of_byte b1 + 256*natural_of_byte b0 in - PR_success (Absolute v) (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 2 |>) + PR_success (sym_natural_const v) (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 2 |>) | _ -> PR_fail "parse_uint32 not given enough bytes" pc end @@ -2333,7 +2142,7 @@ let parse_uint32 c : parser sym_natural= natural_of_byte b0 + 256*natural_of_byte b1 + 256*256*natural_of_byte b2 + 256*256*256*natural_of_byte b3 else natural_of_byte b3 + 256*natural_of_byte b2 + 256*256*natural_of_byte b1 + 256*256*256*natural_of_byte b0 in - PR_success (Absolute v) (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 4 |>) + PR_success (sym_natural_const v) (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 4 |>) | Success (ReadReloc r, bytes') -> if r.arel_target = Data32 then PR_success (sym_natural_of_symbolic_expression r.arel_value) (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 4 |>) @@ -2355,7 +2164,7 @@ let parse_uint64 c : parser sym_natural= natural_of_byte b7 + 256*natural_of_byte b6 + 256*256*natural_of_byte b5 + 256*256*256*natural_of_byte b4 + (256*256*256*256*(natural_of_byte b3 + 256*natural_of_byte b2 + 256*256*natural_of_byte b1 + 256*256*256*natural_of_byte b0)) in - PR_success (Absolute v) (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 8 |>) + PR_success (sym_natural_const v) (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 8 |>) | Success (ReadReloc r, bytes') -> if r.arel_target = Data64 then PR_success (sym_natural_of_symbolic_expression r.arel_value) (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 8 |>) @@ -2404,7 +2213,7 @@ let rec parse_ULEB128' (acc: natural) (shift_factor: natural) : parser natural = let parse_ULEB128 : parser sym_natural = fun (pc:parse_context) -> - pr_map (fun x -> Absolute x) (parse_ULEB128' 0 1 pc) + pr_map (fun x -> sym_natural_const x) (parse_ULEB128' 0 1 pc) let rec parse_SLEB128' (acc: natural) (shift_factor: natural) : parser (bool * natural * natural) = fun (pc:parse_context) -> @@ -2427,7 +2236,7 @@ let rec parse_SLEB128' (acc: natural) (shift_factor: natural) : parser (bool * n let parse_SLEB128 : parser sym_integer = pr_post_map (parse_SLEB128' 0 1) (fun (positive, shift_factor, acc) -> - Absolute (if positive then integerFromNatural acc else integerFromNatural acc - integerFromNatural shift_factor)) + sym_integer_const (if positive then integerFromNatural acc else integerFromNatural acc - integerFromNatural shift_factor)) let parse_nonzero_ULEB128_pair : parser (maybe (sym_natural*sym_natural)) = let _ = my_debug "nonzero_ULEB128_pair " in @@ -2446,14 +2255,14 @@ let parse_uintDwarfN c (df: dwarf_format) : parser sym_natural = end let parse_uint_address_size c (as': sym_natural) : parser sym_natural = - match sym_unwrap as' "parse_uint_address_size" with + match sym_natural_expect_const as' (**"parse_uint_address_size"*) with | 4 -> (parse_uint32 c) | 8 -> (parse_uint64 c) | _ -> Assert_extra.failwith ("cuh_address_size not 4 or 8: " ^ show as') end let parse_uint_segment_selector_size c (ss: sym_natural) : parser (maybe sym_natural) = - match sym_unwrap ss "parse_uint_segment_selector_size_size" with + match sym_natural_expect_const ss (*"parse_uint_segment_selector_size_size"*) with | 0 -> pr_return Nothing | 1 -> pr_post_map (parse_uint8) (fun n -> Just n) | 2 -> pr_post_map (parse_uint16 c) (fun n -> Just n) @@ -2549,7 +2358,7 @@ let rec null_terminated_bs (bs: rel_byte_sequence) : rel_byte_sequence = end let pp_debug_str_entry (str: rel_byte_sequence) (n: sym_natural) : string = - match rbs_dropbytes (sym_unwrap n "pp_debug_str_entry") str with + match rbs_dropbytes (sym_natural_expect_const n (*"pp_debug_str_entry"*)) str with | Fail _ -> "strp beyond .debug_str extent" | Success bs -> string_of_rel_byte_sequence (null_terminated_bs bs) end @@ -2559,7 +2368,7 @@ let pp_debug_str_entry (str: rel_byte_sequence) (n: sym_natural) : string = let pp_operation_argument_value (oav:operation_argument_value) : string = match oav with | OAV_natural n -> pphex_sym n - | OAV_integer n -> pp_sym pphex_integer n (* show n*) + | OAV_integer n -> sym_integer_pp pphex_integer n (* show n*) | OAV_block n bs -> pphex_sym n ^ " " ^ ppbytes bs end @@ -2816,7 +2625,7 @@ let parser_of_attribute_form c cuh n = (* *** where to put this? *) -let pp_pos pos = "<" ^ pp_sym pphexplain pos ^">" +let pp_pos pos = "<" ^ sym_natural_pp pphexplain pos ^">" let pp_cupdie (cu,parents,die) = pp_pos cu.cu_header.cuh_offset ^ "/" ^ pp_pos die.die_offset @@ -3261,7 +3070,7 @@ let rec parse_die c str cuh find_abbreviation_declaration = (fun dies pc''' -> PR_success (Just ( let die = <| - die_offset = Absolute pc.pc_offset; + die_offset = sym_natural_const pc.pc_offset; die_abbreviation_code = abbreviation_code; die_abbreviation_declaration = ad; die_attribute_values = avs; @@ -3322,13 +3131,13 @@ let _ = my_debug4 (pp_compilation_unit_header cuh) in if cuh.cuh_unit_length = 0 then PR_success Nothing pc' else - let pc_abbrev = <|pc_bytes = match rbs_dropbytes (sym_unwrap cuh.cuh_debug_abbrev_offset "mydrop of pc_abbrev") debug_abbrev_section_body with Success bs -> bs | Fail _ -> Assert_extra.failwith "mydrop of debug_abbrev" end; pc_offset = sym_unwrap cuh.cuh_debug_abbrev_offset "mydrop of pc_abbrev"|> in + let pc_abbrev = <|pc_bytes = match rbs_dropbytes (sym_natural_expect_const cuh.cuh_debug_abbrev_offset (*"mydrop of pc_abbrev"*)) debug_abbrev_section_body with Success bs -> bs | Fail _ -> Assert_extra.failwith "mydrop of debug_abbrev" end; pc_offset = sym_natural_expect_const cuh.cuh_debug_abbrev_offset (*"mydrop of pc_abbrev"*)|> in (* todo: this is reparsing the abbreviations table for each cu *) let abbreviations_table = match parse_abbreviations_table c pc_abbrev with | PR_fail s pc_abbrev' -> Assert_extra.failwith ("parse_abbrevations_table fail: " ^ pp_parse_fail s pc_abbrev') - | PR_success at pc_abbrev' -> <| at_offset=Absolute pc_abbrev.pc_offset; at_table= at|> + | PR_success at pc_abbrev' -> <| at_offset=sym_natural_const pc_abbrev.pc_offset; at_table= at|> end in let _ = my_debug4 (pp_abbreviations_table abbreviations_table) in @@ -3382,12 +3191,12 @@ let parse_type_unit c (debug_str_section_body: rel_byte_sequence) (debug_abbrev_ (* let _ = my_debug4 (pp_type_unit_header tuh) in *) - let pc_abbrev = let n = tuh.tuh_cuh.cuh_debug_abbrev_offset in <|pc_bytes = match rbs_dropbytes (sym_unwrap n "mydrop of pc_abbrev") debug_abbrev_section_body with Success bs -> bs | Fail _ -> Assert_extra.failwith "mydrop of debug_abbrev" end; pc_offset = sym_unwrap n "mydrop of pc_abbrev" |> in + let pc_abbrev = let n = tuh.tuh_cuh.cuh_debug_abbrev_offset in <|pc_bytes = match rbs_dropbytes (sym_natural_expect_const n (*"mydrop of pc_abbrev"*)) debug_abbrev_section_body with Success bs -> bs | Fail _ -> Assert_extra.failwith "mydrop of debug_abbrev" end; pc_offset = sym_natural_expect_const n (*"mydrop of pc_abbrev"*) |> in let abbreviations_table = match parse_abbreviations_table c pc_abbrev with | PR_fail s pc_abbrev' -> Assert_extra.failwith ("parse_abbrevations_table fail: " ^ pp_parse_fail s pc_abbrev') - | PR_success at pc_abbrev' -> <| at_offset=Absolute pc_abbrev.pc_offset; at_table= at|> + | PR_success at pc_abbrev' -> <| at_offset=sym_natural_const pc_abbrev.pc_offset; at_table= at|> end in (* let _ = my_debug4 (pp_abbreviations_table abbreviations_table) in *) @@ -3502,7 +3311,7 @@ let parse_location_list c cuh : parser (maybe location_list) = else pr_post_map1 (parse_list (parse_location_list_item c cuh) pc) - (fun llis -> (Just (Absolute pc.pc_offset, llis))) + (fun llis -> (Just (sym_natural_const pc.pc_offset, llis))) let parse_location_list_list c cuh : parser location_list_list = parse_list (parse_location_list c cuh) @@ -3605,7 +3414,7 @@ let parse_range_list c cuh : parser (maybe (list range_list)) = else pr_post_map1 (parse_list (parse_range_list_item c cuh) pc) - (fun rlis -> (Just (expand_range_list_suffixes cuh (Absolute pc.pc_offset, rlis)))) + (fun rlis -> (Just (expand_range_list_suffixes cuh (sym_natural_const pc.pc_offset, rlis)))) let parse_range_list_list c cuh : parser range_list_list = pr_map2 List.concat (parse_list (parse_range_list c cuh)) @@ -3754,7 +3563,7 @@ let parse_call_frame_instruction c cuh : parser (maybe call_frame_instruction) = let pc' = <| pc_bytes = bs'; pc_offset = pc.pc_offset + 1 |> in let ch = unsigned_char_of_byte b in let high_bits = unsigned_char_land ch (unsigned_char_of_natural 192) in - let low_bits = Absolute (natural_of_unsigned_char (unsigned_char_land ch (unsigned_char_of_natural 63))) in + let low_bits = sym_natural_const (natural_of_unsigned_char (unsigned_char_land ch (unsigned_char_of_natural 63))) in if high_bits = unsigned_char_of_natural 0 then match lookup_abCde_de low_bits call_frame_instruction_encoding with | Just ((args: list call_frame_argument_type), result) -> @@ -3865,7 +3674,7 @@ let parse_initial_location c cuh mss mas' : parser ((maybe sym_natural) * sym_na let parse_call_frame_instruction_bytes offset' ul = fun (pc: parse_context) -> - parse_n_bytes (ul - (Absolute pc.pc_offset - offset')) pc + parse_n_bytes (ul - (sym_natural_const pc.pc_offset - offset')) pc let parse_frame_info_element c cuh (fi: list frame_info_element) : parser frame_info_element = parse_dependent @@ -4089,8 +3898,8 @@ let parse_line_number_header c (comp_dir:maybe string) : parser line_number_head (parse_triple (parse_uintDwarfN c df) (* header_length *) (parse_uint8) (* minimum_instruction_length *) - (if v pr_post_map (parse_triple - (pr_post_map (parse_n_bytes (ob-Absolute 1)) (fun bs -> List.map sym_natural_of_byte (byte_list_of_rel_byte_sequence bs))) (* standard_opcode_lengths *) + (pr_post_map (parse_n_bytes (ob-sym_natural_const 1)) (fun bs -> List.map sym_natural_of_byte (byte_list_of_rel_byte_sequence bs))) (* standard_opcode_lengths *) ((*pr_return [[]]*) parse_list parse_non_empty_string) (* include_directories *) (parse_list parse_line_number_file_entry) (* file names *) ) @@ -4282,7 +4091,7 @@ let parse_line_number_info c str (d_line: rel_byte_sequence) (cu: compilation_un lnp | PR_fail s pc' -> Assert_extra.failwith ("parse_line_number_header failed: " ^ s) end in - f (sym_unwrap (line_number_offset_of_compilation_unit c cu) "parse_line_number_info") + f (sym_natural_expect_const (line_number_offset_of_compilation_unit c cu) (*"parse_line_number_info"*)) let parse_line_number_infos c str debug_line_section_body compilation_units = @@ -4414,7 +4223,7 @@ let extract_section_body (f:elf_file) (ri:relocation_interpreter reloc_target_da ) f32.elf32_file_interpreted_sections in match sections with | [section] -> - let section_addr = Offset (section_name, 0) in + let section_addr = sym_natural_section section_name in let section_body = section.Elf_interpreted_section.elf32_section_body in (* let _ = my_debug4 (section_name ^ (": \n" ^ (Elf_interpreted_section.string_of_elf32_interpreted_section section ^ "\n" * ^ " body = " ^ ppbytes2 0 section_body ^ "\n"))) in *) @@ -4437,7 +4246,7 @@ let extract_section_body (f:elf_file) (ri:relocation_interpreter reloc_target_da ) f64.elf64_file_interpreted_sections in match sections with | [section] -> - let section_addr = Offset (section_name, 0) in + let section_addr = sym_natural_section section_name in let section_body = section.Elf_interpreted_section.elf64_section_body in let _ = my_debug "extracted section body" in match extract_elf64_relocations_for_section f64 ri section_name with @@ -4597,7 +4406,7 @@ accumulated so far *) let arithmetic_context_of_cuh cuh = - match sym_unwrap cuh.cuh_address_size "arithmetic_context_of_cuh" with + match sym_natural_expect_const cuh.cuh_address_size (*"arithmetic_context_of_cuh"*) with | 8 -> <| ac_bitwidth = 64; @@ -6831,7 +6640,7 @@ let pp_inlined_subroutines ds iss = let pp_inlined_subroutine_by_range ds ((n1,n2),((m:sym_natural),(n:sym_natural)),is) = pphex_sym n1 ^ " " ^ pphex_sym n2 ^ " " - ^ (if n<>(Absolute 1) then "("^show m^" of "^show n^") " else "") + ^ (if n<>(sym_natural_const 1) then "("^show m^" of "^show n^") " else "") ^ pp_inlined_subroutine_header ds is ^"\n" ^ (if m=0 then pp_inlined_subroutine_const_params ds.ds_dwarf is else "") @@ -6849,13 +6658,13 @@ let pp_inlined_subroutines_by_range ds iss = let rec words_of_rel_byte_sequence (addr:sym_natural) (bs:rel_byte_sequence) (acc:list (sym_natural * sym_natural)) : list (sym_natural * sym_natural) = match rbs_read_4_bytes_be bs with | Success (ReadValue (b0,b1,b2,b3), bs') -> (*TODO*) - let i : sym_natural = Absolute (natural_of_byte b0 + 256*natural_of_byte b1 + 65536*natural_of_byte b2 + 65536*256*natural_of_byte b3) in + let i : sym_natural = sym_natural_const (natural_of_byte b0 + 256*natural_of_byte b1 + 65536*natural_of_byte b2 + 65536*256*natural_of_byte b3) in words_of_rel_byte_sequence (addr+4) bs' ((addr,i)::acc) | Fail _ -> List.reverse acc end let pp_instruction ((addr:sym_natural),(i:sym_natural)) = - hex_string_of_big_int_pad8 (sym_unwrap addr "pp_instruction") ^ " " ^ hex_string_of_big_int_pad8 (sym_unwrap i "pp_instruction") ^ "\n" + hex_string_of_big_int_pad8 (sym_natural_expect_const addr (*"pp_instruction"*)) ^ " " ^ hex_string_of_big_int_pad8 (sym_natural_expect_const i (*"pp_instruction"*)) ^ "\n" val pp_text_section : elf_file -> relocation_interpreter reloc_target_data -> string let pp_text_section f ri = diff --git a/src/dwarf_byte_sequence.lem b/src/dwarf_byte_sequence.lem new file mode 100644 index 0000000..ff1e3f3 --- /dev/null +++ b/src/dwarf_byte_sequence.lem @@ -0,0 +1,108 @@ +open import Byte_sequence +open import Sym +open import Num +open import Map +open import Set +open import Error +open import Maybe +open import Bool +open import Basic_classes + +(* ================= *) +(* sym_byte_sequence *) +(* ================= *) + +type symbolic_bytes = +<| sb_width : natural + ; sb_value : sym_natural + |> + +type sym_byte_sequence = +<| sbs_bytes : byte_sequence + ; sbs_symbolic : Map.map natural symbolic_bytes + ; sbs_pos : natural + |> + +let sym_read_char bs = + if Map.member bs.sbs_pos bs.sbs_symbolic then + Assert_extra.failwith "Read char: is symbolic" + else + read_char bs.sbs_bytes >>= fun (c, bs') -> + return (c, <| sbs_bytes=bs'; sbs_symbolic = bs.sbs_symbolic; sbs_pos = bs.sbs_pos + 1 |>) + +let sym_read_2_bytes_be bs0 = + sym_read_char bs0 >>= fun (b0, bs1) -> + sym_read_char bs1 >>= fun (b1, bs2) -> + return ((b0, b1), bs2) + +let sym_read_4_bytes_be bs0 = + sym_read_char bs0 >>= fun (b0, bs1) -> + sym_read_char bs1 >>= fun (b1, bs2) -> + sym_read_char bs2 >>= fun (b2, bs3) -> + sym_read_char bs3 >>= fun (b3, bs4) -> + return ((b0, b1, b2, b3), bs4) + +let sym_read_8_bytes_be bs0 = + sym_read_char bs0 >>= fun (b0, bs1) -> + sym_read_char bs1 >>= fun (b1, bs2) -> + sym_read_char bs2 >>= fun (b2, bs3) -> + sym_read_char bs3 >>= fun (b3, bs4) -> + sym_read_char bs4 >>= fun (b4, bs5) -> + sym_read_char bs5 >>= fun (b5, bs6) -> + sym_read_char bs6 >>= fun (b6, bs7) -> + sym_read_char bs7 >>= fun (b7, bs8) -> + return ((b0, b1, b2, b3, b4, b5, b6, b7), bs8) + +let sym_dropbytes n bs = + dropbytes n bs.sbs_bytes >>= fun bs' -> + return <| sbs_bytes=bs'; sbs_symbolic=bs.sbs_symbolic; sbs_pos=bs.sbs_pos |> + +let sym_takebytes n bs = + takebytes n bs.sbs_bytes >>= fun bs' -> + return <| sbs_bytes=bs'; sbs_symbolic=bs.sbs_symbolic; sbs_pos=bs.sbs_pos+n |> + +let sym_partition idx bs0 = + sym_takebytes idx bs0 >>= fun l -> + sym_dropbytes idx bs0 >>= fun r -> + return (l, r) + +let sym_bs_length bs = + length bs.sbs_bytes + +let sym_expect_const bs = + let sym_positions = Map.domain bs.sbs_symbolic in + let len = sym_bs_length bs in + if Set.any (fun x -> x >= bs.sbs_pos && x < bs.sbs_pos + len) sym_positions then + Assert_extra.failwith "Byte sequence is symbolic" + else + bs.sbs_bytes + +let sym_bs_construct bs sym = + <| sbs_bytes=bs; sbs_symbolic=sym; sbs_pos=0 |> + + +(* Symboli reads *) + +type read_result 'a = + | Bytes of 'a + | Sym of sym_natural + +let sym_read_4_bytes_be_symbolic bs = + match Map.lookup bs.sbs_pos bs.sbs_symbolic with + | Nothing -> sym_read_4_bytes_be bs >>= fun (b, bs') -> + return (Bytes b, bs') + | Just <| sb_width=4; sb_value=v |> -> + sym_dropbytes 4 bs >>= fun bs' -> + return (Sym v, bs') + | _ -> Assert_extra.failwith "Reading misaligned symbolic value" + end + +let sym_read_8_bytes_be_symbolic bs = + match Map.lookup bs.sbs_pos bs.sbs_symbolic with + | Nothing -> sym_read_8_bytes_be bs >>= fun (b, bs') -> + return (Bytes b, bs') + | Just <| sb_width=8; sb_value=v |> -> + sym_dropbytes 8 bs >>= fun bs' -> + return (Sym v, bs') + | _ -> Assert_extra.failwith "Reading misaligned symbolic value" + end \ No newline at end of file diff --git a/src/lem.mk b/src/lem.mk index 91dfcd7..2ebcd2a 100644 --- a/src/lem.mk +++ b/src/lem.mk @@ -29,7 +29,7 @@ else OCAML_BYTE_SEQUENCE_IMPL=byte_sequence_ocaml.lem endif -LEM_UTIL_SRC := default_printing.lem missing_pervasives.lem show.lem endianness.lem multimap.lem error.lem filesystem.lem +LEM_UTIL_SRC := default_printing.lem missing_pervasives.lem show.lem endianness.lem multimap.lem error.lem filesystem.lem sym.lem # Some of the utility code is directly in ML, some in Lem; order matters! # NOTE: LEM_UTIL_SRC and ALL_UTIL_ML need to be kept in sync manually. # GAH. doing a topsort manually is a sign of failure. @@ -37,8 +37,9 @@ ALL_UTIL_ML := \ uint64_wrapper.ml uint32_wrapper.ml \ show.ml endianness.ml error.ml ml_bindings.ml missing_pervasives.ml multimap.ml \ default_printing.ml byte_sequence_wrapper.ml byte_sequence_impl.ml \ - filesystem.ml filesystem_wrapper.ml - # missing_pervasivesAuxiliary.ml multimapAuxiliary.ml + filesystem.ml filesystem_wrapper.ml \ + sym_ocaml.ml sym.ml \ + # missing_pervasivesAuxiliary.ml multimapAuxiliary.ml ALL_UTIL_ML_WO_LEM := $(filter-out $(patsubst %.lem,%.ml,$(LEM_UTIL_SRC)) $(patsubst %.lem,%Auxiliary.ml,$(LEM_UTIL_SRC)),$(ALL_UTIL_ML)) # Nasty cycle: @@ -57,6 +58,7 @@ LEM_ELF_SRC := byte_sequence.lem byte_pattern.lem byte_pattern_extra.lem \ elf_interpreted_segment.lem elf_interpreted_section.lem \ elf_note.lem elf_file.lem elf_dynamic.lem \ elf_symbolic.lem \ + dwarf_byte_sequence.lem \ dwarf_ctypes.lem dwarf.lem ldconfig.lem LEM_ABI_SRC := \ diff --git a/src/sym.lem b/src/sym.lem new file mode 100644 index 0000000..539ae3a --- /dev/null +++ b/src/sym.lem @@ -0,0 +1,207 @@ +open import Num +open import Show +open import Bool Basic_classes + +class (SymEq 'a) + val sym_eq : 'a -> 'a -> bool +end + +(* =========== *) +(* sym_natural *) +(* =========== *) +type sym_natural +declare ocaml target_rep type sym_natural = `Sym_ocaml.Num.t` + +val sym_natural_const : natural -> sym_natural +declare ocaml target_rep function sym_natural_const = `Sym_ocaml.Num.of_num` + +val sym_natural_section : string -> sym_natural +declare ocaml target_rep function sym_natural_section = `Sym_ocaml.Num.section` + +val sym_natural_expect_const : sym_natural -> natural +declare ocaml target_rep function sym_natural_expect_const = `Sym_ocaml.Num.to_num` + +val sym_natural_map : (natural -> natural) -> sym_natural -> sym_natural +declare ocaml target_rep function sym_natural_map = `Sym_ocaml.Num.map` + +val sym_natural_map2 : (natural -> natural -> natural) -> sym_natural -> sym_natural -> sym_natural +declare ocaml target_rep function sym_natural_map2 = `Sym_ocaml.Num.map2` + +instance (Numeral sym_natural) + let fromNumeral = fun x -> sym_natural_const (fromNumeral x) +end + +val sym_natural_pp : (natural -> string) -> sym_natural -> string +declare ocaml target_rep function sym_natural_pp = `Sym_ocaml.Num.ppf` + +instance (Show sym_natural) + let show = sym_natural_pp show +end + +val sym_natural_add : sym_natural -> sym_natural -> sym_natural +declare ocaml target_rep function sym_natural_add = `Sym_ocaml.Num.add` + + +instance (NumAdd sym_natural) + let (+) = sym_natural_add +end + +val sym_natural_sub : sym_natural -> sym_natural -> sym_natural +declare ocaml target_rep function sym_natural_sub = `Sym_ocaml.Num.sub_nat` + +instance (NumMinus sym_natural) + let (-) = sym_natural_sub +end + +val sym_natural_mul : sym_natural -> sym_natural -> sym_natural +declare ocaml target_rep function sym_natural_mul = `Sym_ocaml.Num.mul` + +instance (NumMult sym_natural) + let ( * ) = sym_natural_mul +end + +val sym_natural_div : sym_natural -> sym_natural -> sym_natural +declare ocaml target_rep function sym_natural_div = `Sym_ocaml.Num.div` + +instance (NumDivision sym_natural) + let (/) = sym_natural_div +end + +val sym_natural_mod : sym_natural -> sym_natural -> sym_natural +declare ocaml target_rep function sym_natural_mod = `Sym_ocaml.Num.modulus` + +instance (NumRemainder sym_natural) + let (mod) = sym_natural_mod +end + +val sym_natural_compare : sym_natural -> sym_natural -> ordering +val sym_natural_less : sym_natural -> sym_natural -> bool +val sym_natural_less_equal : sym_natural -> sym_natural -> bool +val sym_natural_greater : sym_natural -> sym_natural -> bool +val sym_natural_greater_equal : sym_natural -> sym_natural -> bool +val sym_natural_eq : sym_natural -> sym_natural -> bool + +declare ocaml target_rep function sym_natural_compare = `Sym_ocaml.Num.compare` +declare ocaml target_rep function sym_natural_less = `Sym_ocaml.Num.less` +declare ocaml target_rep function sym_natural_less_equal = `Sym_ocaml.Num.less_equal` +declare ocaml target_rep function sym_natural_greater = `Sym_ocaml.Num.greater` +declare ocaml target_rep function sym_natural_greater_equal = `Sym_ocaml.Num.greater_equal` +declare ocaml target_rep function sym_natural_eq = `Sym_ocaml.Num.equal` + +instance (Ord sym_natural) + let compare = sym_natural_compare + let (<) = sym_natural_less + let (<=) = sym_natural_less_equal + let (>) = sym_natural_greater + let (>=) = sym_natural_greater_equal +end + +instance (SymEq sym_natural) + let sym_eq = sym_natural_eq +end + + +(* =========== *) +(* sym_integer *) +(* =========== *) +type sym_integer +declare ocaml target_rep type sym_integer = `Sym_ocaml.Num.t` + +val sym_integer_const : integer -> sym_integer +declare ocaml target_rep function sym_integer_const = `Sym_ocaml.Num.of_num` + +val sym_integer_section : string -> sym_integer +declare ocaml target_rep function sym_integer_section = `Sym_ocaml.Num.section` + +val sym_integer_expect_const : sym_integer -> integer +declare ocaml target_rep function sym_integer_expect_const = `Sym_ocaml.Num.to_num` + +val sym_integer_map : (integer -> integer) -> sym_integer -> sym_integer +declare ocaml target_rep function sym_integer_map = `Sym_ocaml.Num.map` + +val sym_integer_map2 : (integer -> integer -> integer) -> sym_integer -> sym_integer -> sym_integer +declare ocaml target_rep function sym_integer_map2 = `Sym_ocaml.Num.map2` + +instance (Numeral sym_integer) + let fromNumeral = fun x -> sym_integer_const (fromNumeral x) +end + +val sym_integer_pp : (integer -> string) -> sym_integer -> string +declare ocaml target_rep function sym_integer_pp = `Sym_ocaml.Num.ppf` + +instance (Show sym_integer) + let show = sym_integer_pp show +end + +val sym_integer_add : sym_integer -> sym_integer -> sym_integer +declare ocaml target_rep function sym_integer_add = `Sym_ocaml.Num.add` + + +instance (NumAdd sym_integer) + let (+) = sym_integer_add +end + +val sym_integer_sub : sym_integer -> sym_integer -> sym_integer +declare ocaml target_rep function sym_integer_sub = `Sym_ocaml.Num.sub` + +instance (NumMinus sym_integer) + let (-) = sym_integer_sub +end + +val sym_integer_mul : sym_integer -> sym_integer -> sym_integer +declare ocaml target_rep function sym_integer_mul = `Sym_ocaml.Num.mul` + +instance (NumMult sym_integer) + let ( * ) = sym_integer_mul +end + +val sym_integer_div : sym_integer -> sym_integer -> sym_integer +declare ocaml target_rep function sym_integer_div = `Sym_ocaml.Num.div` + +instance (NumDivision sym_integer) + let (/) = sym_integer_div +end + +val sym_integer_mod : sym_integer -> sym_integer -> sym_integer +declare ocaml target_rep function sym_integer_mod = `Sym_ocaml.Num.modulus` + +instance (NumRemainder sym_integer) + let (mod) = sym_integer_mod +end + +val sym_integer_compare : sym_integer -> sym_integer -> ordering +val sym_integer_less : sym_integer -> sym_integer -> bool +val sym_integer_less_equal : sym_integer -> sym_integer -> bool +val sym_integer_greater : sym_integer -> sym_integer -> bool +val sym_integer_greater_equal : sym_integer -> sym_integer -> bool +val sym_integer_eq : sym_integer -> sym_integer -> bool + +declare ocaml target_rep function sym_integer_compare = `Sym_ocaml.Num.compare` +declare ocaml target_rep function sym_integer_less = `Sym_ocaml.Num.less` +declare ocaml target_rep function sym_integer_less_equal = `Sym_ocaml.Num.less_equal` +declare ocaml target_rep function sym_integer_greater = `Sym_ocaml.Num.greater` +declare ocaml target_rep function sym_integer_greater_equal = `Sym_ocaml.Num.greater_equal` +declare ocaml target_rep function sym_integer_eq = `Sym_ocaml.Num.equal` + +instance (Ord sym_integer) + let compare = sym_integer_compare + let (<) = sym_integer_less + let (<=) = sym_integer_less_equal + let (>) = sym_integer_greater + let (>=) = sym_integer_greater_equal +end + +instance (SymEq sym_integer) + let sym_eq = sym_integer_eq +end + +(* ======== *) +(* from *) +(* ======== *) + +val symIntegerFromNatural : sym_natural -> sym_integer +declare ocaml target_rep function symIntegerFromNatural x= ``x + +val partialSymNaturalFromInteger : sym_integer -> sym_natural +declare ocaml target_rep function partialSymNaturalFromInteger = `Sym_ocaml.Num.expect_nonneg` + \ No newline at end of file diff --git a/src/sym_ocaml.ml b/src/sym_ocaml.ml new file mode 100644 index 0000000..a30ec7d --- /dev/null +++ b/src/sym_ocaml.ml @@ -0,0 +1,163 @@ +(* module type Nat_big_num = sig + type num + val zero : num + val succ : num -> num + val pred : num -> num + val pred_nat : num -> num + val negate : num -> num + + val add : num -> num -> num + val sub : num -> num -> num + val sub_nat : num -> num -> num + val div : num -> num -> num + val mul : num -> num -> num + val pow_int : num -> int -> num + val pow_int_positive : int -> int -> num + + + val quomod : num -> num -> num * num + val abs : num -> num + val modulus : num -> num -> num + + val min : num -> num -> num + val max : num -> num -> num + + val less : num -> num -> bool + val greater : num -> num -> bool + val less_equal : num -> num -> bool + val greater_equal : num -> num -> bool + + val compare : num -> num -> int + val equal : num -> num -> bool + + val bitwise_or : num -> num -> num + val bitwise_and : num -> num -> num + val bitwise_xor : num -> num -> num + val shift_left : num -> int -> num + val shift_right : num -> int -> num + + val extract_num : num -> int -> int -> num + + val of_int : int -> num + val of_int32 : Int32.t -> num + val of_int64 : Int64.t -> num + + val to_int : num -> int + val to_int32 : num -> Int32.t + val to_int64 : num -> Int64.t + + val to_string : num -> string + val of_string : string -> num + val of_string_nat : string -> num + val integerDiv_t : num -> num -> num + val integerRem_t : num -> num -> num + val integerRem_f : num -> num -> num +end + +module Make (Nat_big_num : Nat_big_num) = struct *) +(* TODO remove ^ hack for the language server to work *) + + +let fail s = failwith ("Symbolic operation failed: " ^ s) + +(* TODO context? *) +module Num = struct + module NBN = Nat_big_num + + type t = + | Offset of string * NBN.num + | Absolute of NBN.num + + let ppf p = function + | Absolute x -> p x + | Offset (s,x) -> s^"+"^p x + + let to_string = ppf NBN.to_string + + let section s = + if String.starts_with ~prefix:".debug" s then + Absolute NBN.zero + else + Offset (s, NBN.zero) + + let of_num x = Absolute x + + let to_num x = match x with + | Absolute x -> x + | _ -> fail ("to_num " ^ to_string x) + + let add x y = match (x,y) with + | (Absolute x, Absolute y) -> Absolute (NBN.add x y) + | (Offset (s, x), Absolute y) -> Offset (s, NBN.add x y) + | (Absolute x, Offset (s, y)) -> Offset (s, NBN.add x y) + | _ -> fail ("add "^to_string x^" "^to_string y) + + let sub x y = + match (x, y) with + | (Absolute x, Absolute y) -> Absolute (NBN.sub x y) + | (Offset (s, x), Absolute y) -> Offset (s, NBN.sub x y) + | (Offset (s, x'), Offset (t, y')) -> + if s = t then + Absolute (NBN.sub x' y') + else + fail ("sub "^to_string x^" "^to_string y) + | _ -> fail ("sub "^to_string x^" "^to_string y) + + let sub_nat x y = + match (x, y) with + | (Absolute x, Absolute y) -> Absolute (NBN.sub_nat x y) + | (Offset (s, x'), Absolute y') -> + if NBN.greater_equal x' y' then + Offset (s, NBN.sub_nat x' y') + else + fail ("sub_nat "^to_string x^" "^to_string y) + | (Offset (s, x'), Offset (t, y')) -> + if s = t then + Absolute (NBN.sub_nat x' y') + else + fail ("sub_nat "^to_string x^" "^to_string y) + | _ -> fail ("sub_nat "^to_string x^" "^to_string y) + + let map f x = of_num (f(to_num x)) + + let map2 f x y = of_num (f(to_num x)(to_num y)) + + let mul = map2 NBN.mul + let div = map2 NBN.div + + let modulus x y = + if match y with + | Absolute(y) -> NBN.greater_equal y (NBN.pow_int (NBN.of_int 2) 64) + | _ -> false + then + x + else + map2 NBN.modulus x y + + let comp f a b = match (a, b) with + | (Absolute a, Absolute b) -> f a b + | (Offset (s, a'), Offset(t, b')) -> if s = t then + f a' b' + else + fail ("comp "^to_string a^" "^to_string b) + | _ -> fail ("comp "^to_string a^" "^to_string b) + + let compare = comp NBN.compare + let less = comp NBN.less + let greater = comp NBN.greater + let less_equal = comp NBN.less_equal + let greater_equal = comp NBN.greater_equal + let equal = comp NBN.equal + + let expect_nonneg x = + let nonneg = match x with + | Absolute x -> NBN.greater_equal x NBN.zero + | Offset (s, x) -> NBN.greater_equal x NBN.zero + in + if nonneg then + x + else + fail (to_string x^" can be negative") +end + +(* end *) From 576dbff90a63b99344eb5ac88a811806be93f347 Mon Sep 17 00:00:00 2001 From: Matej Urban Date: Wed, 5 Mar 2025 19:37:15 +0000 Subject: [PATCH 29/44] wip --- src/dwarf.lem | 212 +++++++----------------------------- src/dwarf_byte_sequence.lem | 63 +++++++++-- 2 files changed, 91 insertions(+), 184 deletions(-) diff --git a/src/dwarf.lem b/src/dwarf.lem index b0a2dcc..7b45736 100644 --- a/src/dwarf.lem +++ b/src/dwarf.lem @@ -194,175 +194,46 @@ let sym_natural_nat_shift_right x sh = sym_natural_map (fun x -> natural_nat_shi (* byte sequence *) -type next_reloc = - | NoReloc of natural - | Reloc of abstract_relocation reloc_target_data - -let pp_relocs relocs = - let f = function - | NoReloc -> "NoReloc" - | Reloc x -> match x.arel_target with - | Data32 -> "Data32 " - | Data64 -> "Data64 " - end ^ pp_sym_expr x.arel_value - end in - "[" ^ String.concat "," (List.map f relocs) ^ "]" - - -type rel_byte_sequence = - <| rbs_bytes : byte_sequence - ; rbs_relocs : list next_reloc - |> - -type read_result 'a = - | ReadValue of 'a - | ReadReloc of abstract_relocation reloc_target_data - -let read_result_unwrap = function - | ReadValue x -> x - | ReadReloc _ -> Assert_extra.failwith "read_result_unwrap" -end - -let rbs_length rbs = Byte_sequence.length rbs.rbs_bytes +type rel_byte_sequence = sym_byte_sequence -let rbs_no_reloc (bs : byte_sequence) : rel_byte_sequence = - <| rbs_bytes = bs - ; rbs_relocs = [NoReloc (Byte_sequence.length bs)] |> +let rbs_length = sym_bs_length -let rbs_unwrap bs = - match bs.rbs_relocs with - | [NoReloc n] -> bs.rbs_bytes - | [] -> - let _ = my_debug ("Bytes should be empty:" ^ (show bs.rbs_bytes)) in - bs.rbs_bytes - | x -> Assert_extra.failwith ("rbs_unwrap: has relocations " ^ (pp_relocs x)) - end - -let rel_byte_sequence_of_byte_list l = rbs_no_reloc (byte_sequence_of_byte_list l) +let rbs_unwrap = sym_bs_expect_const -let pad_no_reloc n rels = - if n = 0 then - rels - else match rels with - | NoReloc m :: rels -> NoReloc (n+m) :: rels - | _ -> NoReloc n :: rels -end - -(* TODO strict mode? *) -val reloc_map_to_reloc_list' : Map.map elf64_addr (abstract_relocation reloc_target_data) -> natural -> natural -> list next_reloc -> list next_reloc -let rec reloc_map_to_reloc_list' rels i l acc = - if i = l then - List.reverse acc - else - match Map.lookup (elf64_addr_of_natural i) rels with - | Nothing -> reloc_map_to_reloc_list' rels (i+1) l (pad_no_reloc 1 acc) - | Just x -> reloc_map_to_reloc_list' rels (i + reloc_width_bytes x.arel_target) l (Reloc x :: acc) - end - -let reloc_map_to_reloc_list rels l = - reloc_map_to_reloc_list' rels 0 l [] +let rel_byte_sequence_of_byte_list l = sym_bs_construct (byte_sequence_of_byte_list l) Map.empty let construct_rel_byte_sequence bs rel = - <| rbs_bytes = bs ; rbs_relocs = reloc_map_to_reloc_list rel (Byte_sequence.length bs) |> - -let rbs_read_char bs = - match bs.rbs_relocs with - | NoReloc n :: rels -> - read_char bs.rbs_bytes >>= fun (c,bs') -> - return (c, <| rbs_bytes = bs' ; rbs_relocs = pad_no_reloc (n-1) rels |>) - | _ -> fail "rbs_read_char: has reloaction" - end + let rel_list = Map_extra.toList rel in + let sym_list = List.map (fun (pos, rel) -> + ( + natural_of_elf64_addr pos, + <| sb_width=reloc_width_bytes rel.arel_target + ; sb_value=sym_natural_of_symbolic_expression rel.arel_value + |> + ) + ) rel_list in + let sym_map = Map.fromList sym_list in + sym_bs_construct bs sym_map -let rbs_read_2_bytes_be bs = - match bs.rbs_relocs with - | NoReloc n :: rels -> - if n < 2 then - fail "rbs_read_2_bytes_be: has reloaction" - else - read_2_bytes_be bs.rbs_bytes >>= fun (b2,bs') -> - return (b2, <| rbs_bytes = bs' ; rbs_relocs = pad_no_reloc (n-2) rels |>) - | _ -> fail "rbs_read_2_bytes_be: has reloaction" - end +let rbs_read_char = sym_read_char -let rbs_read_4_bytes_be bs = - match bs.rbs_relocs with - | NoReloc n :: rels -> - if n < 4 then - fail "rbs_read_4_bytes_be: has misaligned reloaction" - else - read_4_bytes_be bs.rbs_bytes >>= fun (b4,bs') -> - return (ReadValue b4, <| rbs_bytes = bs' ; rbs_relocs = pad_no_reloc (n-4) rels |>) - | Reloc rel :: rels -> - if reloc_width_bytes rel.arel_target <> 4 then - fail "rbs_read_4_bytes_be: has misaligned reloaction" - else - dropbytes 4 bs.rbs_bytes >>= fun bs' -> - return (ReadReloc rel, <| rbs_bytes = bs' ; rbs_relocs = rels |>) - | _ -> fail "rbs_read_4_bytes_be: has misaligned reloaction" - end +let rbs_read_2_bytes_be = sym_read_2_bytes_be -let rbs_read_8_bytes_be bs = - match bs.rbs_relocs with - | NoReloc n :: rels -> - if n < 8 then - fail "rbs_read_8_bytes_be: has misaligned reloaction" - else - read_8_bytes_be bs.rbs_bytes >>= fun (b8,bs') -> - return (ReadValue b8, <| rbs_bytes = bs' ; rbs_relocs = pad_no_reloc (n-8) rels |>) - | Reloc rel :: rels -> - if reloc_width_bytes rel.arel_target <> 8 then - fail "rbs_read_8_bytes_be: has misaligned reloaction" - else - dropbytes 8 bs.rbs_bytes >>= fun bs' -> - return (ReadReloc rel, <| rbs_bytes = bs' ; rbs_relocs = rels |>) - | _ -> fail "rbs_read_8_bytes_be: has misaligned reloaction" - end +let rbs_read_4_bytes_be = sym_read_4_bytes_be -let rec reloc_list_partition n relocs = match (n, relocs) with - | (0, relocs) -> return ([], relocs) - | (n, NoReloc m :: relocs) -> if m > n then - return ([NoReloc n], pad_no_reloc (m - n) relocs) - else - reloc_list_partition (n-m) relocs >>= fun (a, b) -> - return (pad_no_reloc m a, b) - | (n, Reloc r :: relocs) -> - let m = reloc_width_bytes r.arel_target in - if m > n then - fail "reloc_list_partition: partition inside relocation" - else - reloc_list_partition (n-m) relocs >>= fun (a, b) -> - return (Reloc r :: a, b) - | (n, []) -> fail "reloc_list_partition: cannot take more bytes than are contained in sequence" -end +let rbs_read_8_bytes_be = sym_read_8_bytes_be -let rbs_partition n rbs = - partition n rbs.rbs_bytes >>= fun (bs1, bs2) -> - reloc_list_partition n rbs.rbs_relocs >>= fun (r1, r2) -> - return (<| rbs_bytes = bs1 ; rbs_relocs = r1 |>, <| rbs_bytes = bs2 ; rbs_relocs = r2 |>) +let rbs_partition = sym_partition -let rbs_takebytes n rbs = - rbs_partition n rbs >>= fun(x,_) -> return x +let rbs_takebytes = sym_takebytes -let rbs_dropbytes n rbs = - rbs_partition n rbs >>= fun(_,x) -> return x +let rbs_dropbytes = sym_dropbytes -let rbs_find_byte rbs b = - Maybe.bind (find_byte rbs.rbs_bytes b) (fun n -> - let errmsg = "rbs_find_byte: relocations before byte found" in - match rbs.rbs_relocs with - | NoReloc m :: _ -> if m >= n then Just n else Assert_extra.failwith errmsg - | _ -> Assert_extra.failwith errmsg - end) +let rbs_find_byte = sym_find_byte -let byte_list_of_rel_byte_sequence rbs = - byte_list_of_byte_sequence (rbs_unwrap rbs) +let byte_list_of_rel_byte_sequence = byte_list_of_sym_byte_sequence -let string_of_rel_byte_sequence rbs = - string_of_byte_sequence (rbs_unwrap rbs) - -instance (Show rel_byte_sequence) - let show = string_of_rel_byte_sequence -end +let string_of_rel_byte_sequence = string_of_sym_byte_sequence (** ************************************************************ *) (** ** dwarf representation types **************************** *) @@ -1757,8 +1628,7 @@ declare coq target_rep function abs n = (`Zpred` (`Zpos` (`P_of_succ_nat` n let pphex_integer n = if n<0 then "-" ^ pphex (abs n) else pphex (abs n) -let ppbytes bs = show (List.map (fun x -> show x) (byte_list_of_byte_sequence bs.rbs_bytes)) -(* let ppbytes bs = show (List.map (fun x -> show x) (byte_list_of_rel_byte_sequence bs)) *) +let ppbytes = sym_ppbytes let rec ppbytes2 n bs = match rbs_read_char bs with @@ -2136,18 +2006,15 @@ let parse_uint16 c : parser sym_natural= let parse_uint32 c : parser sym_natural= fun (pc:parse_context) -> let _ = my_debug "uint32 " in - match rbs_read_4_bytes_be pc.pc_bytes with - | Success (ReadValue (b0,b1,b2,b3),bytes') -> + match sym_read_4_bytes_be_symbolic pc.pc_bytes with + | Success (Bytes (b0,b1,b2,b3),bytes') -> let v = if c.endianness=Little then natural_of_byte b0 + 256*natural_of_byte b1 + 256*256*natural_of_byte b2 + 256*256*256*natural_of_byte b3 else natural_of_byte b3 + 256*natural_of_byte b2 + 256*256*natural_of_byte b1 + 256*256*256*natural_of_byte b0 in PR_success (sym_natural_const v) (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 4 |>) - | Success (ReadReloc r, bytes') -> - if r.arel_target = Data32 then - PR_success (sym_natural_of_symbolic_expression r.arel_value) (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 4 |>) - else - PR_fail "parse_uint32 wrong relocation type" pc + | Success (Sym n, bytes') -> + PR_success n (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 4 |>) | _ -> PR_fail "parse_uint32 not given enough bytes" pc end @@ -2155,8 +2022,8 @@ let parse_uint32 c : parser sym_natural= let parse_uint64 c : parser sym_natural= fun (pc:parse_context) -> let _ = my_debug "uint64 " in - match rbs_read_8_bytes_be pc.pc_bytes with - | Success (ReadValue (b0,b1,b2,b3,b4,b5,b6,b7),bytes') -> (*TODO*) + match sym_read_8_bytes_be_symbolic pc.pc_bytes with + | Success (Bytes (b0,b1,b2,b3,b4,b5,b6,b7),bytes') -> (*TODO*) let v = if c.endianness=Little then natural_of_byte b0 + 256*natural_of_byte b1 + 256*256*natural_of_byte b2 + 256*256*256*natural_of_byte b3 + (256*256*256*256*(natural_of_byte b4 + 256*natural_of_byte b5 + 256*256*natural_of_byte b6 + 256*256*256*natural_of_byte b7)) @@ -2165,11 +2032,8 @@ let parse_uint64 c : parser sym_natural= + (256*256*256*256*(natural_of_byte b3 + 256*natural_of_byte b2 + 256*256*natural_of_byte b1 + 256*256*256*natural_of_byte b0)) in PR_success (sym_natural_const v) (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 8 |>) - | Success (ReadReloc r, bytes') -> - if r.arel_target = Data64 then - PR_success (sym_natural_of_symbolic_expression r.arel_value) (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 8 |>) - else - PR_fail "parse_uint64 wrong relocation type" pc + | Success (Sym n, bytes') -> + PR_success n (<| pc_bytes = bytes'; pc_offset = pc.pc_offset + 8 |>) | _ -> PR_fail "parse_uint64 not given enough bytes" pc end @@ -4233,7 +4097,7 @@ let extract_section_body (f:elf_file) (ri:relocation_interpreter reloc_target_da if strict then Assert_extra.failwith ("" ^ section_name ^ " section not present") else - (c,0,<| rbs_bytes = Byte_sequence.empty ; rbs_relocs = [] |>) + (c,0,sym_bs_empty) | _ -> Assert_extra.failwith ("multiple " ^ section_name ^ " sections present") end @@ -4260,7 +4124,7 @@ let extract_section_body (f:elf_file) (ri:relocation_interpreter reloc_target_da if strict then Assert_extra.failwith ("" ^ section_name ^ " section not present") else - (c,0,<| rbs_bytes = Byte_sequence.empty ; rbs_relocs = [] |>) + (c,0,sym_bs_empty) | _ -> Assert_extra.failwith ("multiple " ^ section_name ^ " sections present") end end @@ -6656,8 +6520,8 @@ let pp_inlined_subroutines_by_range ds iss = let rec words_of_rel_byte_sequence (addr:sym_natural) (bs:rel_byte_sequence) (acc:list (sym_natural * sym_natural)) : list (sym_natural * sym_natural) = - match rbs_read_4_bytes_be bs with - | Success (ReadValue (b0,b1,b2,b3), bs') -> (*TODO*) + match sym_read_4_bytes_be_symbolic bs with + | Success (Bytes (b0,b1,b2,b3), bs') -> (*TODO allow symbolic? *) let i : sym_natural = sym_natural_const (natural_of_byte b0 + 256*natural_of_byte b1 + 65536*natural_of_byte b2 + 65536*256*natural_of_byte b3) in words_of_rel_byte_sequence (addr+4) bs' ((addr,i)::acc) | Fail _ -> List.reverse acc diff --git a/src/dwarf_byte_sequence.lem b/src/dwarf_byte_sequence.lem index ff1e3f3..c1c794d 100644 --- a/src/dwarf_byte_sequence.lem +++ b/src/dwarf_byte_sequence.lem @@ -7,6 +7,11 @@ open import Error open import Maybe open import Bool open import Basic_classes +open import Show +open import String + +(* TODO fast implementation *) + (* ================= *) (* sym_byte_sequence *) @@ -24,11 +29,13 @@ type sym_byte_sequence = |> let sym_read_char bs = - if Map.member bs.sbs_pos bs.sbs_symbolic then - Assert_extra.failwith "Read char: is symbolic" - else - read_char bs.sbs_bytes >>= fun (c, bs') -> - return (c, <| sbs_bytes=bs'; sbs_symbolic = bs.sbs_symbolic; sbs_pos = bs.sbs_pos + 1 |>) + read_char bs.sbs_bytes >>= fun (c, bs') -> + match Map.lookup bs.sbs_pos bs.sbs_symbolic with + | Just n -> Assert_extra.failwith + ("Read char: is symbolic (width: " ^ show n.sb_width ^ ") " ^ show n.sb_value) + | Nothing -> + return (c, <| sbs_bytes=bs'; sbs_symbolic = bs.sbs_symbolic; sbs_pos = bs.sbs_pos + 1 |>) + end let sym_read_2_bytes_be bs0 = sym_read_char bs0 >>= fun (b0, bs1) -> @@ -55,11 +62,11 @@ let sym_read_8_bytes_be bs0 = let sym_dropbytes n bs = dropbytes n bs.sbs_bytes >>= fun bs' -> - return <| sbs_bytes=bs'; sbs_symbolic=bs.sbs_symbolic; sbs_pos=bs.sbs_pos |> + return <| sbs_bytes=bs'; sbs_symbolic=bs.sbs_symbolic; sbs_pos=bs.sbs_pos+n |> let sym_takebytes n bs = takebytes n bs.sbs_bytes >>= fun bs' -> - return <| sbs_bytes=bs'; sbs_symbolic=bs.sbs_symbolic; sbs_pos=bs.sbs_pos+n |> + return <| sbs_bytes=bs'; sbs_symbolic=bs.sbs_symbolic; sbs_pos=bs.sbs_pos |> let sym_partition idx bs0 = sym_takebytes idx bs0 >>= fun l -> @@ -69,10 +76,13 @@ let sym_partition idx bs0 = let sym_bs_length bs = length bs.sbs_bytes -let sym_expect_const bs = +let symbolic_bytes_in_range off len bs = let sym_positions = Map.domain bs.sbs_symbolic in + Set.any (fun x -> x >= bs.sbs_pos + off && x < bs.sbs_pos + off + len) sym_positions + +let sym_bs_expect_const bs = let len = sym_bs_length bs in - if Set.any (fun x -> x >= bs.sbs_pos && x < bs.sbs_pos + len) sym_positions then + if symbolic_bytes_in_range 0 len bs then Assert_extra.failwith "Byte sequence is symbolic" else bs.sbs_bytes @@ -80,7 +90,31 @@ let sym_expect_const bs = let sym_bs_construct bs sym = <| sbs_bytes=bs; sbs_symbolic=sym; sbs_pos=0 |> +let sym_find_byte bs b = + match find_byte bs.sbs_bytes b with + | Nothing -> + if symbolic_bytes_in_range 0 (sym_bs_length bs) bs then + Assert_extra.failwith "Find encountered symbolic bytes" + else + Nothing + | Just n -> + if symbolic_bytes_in_range 0 (n+1) bs then + Assert_extra.failwith "Find encountered symbolic bytes" + else + Just n + end + +let sym_bs_empty = sym_bs_construct Byte_sequence.empty Map.empty + +let byte_list_of_sym_byte_sequence rbs = + byte_list_of_byte_sequence (sym_bs_expect_const rbs) +let string_of_sym_byte_sequence rbs = + string_of_byte_sequence (sym_bs_expect_const rbs) + +instance (Show sym_byte_sequence) + let show = string_of_sym_byte_sequence +end (* Symboli reads *) type read_result 'a = @@ -105,4 +139,13 @@ let sym_read_8_bytes_be_symbolic bs = sym_dropbytes 8 bs >>= fun bs' -> return (Sym v, bs') | _ -> Assert_extra.failwith "Reading misaligned symbolic value" - end \ No newline at end of file + end + +let sym_ppbytes bs = + let symmsg = + if symbolic_bytes_in_range 0 (sym_bs_length bs) bs then + "With symbolic bytes! " (*TODO print them*) + else + "" + in + symmsg ^ (show (List.map (fun x -> show x) (byte_list_of_byte_sequence bs.sbs_bytes))) From 1b6f60fe0f85d902073de5393fb9a1a22d38eef6 Mon Sep 17 00:00:00 2001 From: Matej Urban Date: Thu, 6 Mar 2025 04:01:42 +0000 Subject: [PATCH 30/44] wip (bug?) --- src/dwarf.lem | 7 +- src/dwarf_byte_sequence.lem | 124 ++++++++++++++++++++++++++---------- 2 files changed, 95 insertions(+), 36 deletions(-) diff --git a/src/dwarf.lem b/src/dwarf.lem index 7b45736..cf25b5b 100644 --- a/src/dwarf.lem +++ b/src/dwarf.lem @@ -207,9 +207,10 @@ let construct_rel_byte_sequence bs rel = let sym_list = List.map (fun (pos, rel) -> ( natural_of_elf64_addr pos, - <| sb_width=reloc_width_bytes rel.arel_target - ; sb_value=sym_natural_of_symbolic_expression rel.arel_value - |> + ( + reloc_width_bytes rel.arel_target, + sym_natural_of_symbolic_expression rel.arel_value + ) ) ) rel_list in let sym_map = Map.fromList sym_list in diff --git a/src/dwarf_byte_sequence.lem b/src/dwarf_byte_sequence.lem index c1c794d..a94fb98 100644 --- a/src/dwarf_byte_sequence.lem +++ b/src/dwarf_byte_sequence.lem @@ -9,32 +9,87 @@ open import Bool open import Basic_classes open import Show open import String +open import List -(* TODO fast implementation *) +type sym_mask_entry = + | NoSym of natural + | SymVal of natural * sym_natural +let rec sym_mask_pp sm = match sm with +| NoSym x :: sm -> "NoSym(" ^ show x ^ ")," ^ sym_mask_pp sm +| SymVal x v :: sm -> "SymVal(" ^ show x ^ "," ^ show v ^ ")," ^ sym_mask_pp sm +| [] -> "" +end + + +let rec sym_mask_partition n sm = + if n = 0 then + ([], sm) + else + match sm with + | NoSym k :: sm -> + if k > n then + ([NoSym n], NoSym (k-n) :: sm) + else + let (l,r) = sym_mask_partition (n-k) sm in + (NoSym k :: l, r) + | SymVal k v :: sm -> + if k > n then + Assert_extra.failwith "Attempting to split seqence in the middle of symbolic part" + else + let (l,r) = sym_mask_partition (n-k) sm in + (SymVal k v :: l, r) + end + +let sym_mask_dropbytes n sm = + let (_,r) = sym_mask_partition n sm in r + +let sym_mask_takebytes n sm = + let (l,_) = sym_mask_partition n sm in l + +let sym_mask_is_symbolic = function +| [NoSym _] -> false +| [] -> false +| _ -> true +end + +let sym_mask_pad_nosym n sm = + if n = 0 then + sm + else match sm with + | NoSym m :: sm -> NoSym (n+m) :: sm + | _ -> NoSym n :: sm +end + +(* TODO strict mode? *) +let rec sym_mask_from_map' m i l acc = + if i = l then + List.reverse acc + else + match Map.lookup i m with + | Nothing -> sym_mask_from_map' m (i+1) l (sym_mask_pad_nosym 1 acc) + | Just (w, v) -> sym_mask_from_map' m (i + w) l (SymVal w v :: acc) + end + +let sym_mask_from_map m l = + sym_mask_from_map' m 0 l [] (* ================= *) (* sym_byte_sequence *) (* ================= *) -type symbolic_bytes = -<| sb_width : natural - ; sb_value : sym_natural - |> - type sym_byte_sequence = <| sbs_bytes : byte_sequence - ; sbs_symbolic : Map.map natural symbolic_bytes - ; sbs_pos : natural + ; sbs_symbolic : list sym_mask_entry |> let sym_read_char bs = read_char bs.sbs_bytes >>= fun (c, bs') -> - match Map.lookup bs.sbs_pos bs.sbs_symbolic with - | Just n -> Assert_extra.failwith - ("Read char: is symbolic (width: " ^ show n.sb_width ^ ") " ^ show n.sb_value) - | Nothing -> - return (c, <| sbs_bytes=bs'; sbs_symbolic = bs.sbs_symbolic; sbs_pos = bs.sbs_pos + 1 |>) + match bs.sbs_symbolic with + | SymVal n v :: _ -> Assert_extra.failwith + ("Read char: is symbolic (width: " ^ show n ^ ") " ^ show v) + | _ -> + return (c, <| sbs_bytes=bs'; sbs_symbolic = sym_mask_dropbytes 1 bs.sbs_symbolic |>) end let sym_read_2_bytes_be bs0 = @@ -62,11 +117,11 @@ let sym_read_8_bytes_be bs0 = let sym_dropbytes n bs = dropbytes n bs.sbs_bytes >>= fun bs' -> - return <| sbs_bytes=bs'; sbs_symbolic=bs.sbs_symbolic; sbs_pos=bs.sbs_pos+n |> + return <| sbs_bytes=bs'; sbs_symbolic=sym_mask_dropbytes n bs.sbs_symbolic |> let sym_takebytes n bs = takebytes n bs.sbs_bytes >>= fun bs' -> - return <| sbs_bytes=bs'; sbs_symbolic=bs.sbs_symbolic; sbs_pos=bs.sbs_pos |> + return <| sbs_bytes=bs'; sbs_symbolic=sym_mask_takebytes n bs.sbs_symbolic |> let sym_partition idx bs0 = sym_takebytes idx bs0 >>= fun l -> @@ -74,31 +129,36 @@ let sym_partition idx bs0 = return (l, r) let sym_bs_length bs = - length bs.sbs_bytes + Byte_sequence.length bs.sbs_bytes +val print_endline : string -> unit +declare ocaml target_rep function print_endline = `print_endline` +(* let symbolic_bytes_in_range off len bs = + let _ = print_endline "slow operation" in let sym_positions = Map.domain bs.sbs_symbolic in - Set.any (fun x -> x >= bs.sbs_pos + off && x < bs.sbs_pos + off + len) sym_positions + Set.any (fun x -> x >= bs.sbs_pos + off && x < bs.sbs_pos + off + len) sym_positions *) let sym_bs_expect_const bs = let len = sym_bs_length bs in - if symbolic_bytes_in_range 0 len bs then + if sym_mask_is_symbolic bs.sbs_symbolic then Assert_extra.failwith "Byte sequence is symbolic" else bs.sbs_bytes let sym_bs_construct bs sym = - <| sbs_bytes=bs; sbs_symbolic=sym; sbs_pos=0 |> + let len = Byte_sequence.length bs in + <| sbs_bytes=bs; sbs_symbolic=sym_mask_from_map sym len |> let sym_find_byte bs b = match find_byte bs.sbs_bytes b with | Nothing -> - if symbolic_bytes_in_range 0 (sym_bs_length bs) bs then + if sym_mask_is_symbolic bs.sbs_symbolic then Assert_extra.failwith "Find encountered symbolic bytes" else Nothing | Just n -> - if symbolic_bytes_in_range 0 (n+1) bs then + if sym_mask_is_symbolic (sym_mask_takebytes n bs.sbs_symbolic) then Assert_extra.failwith "Find encountered symbolic bytes" else Just n @@ -115,35 +175,33 @@ let string_of_sym_byte_sequence rbs = instance (Show sym_byte_sequence) let show = string_of_sym_byte_sequence end -(* Symboli reads *) +(* Symbolic reads *) type read_result 'a = | Bytes of 'a | Sym of sym_natural let sym_read_4_bytes_be_symbolic bs = - match Map.lookup bs.sbs_pos bs.sbs_symbolic with - | Nothing -> sym_read_4_bytes_be bs >>= fun (b, bs') -> - return (Bytes b, bs') - | Just <| sb_width=4; sb_value=v |> -> + match bs.sbs_symbolic with + | SymVal 4 v :: _ -> sym_dropbytes 4 bs >>= fun bs' -> return (Sym v, bs') - | _ -> Assert_extra.failwith "Reading misaligned symbolic value" + | _ -> sym_read_4_bytes_be bs >>= fun (b, bs') -> + return (Bytes b, bs') end let sym_read_8_bytes_be_symbolic bs = - match Map.lookup bs.sbs_pos bs.sbs_symbolic with - | Nothing -> sym_read_8_bytes_be bs >>= fun (b, bs') -> - return (Bytes b, bs') - | Just <| sb_width=8; sb_value=v |> -> + match bs.sbs_symbolic with + | SymVal 8 v :: _ -> sym_dropbytes 8 bs >>= fun bs' -> return (Sym v, bs') - | _ -> Assert_extra.failwith "Reading misaligned symbolic value" + | _ -> sym_read_8_bytes_be bs >>= fun (b, bs') -> + return (Bytes b, bs') end let sym_ppbytes bs = let symmsg = - if symbolic_bytes_in_range 0 (sym_bs_length bs) bs then + if sym_mask_is_symbolic bs.sbs_symbolic then "With symbolic bytes! " (*TODO print them*) else "" From d25664ccf824c7ec5c332cbec78884996e80c334 Mon Sep 17 00:00:00 2001 From: Matej Urban Date: Thu, 6 Mar 2025 05:21:22 +0000 Subject: [PATCH 31/44] bugfix --- src/dwarf.lem | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/dwarf.lem b/src/dwarf.lem index cf25b5b..7a436e5 100644 --- a/src/dwarf.lem +++ b/src/dwarf.lem @@ -4051,8 +4051,6 @@ let parse_dwarf c let pc_frame = <|pc_bytes = debug_frame_section_body; pc_offset = 0 |> in let fi = - let _ = my_debug5 ("debug_frame_section_body:\n" ^ ppbytes2 0 debug_frame_section_body) in - match parse_frame_info c cuh_default pc_frame with | PR_fail s pc_info' -> Assert_extra.failwith ("parse_frame_info: " ^ pp_parse_fail s pc_info') | PR_success fi pc_loc' -> fi From dec6c349a8886a926cbb9c8dfca9c85345a35c39 Mon Sep 17 00:00:00 2001 From: Matej Urban Date: Tue, 11 Mar 2025 11:48:57 +0000 Subject: [PATCH 32/44] Dont use sym_map in relocation translation slow-down only ~1m10s->1m20s on pkvm but much better readability --- .../abi_aarch64_symbolic_relocation.lem | 10 +++++----- src/elf_symbolic.lem | 18 ++++++++---------- 2 files changed, 13 insertions(+), 15 deletions(-) diff --git a/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem b/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem index ecd7a10..021d04e 100644 --- a/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem +++ b/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem @@ -147,11 +147,11 @@ let abi_aarch64_apply_relocation_symbolic rel s_val p_val ef = fail "abi_aarch64_apply_relocation: not a relocatable file" val abi_aarch64_relocation_to_abstract : relocation_interpreter aarch64_relocation_target -let abi_aarch64_relocation_to_abstract ef symtab_map sidx rel = +let abi_aarch64_relocation_to_abstract ef symtab sidx rel = section_with_offset ef sidx rel.elf64_ra_offset >>= fun p_val -> let (_, sym) = parse_elf64_relocation_info rel.elf64_ra_info in - match Map.lookup sym symtab_map with - | Just ste -> symbolic_address_from_elf64_symbol_table_entry ef ste + match symbolic_address_of_symbol ef symtab (natFromNatural sym) with + | Just x -> x | Nothing -> fail "Invalid symbol table index" end >>= fun s_val -> abi_aarch64_apply_relocation_symbolic rel s_val p_val ef >>= fun rel_desc_map -> @@ -163,8 +163,8 @@ let aarch64_relocation_target_to_data_target = function | _ -> fail "Not a data relocation" end -let aarch64_data_relocation_interpreter ef symtab_map sidx rel = - abi_aarch64_relocation_to_abstract ef symtab_map sidx rel >>= fun arels -> +let aarch64_data_relocation_interpreter ef symtab sidx rel = + abi_aarch64_relocation_to_abstract ef symtab sidx rel >>= fun arels -> map_mapM (fun arel -> aarch64_relocation_target_to_data_target arel.arel_target >>= fun target -> return <| arel_value = arel.arel_value diff --git a/src/elf_symbolic.lem b/src/elf_symbolic.lem index a50dbcb..5e6761e 100644 --- a/src/elf_symbolic.lem +++ b/src/elf_symbolic.lem @@ -75,15 +75,13 @@ let reloc_width_bytes : reloc_target_data -> natural = function | Data64 -> 8 end -type relocation_interpreter 'a = elf64_file -> Map.map natural elf64_symbol_table_entry -> elf64_half -> elf64_relocation_a -> error (Map.map elf64_addr (abstract_relocation 'a)) +type relocation_interpreter 'a = elf64_file -> elf64_symbol_table -> elf64_half -> elf64_relocation_a -> error (Map.map elf64_addr (abstract_relocation 'a)) -val symbol_map_from_elf64_symtab : elf64_file -> elf64_symbol_table -> Map.map natural elf64_symbol_table_entry -let symbol_map_from_elf64_symtab f symtab = - let convert i ste = - (naturalFromNat i, ste) - in - let indexed_list = List.mapi convert symtab in - Map.fromList indexed_list +let symbolic_address_of_symbol f symtab sym = + match List.index symtab sym with + | Nothing -> Nothing + | Just ste -> Just (symbolic_address_from_elf64_symbol_table_entry f ste) + end val extract_elf64_relocations_for_section' : forall 'a. elf64_file -> relocation_interpreter 'a -> elf64_half -> error (Map.map elf64_addr (abstract_relocation 'a)) let extract_elf64_relocations_for_section' f1 interp sidx = @@ -100,8 +98,8 @@ let extract_elf64_relocations_for_section' f1 interp sidx = let rels = rel_sec.elf64_section_body in Elf_relocation.read_elf64_relocation_a_section' endian rels >>= fun rels -> Elf_file.get_elf64_symbol_table_by_index f1 lnk >>= fun symtab -> - let symtab_map = symbol_map_from_elf64_symtab f1 symtab in - mapM (interp f1 symtab_map sidx) rels >>= fun rel_maps -> + (* let symtab_map = symbol_map_from_elf64_symtab f1 symtab in *) + mapM (interp f1 symtab sidx) rels >>= fun rel_maps -> let rel_map = Map.fromList (List.concatMap Map_extra.toList rel_maps) in if Map.size rel_map <> List.length rels then fail "Multiple relocations at the same location" From b548b1df769caa426e7e9301d16a97ad82056500 Mon Sep 17 00:00:00 2001 From: Matej Urban Date: Tue, 11 Mar 2025 11:56:05 +0000 Subject: [PATCH 33/44] Cleanup dwarf.lem --- src/dwarf.lem | 294 ++++++++++++++++++++++---------------------------- 1 file changed, 131 insertions(+), 163 deletions(-) diff --git a/src/dwarf.lem b/src/dwarf.lem index 7a436e5..c37bfd2 100644 --- a/src/dwarf.lem +++ b/src/dwarf.lem @@ -171,9 +171,7 @@ let sym_natural_land = sym_natural_map2 natural_land let sym_natural_lxor = sym_natural_map2 natural_lxor let sym_natural_lor = sym_natural_map2 natural_lor -let symIntegerFromSymNatural = symIntegerFromNatural - -let natFromSymNatural x = natFromNatural (sym_natural_expect_const x (*"symIntegerFromSymNatural"*)) +let natFromSymNatural x = natFromNatural (sym_natural_expect_const x (*"symIntegerFromNatural"*)) let symNaturalFromNat x = sym_natural_const (naturalFromNat x) @@ -183,26 +181,16 @@ let sym_natural_of_byte x = sym_natural_const (natural_of_byte x) let symNaturalPow x y = sym_natural_map (fun x -> naturalPow x y) x -let symNaturalFromSymInteger = partialSymNaturalFromInteger - let index_sym_natural l n = index_natural l (sym_natural_expect_const n (*"index_sym_natural"*)) -let partialSymNaturalFromSymInteger = partialSymNaturalFromInteger - let sym_natural_nat_shift_left x sh = sym_natural_map (fun x -> natural_nat_shift_left x sh) x let sym_natural_nat_shift_right x sh = sym_natural_map (fun x -> natural_nat_shift_right x sh) x (* byte sequence *) -type rel_byte_sequence = sym_byte_sequence - -let rbs_length = sym_bs_length +let sym_byte_sequence_of_byte_list l = sym_bs_construct (byte_sequence_of_byte_list l) Map.empty -let rbs_unwrap = sym_bs_expect_const - -let rel_byte_sequence_of_byte_list l = sym_bs_construct (byte_sequence_of_byte_list l) Map.empty - -let construct_rel_byte_sequence bs rel = +let construct_sym_byte_sequence bs rel = let rel_list = Map_extra.toList rel in let sym_list = List.map (fun (pos, rel) -> ( @@ -216,26 +204,6 @@ let construct_rel_byte_sequence bs rel = let sym_map = Map.fromList sym_list in sym_bs_construct bs sym_map -let rbs_read_char = sym_read_char - -let rbs_read_2_bytes_be = sym_read_2_bytes_be - -let rbs_read_4_bytes_be = sym_read_4_bytes_be - -let rbs_read_8_bytes_be = sym_read_8_bytes_be - -let rbs_partition = sym_partition - -let rbs_takebytes = sym_takebytes - -let rbs_dropbytes = sym_dropbytes - -let rbs_find_byte = sym_find_byte - -let byte_list_of_rel_byte_sequence = byte_list_of_sym_byte_sequence - -let string_of_rel_byte_sequence = string_of_sym_byte_sequence - (** ************************************************************ *) (** ** dwarf representation types **************************** *) (** ************************************************************ *) @@ -276,7 +244,7 @@ type operation_argument_type = type operation_argument_value = | OAV_natural of sym_natural | OAV_integer of sym_integer - | OAV_block of sym_natural * rel_byte_sequence + | OAV_block of sym_natural * sym_byte_sequence type operation_stack = list sym_natural @@ -322,7 +290,7 @@ type operation = type simple_location = | SL_memory_address of sym_natural | SL_register of sym_natural - | SL_implicit of rel_byte_sequence (* used for implicit and stack values *) + | SL_implicit of sym_byte_sequence (* used for implicit and stack values *) | SL_empty type composite_location_piece = @@ -387,17 +355,17 @@ type abbreviations_table = type attribute_value = (* following Figure 3 *) | AV_addr of sym_natural - | AV_block of sym_natural * rel_byte_sequence - | AV_constantN of sym_natural * rel_byte_sequence + | AV_block of sym_natural * sym_byte_sequence + | AV_constantN of sym_natural * sym_byte_sequence | AV_constant_SLEB128 of sym_integer | AV_constant_ULEB128 of sym_natural - | AV_exprloc of sym_natural * rel_byte_sequence + | AV_exprloc of sym_natural * sym_byte_sequence | AV_flag of bool | AV_ref of sym_natural | AV_ref_addr of sym_natural (* dwarf_format dependent *) | AV_ref_sig8 of sym_natural | AV_sec_offset of sym_natural - | AV_string of rel_byte_sequence (* not including terminating null *) + | AV_string of sym_byte_sequence (* not including terminating null *) | AV_strp of sym_natural (* dwarf_format dependent *) @@ -452,7 +420,7 @@ type type_units = list type_unit (* .debug_loc section *) -type single_location_description = rel_byte_sequence +type single_location_description = sym_byte_sequence type location_list_entry = <| @@ -493,7 +461,7 @@ type range_list_list = list range_list (* .debug_frame section: call frame instructions *) type cfa_address = sym_natural -type cfa_block = rel_byte_sequence +type cfa_block = sym_byte_sequence type cfa_delta = sym_natural type cfa_offset = sym_natural type cfa_register = sym_natural @@ -556,13 +524,13 @@ type cie = cie_length: sym_natural; cie_id: sym_natural; cie_version: sym_natural; - cie_augmentation: rel_byte_sequence; (* not including terminating null *) + cie_augmentation: sym_byte_sequence; (* not including terminating null *) cie_address_size: maybe sym_natural; cie_segment_size: maybe sym_natural; cie_code_alignment_factor: sym_natural; cie_data_alignment_factor: sym_integer; cie_return_address_register: cfa_register; - cie_initial_instructions_bytes: rel_byte_sequence; + cie_initial_instructions_bytes: sym_byte_sequence; cie_initial_instructions: list call_frame_instruction; |> @@ -574,7 +542,7 @@ type fde = fde_initial_location_segment_selector: maybe sym_natural; fde_initial_location_address: sym_natural; fde_address_range: sym_natural; - fde_instructions_bytes: rel_byte_sequence; + fde_instructions_bytes: sym_byte_sequence; fde_instructions: list call_frame_instruction; |> @@ -644,7 +612,7 @@ type line_number_argument_value = | LNAV_ULEB128 of sym_natural | LNAV_SLEB128 of sym_integer | LNAV_uint16 of sym_natural - | LNAV_string of rel_byte_sequence (* not including terminating null *) + | LNAV_string of sym_byte_sequence (* not including terminating null *) type line_number_operation = (* standard *) @@ -663,14 +631,14 @@ type line_number_operation = (* extended *) | DW_LNE_end_sequence | DW_LNE_set_address of sym_natural - | DW_LNE_define_file of rel_byte_sequence * sym_natural * sym_natural * sym_natural + | DW_LNE_define_file of sym_byte_sequence * sym_natural * sym_natural * sym_natural | DW_LNE_set_discriminator of sym_natural (* special *) | DW_LN_special of sym_natural (* the adjusted opcode *) type line_number_file_entry = <| - lnfe_path: rel_byte_sequence; + lnfe_path: sym_byte_sequence; lnfe_directory_index: sym_natural; lnfe_last_modification: sym_natural; lnfe_length: sym_natural; @@ -690,7 +658,7 @@ type line_number_header = lnh_line_range: sym_natural; lnh_opcode_base: sym_natural; lnh_standard_opcode_lengths: list sym_natural; - lnh_include_directories: list (rel_byte_sequence); + lnh_include_directories: list (sym_byte_sequence); lnh_file_entries: list line_number_file_entry; lnh_comp_dir: maybe string; (* passed down from cu DW_AT_comp_dir *) |> @@ -729,7 +697,7 @@ type unpacked_decl = unpacked_file_entry * nat(*line*) * string(*subprogram name type dwarf = <| d_endianness: Endianness.endianness; (* from the ELF *) - d_str: rel_byte_sequence; + d_str: sym_byte_sequence; d_compilation_units: compilation_units; d_type_units: type_units; d_loc: location_list_list; @@ -1164,9 +1132,9 @@ let operation_encodings = [ ("DW_OP_abs", sym_natural_of_hex "0x19", [] , OpSem_unary (fun ac v -> if v < ac.ac_half then Just v else if v=ac.ac_max then Nothing else Just (ac.ac_all-v))); (*0*) ("DW_OP_and", sym_natural_of_hex "0x1a", [] , OpSem_binary (fun ac v1 v2 -> Just (sym_natural_land v1 v2))); (*0*) ("DW_OP_div", sym_natural_of_hex "0x1b", [] , OpSem_not_supported) (*TODO*); (*0*) -("DW_OP_minus", sym_natural_of_hex "0x1c", [] , OpSem_binary (fun ac v1 v2 -> Just (partialSymNaturalFromSymInteger ((symIntegerFromSymNatural v1 - symIntegerFromSymNatural v2) mod (symIntegerFromSymNatural ac.ac_all))))); (*0*) +("DW_OP_minus", sym_natural_of_hex "0x1c", [] , OpSem_binary (fun ac v1 v2 -> Just (partialSymNaturalFromInteger ((symIntegerFromNatural v1 - symIntegerFromNatural v2) mod (symIntegerFromNatural ac.ac_all))))); (*0*) ("DW_OP_mod", sym_natural_of_hex "0x1d", [] , OpSem_binary (fun ac v1 v2 -> Just (v1 mod v2))); (*0*) -("DW_OP_mul", sym_natural_of_hex "0x1e", [] , OpSem_binary (fun ac v1 v2 -> Just (partialSymNaturalFromSymInteger ((symIntegerFromSymNatural v1 * symIntegerFromSymNatural v2) mod (symIntegerFromSymNatural ac.ac_all))))); (*0*) +("DW_OP_mul", sym_natural_of_hex "0x1e", [] , OpSem_binary (fun ac v1 v2 -> Just (partialSymNaturalFromInteger ((symIntegerFromNatural v1 * symIntegerFromNatural v2) mod (symIntegerFromNatural ac.ac_all))))); (*0*) ("DW_OP_neg", sym_natural_of_hex "0x1f", [] , OpSem_unary (fun ac v -> if v < ac.ac_half then Just (ac.ac_max - v) else if v=ac.ac_half then Nothing else Just (ac.ac_all - v))); (*0*) ("DW_OP_not", sym_natural_of_hex "0x20", [] , OpSem_unary (fun ac v -> Just (sym_natural_lxor v ac.ac_max))); (*0*) ("DW_OP_or", sym_natural_of_hex "0x21", [] , OpSem_binary (fun ac v1 v2 -> Just (sym_natural_lor v1 v2))); (*0*) @@ -1518,9 +1486,9 @@ let rec myfiltermaybe f xs = -val bytes_of_natural: endianness -> natural (*size*) -> natural (*value*) -> rel_byte_sequence +val bytes_of_natural: endianness -> natural (*size*) -> natural (*value*) -> sym_byte_sequence let bytes_of_natural en size n = - rel_byte_sequence_of_byte_list ( + sym_byte_sequence_of_byte_list ( if size = 8 then bytes_of_elf64_xword en (elf64_xword_of_natural n) else if size = 4 then @@ -1531,18 +1499,18 @@ let bytes_of_natural en size n = let bytes_of_sym_natural en size n = bytes_of_natural en (sym_natural_expect_const size (*"bytes_of_sym_natural size"*)) (sym_natural_expect_const n (*"bytes_of_sym_natural n"*)) let rec natural_of_bytes_little bs : natural = - match rbs_read_char bs with + match sym_read_char bs with | Fail _ -> 0 | Success (b, bs') -> natural_of_byte b + 256 * natural_of_bytes_little bs' end let rec natural_of_bytes_big acc bs = - match rbs_read_char bs with + match sym_read_char bs with | Fail _ -> acc | Success (b, bs') -> natural_of_bytes_big (natural_of_byte b + 256 * acc) bs' end -val natural_of_bytes: endianness -> rel_byte_sequence -> natural +val natural_of_bytes: endianness -> sym_byte_sequence -> natural let natural_of_bytes en bs = match en with | Little -> natural_of_bytes_little bs @@ -1632,7 +1600,7 @@ let pphex_integer n = if n<0 then "-" ^ pphex (abs n) else pphex (abs n) let ppbytes = sym_ppbytes let rec ppbytes2 n bs = - match rbs_read_char bs with + match sym_read_char bs with | Fail _ -> "" | Success (x,xs') -> "<" ^ pphex n ^ "> " ^ show x ^ "\n" ^ ppbytes2 (n+1) xs' end @@ -1776,7 +1744,7 @@ let base_type_attribute_encode (s: string) : sym_natural = (* parsing combinators *) -type parse_context = <| pc_bytes: rel_byte_sequence; pc_offset: natural |> +type parse_context = <| pc_bytes: sym_byte_sequence; pc_offset: natural |> type parse_result 'a = | PR_success of 'a * parse_context @@ -1902,7 +1870,7 @@ let rec parse_parser_list ps = val parse_maybe : forall 'a. parser 'a -> parser (maybe 'a) let parse_maybe p = fun pc -> - match rbs_length pc.pc_bytes with + match sym_bs_length pc.pc_bytes with | 0 -> pr_return Nothing pc | _ -> match p pc with @@ -1925,7 +1893,7 @@ let parse_demaybe s p = val parse_restrict_length : forall 'a. sym_natural -> parser 'a -> parser 'a let parse_restrict_length n p = fun pc -> - match rbs_partition (sym_natural_expect_const n (*"parse_strict_length"*)) pc.pc_bytes with + match sym_partition (sym_natural_expect_const n (*"parse_strict_length"*)) pc.pc_bytes with | Fail _ -> Assert_extra.failwith "parse_restrict_length not given enough bytes" | Success (xs,ys) -> let pc' = <| pc_bytes = xs; pc_offset = pc.pc_offset |> in @@ -1937,24 +1905,24 @@ let parse_restrict_length n p = let parse_byte : parser(byte) = fun (pc:parse_context) -> - match rbs_read_char pc.pc_bytes with + match sym_read_char pc.pc_bytes with | Fail _ -> PR_fail "parse_byte" pc | Success (b,bs) -> PR_success b (<|pc_bytes=bs; pc_offset= pc.pc_offset + 1 |> ) end -let parse_n_bytes (n:sym_natural) : parser (rel_byte_sequence) = +let parse_n_bytes (n:sym_natural) : parser (sym_byte_sequence) = fun (pc:parse_context) -> - match rbs_partition (sym_natural_expect_const n (*"parse_n_bytes"*)) pc.pc_bytes with + match sym_partition (sym_natural_expect_const n (*"parse_n_bytes"*)) pc.pc_bytes with | Fail _ -> PR_fail ("parse_n_bytes n=" ^ pphex_sym n) pc | Success (xs,bs) -> - PR_success xs (<|pc_bytes=bs; pc_offset= pc.pc_offset + (rbs_length xs) |> ) + PR_success xs (<|pc_bytes=bs; pc_offset= pc.pc_offset + (sym_bs_length xs) |> ) end let bzero = byte_of_natural 0 -let parse_string : parser (rel_byte_sequence) = +let parse_string : parser (sym_byte_sequence) = fun (pc:parse_context) -> - match rbs_find_byte pc.pc_bytes bzero with + match sym_find_byte pc.pc_bytes bzero with | Nothing -> PR_fail "parse_string" pc | Just n -> pr_bind (parse_n_bytes (sym_natural_const n) pc) (fun res pc -> (*todo find byte should respect relocs*) @@ -1963,10 +1931,10 @@ let parse_string : parser (rel_byte_sequence) = end (* parse a null-terminated string; return Nothing if it is empty, Just s otherwise *) -let parse_non_empty_string : parser (maybe rel_byte_sequence) = +let parse_non_empty_string : parser (maybe sym_byte_sequence) = fun (pc:parse_context) -> pr_bind (parse_string pc) (fun str pc -> - if rbs_length str = 0 then + if sym_bs_length str = 0 then pr_return Nothing pc else pr_return (Just str) pc) @@ -1976,7 +1944,7 @@ let parse_non_empty_string : parser (maybe rel_byte_sequence) = let parse_uint8 : parser sym_natural= fun (pc:parse_context) -> let _ = my_debug "uint8 " in - match rbs_read_char pc.pc_bytes with + match sym_read_char pc.pc_bytes with | Success (b, bytes) -> let v = natural_of_byte b in PR_success (sym_natural_const v) (<| pc_bytes = bytes; pc_offset = pc.pc_offset + 1 |>) @@ -1993,7 +1961,7 @@ let parse_uint8_constant (v:sym_natural) : parser sym_natural= let parse_uint16 c : parser sym_natural= fun (pc:parse_context) -> let _ = my_debug "uint16 " in - match rbs_read_2_bytes_be pc.pc_bytes with + match sym_read_2_bytes_be pc.pc_bytes with | Success ((b0,b1),bytes') -> let v = if c.endianness=Little then natural_of_byte b0 + 256*natural_of_byte b1 @@ -2040,11 +2008,11 @@ let parse_uint64 c : parser sym_natural= let integerFromTwosComplementNatural (n:sym_natural) (half: sym_natural) (all:sym_integer) : sym_integer = - if n < half then symIntegerFromSymNatural n else symIntegerFromSymNatural n - all + if n < half then symIntegerFromNatural n else symIntegerFromNatural n - all let partialTwosComplementNaturalFromInteger (i:sym_integer) (half: sym_natural) (all:sym_integer) : sym_natural = - if i >=0 && i < symIntegerFromSymNatural half then partialSymNaturalFromSymInteger i - else if i >= (0-symIntegerFromSymNatural half) && i < 0 then partialSymNaturalFromSymInteger (all + i) + if i >=0 && i < symIntegerFromNatural half then partialSymNaturalFromInteger i + else if i >= (0-symIntegerFromNatural half) && i < 0 then partialSymNaturalFromInteger (all + i) else Assert_extra.failwith "partialTwosComplementNaturalFromInteger" let parse_sint8 : parser sym_integer = @@ -2062,7 +2030,7 @@ let parse_sint64 c : parser sym_integer = let rec parse_ULEB128' (acc: natural) (shift_factor: natural) : parser natural = fun (pc:parse_context) -> let _ = my_debug "ULEB128' " in - match rbs_read_char pc.pc_bytes with + match sym_read_char pc.pc_bytes with | Success (b,bytes') -> let n = natural_of_byte b in let acc' = (natural_land n 127) * shift_factor + acc in @@ -2083,7 +2051,7 @@ let parse_ULEB128 : parser sym_natural = let rec parse_SLEB128' (acc: natural) (shift_factor: natural) : parser (bool * natural * natural) = fun (pc:parse_context) -> let _ = my_debug "SLEB128' " in - match rbs_read_char pc.pc_bytes with + match sym_read_char pc.pc_bytes with | Success (b,bytes') -> let n = natural_of_byte b in let acc' = acc + (natural_land n 127) * shift_factor in @@ -2212,20 +2180,20 @@ let parse_abbreviations_table c = (** debug_str entry *) -let rec null_terminated_bs (bs: rel_byte_sequence) : rel_byte_sequence = - match rbs_find_byte bs bzero with +let rec null_terminated_bs (bs: sym_byte_sequence) : sym_byte_sequence = + match sym_find_byte bs bzero with | Just i -> - match rbs_takebytes i bs with + match sym_takebytes i bs with | Success bs' -> bs' | Fail _ -> Assert_extra.failwith "find_byte or take_byte is broken" end | Nothing -> bs end -let pp_debug_str_entry (str: rel_byte_sequence) (n: sym_natural) : string = - match rbs_dropbytes (sym_natural_expect_const n (*"pp_debug_str_entry"*)) str with +let pp_debug_str_entry (str: sym_byte_sequence) (n: sym_natural) : string = + match sym_dropbytes (sym_natural_expect_const n (*"pp_debug_str_entry"*)) str with | Fail _ -> "strp beyond .debug_str extent" - | Success bs -> string_of_rel_byte_sequence (null_terminated_bs bs) + | Success bs -> string_of_sym_byte_sequence (null_terminated_bs bs) end (** operations: pp and parsing *) @@ -2319,20 +2287,20 @@ let parse_operations_bs c cuh bs : list operation = match parse_operations c cuh pc with | PR_fail s pc' -> Assert_extra.failwith ("parse_operations_bs fail: " ^ pp_parse_fail s pc') | PR_success ops pc' -> - let _ = if rbs_length pc'.pc_bytes <> 0 then Assert_extra.failwith ("parse_operations_bs extra non-parsed bytes") else () in + let _ = if sym_bs_length pc'.pc_bytes <> 0 then Assert_extra.failwith ("parse_operations_bs extra non-parsed bytes") else () in ops end -val parse_and_pp_operations : p_context -> compilation_unit_header -> rel_byte_sequence -> string +val parse_and_pp_operations : p_context -> compilation_unit_header -> sym_byte_sequence -> string let parse_and_pp_operations c cuh bs = let pc = <|pc_bytes = bs; pc_offset = 0 |> in match parse_operations c cuh pc with | PR_fail s pc' -> "parse_operations fail: " ^ pp_parse_fail s pc' | PR_success ops pc' -> pp_operations ops - ^ if rbs_length pc'.pc_bytes <> 0 then " Warning: extra non-parsed bytes" else "" + ^ if sym_bs_length pc'.pc_bytes <> 0 then " Warning: extra non-parsed bytes" else "" end @@ -2353,12 +2321,12 @@ let pp_attribute_value_plain av = | AV_ref_addr n -> "AV_ref_addr " ^ pphex_sym n | AV_ref_sig8 n -> "AV_ref_sig8 " ^ pphex_sym n | AV_sec_offset n -> "AV_sec_offset " ^ pphex_sym n - | AV_string bs -> string_of_rel_byte_sequence bs + | AV_string bs -> string_of_sym_byte_sequence bs | AV_strp n -> "AV_sec_offset " ^ pphex_sym n ^ " " end -val pp_attribute_value : p_context -> compilation_unit_header -> rel_byte_sequence -> sym_natural (*attribute tag*) -> attribute_value -> string +val pp_attribute_value : p_context -> compilation_unit_header -> sym_byte_sequence -> sym_natural (*attribute tag*) -> attribute_value -> string let pp_attribute_value c cuh str at av = match av with | AV_addr x -> "AV_addr " ^ pphex_sym x @@ -2374,12 +2342,12 @@ let pp_attribute_value c cuh str at av = | AV_ref_addr n -> "AV_ref_addr " ^ pphex_sym n | AV_ref_sig8 n -> "AV_ref_sig8 " ^ pphex_sym n | AV_sec_offset n -> "AV_sec_offset " ^ pphex_sym n - | AV_string bs -> string_of_rel_byte_sequence bs + | AV_string bs -> string_of_sym_byte_sequence bs | AV_strp n -> "AV_sec_offset " ^ pphex_sym n ^ " " ^ pp_debug_str_entry str n end -val pp_attribute_value_like_objdump : p_context -> compilation_unit_header -> rel_byte_sequence -> sym_natural (*attribute tag*) -> attribute_value -> string +val pp_attribute_value_like_objdump : p_context -> compilation_unit_header -> sym_byte_sequence -> sym_natural (*attribute tag*) -> attribute_value -> string let pp_attribute_value_like_objdump c cuh str at av = match av with | AV_addr x -> (*"AV_addr " ^*) pphex_sym x @@ -2398,7 +2366,7 @@ let pp_attribute_value_like_objdump c cuh str at av = | AV_ref_sig8 n -> "AV_ref_sig8 " ^ pphex_sym n | AV_sec_offset n -> (*"AV_sec_offset " ^*) pphex_sym n ^ if at = attribute_encode "DW_AT_location" then " (location list)" else "" - | AV_string bs -> string_of_rel_byte_sequence bs + | AV_string bs -> string_of_sym_byte_sequence bs | AV_strp n -> (*"AV_sec_offset " ^ pphex_sym n ^ " " ^ pp_debug_str_entry str n*) "(indirect string, offset: "^pphex_sym n ^ "): " ^ pp_debug_str_entry str n @@ -2539,7 +2507,7 @@ let find_dies (p:die->bool) (d: dwarf) : list cupdie = let string_of_string_attribute_value str av : string = match av with - | AV_string bs -> string_of_rel_byte_sequence bs + | AV_string bs -> string_of_sym_byte_sequence bs | AV_strp n -> pp_debug_str_entry str n | _ -> "find_string_attribute_value_of_die AV not understood" end @@ -2560,10 +2528,10 @@ let natural_of_constant_attribute_value die1 c av : sym_natural = let integer_of_constant_attribute_value c av : sym_integer = match av with - | AV_constantN n bs -> symIntegerFromSymNatural n - | AV_constant_ULEB128 n -> symIntegerFromSymNatural n + | AV_constantN n bs -> symIntegerFromNatural n + | AV_constant_ULEB128 n -> symIntegerFromNatural n | AV_constant_SLEB128 n -> n - | AV_block n bs -> symIntegerFromSymNatural (sym_natural_of_bytes c.endianness bs) + | AV_block n bs -> symIntegerFromNatural (sym_natural_of_bytes c.endianness bs) | _ -> Assert_extra.failwith ("integer_of_constant_attribute_value fail") end @@ -2820,7 +2788,7 @@ let indent_level_plus_one indent level = else " "^" " -let pp_die_attribute c (cuh:compilation_unit_header) (str : rel_byte_sequence) (indent:bool) (level: natural) (((at: sym_natural), (af: sym_natural)), ((pos: sym_natural),(av:attribute_value))) : string = +let pp_die_attribute c (cuh:compilation_unit_header) (str : sym_byte_sequence) (indent:bool) (level: natural) (((at: sym_natural), (af: sym_natural)), ((pos: sym_natural),(av:attribute_value))) : string = indent_level_plus_one indent level ^ pp_pos pos ^ " " ^ right_space_padded_to 18 (pp_attribute_encoding at) ^ ": " ^ @@ -2832,7 +2800,7 @@ let pp_die_attribute c (cuh:compilation_unit_header) (str : rel_byte_sequence) ( pp_attribute_value_like_objdump c cuh str at av ^ "\n" -val pp_die : p_context -> compilation_unit_header -> rel_byte_sequence -> bool -> natural -> bool -> die -> string +val pp_die : p_context -> compilation_unit_header -> sym_byte_sequence -> bool -> natural -> bool -> die -> string let rec pp_die c cuh str indent level (pp_children:bool) die = indent_level indent level ^ "<" ^ show level ^ ">" ^ pp_pos die.die_offset @@ -2846,7 +2814,7 @@ let rec pp_die c cuh str indent level (pp_children:bool) die = ^ if pp_children then String.concat "" (List.map (pp_die c cuh str indent (level +1) pp_children) die.die_children) else "" -val pp_die_abbrev : p_context -> compilation_unit_header -> rel_byte_sequence -> natural -> bool -> (list die) -> die -> string +val pp_die_abbrev : p_context -> compilation_unit_header -> sym_byte_sequence -> natural -> bool -> (list die) -> die -> string let rec pp_die_abbrev c cuh str level (pp_children:bool) parents die = indent_level true level ^ pp_tag_encoding die.die_abbreviation_declaration.ad_tag @@ -2862,7 +2830,7 @@ let rec pp_die_abbrev c cuh str level (pp_children:bool) parents die = (* condensed pp for variables *) -val pp_die_abbrev_var : p_context -> dwarf -> compilation_unit -> rel_byte_sequence -> bool -> (list die) -> die -> (string (*name*) * string (*offset*) * string (*kind*)) +val pp_die_abbrev_var : p_context -> dwarf -> compilation_unit -> sym_byte_sequence -> bool -> (list die) -> die -> (string (*name*) * string (*offset*) * string (*kind*)) let rec pp_die_abbrev_var c d cu str (pp_children:bool) parents die = (* (indent_level true level*) (* ^ pp_tag_encoding die.die_abbreviation_declaration.ad_tag*) @@ -2879,7 +2847,7 @@ let rec pp_die_abbrev_var c d cu str (pp_children:bool) parents die = ) (* condensed pp for variable parents *) -val pp_die_abbrev_var_parent : p_context -> dwarf -> compilation_unit -> rel_byte_sequence -> die -> string +val pp_die_abbrev_var_parent : p_context -> dwarf -> compilation_unit -> sym_byte_sequence -> die -> string let pp_die_abbrev_var_parent c d cu str die = (* (indent_level true level*) (* ^ pp_tag_encoding die.die_abbreviation_declaration.ad_tag*) @@ -2894,7 +2862,7 @@ let pp_die_abbrev_var_parent c d cu str die = -val pp_die_abbrev_var_parents : p_context -> dwarf -> compilation_unit -> rel_byte_sequence -> list die -> string +val pp_die_abbrev_var_parents : p_context -> dwarf -> compilation_unit -> sym_byte_sequence -> list die -> string let pp_die_abbrev_var_parents c d cu str parents = String.concat ":" (List.map (fun die -> pp_die_abbrev_var_parent c d cu str die) parents) @@ -2908,7 +2876,7 @@ let pp_die_abbrev_var_parents c d cu str parents = -val parse_die : p_context -> rel_byte_sequence -> compilation_unit_header -> (sym_natural->abbreviation_declaration) -> parser (maybe die) +val parse_die : p_context -> sym_byte_sequence -> compilation_unit_header -> (sym_natural->abbreviation_declaration) -> parser (maybe die) let rec parse_die c str cuh find_abbreviation_declaration = fun (pc: parse_context) -> let _ = my_debug3 ("parse_die called at " ^ pp_parse_context pc ^ "\n") in @@ -2952,7 +2920,7 @@ let has_attribute (an: string) (die: die) : bool = (** compilation units: pp and parsing *) -let pp_compilation_unit c (indent:bool) (debug_str_section_body: rel_byte_sequence) cu = +let pp_compilation_unit c (indent:bool) (debug_str_section_body: sym_byte_sequence) cu = "" (* "*** compilation unit header ***\n"*) ^ pp_compilation_unit_header cu.cu_header @@ -2967,7 +2935,7 @@ let pp_compilation_units c (indent:bool) debug_string_section_body (compilation_ String.concat "" (List.map (pp_compilation_unit c indent debug_string_section_body) compilation_units) -let pp_compilation_unit_abbrev c (debug_str_section_body: rel_byte_sequence) cu = +let pp_compilation_unit_abbrev c (debug_str_section_body: sym_byte_sequence) cu = pp_compilation_unit_header cu.cu_header (* ^ pp_abbreviations_table cu.cu_abbreviations_table*) ^ pp_die_abbrev c cu.cu_header debug_str_section_body 0 true [] cu.cu_die @@ -2980,10 +2948,10 @@ let rec add_die_to_index acc parents die = let nacc : die_index = Map.insert die.die_offset (parents,die) acc in List.foldl (fun acc ndie -> add_die_to_index acc (die::parents) ndie) nacc die.die_children -let parse_compilation_unit c (debug_str_section_body: rel_byte_sequence) (debug_abbrev_section_body: rel_byte_sequence) : parser (maybe compilation_unit) = +let parse_compilation_unit c (debug_str_section_body: sym_byte_sequence) (debug_abbrev_section_body: sym_byte_sequence) : parser (maybe compilation_unit) = fun (pc:parse_context) -> - if rbs_length pc.pc_bytes = 0 then PR_success Nothing pc else + if sym_bs_length pc.pc_bytes = 0 then PR_success Nothing pc else let (cuh, pc') = @@ -2996,7 +2964,7 @@ let _ = my_debug4 (pp_compilation_unit_header cuh) in if cuh.cuh_unit_length = 0 then PR_success Nothing pc' else - let pc_abbrev = <|pc_bytes = match rbs_dropbytes (sym_natural_expect_const cuh.cuh_debug_abbrev_offset (*"mydrop of pc_abbrev"*)) debug_abbrev_section_body with Success bs -> bs | Fail _ -> Assert_extra.failwith "mydrop of debug_abbrev" end; pc_offset = sym_natural_expect_const cuh.cuh_debug_abbrev_offset (*"mydrop of pc_abbrev"*)|> in + let pc_abbrev = <|pc_bytes = match sym_dropbytes (sym_natural_expect_const cuh.cuh_debug_abbrev_offset (*"mydrop of pc_abbrev"*)) debug_abbrev_section_body with Success bs -> bs | Fail _ -> Assert_extra.failwith "mydrop of debug_abbrev" end; pc_offset = sym_natural_expect_const cuh.cuh_debug_abbrev_offset (*"mydrop of pc_abbrev"*)|> in (* todo: this is reparsing the abbreviations table for each cu *) let abbreviations_table = @@ -3027,14 +2995,14 @@ let _ = my_debug4 (pp_compilation_unit_header cuh) in PR_success (Just cu) pc'' end -let parse_compilation_units c (debug_str_section_body: rel_byte_sequence) (debug_abbrev_section_body: rel_byte_sequence): parser (list compilation_unit) +let parse_compilation_units c (debug_str_section_body: sym_byte_sequence) (debug_abbrev_section_body: sym_byte_sequence): parser (list compilation_unit) = parse_list (parse_compilation_unit c debug_str_section_body debug_abbrev_section_body) (** type units: pp and parsing *) -let pp_type_unit c (debug_str_section_body: rel_byte_sequence) tu = +let pp_type_unit c (debug_str_section_body: sym_byte_sequence) tu = pp_type_unit_header tu.tu_header ^ pp_abbreviations_table tu.tu_abbreviations_table ^ pp_die c tu.tu_header.tuh_cuh debug_str_section_body true 0 true tu.tu_die @@ -3043,10 +3011,10 @@ let pp_type_units c debug_string_section_body (type_units: list type_unit) : str String.concat "" (List.map (pp_type_unit c debug_string_section_body) type_units) -let parse_type_unit c (debug_str_section_body: rel_byte_sequence) (debug_abbrev_section_body: rel_byte_sequence) : parser (maybe type_unit) = +let parse_type_unit c (debug_str_section_body: sym_byte_sequence) (debug_abbrev_section_body: sym_byte_sequence) : parser (maybe type_unit) = fun (pc:parse_context) -> - if rbs_length pc.pc_bytes = 0 then PR_success Nothing pc else + if sym_bs_length pc.pc_bytes = 0 then PR_success Nothing pc else let (tuh, pc') = match parse_type_unit_header c pc with @@ -3056,7 +3024,7 @@ let parse_type_unit c (debug_str_section_body: rel_byte_sequence) (debug_abbrev_ (* let _ = my_debug4 (pp_type_unit_header tuh) in *) - let pc_abbrev = let n = tuh.tuh_cuh.cuh_debug_abbrev_offset in <|pc_bytes = match rbs_dropbytes (sym_natural_expect_const n (*"mydrop of pc_abbrev"*)) debug_abbrev_section_body with Success bs -> bs | Fail _ -> Assert_extra.failwith "mydrop of debug_abbrev" end; pc_offset = sym_natural_expect_const n (*"mydrop of pc_abbrev"*) |> in + let pc_abbrev = let n = tuh.tuh_cuh.cuh_debug_abbrev_offset in <|pc_bytes = match sym_dropbytes (sym_natural_expect_const n (*"mydrop of pc_abbrev"*)) debug_abbrev_section_body with Success bs -> bs | Fail _ -> Assert_extra.failwith "mydrop of debug_abbrev" end; pc_offset = sym_natural_expect_const n (*"mydrop of pc_abbrev"*) |> in let abbreviations_table = match parse_abbreviations_table c pc_abbrev with @@ -3085,7 +3053,7 @@ let parse_type_unit c (debug_str_section_body: rel_byte_sequence) (debug_abbrev_ PR_success (Just tu) pc'' end -let parse_type_units c (debug_str_section_body: rel_byte_sequence) (debug_abbrev_section_body: rel_byte_sequence): parser (list type_unit) +let parse_type_units c (debug_str_section_body: sym_byte_sequence) (debug_abbrev_section_body: sym_byte_sequence): parser (list type_unit) = parse_list (parse_type_unit c debug_str_section_body debug_abbrev_section_body) @@ -3171,7 +3139,7 @@ let parse_location_list_item c (cuh: compilation_unit_header) : parser (maybe lo let parse_location_list c cuh : parser (maybe location_list) = fun (pc: parse_context) -> - if rbs_length pc.pc_bytes = 0 then + if sym_bs_length pc.pc_bytes = 0 then PR_success Nothing pc else pr_post_map1 @@ -3274,7 +3242,7 @@ let rec expand_range_list_suffixes cuh (offset,(rlis: list range_list_item)) : l let parse_range_list c cuh : parser (maybe (list range_list)) = fun (pc: parse_context) -> - if rbs_length pc.pc_bytes = 0 then + if sym_bs_length pc.pc_bytes = 0 then PR_success Nothing pc else pr_post_map1 @@ -3373,29 +3341,29 @@ let pp_register_rule (rr:register_rule) : string = (*TODO make this more readel let pp_call_frame_instruction i = match i with | DW_CFA_advance_loc d -> "DW_CFA_advance_loc" ^ " " ^ pp_cfa_delta d - | DW_CFA_offset r n -> "DW_CFA_offset" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_offset (symIntegerFromSymNatural n) + | DW_CFA_offset r n -> "DW_CFA_offset" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_offset (symIntegerFromNatural n) | DW_CFA_restore r -> "DW_CFA_restore" ^ " " ^ pp_cfa_register r | DW_CFA_nop -> "DW_CFA_nop" | DW_CFA_set_loc a -> "DW_CFA_set_loc" ^ " " ^ pp_cfa_address a | DW_CFA_advance_loc1 d -> "DW_CFA_advance_loc1" ^ " " ^ pp_cfa_delta d | DW_CFA_advance_loc2 d -> "DW_CFA_advance_loc2" ^ " " ^ pp_cfa_delta d | DW_CFA_advance_loc4 d -> "DW_CFA_advance_loc4" ^ " " ^ pp_cfa_delta d - | DW_CFA_offset_extended r n -> "DW_CFA_offset_extended" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_offset (symIntegerFromSymNatural n) + | DW_CFA_offset_extended r n -> "DW_CFA_offset_extended" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_offset (symIntegerFromNatural n) | DW_CFA_restore_extended r -> "DW_CFA_restore_extended" ^ " " ^ pp_cfa_register r | DW_CFA_undefined r -> "DW_CFA_undefined" ^ " " ^ pp_cfa_register r | DW_CFA_same_value r -> "DW_CFA_same_value" ^ " " ^ pp_cfa_register r | DW_CFA_register r1 r2 -> "DW_CFA_register" ^ " " ^ pp_cfa_register r1 ^ " " ^ pp_cfa_register r2 | DW_CFA_remember_state -> "DW_CFA_remember_state" | DW_CFA_restore_state -> "DW_CFA_restore_state" - | DW_CFA_def_cfa r n -> "DW_CFA_def_cfa" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_offset (symIntegerFromSymNatural n) + | DW_CFA_def_cfa r n -> "DW_CFA_def_cfa" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_offset (symIntegerFromNatural n) | DW_CFA_def_cfa_register r -> "DW_CFA_def_cfa_register" ^ " " ^ pp_cfa_register r - | DW_CFA_def_cfa_offset n -> "DW_CFA_def_cfa_offset" ^ " " ^ pp_cfa_offset (symIntegerFromSymNatural n) + | DW_CFA_def_cfa_offset n -> "DW_CFA_def_cfa_offset" ^ " " ^ pp_cfa_offset (symIntegerFromNatural n) | DW_CFA_def_cfa_expression b -> "DW_CFA_def_cfa_expression" ^ " " ^ pp_cfa_block b | DW_CFA_expression r b -> "DW_CFA_expression" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_block b | DW_CFA_offset_extended_sf r i -> "DW_CFA_offset_extended_sf" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_sfoffset i | DW_CFA_def_cfa_sf r i -> "DW_CFA_def_cfa_sf" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_sfoffset i | DW_CFA_def_cfa_offset_sf i -> "DW_CFA_def_cfa_offset_sf" ^ " " ^ pp_cfa_sfoffset i - | DW_CFA_val_offset r n -> "DW_CFA_val_offset" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_offset (symIntegerFromSymNatural n) + | DW_CFA_val_offset r n -> "DW_CFA_val_offset" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_offset (symIntegerFromNatural n) | DW_CFA_val_offset_sf r i -> "DW_CFA_val_offset_sf" ^ pp_cfa_register r ^ " " ^ pp_cfa_sfoffset i | DW_CFA_val_expression r b -> "DW_CFA_val_expression" ^ " " ^ pp_cfa_register r ^ " " ^ pp_cfa_block b | DW_CFA_AARCH64_negate_ra_state -> "DW_CFA_AARCH64_negate_ra_state" @@ -3422,7 +3390,7 @@ let parser_of_call_frame_argument_type c cuh (cfat: call_frame_argument_type) : let parse_call_frame_instruction c cuh : parser (maybe call_frame_instruction) = fun pc -> - match rbs_read_char pc.pc_bytes with + match sym_read_char pc.pc_bytes with | Fail _ -> PR_success Nothing pc | Success (b,bs') -> let pc' = <| pc_bytes = bs'; pc_offset = pc.pc_offset + 1 |> in @@ -3463,14 +3431,14 @@ let parse_call_frame_instruction c cuh : parser (maybe call_frame_instruction) = let parse_call_frame_instructions c cuh : parser (list call_frame_instruction) = parse_list (parse_call_frame_instruction c cuh) -val parse_and_pp_call_frame_instructions : p_context -> compilation_unit_header -> rel_byte_sequence -> string +val parse_and_pp_call_frame_instructions : p_context -> compilation_unit_header -> sym_byte_sequence -> string let parse_and_pp_call_frame_instructions c cuh bs = let pc = <|pc_bytes = bs; pc_offset = 0 |> in match parse_call_frame_instructions c cuh pc with | PR_fail s pc' -> "parse_call_frame_instructions fail: " ^ pp_parse_fail s pc' | PR_success is pc' -> pp_call_frame_instructions is - ^ if rbs_length pc'.pc_bytes <> 0 then " Warning: extra non-parsed bytes" else "" + ^ if sym_bs_length pc'.pc_bytes <> 0 then " Warning: extra non-parsed bytes" else "" end @@ -3487,7 +3455,7 @@ let pp_cie c cuh cie = ^ " " ^ pphex_sym cie.cie_id ^ " CIE\n" ^ " Version: " ^ show cie.cie_version ^ "\n" - ^ " Augmentation: \""^ show (string_of_rel_byte_sequence cie.cie_augmentation) ^ "\"\n" + ^ " Augmentation: \""^ show (string_of_sym_byte_sequence cie.cie_augmentation) ^ "\"\n" ^ " Code alignment factor: " ^ show cie.cie_code_alignment_factor ^ "\n" ^ " Data alignment factor: " ^ show cie.cie_data_alignment_factor ^ "\n" ^ " Return address column: " ^ show cie.cie_return_address_register ^ "\n" @@ -3634,7 +3602,7 @@ Hence the following, which should be made more tail-recursive. *) val parse_dependent_list' : forall 'a. (list 'a -> parser 'a) -> list 'a -> parser (list 'a) let rec parse_dependent_list' p1 acc = fun pc -> - if rbs_length pc.pc_bytes = 0 then + if sym_bs_length pc.pc_bytes = 0 then PR_success (List.reverse acc) pc else pr_bind @@ -3654,7 +3622,7 @@ let parse_frame_info c cuh : parser frame_info (** line numbers .debug_line, pp and parsing *) let pp_line_number_file_entry lnfe = - "lnfe_path = " ^ string_of_rel_byte_sequence lnfe.lnfe_path ^ "\n" + "lnfe_path = " ^ string_of_sym_byte_sequence lnfe.lnfe_path ^ "\n" ^ "lnfe_directory_index " ^ show lnfe.lnfe_directory_index ^ "\n" ^ "lnfe_last_modification = " ^ show lnfe.lnfe_last_modification ^ "\n" ^ "lnfe_length = " ^ show lnfe.lnfe_length ^ "\n" @@ -3674,7 +3642,7 @@ let pp_line_number_header lnh = ^ "opcode_base = " ^ show lnh.lnh_opcode_base ^ "\n" ^ "standard_opcode_lengths = " ^ show lnh.lnh_standard_opcode_lengths ^ "\n" ^ "comp_dir = " ^ show lnh.lnh_comp_dir ^ "\n" -^ "include_directories = " ^ String.concat ", " (List.map string_of_rel_byte_sequence lnh.lnh_include_directories) ^ "\n" +^ "include_directories = " ^ String.concat ", " (List.map string_of_sym_byte_sequence lnh.lnh_include_directories) ^ "\n" ^ "file_entries = \n\n" ^ String.concat "\n" (List.map pp_line_number_file_entry lnh.lnh_file_entries) ^ "\n" @@ -3777,7 +3745,7 @@ let parse_line_number_header c (comp_dir:maybe string) : parser line_number_head (fun ((v,(((hl,(minil,maxopi))),(dis,(lb,(lr,ob)))))) -> pr_post_map (parse_triple - (pr_post_map (parse_n_bytes (ob-sym_natural_const 1)) (fun bs -> List.map sym_natural_of_byte (byte_list_of_rel_byte_sequence bs))) (* standard_opcode_lengths *) + (pr_post_map (parse_n_bytes (ob-sym_natural_const 1)) (fun bs -> List.map sym_natural_of_byte (byte_list_of_sym_byte_sequence bs))) (* standard_opcode_lengths *) ((*pr_return [[]]*) parse_list parse_non_empty_string) (* include_directories *) (parse_list parse_line_number_file_entry) (* file names *) ) @@ -3902,7 +3870,7 @@ let filename d cu n = if n=0 then Nothing else match mynth (n - 1) lnp.lnp_header.lnh_file_entries with | Just lnfe -> - Just (string_of_rel_byte_sequence lnfe.lnfe_path) + Just (string_of_sym_byte_sequence lnfe.lnfe_path) | Nothing -> Assert_extra.failwith ("line number file entry not found") end @@ -3915,11 +3883,11 @@ let unpack_file_entry lnh file : unpacked_file_entry = Nothing else match mynth (lnfe.lnfe_directory_index - 1) lnh.lnh_include_directories with - | Just d -> Just (string_of_rel_byte_sequence d) + | Just d -> Just (string_of_sym_byte_sequence d) | Nothing -> Just "" end in - (lnh.lnh_comp_dir, directory, string_of_rel_byte_sequence lnfe.lnfe_path) + (lnh.lnh_comp_dir, directory, string_of_sym_byte_sequence lnfe.lnfe_path) | Nothing -> (Nothing,Nothing,"") end @@ -3945,10 +3913,10 @@ let pp_ufe_brief (((mcomp_dir,mdir,file) as ufe) : unpacked_file_entry) : string ^ " comp_dir=" ^ match mcomp_dir with | Just s->s|Nothing->"" end *) -let parse_line_number_info c str (d_line: rel_byte_sequence) (cu: compilation_unit) : line_number_program = +let parse_line_number_info c str (d_line: sym_byte_sequence) (cu: compilation_unit) : line_number_program = let comp_dir = find_string_attribute_value_of_die "DW_AT_comp_dir" str cu.cu_die in let f n = - let d_line' = match rbs_dropbytes n d_line with Success xs -> xs | Fail _ -> Assert_extra.failwith "parse_line_number_info drop" end in + let d_line' = match sym_dropbytes n d_line with Success xs -> xs | Fail _ -> Assert_extra.failwith "parse_line_number_info drop" end in let pc = <| pc_bytes = d_line'; pc_offset = n|> in match parse_line_number_program c cu.cu_header comp_dir pc with | PR_success lnp pc' -> @@ -4009,13 +3977,13 @@ let pp_dwarf d = (* TODO: don't use lists of bytes here! *) let parse_dwarf c - (debug_info_section_body: rel_byte_sequence) - (debug_abbrev_section_body: rel_byte_sequence) - (debug_str_section_body: rel_byte_sequence) - (debug_loc_section_body: rel_byte_sequence) - (debug_ranges_section_body: rel_byte_sequence) - (debug_frame_section_body: rel_byte_sequence) - (debug_line_section_body: rel_byte_sequence) + (debug_info_section_body: sym_byte_sequence) + (debug_abbrev_section_body: sym_byte_sequence) + (debug_str_section_body: sym_byte_sequence) + (debug_loc_section_body: sym_byte_sequence) + (debug_ranges_section_body: sym_byte_sequence) + (debug_frame_section_body: sym_byte_sequence) + (debug_line_section_body: sym_byte_sequence) : dwarf = let pc_info = <|pc_bytes = debug_info_section_body; pc_offset = 0 |> in @@ -4069,7 +4037,7 @@ let parse_dwarf c d_line_info = li; |> -val extract_section_body : elf_file -> relocation_interpreter reloc_target_data -> string -> bool -> p_context * sym_natural * rel_byte_sequence +val extract_section_body : elf_file -> relocation_interpreter reloc_target_data -> string -> bool -> p_context * sym_natural * sym_byte_sequence let extract_section_body (f:elf_file) (ri:relocation_interpreter reloc_target_data) (section_name:string) (strict: bool) = let (en: Endianness.endianness) = match f with @@ -4115,7 +4083,7 @@ let extract_section_body (f:elf_file) (ri:relocation_interpreter reloc_target_da match extract_elf64_relocations_for_section f64 ri section_name with | Success relocations -> let _ = my_debug "extracted relocations" in - let section_body = construct_rel_byte_sequence section_body relocations in + let section_body = construct_sym_byte_sequence section_body relocations in (c,section_addr,section_body) | Fail err -> Assert_extra.failwith ("failed extracting relocations: " ^ err) end @@ -4131,7 +4099,7 @@ let extract_section_body (f:elf_file) (ri:relocation_interpreter reloc_target_da let extract_section_body_without_relocations f section_name strict = let err_on_relocation ef symtab_map sidx rel = Assert_extra.failwith "Relocation found while extracting a section without relocations" in let (c, addr, body) = extract_section_body f err_on_relocation section_name strict in - (c, addr, rbs_unwrap body) + (c, addr, sym_bs_expect_const body) val extract_dwarf : elf_file -> relocation_interpreter reloc_target_data -> maybe dwarf let extract_dwarf f ri = @@ -4149,7 +4117,7 @@ let extract_dwarf f ri = Just d -val extract_text : elf_file -> relocation_interpreter reloc_target_data -> p_context * sym_natural * rel_byte_sequence (* (p_context, elf32/64_section_addr, elf32/64_section_body) *) +val extract_text : elf_file -> relocation_interpreter reloc_target_data -> p_context * sym_natural * sym_byte_sequence (* (p_context, elf32/64_section_addr, elf32/64_section_body) *) let extract_text f ri = extract_section_body f ri ".text" true @@ -4314,7 +4282,7 @@ let rec evaluate_operation_list (c:p_context) (dloc: location_list_list) (evalua let bregxi r i = match ev.read_register r with - | RRR_result v -> push_memory_address (partialSymNaturalFromSymInteger ((symIntegerFromSymNatural v+i) mod (symIntegerFromSymNatural ac.ac_all))) s.s_stack + | RRR_result v -> push_memory_address (partialSymNaturalFromInteger ((symIntegerFromNatural v+i) mod (symIntegerFromNatural ac.ac_all))) s.s_stack | RRR_not_currently_available -> Fail "RRR_not_currently_available" | RRR_bad_register_number -> Fail ("RRR_bad_register_number " ^ show r) end in @@ -4348,7 +4316,7 @@ let rec evaluate_operation_list (c:p_context) (dloc: location_list_list) (evalua | (OpSem_lit, [OAV_natural n]) -> push_memory_address n s.s_stack | (OpSem_lit, [OAV_integer i]) -> - push_memory_address (partialTwosComplementNaturalFromInteger i ac.ac_half (symIntegerFromSymNatural ac.ac_all)) s.s_stack + push_memory_address (partialTwosComplementNaturalFromInteger i ac.ac_half (symIntegerFromNatural ac.ac_all)) s.s_stack | (OpSem_stack f, []) -> match f ac s.s_stack op.op_argument_values with | Just stack' -> @@ -4396,9 +4364,9 @@ let rec evaluate_operation_list (c:p_context) (dloc: location_list_list) (evalua match l with | SL_simple (SL_memory_address a) -> (*let _ = my_debug5 ("OpSem_fbreg: a = "^ pphex a ^ "\n") in*) - let vi = ((symIntegerFromSymNatural a) + i) mod (symIntegerFromSymNatural ac.ac_all) in + let vi = ((symIntegerFromNatural a) + i) mod (symIntegerFromNatural ac.ac_all) in (*let _ = my_debug5 ("OpSem_fbreg: v = "^ show vi ^ "\n") in*) - let v = partialSymNaturalFromSymInteger vi (*ac.ac_half (symIntegerFromSymNatural ac.ac_all)*) in + let v = partialSymNaturalFromInteger vi (*ac.ac_half (symIntegerFromNatural ac.ac_all)*) in push_memory_address v s.s_stack | _ -> Fail "OpSem_fbreg got a non-SL_simple (SL_memory_address _) result" @@ -4469,12 +4437,12 @@ let rec evaluate_operation_list (c:p_context) (dloc: location_list_list) (evalua end end -and evaluate_location_description_bytes (c:p_context) (dloc: location_list_list) (evaluated_frame_info: evaluated_frame_info) (cuh: compilation_unit_header) (ac: arithmetic_context) (ev: evaluation_context) (mfbloc: maybe attribute_value) (pc: sym_natural) (bs: rel_byte_sequence) : error single_location = +and evaluate_location_description_bytes (c:p_context) (dloc: location_list_list) (evaluated_frame_info: evaluated_frame_info) (cuh: compilation_unit_header) (ac: arithmetic_context) (ev: evaluation_context) (mfbloc: maybe attribute_value) (pc: sym_natural) (bs: sym_byte_sequence) : error single_location = let parse_context = <|pc_bytes = bs; pc_offset = 0 |> in match parse_operations c cuh parse_context with | PR_fail s pc' -> Fail ("evaluate_location_description_bytes: parse_operations fail: " ^ pp_parse_fail s pc') | PR_success ops pc' -> - if rbs_length pc'.pc_bytes <> 0 then + if sym_bs_length pc'.pc_bytes <> 0 then Fail "evaluate_location_description_bytes: extra non-parsed bytes" else evaluate_operation_list c dloc evaluated_frame_info cuh ac ev mfbloc pc initial_state ops @@ -4662,7 +4630,7 @@ let evaluate_call_frame_instruction (fi: frame_info) (cie: cie) (state: cfa_stat (* CFA Definition Instructions *) | DW_CFA_def_cfa r n -> - update_cfa (CR_register r (symIntegerFromSymNatural n)) + update_cfa (CR_register r (symIntegerFromNatural n)) | DW_CFA_def_cfa_sf r i -> update_cfa (CR_register r (i * cie.cie_data_alignment_factor)) | DW_CFA_def_cfa_register r -> @@ -4681,7 +4649,7 @@ let evaluate_call_frame_instruction (fi: frame_info) (cie: cie) (state: cfa_stat | DW_CFA_def_cfa_offset n -> match state.cs_current_row.ctr_cfa with | CR_register r i -> - update_cfa (CR_register r (symIntegerFromSymNatural n)) + update_cfa (CR_register r (symIntegerFromNatural n)) | _ -> Assert_extra.failwith "DW_CFA_def_cfa_offset: current rule is not CR_register" end | DW_CFA_def_cfa_offset_sf i -> @@ -4699,13 +4667,13 @@ let evaluate_call_frame_instruction (fi: frame_info) (cie: cie) (state: cfa_stat | DW_CFA_same_value r -> update_reg r (RR_same_value) | DW_CFA_offset r n -> - update_reg r (RR_offset ((symIntegerFromSymNatural n) * cie.cie_data_alignment_factor)) + update_reg r (RR_offset ((symIntegerFromNatural n) * cie.cie_data_alignment_factor)) | DW_CFA_offset_extended r n -> - update_reg r (RR_offset ((symIntegerFromSymNatural n) * cie.cie_data_alignment_factor)) + update_reg r (RR_offset ((symIntegerFromNatural n) * cie.cie_data_alignment_factor)) | DW_CFA_offset_extended_sf r i -> update_reg r (RR_offset (i * cie.cie_data_alignment_factor)) | DW_CFA_val_offset r n -> - update_reg r (RR_val_offset ((symIntegerFromSymNatural n) * cie.cie_data_alignment_factor)) + update_reg r (RR_val_offset ((symIntegerFromNatural n) * cie.cie_data_alignment_factor)) | DW_CFA_val_offset_sf r i -> update_reg r (RR_val_offset (i * cie.cie_data_alignment_factor)) | DW_CFA_register r1 r2 -> @@ -5167,7 +5135,7 @@ let analyse_locations_raw c (d: dwarf) = let name = match av_name with - | AV_string bs -> string_of_rel_byte_sequence bs + | AV_string bs -> string_of_sym_byte_sequence bs | AV_strp n -> pp_debug_str_entry d.d_str n | _ -> "av_name AV not understood" end in @@ -5236,7 +5204,7 @@ let range_of_die c cuh str (dranges: range_list_list) (cu_base_address: sym_natu | (Just (AV_addr n), Nothing, Nothing ) -> Just [(n,n+1)] (* unclear if this case is used? *) | (Just (AV_addr n1), Just (AV_addr n2), Nothing ) -> Just [(n1,n2)] | (Just (AV_addr n1), Just (AV_constant_ULEB128 n2), Nothing ) -> Just [(n1, n1+n2)] (* should be mod all? *) - | (Just (AV_addr n1), Just (AV_constant_SLEB128 i2), Nothing ) -> Just [(n1, symNaturalFromSymInteger (symIntegerFromSymNatural n1 + i2))] (* should be mod all? *) + | (Just (AV_addr n1), Just (AV_constant_SLEB128 i2), Nothing ) -> Just [(n1, partialSymNaturalFromInteger (symIntegerFromNatural n1 + i2))] (* should be mod all? *) | (Just (AV_addr n1), Just (AV_constantN _ _), Nothing ) -> Assert_extra.failwith "AV_constantN in range_of_die" | (Just (AV_addr n1), Just (AV_block n bs), Nothing ) -> let n2 = sym_natural_of_bytes c.endianness bs in Just [(n1, n1+n2)] (* should be mod all? *) (* signed or unsigned interp? *) @@ -5746,10 +5714,10 @@ let evaluate_line_number_operation match lno with | DW_LN_special adjusted_opcode -> let operation_advance = adjusted_opcode / lnh.lnh_line_range in - let line_increment = lnh.lnh_line_base + symIntegerFromSymNatural (adjusted_opcode mod lnh.lnh_line_range) in + let line_increment = lnh.lnh_line_base + symIntegerFromNatural (adjusted_opcode mod lnh.lnh_line_range) in let s' = <| s with - lnr_line = partialSymNaturalFromSymInteger ((symIntegerFromSymNatural s.lnr_line) + line_increment); + lnr_line = partialSymNaturalFromInteger ((symIntegerFromNatural s.lnr_line) + line_increment); lnr_address = new_address s operation_advance; lnr_op_index = new_op_index s operation_advance; |> in @@ -5780,7 +5748,7 @@ let evaluate_line_number_operation |> in (s', lnrs) | DW_LNS_advance_line line_increment -> - let s' = <| s with lnr_line = partialSymNaturalFromSymInteger ((symIntegerFromSymNatural s.lnr_line) + line_increment) |> in (s', lnrs) + let s' = <| s with lnr_line = partialSymNaturalFromInteger ((symIntegerFromNatural s.lnr_line) + line_increment) |> in (s', lnrs) | DW_LNS_set_file n -> let s' = <| s with lnr_file = n |> in (s', lnrs) | DW_LNS_set_column n -> @@ -6518,11 +6486,11 @@ let pp_inlined_subroutines_by_range ds iss = (* assume 4-byte ARM instructions *) -let rec words_of_rel_byte_sequence (addr:sym_natural) (bs:rel_byte_sequence) (acc:list (sym_natural * sym_natural)) : list (sym_natural * sym_natural) = +let rec words_of_sym_byte_sequence (addr:sym_natural) (bs:sym_byte_sequence) (acc:list (sym_natural * sym_natural)) : list (sym_natural * sym_natural) = match sym_read_4_bytes_be_symbolic bs with | Success (Bytes (b0,b1,b2,b3), bs') -> (*TODO allow symbolic? *) let i : sym_natural = sym_natural_const (natural_of_byte b0 + 256*natural_of_byte b1 + 65536*natural_of_byte b2 + 65536*256*natural_of_byte b3) in - words_of_rel_byte_sequence (addr+4) bs' ((addr,i)::acc) + words_of_sym_byte_sequence (addr+4) bs' ((addr,i)::acc) | Fail _ -> List.reverse acc end @@ -6532,7 +6500,7 @@ let pp_instruction ((addr:sym_natural),(i:sym_natural)) = val pp_text_section : elf_file -> relocation_interpreter reloc_target_data -> string let pp_text_section f ri = let (p_context, addr, bs) = extract_text f ri in - let instructions : list (sym_natural * sym_natural) = words_of_rel_byte_sequence addr bs [] in + let instructions : list (sym_natural * sym_natural) = words_of_sym_byte_sequence addr bs [] in String.concat "" (List.map pp_instruction instructions) (** ************************************************************ *) From b1dd33db6b50c5350d792b80e6c2530959bd175a Mon Sep 17 00:00:00 2001 From: Matej Urban Date: Tue, 11 Mar 2025 12:09:16 +0000 Subject: [PATCH 34/44] Don't use symbolic values for non-relocatable files --- src/dwarf.lem | 18 +++++++++++++++--- 1 file changed, 15 insertions(+), 3 deletions(-) diff --git a/src/dwarf.lem b/src/dwarf.lem index c37bfd2..a9c75b1 100644 --- a/src/dwarf.lem +++ b/src/dwarf.lem @@ -4054,11 +4054,19 @@ let extract_section_body (f:elf_file) (ri:relocation_interpreter reloc_target_da ) f32.elf32_file_interpreted_sections in match sections with | [section] -> - let section_addr = sym_natural_section section_name in + let section_addr = if is_elf32_relocatable_file f32.elf32_file_header then + sym_natural_section section_name + else + sym_natural_const section.Elf_interpreted_section.elf32_section_addr + in let section_body = section.Elf_interpreted_section.elf32_section_body in (* let _ = my_debug4 (section_name ^ (": \n" ^ (Elf_interpreted_section.string_of_elf32_interpreted_section section ^ "\n" * ^ " body = " ^ ppbytes2 0 section_body ^ "\n"))) in *) - let section_body = Assert_extra.failwith "Not implemented" in + let section_body = if is_elf32_relocatable_file f32.elf32_file_header then + Assert_extra.failwith "Not implemented" + else + sym_bs_construct section_body Map.empty + in (c,section_addr,section_body) | [] -> if strict then @@ -4077,7 +4085,11 @@ let extract_section_body (f:elf_file) (ri:relocation_interpreter reloc_target_da ) f64.elf64_file_interpreted_sections in match sections with | [section] -> - let section_addr = sym_natural_section section_name in + let section_addr = if is_elf64_relocatable_file f64.elf64_file_header then + sym_natural_section section_name + else + sym_natural_const section.Elf_interpreted_section.elf64_section_addr + in let section_body = section.Elf_interpreted_section.elf64_section_body in let _ = my_debug "extracted section body" in match extract_elf64_relocations_for_section f64 ri section_name with From f1c41ae7df5cdde06beb67b54a7748838935867a Mon Sep 17 00:00:00 2001 From: Matej Urban Date: Tue, 11 Mar 2025 16:51:39 +0000 Subject: [PATCH 35/44] Cleanup relocation code --- .../abi_aarch64_symbolic_relocation.lem | 30 +++++-------------- src/abis/abi_symbolic_relocation.lem | 26 +++++++++++++--- src/elf_symbolic.lem | 28 ++++++++++++----- src/main_elf.lem | 1 + 4 files changed, 52 insertions(+), 33 deletions(-) diff --git a/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem b/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem index 021d04e..2a446c0 100644 --- a/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem +++ b/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem @@ -25,9 +25,7 @@ type aarch64_relocation_target | CALL (* TODO fix sizes and stuff *) -val abi_aarch64_apply_relocation_symbolic : - elf64_relocation_a -> symbolic_expression -> symbolic_expression -> elf64_file -> - error (Map.map elf64_addr (relocation_description symbolic_expression aarch64_relocation_target)) +val abi_aarch64_apply_relocation_symbolic : relocation_spec aarch64_relocation_target let abi_aarch64_apply_relocation_symbolic rel s_val p_val ef = if is_elf64_relocatable_file ef.elf64_file_header then let (rel_type, _) = parse_elf64_relocation_info rel.elf64_ra_info in @@ -146,28 +144,16 @@ let abi_aarch64_apply_relocation_symbolic rel s_val p_val ef = else fail "abi_aarch64_apply_relocation: not a relocatable file" -val abi_aarch64_relocation_to_abstract : relocation_interpreter aarch64_relocation_target -let abi_aarch64_relocation_to_abstract ef symtab sidx rel = - section_with_offset ef sidx rel.elf64_ra_offset >>= fun p_val -> - let (_, sym) = parse_elf64_relocation_info rel.elf64_ra_info in - match symbolic_address_of_symbol ef symtab (natFromNatural sym) with - | Just x -> x - | Nothing -> fail "Invalid symbol table index" - end >>= fun s_val -> - abi_aarch64_apply_relocation_symbolic rel s_val p_val ef >>= fun rel_desc_map -> - map_mapM eval_relocation rel_desc_map - let aarch64_relocation_target_to_data_target = function | Data32 -> return Elf_symbolic.Data32 | Data64 -> return Elf_symbolic.Data64 | _ -> fail "Not a data relocation" end -let aarch64_data_relocation_interpreter ef symtab sidx rel = - abi_aarch64_relocation_to_abstract ef symtab sidx rel >>= fun arels -> - map_mapM (fun arel -> - aarch64_relocation_target_to_data_target arel.arel_target >>= fun target -> - return <| arel_value = arel.arel_value - ; arel_target = target - |> - ) arels \ No newline at end of file +let aarch64_relocation_interpreter = + abi_relocation_interpreter abi_aarch64_apply_relocation_symbolic + +let aarch64_data_relocation_interpreter = + relocation_interpreter_map_target + aarch64_relocation_interpreter + aarch64_relocation_target_to_data_target diff --git a/src/abis/abi_symbolic_relocation.lem b/src/abis/abi_symbolic_relocation.lem index d11e712..7230a66 100644 --- a/src/abis/abi_symbolic_relocation.lem +++ b/src/abis/abi_symbolic_relocation.lem @@ -1,5 +1,8 @@ open import Num open import Maybe +open import Bool +open import Basic_classes +open import String open import Error @@ -8,7 +11,11 @@ open import Abi_utilities open import Elf_types_native_uint open import Elf_symbol_table open import Elf_symbolic - +open import Elf_relocation +open import Elf_file +open import Elf_header +open import Elf_section_header_table +open import Elf_interpreted_section type relocation_description 'res 'tar = <| rel_desc_operation : (relocation_operator_expression 'res) @@ -18,8 +25,6 @@ type relocation_description 'res 'tar = ; rel_desc_target : 'tar |> - - let rec eval_op_exp op: error symbolic_expression = match op with | Lift x -> return x @@ -37,7 +42,6 @@ let rec eval_op_exp op: error symbolic_expression = | _ -> fail "Not supported" end - let eval_relocation desc = let (hi, lo) = desc.rel_desc_mask in @@ -54,3 +58,17 @@ let eval_relocation desc = >>= fun value -> return <| arel_value = Mask(value, hi, lo) ; arel_target = desc.rel_desc_target |> +type relocation_spec 'a = elf64_relocation_a -> symbolic_expression -> symbolic_expression -> elf64_file -> + error (Map.map elf64_addr (relocation_description symbolic_expression 'a)) + +val abi_relocation_interpreter : forall 'a. relocation_spec 'a -> relocation_interpreter 'a +let abi_relocation_interpreter spec ef symtab sidx rel = + section_with_offset ef sidx rel.elf64_ra_offset >>= fun p_val -> + let (_, sym) = parse_elf64_relocation_info rel.elf64_ra_info in + match symbolic_address_of_symbol ef symtab (natFromNatural sym) with + | Just x -> x + | Nothing -> fail "Invalid symbol table index" + end >>= fun s_val -> + spec rel s_val p_val ef >>= fun rel_desc_map -> + map_mapM eval_relocation rel_desc_map + diff --git a/src/elf_symbolic.lem b/src/elf_symbolic.lem index 5e6761e..6436337 100644 --- a/src/elf_symbolic.lem +++ b/src/elf_symbolic.lem @@ -20,6 +20,8 @@ open import Elf_header open import Elf_section_header_table open import Elf_interpreted_section +(* Symbolic expressions *) + (* TODO *) type binary_operation = Add @@ -61,6 +63,14 @@ end let symbolic_address_from_elf64_symbol_table_entry f ste = section_with_offset f ste.elf64_st_shndx ste.elf64_st_value +let symbolic_address_of_symbol f symtab sym = + match List.index symtab sym with + | Nothing -> Nothing + | Just ste -> Just (symbolic_address_from_elf64_symbol_table_entry f ste) + end + +(* Relocation expressions *) + type abstract_relocation 'a = <| arel_value : symbolic_expression ; arel_target : 'a @@ -75,13 +85,17 @@ let reloc_width_bytes : reloc_target_data -> natural = function | Data64 -> 8 end -type relocation_interpreter 'a = elf64_file -> elf64_symbol_table -> elf64_half -> elf64_relocation_a -> error (Map.map elf64_addr (abstract_relocation 'a)) - -let symbolic_address_of_symbol f symtab sym = - match List.index symtab sym with - | Nothing -> Nothing - | Just ste -> Just (symbolic_address_from_elf64_symbol_table_entry f ste) - end +type relocation_interpreter 'a = elf64_file -> elf64_symbol_table -> elf64_half -> elf64_relocation_a -> + error (Map.map elf64_addr (abstract_relocation 'a)) + +let relocation_interpreter_map_target interp conv ef symtab sidx rel = + interp ef symtab sidx rel >>= fun arels -> + map_mapM (fun arel -> + conv arel.arel_target >>= fun target -> + return <| arel_value = arel.arel_value + ; arel_target = target + |> + ) arels val extract_elf64_relocations_for_section' : forall 'a. elf64_file -> relocation_interpreter 'a -> elf64_half -> error (Map.map elf64_addr (abstract_relocation 'a)) let extract_elf64_relocations_for_section' f1 interp sidx = diff --git a/src/main_elf.lem b/src/main_elf.lem index bbcbb35..74c3b71 100644 --- a/src/main_elf.lem +++ b/src/main_elf.lem @@ -37,6 +37,7 @@ open import Elf_symbolic open import Harness_interface open import Sail_interface +open import Abi_symbolic_relocation open import Abi_aarch64_relocation open import Abi_aarch64_symbolic_relocation From c914d9e9ef4805eeccec592741562c3192466c9d Mon Sep 17 00:00:00 2001 From: Matej Urban Date: Wed, 9 Apr 2025 09:28:31 +0100 Subject: [PATCH 36/44] fix --- src/elf_symbolic.lem | 1 + src/sym_ocaml.ml | 11 ++++------- 2 files changed, 5 insertions(+), 7 deletions(-) diff --git a/src/elf_symbolic.lem b/src/elf_symbolic.lem index 6436337..be7986b 100644 --- a/src/elf_symbolic.lem +++ b/src/elf_symbolic.lem @@ -71,6 +71,7 @@ let symbolic_address_of_symbol f symtab sym = (* Relocation expressions *) +(* TODO rename *) type abstract_relocation 'a = <| arel_value : symbolic_expression ; arel_target : 'a diff --git a/src/sym_ocaml.ml b/src/sym_ocaml.ml index a30ec7d..9b42fe2 100644 --- a/src/sym_ocaml.ml +++ b/src/sym_ocaml.ml @@ -126,13 +126,10 @@ module Num = struct let div = map2 NBN.div let modulus x y = - if match y with - | Absolute(y) -> NBN.greater_equal y (NBN.pow_int (NBN.of_int 2) 64) - | _ -> false - then - x - else - map2 NBN.modulus x y + let y = to_num y in + match x with + | Absolute x -> Absolute (NBN.modulus x y) + | Offset (s, x) -> Offset (s, NBN.modulus x y) (*Unsafe*) let comp f a b = match (a, b) with | (Absolute a, Absolute b) -> f a b From 6e7cec1e047cc0793328f32c18939476f41d50f3 Mon Sep 17 00:00:00 2001 From: Matej Urban Date: Wed, 9 Apr 2025 10:09:36 +0100 Subject: [PATCH 37/44] Handle undef symbols --- src/elf_symbolic.lem | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/src/elf_symbolic.lem b/src/elf_symbolic.lem index be7986b..4aa2a38 100644 --- a/src/elf_symbolic.lem +++ b/src/elf_symbolic.lem @@ -61,7 +61,13 @@ end (* TODO handle special shndx *) let symbolic_address_from_elf64_symbol_table_entry f ste = - section_with_offset f ste.elf64_st_shndx ste.elf64_st_value + if natural_of_elf64_half ste.elf64_st_shndx = shn_undef then + let name = natural_of_elf64_word ste.elf64_st_name in + get_elf64_file_symbol_string_table f >>= fun strtab -> + String_table.get_string_at name strtab >>= fun str -> + return (Section ("UND."^str)) + else + section_with_offset f ste.elf64_st_shndx ste.elf64_st_value let symbolic_address_of_symbol f symtab sym = match List.index symtab sym with From 94e66ce79738018ccf95cfd730cd759fdf926888 Mon Sep 17 00:00:00 2001 From: Matej Urban Date: Thu, 10 Apr 2025 12:19:12 +0100 Subject: [PATCH 38/44] add reloc types --- .../abi_aarch64_symbolic_relocation.lem | 33 +++++++++++++++++++ 1 file changed, 33 insertions(+) diff --git a/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem b/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem index 2a446c0..7f04a05 100644 --- a/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem +++ b/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem @@ -106,6 +106,28 @@ let abi_aarch64_apply_relocation_symbolic rel s_val p_val ef = ; rel_desc_target = ADD |> ) + else if rel_type = r_aarch64_ldst8_abs_lo12_nc then + let result = Plus(Lift s_val, Lift a_val) in + let addr = rel.elf64_ra_offset in + return (Map.singleton addr + <| rel_desc_operation = result + ; rel_desc_range = Nothing + ; rel_desc_alignment_bits = 0 + ; rel_desc_mask = (11, 0) + ; rel_desc_target = LDST 0 + |> + ) + else if rel_type = r_aarch64_ldst16_abs_lo12_nc then + let result = Plus(Lift s_val, Lift a_val) in + let addr = rel.elf64_ra_offset in + return (Map.singleton addr + <| rel_desc_operation = result + ; rel_desc_range = Nothing + ; rel_desc_alignment_bits = 1 + ; rel_desc_mask = (11, 1) + ; rel_desc_target = LDST 1 + |> + ) else if rel_type = r_aarch64_ldst32_abs_lo12_nc then let result = Plus(Lift s_val, Lift a_val) in let addr = rel.elf64_ra_offset in @@ -128,6 +150,17 @@ let abi_aarch64_apply_relocation_symbolic rel s_val p_val ef = ; rel_desc_target = LDST 3 |> ) + else if rel_type = r_aarch64_ldst128_abs_lo12_nc then + let result = Plus(Lift s_val, Lift a_val) in + let addr = rel.elf64_ra_offset in + return (Map.singleton addr + <| rel_desc_operation = result + ; rel_desc_range = Nothing + ; rel_desc_alignment_bits = 4 + ; rel_desc_mask = (11, 4) + ; rel_desc_target = LDST 4 + |> + ) else if rel_type = r_aarch64_call26 then let result = Minus(Plus(Lift s_val, Lift a_val), Lift p_val) in let addr = rel.elf64_ra_offset in From c8ecbbe35223c96a12240019ee41fee58a5e99d7 Mon Sep 17 00:00:00 2001 From: Matej Urban Date: Tue, 15 Apr 2025 22:28:09 +0100 Subject: [PATCH 39/44] Simplify the abi symbolic relocation representation --- .../abi_aarch64_symbolic_relocation.lem | 282 ++++++++---------- src/abis/abi_symbolic_relocation.lem | 51 ++-- 2 files changed, 164 insertions(+), 169 deletions(-) diff --git a/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem b/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem index 7f04a05..20f48b1 100644 --- a/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem +++ b/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem @@ -24,158 +24,140 @@ type aarch64_relocation_target | LDST of int | CALL -(* TODO fix sizes and stuff *) val abi_aarch64_apply_relocation_symbolic : relocation_spec aarch64_relocation_target -let abi_aarch64_apply_relocation_symbolic rel s_val p_val ef = - if is_elf64_relocatable_file ef.elf64_file_header then - let (rel_type, _) = parse_elf64_relocation_info rel.elf64_ra_info in - let a_val = Const (integer_of_elf64_sxword rel.elf64_ra_addend) in - (** No width, no calculation *) - if rel_type = r_aarch64_none then - return Map.empty - (** No width, no calculation *) - else if rel_type = r_aarch64_withdrawn then - return Map.empty - (** Signed 64 bit width, calculation: S + A *) - else if rel_type = r_aarch64_abs64 then - let result = Plus(Lift s_val, Lift a_val) in - let addr = rel.elf64_ra_offset in - return (Map.singleton addr - <| rel_desc_operation = result - ; rel_desc_range = Nothing - ; rel_desc_alignment_bits = 0 - ; rel_desc_mask = (63, 0) - ; rel_desc_target = Data64 - |> - ) - (** Signed 32 bit width, calculation: S + A *) - else if rel_type = r_aarch64_abs32 then - let result = Plus(Lift s_val, Lift a_val) in - let addr = rel.elf64_ra_offset in - return (Map.singleton addr - <| rel_desc_operation = result - ; rel_desc_range = Just (~(2**31), 2**32) - ; rel_desc_alignment_bits = 0 - ; rel_desc_mask = (31, 0) - ; rel_desc_target = Data32 - |> - ) - (** Signed 64 bit width, calculation: S + A - P *) - else if rel_type = r_aarch64_prel64 then - let result = Minus(Plus(Lift s_val, Lift a_val), Lift p_val) in - let addr = rel.elf64_ra_offset in - return (Map.singleton addr - <| rel_desc_operation = result - ; rel_desc_range = Nothing - ; rel_desc_alignment_bits = 0 - ; rel_desc_mask = (63, 0) - ; rel_desc_target = Data64 - |> - ) - (** Signed 32 bit width, calculation: S + A - P *) - else if rel_type = r_aarch64_prel32 then - let result = Minus(Plus(Lift s_val, Lift a_val), Lift p_val) in - let addr = rel.elf64_ra_offset in - return (Map.singleton addr - <| rel_desc_operation = result - ; rel_desc_range = Just (~(2**31), 2**32) - ; rel_desc_alignment_bits = 0 - ; rel_desc_mask = (31, 0) - ; rel_desc_target = Data32 - |> - ) - else if rel_type = r_aarch64_adr_prel_pg_hi21 then - let result = Minus(Apply(Page, Plus(Lift s_val, Lift a_val)), Apply(Page, Lift p_val)) in - let addr = rel.elf64_ra_offset in - return (Map.singleton addr - <| rel_desc_operation = result - ; rel_desc_range = Just (~(2**32), 2**32) - ; rel_desc_alignment_bits = 0 - ; rel_desc_mask = (32, 12) - ; rel_desc_target = ADRP - |> - ) - else if rel_type = r_aarch64_add_abs_lo12_nc then - let result = Plus(Lift s_val, Lift a_val) in - let addr = rel.elf64_ra_offset in - return (Map.singleton addr - <| rel_desc_operation = result - ; rel_desc_range = Nothing - ; rel_desc_alignment_bits = 0 - ; rel_desc_mask = (11, 0) - ; rel_desc_target = ADD - |> - ) - else if rel_type = r_aarch64_ldst8_abs_lo12_nc then - let result = Plus(Lift s_val, Lift a_val) in - let addr = rel.elf64_ra_offset in - return (Map.singleton addr - <| rel_desc_operation = result - ; rel_desc_range = Nothing - ; rel_desc_alignment_bits = 0 - ; rel_desc_mask = (11, 0) - ; rel_desc_target = LDST 0 - |> - ) - else if rel_type = r_aarch64_ldst16_abs_lo12_nc then - let result = Plus(Lift s_val, Lift a_val) in - let addr = rel.elf64_ra_offset in - return (Map.singleton addr - <| rel_desc_operation = result - ; rel_desc_range = Nothing - ; rel_desc_alignment_bits = 1 - ; rel_desc_mask = (11, 1) - ; rel_desc_target = LDST 1 - |> - ) - else if rel_type = r_aarch64_ldst32_abs_lo12_nc then - let result = Plus(Lift s_val, Lift a_val) in - let addr = rel.elf64_ra_offset in - return (Map.singleton addr - <| rel_desc_operation = result - ; rel_desc_range = Nothing - ; rel_desc_alignment_bits = 2 - ; rel_desc_mask = (11, 2) - ; rel_desc_target = LDST 2 - |> - ) - else if rel_type = r_aarch64_ldst64_abs_lo12_nc then - let result = Plus(Lift s_val, Lift a_val) in - let addr = rel.elf64_ra_offset in - return (Map.singleton addr - <| rel_desc_operation = result - ; rel_desc_range = Nothing - ; rel_desc_alignment_bits = 3 - ; rel_desc_mask = (11, 3) - ; rel_desc_target = LDST 3 - |> - ) - else if rel_type = r_aarch64_ldst128_abs_lo12_nc then - let result = Plus(Lift s_val, Lift a_val) in - let addr = rel.elf64_ra_offset in - return (Map.singleton addr - <| rel_desc_operation = result - ; rel_desc_range = Nothing - ; rel_desc_alignment_bits = 4 - ; rel_desc_mask = (11, 4) - ; rel_desc_target = LDST 4 - |> - ) - else if rel_type = r_aarch64_call26 then - let result = Minus(Plus(Lift s_val, Lift a_val), Lift p_val) in - let addr = rel.elf64_ra_offset in - return (Map.singleton addr - <| rel_desc_operation = result - ; rel_desc_range = Just (~(2**27), 2**27) - ; rel_desc_alignment_bits = 2 - ; rel_desc_mask = (27, 2) - ; rel_desc_target = CALL - |> - ) - else - fail ("Unsupported AARCH64 relocation type " ^ (string_of_aarch64_relocation_type rel_type)) +let abi_aarch64_apply_relocation_symbolic rel_type = + (** No width, no calculation *) + if rel_type = r_aarch64_none then + return Nothing + (** No width, no calculation *) + else if rel_type = r_aarch64_withdrawn then + return Nothing + (** Signed 64 bit width, calculation: S + A *) + else if rel_type = r_aarch64_abs64 then + let result = Plus(Lift S, Lift A) in + return (Just + <| rel_desc_operation = result + ; rel_desc_range = Nothing + ; rel_desc_alignment_bits = 0 + ; rel_desc_mask = (63, 0) + ; rel_desc_target = Data64 + |> + ) + (** Signed 32 bit width, calculation: S + A *) + else if rel_type = r_aarch64_abs32 then + let result = Plus(Lift S, Lift A) in + return (Just + <| rel_desc_operation = result + ; rel_desc_range = Just (~(2**31), 2**32) + ; rel_desc_alignment_bits = 0 + ; rel_desc_mask = (31, 0) + ; rel_desc_target = Data32 + |> + ) + (** Signed 64 bit width, calculation: S + A - P *) + else if rel_type = r_aarch64_prel64 then + let result = Minus(Plus(Lift S, Lift A), Lift P) in + return (Just + <| rel_desc_operation = result + ; rel_desc_range = Nothing + ; rel_desc_alignment_bits = 0 + ; rel_desc_mask = (63, 0) + ; rel_desc_target = Data64 + |> + ) + (** Signed 32 bit width, calculation: S + A - P *) + else if rel_type = r_aarch64_prel32 then + let result = Minus(Plus(Lift S, Lift A), Lift P) in + return (Just + <| rel_desc_operation = result + ; rel_desc_range = Just (~(2**31), 2**32) + ; rel_desc_alignment_bits = 0 + ; rel_desc_mask = (31, 0) + ; rel_desc_target = Data32 + |> + ) + else if rel_type = r_aarch64_adr_prel_pg_hi21 then + let result = Minus(Apply(Page, Plus(Lift S, Lift A)), Apply(Page, Lift P)) in + return (Just + <| rel_desc_operation = result + ; rel_desc_range = Just (~(2**32), 2**32) + ; rel_desc_alignment_bits = 0 + ; rel_desc_mask = (32, 12) + ; rel_desc_target = ADRP + |> + ) + else if rel_type = r_aarch64_add_abs_lo12_nc then + let result = Plus(Lift S, Lift A) in + return (Just + <| rel_desc_operation = result + ; rel_desc_range = Nothing + ; rel_desc_alignment_bits = 0 + ; rel_desc_mask = (11, 0) + ; rel_desc_target = ADD + |> + ) + else if rel_type = r_aarch64_ldst8_abs_lo12_nc then + let result = Plus(Lift S, Lift A) in + return (Just + <| rel_desc_operation = result + ; rel_desc_range = Nothing + ; rel_desc_alignment_bits = 0 + ; rel_desc_mask = (11, 0) + ; rel_desc_target = LDST 0 + |> + ) + else if rel_type = r_aarch64_ldst16_abs_lo12_nc then + let result = Plus(Lift S, Lift A) in + return (Just + <| rel_desc_operation = result + ; rel_desc_range = Nothing + ; rel_desc_alignment_bits = 1 + ; rel_desc_mask = (11, 1) + ; rel_desc_target = LDST 1 + |> + ) + else if rel_type = r_aarch64_ldst32_abs_lo12_nc then + let result = Plus(Lift S, Lift A) in + return (Just + <| rel_desc_operation = result + ; rel_desc_range = Nothing + ; rel_desc_alignment_bits = 2 + ; rel_desc_mask = (11, 2) + ; rel_desc_target = LDST 2 + |> + ) + else if rel_type = r_aarch64_ldst64_abs_lo12_nc then + let result = Plus(Lift S, Lift A) in + return (Just + <| rel_desc_operation = result + ; rel_desc_range = Nothing + ; rel_desc_alignment_bits = 3 + ; rel_desc_mask = (11, 3) + ; rel_desc_target = LDST 3 + |> + ) + else if rel_type = r_aarch64_ldst128_abs_lo12_nc then + let result = Plus(Lift S, Lift A) in + return (Just + <| rel_desc_operation = result + ; rel_desc_range = Nothing + ; rel_desc_alignment_bits = 4 + ; rel_desc_mask = (11, 4) + ; rel_desc_target = LDST 4 + |> + ) + else if rel_type = r_aarch64_call26 then + let result = Minus(Plus(Lift S, Lift A), Lift P) in + return (Just + <| rel_desc_operation = result + ; rel_desc_range = Just (~(2**27), 2**27) + ; rel_desc_alignment_bits = 2 + ; rel_desc_mask = (27, 2) + ; rel_desc_target = CALL + |> + ) else - fail "abi_aarch64_apply_relocation: not a relocatable file" + fail ("Unsupported AARCH64 relocation type " ^ (string_of_aarch64_relocation_type rel_type)) let aarch64_relocation_target_to_data_target = function | Data32 -> return Elf_symbolic.Data32 diff --git a/src/abis/abi_symbolic_relocation.lem b/src/abis/abi_symbolic_relocation.lem index 7230a66..4003fec 100644 --- a/src/abis/abi_symbolic_relocation.lem +++ b/src/abis/abi_symbolic_relocation.lem @@ -17,6 +17,8 @@ open import Elf_header open import Elf_section_header_table open import Elf_interpreted_section +type relocation_param = S | A | P + type relocation_description 'res 'tar = <| rel_desc_operation : (relocation_operator_expression 'res) ; rel_desc_range : maybe (integer * integer) @@ -25,27 +27,30 @@ type relocation_description 'res 'tar = ; rel_desc_target : 'tar |> -let rec eval_op_exp op: error symbolic_expression = +let rec eval_op_exp s_val a_val p_val op: error symbolic_expression = + let f = eval_op_exp s_val a_val p_val in match op with - | Lift x -> return x + | Lift S -> return s_val + | Lift A -> return a_val + | Lift P -> return p_val | Plus (x, y) -> - eval_op_exp x >>= fun a -> - eval_op_exp y >>= fun b -> + f x >>= fun a -> + f y >>= fun b -> return (BinOp (a, Add, b)) | Minus (x, y) -> - eval_op_exp x >>= fun a -> - eval_op_exp y >>= fun b -> + f x >>= fun a -> + f y >>= fun b -> return (BinOp (a, Sub, b)) | Apply(Page, x) -> - eval_op_exp x >>= fun a -> + f x >>= fun a -> return (BinOp (a, And, UnOp (Not, Const 4095 (*0xFFF*)))) | _ -> fail "Not supported" end -let eval_relocation desc = +let eval_relocation s_val a_val p_val desc= let (hi, lo) = desc.rel_desc_mask in - eval_op_exp desc.rel_desc_operation >>= fun value -> + eval_op_exp s_val a_val p_val desc.rel_desc_operation >>= fun value -> match desc.rel_desc_range with | Just (min, max) -> return (AssertRange(value, min, max)) | Nothing -> return value @@ -58,17 +63,25 @@ let eval_relocation desc = >>= fun value -> return <| arel_value = Mask(value, hi, lo) ; arel_target = desc.rel_desc_target |> -type relocation_spec 'a = elf64_relocation_a -> symbolic_expression -> symbolic_expression -> elf64_file -> - error (Map.map elf64_addr (relocation_description symbolic_expression 'a)) +type relocation_spec 'a = natural -> error (maybe (relocation_description relocation_param 'a)) val abi_relocation_interpreter : forall 'a. relocation_spec 'a -> relocation_interpreter 'a let abi_relocation_interpreter spec ef symtab sidx rel = - section_with_offset ef sidx rel.elf64_ra_offset >>= fun p_val -> - let (_, sym) = parse_elf64_relocation_info rel.elf64_ra_info in - match symbolic_address_of_symbol ef symtab (natFromNatural sym) with - | Just x -> x - | Nothing -> fail "Invalid symbol table index" - end >>= fun s_val -> - spec rel s_val p_val ef >>= fun rel_desc_map -> - map_mapM eval_relocation rel_desc_map + if is_elf64_relocatable_file ef.elf64_file_header then + section_with_offset ef sidx rel.elf64_ra_offset >>= fun p_val -> + let (rel_type, sym) = parse_elf64_relocation_info rel.elf64_ra_info in + let a_val = Const (integer_of_elf64_sxword rel.elf64_ra_addend) in + let addr = rel.elf64_ra_offset in + match symbolic_address_of_symbol ef symtab (natFromNatural sym) with + | Just x -> x + | Nothing -> fail "Invalid symbol table index" + end >>= fun s_val -> + spec rel_type >>= function + | Nothing -> return Map.empty + | Just rel_desc -> + eval_relocation s_val a_val p_val rel_desc >>= fun x -> + return (Map.singleton addr x) + end + else + fail "abi_relocation_interpreter: not a relocatable file" From beb0d46ac9780795da2f705262569e4ec647043f Mon Sep 17 00:00:00 2001 From: Matej Urban Date: Thu, 24 Apr 2025 12:38:42 +0100 Subject: [PATCH 40/44] Add frame base info to the sdt --- src/dwarf.lem | 22 +++++++++++++--------- 1 file changed, 13 insertions(+), 9 deletions(-) diff --git a/src/dwarf.lem b/src/dwarf.lem index a9c75b1..691d1f4 100644 --- a/src/dwarf.lem +++ b/src/dwarf.lem @@ -803,6 +803,7 @@ type sdt_variable_or_formal_parameter = svfp_const_value : maybe sym_integer; svfp_external : bool; svfp_declaration : bool; + svfp_locations_frame_base : maybe (list (sym_natural * sym_natural * list operation)); svfp_locations : maybe (list (sym_natural * sym_natural * list operation (*the parsed single_location_description*))); svfp_decl : maybe unpacked_decl; |> @@ -5269,15 +5270,11 @@ let rec closest_enclosing_frame_base dloc (base_address: sym_natural) (parents: end end - - - -let interpreted_location_of_die c cuh str (dloc: location_list_list) (dranges: range_list_list) (base_address: sym_natural) (parents: list die) (die: die) : maybe (list (sym_natural * sym_natural * single_location_description)) = - +let interpreted_location c cuh str (dloc: location_list_list) (dranges: range_list_list) (base_address: sym_natural) (parents: list die) loc : maybe (list (sym_natural * sym_natural * single_location_description)) = (* for a simple location expression bs, we look in the enclosing die tree to find the associated pc range *) let location bs = - match closest_enclosing_range c cuh str dranges base_address (die::parents) with + match closest_enclosing_range c cuh str dranges base_address parents with | Just nns -> Just (List.map (fun (n1,n2) -> (n1,n2,bs)) nns) | Nothing -> @@ -5285,7 +5282,7 @@ let interpreted_location_of_die c cuh str (dloc: location_list_list) (dranges: r Just [(0,(arithmetic_context_of_cuh cuh).ac_max,bs)] end in - match find_attribute_value "DW_AT_location" die with + match loc with | Just (AV_exprloc n bs) -> location bs | Just (AV_block n bs) -> location bs (* while for a location list, we take the associated pc range from @@ -5296,7 +5293,9 @@ let interpreted_location_of_die c cuh str (dloc: location_list_list) (dranges: r | Nothing -> Nothing end - +let interpreted_location_of_die c cuh str (dloc: location_list_list) (dranges: range_list_list) (base_address: sym_natural) (parents: list die) (die: die) : maybe (list (sym_natural * sym_natural * single_location_description)) = + let loc = find_attribute_value "DW_AT_location" die in + interpreted_location c cuh str dloc dranges base_address (die::parents) loc val analyse_locations : dwarf -> analysed_location_data let analyse_locations (d: dwarf) : analysed_location_data = @@ -6018,6 +6017,8 @@ let rec mk_sdt_variable_or_formal_parameter (d:dwarf) subprogram_line_extents cu (* find aDW_AT_specification die, if it exists. TODO: how should this interact with abstract origins? *) let mcupdie_spec = find_reference_attribute_of_die c d cu d.d_str "DW_AT_specification" die in + let base_address = cu_base_address cu in + Just ( <| svfp_cupdie = cupdie; @@ -6035,8 +6036,11 @@ let rec mk_sdt_variable_or_formal_parameter (d:dwarf) subprogram_line_extents cu svfp_const_value = find_integer_attribute_value_of_die c "DW_AT_const_value" die; svfp_external = match find_flag_attribute_value_of_die_using_abstract_origin d "DW_AT_external" cupdie with Just b -> b | Nothing -> false end; svfp_declaration = match find_flag_attribute_value_of_die_using_abstract_origin d "DW_AT_declaration" cupdie with Just b -> b | Nothing -> false end; + svfp_locations_frame_base = + let frame_base = closest_enclosing_frame_base d.d_loc base_address (die::parents) in + let interpreted_frame_base = interpreted_location c cu.cu_header d.d_str d.d_loc d.d_ranges base_address (die::parents) frame_base in + Maybe.map (fun nnbss -> List.map (fun (n1,n2,bs) -> (n1,n2,parse_operations_bs c cu.cu_header bs)) nnbss) interpreted_frame_base; svfp_locations = - let base_address = cu_base_address cu in let interpreted_locations : maybe (list (sym_natural * sym_natural * single_location_description)) = interpreted_location_of_die c cu.cu_header d.d_str d.d_loc d.d_ranges base_address parents die in Maybe.map (fun nnbss -> List.map (fun (n1,n2,bs) -> (n1,n2,parse_operations_bs c cu.cu_header bs)) nnbss) interpreted_locations; From 2534c5aa3a8e2ee58b5a221b9bc7693f89334cb5 Mon Sep 17 00:00:00 2001 From: Matej Urban Date: Sat, 3 May 2025 13:21:55 +0100 Subject: [PATCH 41/44] More relocation types --- .../abi_aarch64_symbolic_relocation.lem | 24 ++++++++++++++++++- 1 file changed, 23 insertions(+), 1 deletion(-) diff --git a/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem b/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem index 20f48b1..f8974a0 100644 --- a/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem +++ b/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem @@ -23,6 +23,8 @@ type aarch64_relocation_target | ADD | LDST of int | CALL + | CONDBR + | B val abi_aarch64_apply_relocation_symbolic : relocation_spec aarch64_relocation_target let abi_aarch64_apply_relocation_symbolic rel_type = @@ -155,7 +157,27 @@ let abi_aarch64_apply_relocation_symbolic rel_type = ; rel_desc_mask = (27, 2) ; rel_desc_target = CALL |> - ) + ) + else if rel_type = r_aarch64_condbr19 then + let result = Minus(Plus(Lift S, Lift A), Lift P) in + return (Just + <| rel_desc_operation = result + ; rel_desc_range = Just (~(2**20), 2**20) + ; rel_desc_alignment_bits = 2 + ; rel_desc_mask = (20, 2) + ; rel_desc_target = CONDBR + |> + ) + else if rel_type = r_aarch64_jump26 then + let result = Minus(Plus(Lift S, Lift A), Lift P) in + return (Just + <| rel_desc_operation = result + ; rel_desc_range = Just (~(2**27), 2**27) + ; rel_desc_alignment_bits = 2 + ; rel_desc_mask = (27, 2) + ; rel_desc_target = B + |> + ) else fail ("Unsupported AARCH64 relocation type " ^ (string_of_aarch64_relocation_type rel_type)) From 6f416c40c092e8adde9451aa748f300e77fcbb34 Mon Sep 17 00:00:00 2001 From: Matej Urban Date: Sat, 3 May 2025 16:30:19 +0100 Subject: [PATCH 42/44] refactor --- .../abi_aarch64_symbolic_relocation.lem | 70 ++++++++----------- src/abis/abi_symbolic_relocation.lem | 36 ++++------ src/dwarf.lem | 8 +-- src/elf_symbolic.lem | 35 ++++++---- 4 files changed, 66 insertions(+), 83 deletions(-) diff --git a/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem b/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem index f8974a0..d5e23e4 100644 --- a/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem +++ b/src/abis/aarch64/abi_aarch64_symbolic_relocation.lem @@ -38,9 +38,8 @@ let abi_aarch64_apply_relocation_symbolic rel_type = else if rel_type = r_aarch64_abs64 then let result = Plus(Lift S, Lift A) in return (Just - <| rel_desc_operation = result - ; rel_desc_range = Nothing - ; rel_desc_alignment_bits = 0 + <| rel_desc_value = result + ; rel_desc_checks = [] ; rel_desc_mask = (63, 0) ; rel_desc_target = Data64 |> @@ -49,9 +48,8 @@ let abi_aarch64_apply_relocation_symbolic rel_type = else if rel_type = r_aarch64_abs32 then let result = Plus(Lift S, Lift A) in return (Just - <| rel_desc_operation = result - ; rel_desc_range = Just (~(2**31), 2**32) - ; rel_desc_alignment_bits = 0 + <| rel_desc_value = result + ; rel_desc_checks = [Overflow (~(2**31), 2**32)] ; rel_desc_mask = (31, 0) ; rel_desc_target = Data32 |> @@ -60,9 +58,8 @@ let abi_aarch64_apply_relocation_symbolic rel_type = else if rel_type = r_aarch64_prel64 then let result = Minus(Plus(Lift S, Lift A), Lift P) in return (Just - <| rel_desc_operation = result - ; rel_desc_range = Nothing - ; rel_desc_alignment_bits = 0 + <| rel_desc_value = result + ; rel_desc_checks = [] ; rel_desc_mask = (63, 0) ; rel_desc_target = Data64 |> @@ -71,9 +68,8 @@ let abi_aarch64_apply_relocation_symbolic rel_type = else if rel_type = r_aarch64_prel32 then let result = Minus(Plus(Lift S, Lift A), Lift P) in return (Just - <| rel_desc_operation = result - ; rel_desc_range = Just (~(2**31), 2**32) - ; rel_desc_alignment_bits = 0 + <| rel_desc_value = result + ; rel_desc_checks = [Overflow (~(2**31), 2**32)] ; rel_desc_mask = (31, 0) ; rel_desc_target = Data32 |> @@ -81,9 +77,8 @@ let abi_aarch64_apply_relocation_symbolic rel_type = else if rel_type = r_aarch64_adr_prel_pg_hi21 then let result = Minus(Apply(Page, Plus(Lift S, Lift A)), Apply(Page, Lift P)) in return (Just - <| rel_desc_operation = result - ; rel_desc_range = Just (~(2**32), 2**32) - ; rel_desc_alignment_bits = 0 + <| rel_desc_value = result + ; rel_desc_checks = [Overflow (~(2**32), 2**32)] ; rel_desc_mask = (32, 12) ; rel_desc_target = ADRP |> @@ -91,9 +86,8 @@ let abi_aarch64_apply_relocation_symbolic rel_type = else if rel_type = r_aarch64_add_abs_lo12_nc then let result = Plus(Lift S, Lift A) in return (Just - <| rel_desc_operation = result - ; rel_desc_range = Nothing - ; rel_desc_alignment_bits = 0 + <| rel_desc_value = result + ; rel_desc_checks = [] ; rel_desc_mask = (11, 0) ; rel_desc_target = ADD |> @@ -101,9 +95,8 @@ let abi_aarch64_apply_relocation_symbolic rel_type = else if rel_type = r_aarch64_ldst8_abs_lo12_nc then let result = Plus(Lift S, Lift A) in return (Just - <| rel_desc_operation = result - ; rel_desc_range = Nothing - ; rel_desc_alignment_bits = 0 + <| rel_desc_value = result + ; rel_desc_checks = [] ; rel_desc_mask = (11, 0) ; rel_desc_target = LDST 0 |> @@ -111,9 +104,8 @@ let abi_aarch64_apply_relocation_symbolic rel_type = else if rel_type = r_aarch64_ldst16_abs_lo12_nc then let result = Plus(Lift S, Lift A) in return (Just - <| rel_desc_operation = result - ; rel_desc_range = Nothing - ; rel_desc_alignment_bits = 1 + <| rel_desc_value = result + ; rel_desc_checks = [Alignment 1] ; rel_desc_mask = (11, 1) ; rel_desc_target = LDST 1 |> @@ -121,9 +113,8 @@ let abi_aarch64_apply_relocation_symbolic rel_type = else if rel_type = r_aarch64_ldst32_abs_lo12_nc then let result = Plus(Lift S, Lift A) in return (Just - <| rel_desc_operation = result - ; rel_desc_range = Nothing - ; rel_desc_alignment_bits = 2 + <| rel_desc_value = result + ; rel_desc_checks = [Alignment 2] ; rel_desc_mask = (11, 2) ; rel_desc_target = LDST 2 |> @@ -131,9 +122,8 @@ let abi_aarch64_apply_relocation_symbolic rel_type = else if rel_type = r_aarch64_ldst64_abs_lo12_nc then let result = Plus(Lift S, Lift A) in return (Just - <| rel_desc_operation = result - ; rel_desc_range = Nothing - ; rel_desc_alignment_bits = 3 + <| rel_desc_value = result + ; rel_desc_checks = [Alignment 3] ; rel_desc_mask = (11, 3) ; rel_desc_target = LDST 3 |> @@ -141,9 +131,8 @@ let abi_aarch64_apply_relocation_symbolic rel_type = else if rel_type = r_aarch64_ldst128_abs_lo12_nc then let result = Plus(Lift S, Lift A) in return (Just - <| rel_desc_operation = result - ; rel_desc_range = Nothing - ; rel_desc_alignment_bits = 4 + <| rel_desc_value = result + ; rel_desc_checks = [Alignment 4] ; rel_desc_mask = (11, 4) ; rel_desc_target = LDST 4 |> @@ -151,9 +140,8 @@ let abi_aarch64_apply_relocation_symbolic rel_type = else if rel_type = r_aarch64_call26 then let result = Minus(Plus(Lift S, Lift A), Lift P) in return (Just - <| rel_desc_operation = result - ; rel_desc_range = Just (~(2**27), 2**27) - ; rel_desc_alignment_bits = 2 + <| rel_desc_value = result + ; rel_desc_checks = [Overflow (~(2**27), 2**27); Alignment 2] ; rel_desc_mask = (27, 2) ; rel_desc_target = CALL |> @@ -161,9 +149,8 @@ let abi_aarch64_apply_relocation_symbolic rel_type = else if rel_type = r_aarch64_condbr19 then let result = Minus(Plus(Lift S, Lift A), Lift P) in return (Just - <| rel_desc_operation = result - ; rel_desc_range = Just (~(2**20), 2**20) - ; rel_desc_alignment_bits = 2 + <| rel_desc_value = result + ; rel_desc_checks = [Overflow (~(2**20), 2**20); Alignment 2] ; rel_desc_mask = (20, 2) ; rel_desc_target = CONDBR |> @@ -171,9 +158,8 @@ let abi_aarch64_apply_relocation_symbolic rel_type = else if rel_type = r_aarch64_jump26 then let result = Minus(Plus(Lift S, Lift A), Lift P) in return (Just - <| rel_desc_operation = result - ; rel_desc_range = Just (~(2**27), 2**27) - ; rel_desc_alignment_bits = 2 + <| rel_desc_value = result + ; rel_desc_checks = [Overflow (~(2**27), 2**27); Alignment 2] ; rel_desc_mask = (27, 2) ; rel_desc_target = B |> diff --git a/src/abis/abi_symbolic_relocation.lem b/src/abis/abi_symbolic_relocation.lem index 4003fec..556df76 100644 --- a/src/abis/abi_symbolic_relocation.lem +++ b/src/abis/abi_symbolic_relocation.lem @@ -19,14 +19,6 @@ open import Elf_interpreted_section type relocation_param = S | A | P -type relocation_description 'res 'tar = - <| rel_desc_operation : (relocation_operator_expression 'res) - ; rel_desc_range : maybe (integer * integer) - ; rel_desc_alignment_bits : natural - ; rel_desc_mask : (natural * natural) - ; rel_desc_target : 'tar - |> - let rec eval_op_exp s_val a_val p_val op: error symbolic_expression = let f = eval_op_exp s_val a_val p_val in match op with @@ -48,22 +40,20 @@ let rec eval_op_exp s_val a_val p_val op: error symbolic_expression = end let eval_relocation s_val a_val p_val desc= - let (hi, lo) = desc.rel_desc_mask in - - eval_op_exp s_val a_val p_val desc.rel_desc_operation >>= fun value -> - match desc.rel_desc_range with - | Just (min, max) -> return (AssertRange(value, min, max)) - | Nothing -> return value - end - >>= fun value -> - match desc.rel_desc_alignment_bits with - | 0 -> return value - | x -> return (AssertAlignment(value, x)) - end - >>= fun value -> - return <| arel_value = Mask(value, hi, lo) ; arel_target = desc.rel_desc_target |> + eval_op_exp s_val a_val p_val desc.rel_desc_value >>= fun value -> + return <| rel_desc_value = value + ; rel_desc_checks = desc.rel_desc_checks + ; rel_desc_mask = desc.rel_desc_mask + ; rel_desc_target = desc.rel_desc_target + |> + +type relocation_spec 'a = natural -> error (maybe (relocation_description (relocation_operator_expression relocation_param) 'a)) -type relocation_spec 'a = natural -> error (maybe (relocation_description relocation_param 'a)) +let relocation_spec_map_target f spec rel_type = + spec rel_type >>= function + | Nothing -> return Nothing + | Just desc -> return (Just (relocation_map_target f desc)) + end val abi_relocation_interpreter : forall 'a. relocation_spec 'a -> relocation_interpreter 'a let abi_relocation_interpreter spec ef symtab sidx rel = diff --git a/src/dwarf.lem b/src/dwarf.lem index 691d1f4..f79a937 100644 --- a/src/dwarf.lem +++ b/src/dwarf.lem @@ -159,9 +159,9 @@ let rec sym_integer_of_symbolic_expression x = match x with | Const x -> sym_integer_const x | BinOp (x, Add, y) -> (sym_integer_of_symbolic_expression x) + (sym_integer_of_symbolic_expression y) | BinOp (x, Sub, y) -> (sym_integer_of_symbolic_expression x) - (sym_integer_of_symbolic_expression y) - | AssertRange (x, _, _) -> sym_integer_of_symbolic_expression x (*TODO*) + (* | AssertRange (x, _, _) -> sym_integer_of_symbolic_expression x (*TODO*) | AssertAlignment (x, _) -> sym_integer_of_symbolic_expression x (*TODO*) - | Mask (x, _, _) -> sym_integer_of_symbolic_expression x (*TODO*) + | Mask (x, _, _) -> sym_integer_of_symbolic_expression x TODO *) end let sym_natural_of_symbolic_expression x = @@ -196,8 +196,8 @@ let construct_sym_byte_sequence bs rel = ( natural_of_elf64_addr pos, ( - reloc_width_bytes rel.arel_target, - sym_natural_of_symbolic_expression rel.arel_value + reloc_width_bytes rel.rel_desc_target, + sym_natural_of_symbolic_expression rel.rel_desc_value ) ) ) rel_list in diff --git a/src/elf_symbolic.lem b/src/elf_symbolic.lem index 4aa2a38..6a7fe02 100644 --- a/src/elf_symbolic.lem +++ b/src/elf_symbolic.lem @@ -36,9 +36,6 @@ type symbolic_expression | Const of integer | BinOp of (symbolic_expression * binary_operation * symbolic_expression) | UnOp of (unary_operation * symbolic_expression) - | AssertRange of (symbolic_expression * integer * integer) - | AssertAlignment of (symbolic_expression * natural) - | Mask of (symbolic_expression * natural * natural) let rec pp_sym_expr sx = match sx with | Section s -> s @@ -47,9 +44,6 @@ let rec pp_sym_expr sx = match sx with | BinOp (a, Sub, b) -> "(" ^ (pp_sym_expr a) ^ "-" ^ (pp_sym_expr b) ^ ")" | BinOp (a, And, b) -> "(" ^ (pp_sym_expr a) ^ "&" ^ (pp_sym_expr b) ^ ")" | UnOp (Not, b) -> "(" ^ "~" ^ (pp_sym_expr b) ^ ")" - | AssertRange (x, a, b) -> pp_sym_expr x ^ "!" (*TODO*) - | AssertAlignment (x, a) -> pp_sym_expr x ^ "!" (*TODO*) - | Mask (x, a, b) -> pp_sym_expr x ^ "[" ^ (show a) ^ ":" ^ (show b) ^ "]" end val section_with_offset : elf64_file -> elf64_half -> elf64_addr -> error symbolic_expression @@ -77,11 +71,27 @@ let symbolic_address_of_symbol f symtab sym = (* Relocation expressions *) +type safety_check = +| Overflow of (integer * integer) +| Alignment of natural + +type relocation_description 'v 'tar = +<| rel_desc_value : 'v + ; rel_desc_checks : list safety_check + ; rel_desc_mask : (natural * natural) + ; rel_desc_target : 'tar + |> + +let relocation_map_target f desc = + f desc.rel_desc_target >>= fun target -> + return <| rel_desc_value = desc.rel_desc_value + ; rel_desc_checks = desc.rel_desc_checks + ; rel_desc_mask = desc.rel_desc_mask + ; rel_desc_target = target + |> + (* TODO rename *) -type abstract_relocation 'a = - <| arel_value : symbolic_expression - ; arel_target : 'a - |> +type abstract_relocation 'a = relocation_description symbolic_expression 'a type reloc_target_data = | Data32 @@ -98,10 +108,7 @@ type relocation_interpreter 'a = elf64_file -> elf64_symbol_table -> elf64_half let relocation_interpreter_map_target interp conv ef symtab sidx rel = interp ef symtab sidx rel >>= fun arels -> map_mapM (fun arel -> - conv arel.arel_target >>= fun target -> - return <| arel_value = arel.arel_value - ; arel_target = target - |> + relocation_map_target conv arel ) arels val extract_elf64_relocations_for_section' : forall 'a. elf64_file -> relocation_interpreter 'a -> elf64_half -> error (Map.map elf64_addr (abstract_relocation 'a)) From fef7e0c51feeae7e9c7b4197b5005e8ffc6f1187 Mon Sep 17 00:00:00 2001 From: Matej Urban Date: Sat, 3 May 2025 16:31:12 +0100 Subject: [PATCH 43/44] rename abstract relocation --- src/elf_symbolic.lem | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/elf_symbolic.lem b/src/elf_symbolic.lem index 6a7fe02..23b1377 100644 --- a/src/elf_symbolic.lem +++ b/src/elf_symbolic.lem @@ -91,7 +91,7 @@ let relocation_map_target f desc = |> (* TODO rename *) -type abstract_relocation 'a = relocation_description symbolic_expression 'a +type universal_relocation 'a = relocation_description symbolic_expression 'a type reloc_target_data = | Data32 @@ -103,7 +103,7 @@ let reloc_width_bytes : reloc_target_data -> natural = function end type relocation_interpreter 'a = elf64_file -> elf64_symbol_table -> elf64_half -> elf64_relocation_a -> - error (Map.map elf64_addr (abstract_relocation 'a)) + error (Map.map elf64_addr (universal_relocation 'a)) let relocation_interpreter_map_target interp conv ef symtab sidx rel = interp ef symtab sidx rel >>= fun arels -> @@ -111,7 +111,7 @@ let relocation_interpreter_map_target interp conv ef symtab sidx rel = relocation_map_target conv arel ) arels -val extract_elf64_relocations_for_section' : forall 'a. elf64_file -> relocation_interpreter 'a -> elf64_half -> error (Map.map elf64_addr (abstract_relocation 'a)) +val extract_elf64_relocations_for_section' : forall 'a. elf64_file -> relocation_interpreter 'a -> elf64_half -> error (Map.map elf64_addr (universal_relocation 'a)) let extract_elf64_relocations_for_section' f1 interp sidx = let hdr = f1.elf64_file_header in let sections = f1.elf64_file_interpreted_sections in @@ -136,7 +136,7 @@ let extract_elf64_relocations_for_section' f1 interp sidx = | _ -> fail "Multiple relocation sections for this section" end -val extract_elf64_relocations_for_section : forall 'a. elf64_file -> relocation_interpreter 'a -> string -> error (Map.map elf64_addr (abstract_relocation 'a)) +val extract_elf64_relocations_for_section : forall 'a. elf64_file -> relocation_interpreter 'a -> string -> error (Map.map elf64_addr (universal_relocation 'a)) let extract_elf64_relocations_for_section f1 interp section_name = match List.findIndices (fun x -> x.elf64_section_name_as_string = section_name) From ed23774d7145600ab9f3c910f823b262d61cd459 Mon Sep 17 00:00:00 2001 From: Matej Urban Date: Sat, 3 May 2025 16:33:29 +0100 Subject: [PATCH 44/44] remove buildoutput (accidentaly commited before) --- buildoutput | 5 ----- 1 file changed, 5 deletions(-) delete mode 100644 buildoutput diff --git a/buildoutput b/buildoutput deleted file mode 100644 index 8744884..0000000 --- a/buildoutput +++ /dev/null @@ -1,5 +0,0 @@ -make -C src -make[1]: Entering directory '/home/matej/Documents/cam/IIproj/linksem/src' -OCAMLPATH is -make[1]: Nothing to be done for 'default'. -make[1]: Leaving directory '/home/matej/Documents/cam/IIproj/linksem/src'